在 R Shiny 中，如何制作一个复选框表，该表还具有针对各个行/列的“全选”复选框？

Question

使用 R Shiny，我想显示一个表格（例如通过“DT”包），其中每个单元格包含一个复选框。在每行和列标题旁边，我想显示一个“全选”/“主复选框”，选择该复选框后，将选择相应行或列中的所有复选框。作为附加功能，左上角单元格中的复选框将选择表中的所有复选框。一个例子：

尝试过js

我找到了一个此功能的示例，其中有一列的主复选框

here（使用一些javascript），但无法弄清楚如何将其扩展到我的要求。

我尝试过的一个例子

library(shiny)
library(DT)

ui <- fluidPage(
    # Sidebar panel
    sidebarPanel(),
    
    # Main panel with the table
    mainPanel(
        DTOutput("myTable")
    )
)

server <- function(input, output){
    dat <- data.frame(
        vapply(1:6, function(i){
            as.character(
                checkboxInput(paste0("col1-", i), label = NULL, width = "150px")
            )
        }, character(1)),
        vapply(1:6, function(i){
            as.character(
                checkboxInput(paste0("col2-", i), label = NULL, width = "150px")
            )
        }, character(1)),
        vapply(1:6, function(i){
            as.character(
                checkboxInput(paste0("col3-", i), label = NULL, width = "150px")
            )
        }, character(1))
    )
    
    names(dat) <- c(
        as.character(checkboxInput("col1", label = "1", width = "150px")),
        as.character(checkboxInput("col2", label = "2", width = "150px")),
        as.character(checkboxInput("col3", label = "3", width = "150px"))
    )
    
    row_names <- LETTERS[1:6]
    rownames(dat) <- row_names
    
    output$myTable <- renderDT({
        datatable(
            dat, 
            escape = FALSE,
            options = list(
                columnDefs = list(
                    list(targets = c(1, 2, 3), orderable = FALSE, className = "dt-center")
                )
            ),
            callback = JS(
                "$('#col1').on('click', function(){",
                "  var cboxes = $('[id^=col1-]');",
                "  var checked = $('#col1').is(':checked');",
                "  cboxes.each(function(i, cbox) {",
                "    $(cbox).prop('checked', checked);",
                "  });",
                "});",
                "$('#col2').on('click', function(){",
                "  var cboxes = $('[id^=col2-]');",
                "  var checked = $('#col2').is(':checked');",
                "  cboxes.each(function(i, cbox) {",
                "    $(cbox).prop('checked', checked);",
                "  });",
                "});",
                "$('#col3').on('click', function(){",
                "  var cboxes = $('[id^=col3-]');",
                "  var checked = $('#col3').is(':checked');",
                "  cboxes.each(function(i, cbox) {",
                "    $(cbox).prop('checked', checked);",
                "  });",
                "});"
            )
        )
    })
}

shinyApp(ui, server)

这是一个开始，但我无法弄清楚如何在行旁边获得主复选框，也无法在所有框的左上角找到一个主复选框。另外，整个东西有点大 - 如果能更紧凑就更好了。

Answer 1

library(shiny)
library(DT)

rowName <- function(L) {
  as.character(
    checkboxInput(paste0("row", L), label = L, width = "150px")
  )
}
rowNames <- vapply(LETTERS[1:6], rowName, character(1))


ui <- fluidPage(
  # Sidebar panel
  sidebarPanel(),
  
  # Main panel with the table
  mainPanel(
    DTOutput("myTable")
  )
)

server <- function(input, output){
  dat <- data.frame(
    vapply(LETTERS[1:6], function(i){
      as.character(
        checkboxInput(paste0("col1-", i), label = NULL, width = "150px")
      )
    }, character(1)),
    vapply(LETTERS[1:6], function(i){
      as.character(
        checkboxInput(paste0("col2-", i), label = NULL, width = "150px")
      )
    }, character(1)),
    vapply(LETTERS[1:6], function(i){
      as.character(
        checkboxInput(paste0("col3-", i), label = NULL, width = "150px")
      )
    }, character(1))
  )
  
  names(dat) <- c(
    as.character(checkboxInput("col1", label = "1", width = "150px")),
    as.character(checkboxInput("col2", label = "2", width = "150px")),
    as.character(checkboxInput("col3", label = "3", width = "150px"))
  )
  
  rownames(dat) <- rowNames
  
  output$myTable <- renderDT({
    datatable(
      dat, 
      escape = FALSE,
      select = "none",
      options = list(
        columnDefs = list(
          list(targets = c(1, 2, 3), orderable = FALSE, className = "dt-center")
        ),
        initComplete = JS(
          "function() {",
          "  $('#col1').on('click', function(){",
          "    var cboxes = $('[id^=col1-]');",
          "    var checked = $('#col1').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#col2').on('click', function(){",
          "    var cboxes = $('[id^=col2-]');",
          "    var checked = $('#col2').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#col3').on('click', function(){",
          "    var cboxes = $('[id^=col3-]');",
          "    var checked = $('#col3').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowA').on('click', function(){",
          "    var cboxes = $('[id$=-A]');",
          "    var checked = $('#rowA').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowB').on('click', function(){",
          "    var cboxes = $('[id$=-B]');",
          "    var checked = $('#rowB').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowC').on('click', function(){",
          "    var cboxes = $('[id$=-C]');",
          "    var checked = $('#rowC').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowD').on('click', function(){",
          "    var cboxes = $('[id$=-D]');",
          "    var checked = $('#rowD').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowE').on('click', function(){",
          "    var cboxes = $('[id$=-E]');",
          "    var checked = $('#rowE').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowF').on('click', function(){",
          "    var cboxes = $('[id$=-F]');",
          "    var checked = $('#rowF').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "}"
        ),
        preDrawCallback = 
          JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
        drawCallback = 
          JS('function() { Shiny.bindAll(this.api().table().node()); } ')
      )
    )
  })
}

