Shiny可响应编辑数据表新增行时复选框状态丢失问题

我正在开发一款用于数据记录的Shiny应用，观测者发现新事件时，需要在响应式可编辑数据框中新增一行记录。野外工作结束后，其他人员会检查数据是否存在录入错误，部分超出常规的数据可能被误判为错误并删除。因此我希望在数据表中添加复选框，让观测者可确认这类特殊数据，避免被误删。

目前手动修改文本或数值字段时，更改可通过自定义的editable函数保存，但切换复选框状态后，新增行时复选框会重置为未勾选状态。

示例代码 #

library(shiny)
library(tidyverse)
library(DT)
library(shinyjs)

shinyApp(
ui <- fluidPage(
  titlePanel("Reactive table with checkbox editable"),
  selectInput("photo","Photo", c("choose"="","Dog", "Shovel", "Cat", "Desk")),
  selectInput("description", "Description", c("choose"="","object", "animal")),
  actionButton("add_line", "Add a line"),
  dataTableOutput("table")
),

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

# Function to manage cell changes
  
  editable<- function(input,data) {
   observeEvent(input$table_cell_edit, {
      info <- input$table_cell_edit
      row <- info$row
      col <- info$col
      value <- info$value
      
      dat <- data()
      if (col == 3) {  
        dat[row, col] <- as.logical(value) 
      } else {
        dat[row, col] <- value
      }
      data(dat)
      
    })}
    

# Creating an empty frame
  
  myinitialframe <- data.frame(
    Photo = character(),
    Description = character(),
    Confirmed = character(),
    stringsAsFactors = FALSE
  )
  
# Get my empty frame reactive
  mydata <- reactiveVal(myinitialframe) 
  
  # ajout de ligne
  observeEvent(input$add_line, {
    new_row <- data.frame(
      Photo = input$photo,
      Description = input$description,
      Confirmed = FALSE
      )
    newdata <- rbind(new_row,mydata())
    mydata(newdata)
  })
  
# Display the table with checkbox in column "Confirmed"

    output$table <- DT::renderDataTable({
    mydata <- as.data.frame (mydata ())
    
    mydata <- datatable(
      mydata,
      editable = "cell",
      options = list(
        columnDefs = list(
          list(
            targets = c(3),
            render = JS(
              "function(data, type, row, meta) {",
              "  if (type === 'display') {",
              "    return '<input type=\"checkbox\" ' + (data === 'TRUE' ? 'checked' : '') + '/>';", 
              "  }",
              "  return data;",
              "}"
            )
          )
        )
      )
    )
    
})
    editable(input,mydata)


  }
)

已尝试的无效方案 #

• 使用论坛推荐的shinyInput，无法适配响应式表格新增行的场景；
• 使用JS回调函数：

callback = JS(
  "table.on('click', 'input[type=checkbox]', function() {",
  "  var data = table.cell(this).data();",
  "  data = !data;",
  "  table.cell(this).data(data).draw(false);",
  "});",
)

• 使用shinyjs：

shinyjs::runjs(
  "shinyjs.toggleCheckbox = function(checkbox) {
    var row = checkbox.closest('tr');
    var rowIndex = mytable.row(row).index();
    var newValue = !mytable.cell(rowIndex, 3).data();
    mytable.cell(rowIndex, 3).data(newValue).draw();
  };",
) 

解决方案 #

问题核心是：自定义渲染的复选框点击时不会触发DT的table_cell_edit事件，导致复选框状态未同步到响应式数据框mydata，新增行重新渲染表格时状态丢失。

修改后的完整代码 #

library(shiny)
library(tidyverse)
library(DT)
library(shinyjs)

shinyApp(
  ui <- fluidPage(
    titlePanel("Reactive table with checkbox editable"),
    selectInput("photo","Photo", c("choose"="","Dog", "Shovel", "Cat", "Desk")),
    selectInput("description", "Description", c("choose"="","object", "animal")),
    actionButton("add_line", "Add a line"),
    dataTableOutput("table")
  ),
  
  server <- function(input, output, session) {
    
    # 管理单元格修改的函数
    editable<- function(input,data) {
      observeEvent(input$table_cell_edit, {
        info <- input$table_cell_edit
        row <- info$row
        col <- info$col
        value <- info$value
        
        dat <- data()
        # 处理复选框列的逻辑值转换
        if (col == 3) {  
          dat[row, col] <- as.logical(value) 
        } else {
          dat[row, col] <- value
        }
        data(dat)
      })
    }
    
    # 创建初始空数据框，Confirmed设为逻辑型
    myinitialframe <- data.frame(
      Photo = character(),
      Description = character(),
      Confirmed = logical(),
      stringsAsFactors = FALSE
    )
    
    # 响应式数据框
    mydata <- reactiveVal(myinitialframe) 
    
    # 新增行
    observeEvent(input$add_line, {
      new_row <- data.frame(
        Photo = input$photo,
        Description = input$description,
        Confirmed = FALSE
      )
      newdata <- rbind(mydata(), new_row)
      mydata(newdata)
    })
    
    # 渲染带复选框的数据表
    output$table <- DT::renderDataTable({
      datatable(
        mydata(),
        editable = "cell",
        options = list(
          columnDefs = list(
            list(
              targets = 2, # DT列索引从0开始，对应R数据框第3列
              render = JS(
                "function(data, type, row, meta) {",
                "  if (type === 'display') {",
                "    return '<input type=\"checkbox\" ' + (data ? 'checked' : '') + '/>';", 
                "  }",
                "  return data;",
                "}"
              )
            )
          )
        ),
        callback = JS(
          "table.on('click', 'input[type=checkbox]', function() {",
          "  var cell = table.cell($(this).closest('td'));",
          "  var newValue = $(this).is(':checked');",
          "  // 手动触发cellEdit事件，同步到Shiny端",
          "  cell.data(newValue).draw(false);",
          "  Shiny.setInputValue('table_cell_edit', {",
          "    row: cell.index().row + 1, // DT行索引从0开始，Shiny的table_cell_edit行索引从1开始",
          "    col: cell.index().column + 1,",
          "    value: newValue",
          "  });",
          "});"
        )
      )
    })
    
    editable(input,mydata)
    
  }
)

关键修改说明 #

1. DT列索引修正：DT的targets参数从0开始计数，原代码中Confirmed列是R数据框第3列，对应DT索引应为2，之前的错误导致复选框渲染逻辑异常；
2. 复选框事件同步：通过callback监听复选框点击，手动更新单元格数据并触发table_cell_edit事件，让editable函数捕获状态变化并同步到mydata；
3. 数据类型统一：初始数据框的Confirmed列设为逻辑型，避免类型转换错误。

修改后，复选框状态会被正确保存到响应式数据框，新增行时之前的勾选状态不会丢失。

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