如何在Shiny模块的DataTable中添加复选框并存储其值？

我有一个Shiny模块，可展示包含评论列的表格，用户能在客户端输入评论并将其存储到数据库。现在需要新增一列复选框，将其对应的TRUE/FALSE值存入数据库，但不清楚如何从表格中获取复选框的值。以下是基于示例数据的尝试代码：

library(tidyverse)
library(shinyWidgets)
library(shiny)
library(htmlwidgets)


mtcars_df <- mtcars %>% 
  rownames_to_column(var="car")


writeback_UI <- function (id) {
  ns <- NS(id)

  DT::dataTableOutput(ns('records_tbl'))
  
}
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
}

# 获取输入值的函数
shinyValue = function(id, len) {
  unlist(lapply(seq_len(len), function(i) {
    value = input[[paste0(id, i)]]
    if (is.null(value)) NA else value
  }))
}



writeback_server <- function (id,records_data) {
  #stopifnot(is.reactive(records_data))
  shiny::moduleServer(id, function (input,output,session) {
    
    
    # 初始化评论存储
    comments_df <- reactiveVal(tibble(car=rownames(mtcars),comments=NA_character_))
    
    records_df <- reactive({
      records_data %>% 
        left_join(comments_df()) %>% 
        mutate(key_check= shinyInput(checkboxInput,nrow(.), 'cb_', value = TRUE))
        #mutate(check_values=shinyValue('cb_', nrow(.)))
    })
    
  
  
    
    
    output$records_tbl <- DT::renderDT({
      num_cols <- dim(records_df())[2]-2
      DT::datatable(
        records_df(),
        editable = list(target="column",disable=list(columns= 1:num_cols)),
        filter = "top",
        escape = FALSE,
        selection = 'none',
        options = list(
          dom = 't',
          paging = TRUE,
          ordering = FALSE,
          preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
          drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '),
          pageLength = 10,
          scrollX=TRUE,
          buttons=c('copy','csv','excel')),
        
      )
    }
    )
    
    
    observe({
      req(input$records_tbl_cell_edit)
      comments_data <- records_df() %>% 
        slice(input$records_tbl_cell_edit$row) %>% 
        select(car) %>% 
        mutate(comment=input$records_tbl_cell_edit$value) %>% 
        filter(comment!="")
      
      
      comments_df(comments_df() %>% 
                    rows_upsert(comments_data) %>% 
                    distinct())
      
  
    }) %>% 
      bindEvent(input$records_tbl_cell_edit)
    
  
    
    
   
    
    return(
      reactive({records_data %>%
          left_join(comments_df())
      }))
    
    # 
  }
  )
}


WriteBackTestApp <- function() {
  
  mtcars_df <- mtcars %>% rownames_to_column(var = "car")
  
  ui <- fluidPage(
    writeback_UI("wb")
  )
  
  server <- function(input, output, session) {
    writeback_server("wb",mtcars_df)
  }
  shinyApp(ui, server)
}

WriteBackTestApp()

修改方案 #

核心修改点 #

1. 新增复选框状态存储：添加checkboxes_df reactiveVal，用于保存每一行复选框的TRUE/FALSE状态
2. 同步复选框初始状态：生成表格时，从存储的状态中读取值，设置复选框的初始选中状态
3. 监听复选框变化：添加observe事件，捕获每个复选框的点击事件，实时更新存储的状态
4. 整合返回数据：将复选框状态和评论数据一起合并到返回的数据集中
5. 调整DT可编辑设置：确保复选框列不被标记为可编辑，避免冲突

修改后的完整代码 #

library(tidyverse)
library(shinyWidgets)
library(shiny)
library(htmlwidgets)


mtcars_df <- mtcars %>% 
  rownames_to_column(var="car")


writeback_UI <- function (id) {
  ns <- NS(id)

  DT::dataTableOutput(ns('records_tbl'))
  
}
shinyInput = function(FUN, len, id, values, ...) {
  inputs = character(len)
  for (i in seq_len(len)) {
    inputs[i] = as.character(FUN(paste0(id, i), label = NULL, value = values[i], ...))
  }
  inputs
}

