无法使用 DT::DataTable 过滤自定义容器中的多个标题

Question

我在 R ShinyApp 中使用 自定义容器。它目前将 Sepal 和 Petal 作为标题，它们都包含 Length 和 Width 列。那么是否可以从 Sepal/Petal 中获得一个下拉菜单来选择/过滤长度或宽度？
即过滤掉标题中的标题。 我目前正在为此目的使用 checkboxGroupInput，但它没有给出所需的结果。 我也附上了我的代码。有人可以整理一下吗。在此先感谢:)

**MY Codes:**
library(shiny)
library(DT)

iris<-iris[,c(5,1:4)]

ui =basicPage(
tags$head(
tags$style(type = "text/css",
           HTML("th { text-align: center; }")  )),

selectInput(inputId = "Species", 
          label = "Species:",
          choices = c("All",
                      unique(as.character(iris$Species)))),

checkboxGroupInput(inputId = "columns", label = "Select Variable:",
                 choices =c("Sepal.Length", "Sepal.Width", "Petal.Length", 
 "Petal.Width"),
                 selected = c("Sepal.Length", "Sepal.Width", "Petal.Length", 
 "Petal.Width")),

h2('Iris Table'),
DT::dataTableOutput('mytable') )

server = function(input, output) {
output$mytable = DT::renderDataTable({

 # a custom table container
sketch = htmltools::withTags(table(
  class = 'display',
  thead(
    tr(
      th(rowspan = 2, 'Species'),
      th(colspan = 2, 'Sepal'),
      th(colspan = 2, 'Petal')),
    tr(
      lapply(rep(c('Length', 'Width'), 2), th)
    )) )) 

  DT::datatable( rownames = FALSE, container = sketch,
              extensions = 'Buttons',
                 options = list(dom = 'Bfrtip',
                             buttons = 
                               list('colvis', list(
                                 extend = 'collection',
                                 buttons = list(list(extend='csv',
                                                     filename = 'hitStats'),
                                                list(extend='excel',
                                                     filename = 'hitStats'),
                                                list(extend='pdf',
                                                     filename= 'hitStats'),
                                                list(extend='copy',
                                                     filename = 'hitStats'),
                                                list(extend='print',
                                              filename = 'hitStats')),

                                 text = 'Download' ))),
               {

                data<-iris

                if(input$Species != 'All'){
                  data<-data[data$Species == input$Species,]
                }    

                data<-data[,c("Species",input$columns),drop=FALSE]   

                data   
              }) })    }

shinyApp(ui = ui, server = server)

Answer 1

实现@Stéphane Laurent 使用反应式容器的想法：

重点是：

• 拆分列名
• 相应地创建一个嵌套列表cols_parsed，格式为list(Sepal = c("Length", "Width"), Petal = c("Length", "Width"))
• 使用该嵌套结构生成表
• 将反应式container = sketch() 参数传递给datatable

---

library(shiny)
library(DT)

iris <- iris[, c(5, 1:4)]

ui <- basicPage(
  tags$head(
    tags$style(
      type = "text/css",
      HTML("th { text-align: center; }")
    )
  ),

  selectInput(
    inputId = "Species",
    label = "Species:",
    choices = c("All", unique(as.character(iris$Species)))
  ),

  checkboxGroupInput(
    inputId = "columns", label = "Select Variable:",
    choices = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width"), 
    selected = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")
  ),

  h2("Iris Table"),
  DT::dataTableOutput("mytable")
)

server <- function(input, output) {
  # a custom table container
  sketch <- 
    reactive({
      cols_nested <-
        if (!is.null(input$columns)) {
          cols_parsed <- strsplit(input$columns, ".", fixed = TRUE)
          split(sapply(cols_parsed, "[[", 2L), sapply(cols_parsed, "[[", 1L))
        }
      htmltools::withTags(table(
        class = "display",
        thead(
          tr(c(
            list(th(rowspan = if (!is.null(cols_nested)) 2 else 1, "Species")),
            mapply(function(.x, .y) th(colspan = length(.x), .y),
                   cols_nested, names(cols_nested), SIMPLIFY = FALSE)
          )),
          if (!is.null(cols_nested)) tr(lapply(unlist(cols_nested), th))
        )
      ))
    })

  output$mytable <- DT::renderDataTable({
    DT::datatable(
      rownames = FALSE, container = sketch(),
      extensions = "Buttons",
      options = list(
        dom = "Bfrtip",
        buttons = 
          list("colvis", list(
            extend = "collection",
            buttons = list(
              list(extend = "csv", filename = "hitStats"),
              list(extend = "excel", filename = "hitStats"),
              list(extend = "pdf", filename = "hitStats"),
              list(extend = "copy", filename = "hitStats"),
              list(extend = "print", filename = "hitStats")
            ),
            text = "Download"
          ))
      ), data = {
        data <- iris
        if (input$Species != "All") {
          data <- data[data$Species == input$Species, ]
        }
        data[, c("Species", input$columns), drop = FALSE]
      }
    )
  })
}

shinyApp(ui = ui, server = server)