R Shiny - 使 kable 表的附加标题行“粘性”答案

【问题标题】：R Shiny - Make additional header row of kable table 'sticky'R Shiny - 使 kable 表的附加标题行“粘性”
【发布时间】：2020-06-16 06:20:24
【问题描述】：

kableExtra 包有一个很棒的函数add_header_above()，它会在输出表中实际列名的顶部创建一个额外的标题行。这对于分组数据非常有用。当在kable_styling() 中设置fixed_thead = TRUE 时，实际的列名在向下滚动时会被冻结，但这个额外的标题行不会。

这是一个最小的shiny 应用程序，它说明了我的意思。请注意，如果您在 RStudio 查看器中查看应用程序，则普通列标题和其他列标题都不是粘性的。而是在适当的网络浏览器中运行它。

library(shiny)
library(magrittr)

ui <- fluidPage(
  tableOutput("table")
)

server <- function(input, output, session) {
  output$table <- function() {
    knitr::kable(mtcars) %>%
      kableExtra::kable_styling(fixed_thead = TRUE) %>%
      kableExtra::add_header_above(c(" " = 1, "Header 1" = 5, "Header 2" = 6))
  }
}

shinyApp(ui, server)

如何使使用add_header_above() 创建的附加标题行具有粘性？我想我需要在应用程序中加入一些 CSS 或 JavaScript 才能做到这一点。

【问题讨论】：

标签： javascript css r shiny kable

【解决方案1】：

library(shiny)
library(magrittr)

CSS <- "
thead tr th {
  position: sticky;
  background-color: white;
}
thead tr:nth-child(1) th {
  top: 0;
}
"

JS <- "
$(document).ready(function(){
  setTimeout(function(){
    var h = $('thead tr:nth-child(1)').height();
    $('thead tr:nth-child(2) th').css('top', h);
  }, 500);
});
"

ui <- fluidPage(
  tags$head(
    tags$style(HTML(CSS)),
    tags$script(HTML(JS))
  ),
  uiOutput("table")
)

server <- function(input, output, session) {
  output$table <- renderUI({
    tabl <- knitr::kable(mtcars) %>%
      kableExtra::add_header_above(c(" " = 1, "Header 1" = 5, "Header 2" = 6)) %>% 
      kableExtra::kable_styling()
    HTML(tabl)
  })
}

shinyApp(ui, server)

【讨论】：

【解决方案2】：

灵感来自@Stéphane Laurent 的回答。下面是一种更通用的方法，用于将粘性属性应用于任意数量的标题。

library(shiny)
library(magrittr)

JS <- "
$(document).ready(function() {
  var myInterval = setInterval(function() {
    // clear interval after the table's DOM is available
    if ($('thead').length) {
      clearInterval(myInterval);
    }

    // setting css
    $('thead tr th').css('position', 'sticky').css('background', 'white');

    var height = 0;

    for (var i = 0, length = $('thead tr').length; i < length; i++) {
      var header = $('thead tr:nth-child(' + i + ')');
      height += header.length ? header.height() : 0;
      $('thead tr:nth-child(' + (i + 1) + ') th').css('top', height);
    }

  }, 500);
});
"

ui <- fluidPage(
  tags$head(
    tags$script(HTML(JS))
  ),
  tableOutput("table")
)

server <- function(input, output, session) {
  output$table <- function() {
    knitr::kable(mtcars) %>%
      kableExtra::add_header_above(c(" " = 1, "Header 1" = 5, "Header 2" = 6)) %>%
      kableExtra::add_header_above(c(" " = 1, "Header" = 11)) %>%
      kableExtra::kable_styling()
  }
}

shinyApp(ui, server)

如果您不希望您的主 app.R 拥有所有这些 Javascript，您可以将代码移动到其他文件，请参阅：Include a javascript file in Shiny app。

【讨论】：

干得好！我不知道clearInterval 的这种技术。