Shiny DT同时实现表头分组与列前景色编码的方法

问题描述 #

我尝试在Shiny的DT表格中合并两个看似无法兼容的功能：根据实操测试，要么可通过传入datatable对象调用formatStyle控制指定列样式，要么可通过自定义container参数控制表头实现列分组，两类配置单独运行均正常，但无法同时生效，我期望在带分组表头的DT表格中实现列的颜色编码。

问题复现代码 #

library(shiny)
library(dplyr)
library(DT)

df <- data.frame(col1 = c("A", "B", "C", "D"),
                 col2 = c("aa", "bb", "cc", "dd"),
                 col3 = c(-1, 0, 1, 2),
                 stringsAsFactors = F)

ui <- fluidPage(h4("Version 1: color coded column"),
                DTOutput("table1"),
                br(),
                h4("Version 2: grouped columns"),
                DTOutput("table2"))

server <- function(input, output, session) {
  ### V1 - 样式格式化 ##########################
  output$table1 <- renderDataTable({
    datatable(df) %>%
      formatStyle(columns = 3,
                  color = styleInterval(cuts = 0, values = c("red", "green")),
                  fontWeight = "bold")})

  ### V2 - 分组表头 ##################
  output$table2 <- renderDataTable(df, 
                                  container = htmltools::withTags(table(
                                    class = 'display',
                                    thead(
                                      tr(
                                        th(colspan = 2, 'Group 1'),
                                        th(colspan = 1, 'Group 2')),
                                      tr(
                                        lapply(c('Column 1', 'Column 2', 'Values'), th))))),
                                  options = list(pageLength = 10, autoWidth = TRUE),
                                  rownames = FALSE,
                                  filter= "bottom")
}
shinyApp(ui = ui, server = server)

运行效果 #

解决方法 #

之前的错误是将container语句放在了datatable()函数外部，导致配置无法同时生效。正确的可运行代码如下：

library(shiny)
library(dplyr)
library(DT)

df <- data.frame(col1 = c("A", "B", "C", "D"),
                 col2 = c("aa", "bb", "cc", "dd"),
                 col3 = c(-1, 0, 1, 2),
                 stringsAsFactors = F)

ui <- fluidPage(h4("All in!"),
                DTOutput("table"))

server <- function(input, output, session) {
  output$table <- renderDataTable({
    datatable(df,
              container = htmltools::withTags(table(
                class = 'display',
                thead(
                  tr(
                    th(colspan = 2, 'Group 1'),
                    th(colspan = 1, 'Group 2')),
                  tr(
                    lapply(c('Column 1', 'Column 2', 'Values'), th))))),
              options = list(pageLength = 10, autoWidth = TRUE),
              rownames = FALSE,
              filter= "bottom") %>%
      formatStyle(columns = 3,
                  color = styleInterval(cuts = 0, values = c("red", "green")),
                  fontWeight = "bold")},
  )
}
shinyApp(ui = ui, server = server)

内容的提问来源于stack exchange，提问作者Matteo Castagna