# 获取输入值的函数
shinyValue = function(id, len) {
  unlist(lapply(seq_len(len), function(i) {
    value = input[[paste0(id, i)]]
    if (is.null(value)) NA else value
  }))
}



writeback_server <- function (id,records_data) {
  shiny::moduleServer(id, function (input,output,session) {
    
    # 初始化评论存储
    comments_df <- reactiveVal(tibble(car=records_data$car, comments=NA_character_))
    # 初始化复选框状态存储
    checkboxes_df <- reactiveVal(tibble(car=records_data$car, is_checked=TRUE))
    
    records_df <- reactive({
      records_data %>% 
        left_join(comments_df(), by="car") %>% 
        left_join(checkboxes_df(), by="car") %>% 
        # 根据存储的状态生成复选框
        mutate(key_check= shinyInput(checkboxInput, nrow(.), 'cb_', values = .$is_checked)) %>% 
        # 调整列顺序，把复选框列放在后面
        select(-is_checked, everything())
    })
    
    output$records_tbl <- DT::renderDT({
      # 计算不可编辑的列：除了评论列之外的所有列（包括复选框列）
      non_editable_cols <- which(colnames(records_df()) != "comments")
      DT::datatable(
        records_df(),
        editable = list(target="column", disable=list(columns=non_editable_cols)),
        filter = "top",
        escape = FALSE,
        selection = 'none',
        options = list(
          dom = 't',
          paging = TRUE,
          ordering = FALSE,
          preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
          drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '),
          pageLength = 10,
          scrollX=TRUE,
          buttons=c('copy','csv','excel')
        )
      )
    })
    
    # 监听评论编辑事件
    observe({
      req(input$records_tbl_cell_edit)
      edit_row <- input$records_tbl_cell_edit$row
      edit_value <- input$records_tbl_cell_edit$value
      
      comments_data <- records_df() %>% 
        slice(edit_row) %>% 
        select(car) %>% 
        mutate(comments=ifelse(edit_value=="", NA_character_, edit_value))
      
      comments_df(comments_df() %>% 
                    rows_upsert(comments_data, by="car"))
    }) %>% bindEvent(input$records_tbl_cell_edit)
    
    # 监听复选框变化事件
    observe({
      # 获取当前所有复选框的值
      current_check_values <- shinyValue('cb_', nrow(records_data))
      # 生成更新后的复选框状态表
      updated_checks <- tibble(
        car=records_data$car,
        is_checked=current_check_values
      )
      # 更新存储的状态
      checkboxes_df(updated_checks)
    }) %>% bindEvent(lapply(seq_len(nrow(records_data)), function(i) input[[paste0("cb_",i)]]))
    
    # 返回包含评论和复选框状态的数据集
    return(
      reactive({
        records_data %>%
          left_join(comments_df(), by="car") %>% 
          left_join(checkboxes_df(), by="car")
      })
    )
    
  })
}


WriteBackTestApp <- function() {
  
  mtcars_df <- mtcars %>% rownames_to_column(var = "car")
  
  ui <- fluidPage(
    writeback_UI("wb")
  )
  
  server <- function(input, output, session) {
    # 可以获取返回的数据集，用于后续存入数据库
    final_data <- writeback_server("wb", mtcars_df)
    
    # 可选：打印数据到控制台查看
    observe(print(final_data()))
  }
  shinyApp(ui, server)
}

WriteBackTestApp()

关键说明 #

• 调整了shinyInput函数，新增values参数来传递复选框的初始选中状态，确保分页或刷新后状态不会丢失
• 用bindEvent监听所有复选框的输入变化，实时更新存储的状态
• 返回的数据集中同时包含评论和复选框的状态，可直接用于写入数据库
• 修正了DT的可编辑列设置，只允许编辑评论列，避免误操作复选框列

内容的提问来源于stack exchange，提问作者Mohamad Sahil