顶部的R闪亮DT复选框可以打勾/取消选中下面的所有复选框

问题描述

我正在寻找一种简单的方法来选择按行组织的数据，并按列选择一些属性（即，这些数据的收集年份）。这些列将是“ 2016”，“ 2017”，“ 2018”，并且在这些列中的每一个下面的每一行上，都应有一个复选框，指示是否应选择该行和今年的数据。做出选择之后，可以通过此选择上的按钮执行某些操作（例如导出）。因此，没有什么例外。由于有大约。我想通过允许用户选择或取消选择整列（即整年）来总共加快1000行的选择速度。

如果可能的话，我想用DT来做。我已经看到一些相关的线程，例如here和there，但是在这里我没有看到任何“系统的”（即，将选择/取消选择所有复选框放在列子集的顶部）。>

您知道使用DT来做到这一点的简便快捷方法吗？

rhandsontable可以替代，但是我觉得它有点像用锤子杀死苍蝇...

[EDIT]：在下面添加了reprex

灵感来自https://github.com/rstudio/DT/issues/93#issuecomment-111001538

    library(shiny)
    library(DT)

    # create a character vector of shiny inputs
    shinyInput <- function(FUN,len,id,...)
    {
        inputs <- character(len)
        
        for (i in seq_len(len))
        {
            inputs[i] <- as.character(FUN(paste0(id,i),label = NULL,...))
        }
        inputs
    }

    # obtain the values of inputs
    shinyValue <- function(id,len)
    {
        unlist(lapply(seq_len(len),function(i)
        {
            value <- input[[paste0(id,i)]]
            if (is.null(value)) NA else value
        }))
    }

    Years <- paste0("Year_",2016:2020)
    MyDataFrame <- data.frame(matrix(nrow = 1000,ncol = 1 + length(Years)),stringsAsFactors = FALSE)
    colnames(MyDataFrame) <- c("Group",Years)
    MyDataFrame[names(MyDataFrame) == "Group"] <- paste0("Group_",1:1000)
    #MyDataFrame[names(MyDataFrame) %in% Years] <- TRUE
    MyDataFrame[names(MyDataFrame) %in% Years] <- lapply(X = Years,FUN = function(x){shinyInput(checkBoxInput,1000,paste0('v_',x,'_'),value = TRUE)})

    ui <- fluidPage(
        sidebarLayout(
            sidebarPanel(
                h4("Filter"),width = 2
            ),mainPanel(
                DT::dataTableOutput("MyTable"),width = 10
            )
        )
    )

    server <- function(input,output,session) {
        output$MyTable = DT::renderDataTable(MyDataFrame,server = FALSE,escape = FALSE,selection = 'none',options = list(
            preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
            )
        )
    }

    shinyApp(ui = ui,server = server,enableBookmarking = "server")

解决方法

类似的东西：

library(DT)

dat <- data.frame(
  vapply(1:10,function(i){
    as.character(
      checkboxInput(paste0("cbox2018-",i),label = NULL,width = "150px")
    )
  },character(1)),rpois(10,100),50)
)
names(dat) <- c(
  as.character(
    checkboxInput("cbox2018",label = "2018",width = "150px")
  ),"foo","bar"
)

datatable(
  dat,escape = FALSE,options = list(
    columnDefs = list(
      list(targets = 1,orderable = FALSE,className = "dt-center")
    )
  ),callback = JS(
    "$('#cbox2018').on('click',function(){","  var cboxes = $('[id^=cbox2018-]');","  var checked = $('#cbox2018').is(':checked');","  cboxes.each(function(i,cbox) {","    $(cbox).prop('checked',checked);","  });","});"
  )
)

并为 Shiny 添加 preDrawCallback 和 drawCallback。

dt r r rhandsontable shiny