在 Shiny datatable 中高效管理多复选框列及其动态值更新

library(shiny)
library(DT)

ui <- fluidPage(
  br(),
  fluidRow(
    column(
      6,
      DTOutput("dtable") # 显示数据表格
    ),
    column(
      6,
      verbatimTextOutput("reactiveDF") # 显示后端响应式数据框
    )
  )
)

checkboxColumn <- function(len, col, ...) { # `col` 是列的索引
  inputs <- character(len)
  for(i in seq_len(len)) {
    # 复选框 ID 格式为 "checkb_列索引_行索引"
    inputs[i] <- as.character(
      checkboxInput(paste0("checkb_", col, "_", i), label = NULL, ...)
    )
  }
  inputs
}

# 基础数据
dat0 <- data.frame(
  fruit  = c("apple", "cherry", "pineapple", "pear"),
  letter = c("a", "b", "c", "d")
)

# 后端用于存储布尔值的响应式数据框
dat1 <- cbind(dat0, bool1 = FALSE, bool2 = FALSE)

# 包含复选框 HTML 的数据框，用于渲染 DT
# 假设 check1 对应第 3 列，check2 对应第 4 列（从 0 开始计数的话）
dat2 <- cbind(
  dat0,
  check1 = checkboxColumn(nrow(dat0), 3), # 第 3 列的复选框
  check2 = checkboxColumn(nrow(dat0), 4)  # 第 4 列的复选框
)

js <- function(dtid, cols, ns = identity) {
  code <- vector("list", length(cols))
  for(i in seq_along(cols)) {
    col <- cols[i] # 当前处理的列索引
    code[[i]] <- c(
      # 使用事件委托，监听 body 上的点击事件，并过滤出特定 ID 模式的复选框
      sprintf(
        "$('body').on('click', '[id^=checkb_%d_]', function() {",
        col),
      "  var id = this.getAttribute('id');", # 获取被点击复选框的完整 ID
      # 通过正则表达式从 ID 中提取行索引
      sprintf(
        "  var i = parseInt(/checkb_%d_(\d+)/.exec(id)[1]);",
        col),
      "  var value = $(this).prop('checked');", # 获取复选框的选中状态
      # 构造 DT.cellInfo 格式的数据
      sprintf(
        "  var info = [{row: i, col: %d, value: value}];",
        col),
      # 使用 Shiny.setInputValue 将信息发送回 R
      # ns() 用于支持 Shiny 模块化
      sprintf(
        "  Shiny.setInputValue('%s', info);",
        ns(sprintf("%s_cell_edit:DT.cellInfo", dtid))
      ),
      "});"
    )
  }
  do.call(c, code) # 将所有列的 JS 代码合并
}

# 定义包含复选框的列的索引（与后端数据框的列索引对应）
checkboxesColumns <- c(3, 4)

server <- function(input, output, session) {

  # 存储后端数据的响应式值
  Dat <- reactiveVal(dat1) 

  output[["dtable"]] <- renderDT({
    datatable(
      dat2, # 包含复选框 HTML 的数据源
      rownames = TRUE,
      escape = FALSE, # 允许 HTML 渲染（复选框）
      editable = list( # 禁用复选框列的默认编辑功能
        target = "cell", disable = list(columns = checkboxesColumns - 1) # 注意：这里 disable 的列索引是基于 DT 渲染的列（从 0 开始），所以需要 -1
      ),
      selection = "none",
      callback = JS(js("dtable", checkboxesColumns)) # 传入自定义的 JS 回调函数
    )
  }, server = FALSE) # server = FALSE 意味着数据在客户端处理，可以更好地支持复杂交互

  # 监听来自 JavaScript 的单元格编辑事件
  observeEvent(input[["dtable_cell_edit"]], { 
    info <- input[["dtable_cell_edit"]] # 获取 JS 传递过来的信息
    # 使用 editData 更新响应式数据框
    # editData 会根据 info 中的 row, col, value 更新 Dat()
    Dat(editData(Dat(), info)) 
  })

  # 显示更新后的后端数据框
  output[["reactiveDF"]] <- renderPrint({ 
    Dat()
  })

}

shinyApp(ui, server)

library(shiny)
library(DT)

ui <- fluidPage(
  br(),
  fluidRow(
    column(
      6,
      DTOutput("dtable")
    ),
    column(
      6,
      verbatimTextOutput("reactiveDF")
    )
  )
)

checkboxColumn <- function(len, col, ...) { # `col` is the column index
  inputs <- character(len)
  for(i in seq_len(len)) {
    inputs[i] <- as.character(
      checkboxInput(paste0("checkb_", col, "_", i), label = NULL, ...)
    )
  }
  inputs
}

dat0 <- data.frame(
  fruit  = c("apple", "cherry", "pineapple", "pear"),
  letter = c("a", "b", "c", "d")
)

dat1 <- cbind(dat0, bool1 = FALSE, bool2 = FALSE)

dat2 <- cbind(
  dat0,
  check1 = checkboxColumn(nrow(dat0), 3),
  check2 = checkboxColumn(nrow(dat0), 4)
)

js <- function(dtid, cols, ns = identity) {
  code <- vector("list", length(cols))
  for(i in seq_along(cols)) {
    col <- cols[i]
    code[[i]] <- c(
      sprintf(
        "$('body').on('click', '[id^=checkb_%d_]', function() {",
        col),
      "  var id = this.getAttribute('id');",
      sprintf(
        "  var i = parseInt(/checkb_%d_(\d+)/.exec(id)[1]);",
        col),
      "  var value = $(this).prop('checked');",
      sprintf(
        "  var info = [{row: i, col: %d, value: value}];",
        col),
      sprintf(
        "  Shiny.setInputValue('%s', info);",
        ns(sprintf("%s_cell_edit:DT.cellInfo", dtid))
      ),
      "});"
    )
  }
  do.call(c, code)
}

checkboxesColumns <- c(3, 4) # 对应 dat1 中 bool1 和 bool2 的列索引

server <- function(input, output, session) {

  Dat <- reactiveVal(dat1)

  output[["dtable"]] <- renderDT({
    datatable(
      dat2, 
      rownames = TRUE,
      escape = FALSE,
      editable = list(
        target = "cell", 
        disable = list(columns = checkboxesColumns - 1) # 禁用复选框列的默认编辑 (DT列索引从0开始)
      ),
      selection = "none",
      callback = JS(js("dtable", checkboxesColumns))
    )
  }, server = FALSE)

  observeEvent(input[["dtable_cell_edit"]], { 
    info <- input[["dtable_cell_edit"]]
    Dat(editData(Dat(), info))
  })

  output[["reactiveDF"]] <- renderPrint({ 
    Dat()
  })

}

shinyApp(ui, server)