shinyApp(ui, server)

---

编辑：“全选”复选框

library(shiny)
library(DT)
library(htmltools)

rowName <- function(L) {
  as.character(
    checkboxInput(paste0("row", L), label = L, width = "150px")
  )
}
rowNames <- vapply(LETTERS[1:6], rowName, character(1))


sketch <- htmltools::withTags(
  table(
    class = "display",
    thead(
      tr(
        th(HTML(as.character(checkboxInput("allboxes", label = "ALL", width = "150px")))), 
        th(HTML(as.character(checkboxInput("col1", label = "1", width = "150px")))),
        th(HTML(as.character(checkboxInput("col2", label = "2", width = "150px")))),
        th(HTML(as.character(checkboxInput("col3", label = "3", width = "150px"))))
      )
    )
  )
)



ui <- fluidPage(
  br(),
  # Sidebar panel
  sidebarPanel(),
  
  # Main panel with the table
  mainPanel(
    DTOutput("myTable")
  )
)

server <- function(input, output){
  dat <- data.frame(
    vapply(LETTERS[1:6], function(i){
      as.character(
        checkboxInput(paste0("col1-", i), label = NULL, width = "150px")
      )
    }, character(1)),
    vapply(LETTERS[1:6], function(i){
      as.character(
        checkboxInput(paste0("col2-", i), label = NULL, width = "150px")
      )
    }, character(1)),
    vapply(LETTERS[1:6], function(i){
      as.character(
        checkboxInput(paste0("col3-", i), label = NULL, width = "150px")
      )
    }, character(1))
  )
  
  rownames(dat) <- rowNames
  
  output$myTable <- renderDT({
    datatable(
      dat, container = sketch,
      escape = FALSE,
      select = "none",
      options = list(
        columnDefs = list(
          list(targets = c(1, 2, 3), orderable = FALSE, className = "dt-center")
        ),
        initComplete = JS(
          "function() {",
          "  $('#allboxes').on('click', function(){",
          "    var cboxes = $('input[type=checkbox]');",
          "    var checked = $('#allboxes').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#col1').on('click', function(){",
          "    var cboxes = $('[id^=col1-]');",
          "    var checked = $('#col1').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#col2').on('click', function(){",
          "    var cboxes = $('[id^=col2-]');",
          "    var checked = $('#col2').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#col3').on('click', function(){",
          "    var cboxes = $('[id^=col3-]');",
          "    var checked = $('#col3').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowA').on('click', function(){",
          "    var cboxes = $('[id$=-A]');",
          "    var checked = $('#rowA').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowB').on('click', function(){",
          "    var cboxes = $('[id$=-B]');",
          "    var checked = $('#rowB').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowC').on('click', function(){",
          "    var cboxes = $('[id$=-C]');",
          "    var checked = $('#rowC').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowD').on('click', function(){",
          "    var cboxes = $('[id$=-D]');",
          "    var checked = $('#rowD').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowE').on('click', function(){",
          "    var cboxes = $('[id$=-E]');",
          "    var checked = $('#rowE').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "  $('#rowF').on('click', function(){",
          "    var cboxes = $('[id$=-F]');",
          "    var checked = $('#rowF').is(':checked');",
          "    cboxes.each(function(i, cbox) {",
          "      $(cbox).prop('checked', checked);",
          "    });",
          "  });",
          "}"
        ),
        preDrawCallback = 
          JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
        drawCallback = 
          JS('function() { Shiny.bindAll(this.api().table().node()); } ')
      )
    )
  })
}

shinyApp(ui, server)