如何在Shiny应用中切换单元格并将其排除在后续计算外

我正在开发一个计算行均值（rowmeans）和行变异系数（coefficient variation, CV）的Shiny应用，每个ID对应3个测量值。当CV超过8时，用户需要能够移除1个或2个值。目前已实现表格单元格点击选中/取消选中的样式切换，但无法实现点击单元格时移除对应值并更新均值和CV的功能，以下是当前应用代码：

library(shiny)
library(DT)

ui <- fluidPage(
  fluidRow(
    column(width = 8, DTOutput("table1")),
    column(width = 4, DTOutput("table2"))
  ),
  
  # Custom CSS to define the initial cell color
  tags$head(
    tags$style(HTML("
      .default-cell-color {
        background-color: lightgreen !important;
      }
      .selected-cell-color {
        background-color: lightcoral !important;
      }
    "))
  )
)

server <- function(input, output, session) {
  # Sample data for demonstration purposes (contains only numeric values)
  data <- data.frame(
    ID = c(1, 2, 3),
    Measure1 = c(25, 30, 22),
    Measure2 = c(30, 32, 28),
    Measure3 = c(35, 40, 30)
  )
  
  # Add a new column for row means
  data$row_mean <- apply(data[, -1], 1, mean) # Calculate row means for numeric columns (excluding the first column)
  
  # Add a new column for coefficient of variation (CV)
  data$cv <- apply(data[, -1], 1, function(row) (sd(row) / mean(row)) * 100)
  
  # Render the first table using DT::renderDataTable
  output$table1 <- DT::renderDataTable({
    datatable(
      data[, c(1:4)],
      selection = "none", # Disable row selection
      editable = FALSE,   # Disable cell editing
      class = "cell-color-table",
      options = list(
        dom = "t",        # Display table only without search bar, etc.
        pageLength = 10,  # Number of rows per page
        columnDefs = list(
          list(targets = "_all", className = "dt-center") # Center-align all columns
        ),
        initComplete = JS(
          "function(settings, json) {",
          "  var table = settings.oInstance.api();",
          "  table.cells().every(function() {",
          "    $(this.node()).addClass('default-cell-color');",
          "  });",
          "  table.on('click.dt', 'td', function() {",
          "    var cell = $(this);",
          "    var table = cell.closest('table').DataTable();",
          "    var row = table.cell(this).index().row;",
          "    var col = table.cell(this).index().column;",
          "    var isSelected = cell.hasClass('selected-cell-color');",
          "    if (isSelected) {",
          "      cell.removeClass('selected-cell-color');",
          "      cell.addClass('default-cell-color');",
          "    } else {",
          "      cell.removeClass('default-cell-color');",
          "      cell.addClass('selected-cell-color');",
          "    }",
          "    Shiny.setInputValue('selected_cells', {row: row, col: col, isSelected: !isSelected});",
          "  });",
          "}"
        )
      )
    )
  })
  
  # Render the second table for row means and CV
  output$table2 <- DT::renderDataTable({
    datatable(
      data[, c("row_mean", "cv")],
      selection = "none", # Disable row selection
      editable = FALSE,   # Disable cell editing
      class = "cell-color-table",
      options = list(
        dom = "t",        # Display table only without search bar, etc.
        pageLength = 10,  # Number of rows per page
        columnDefs = list(
          list(targets = "_all", className = "dt-center") # Center-align all columns
        )
      )
    ) %>% 
      formatStyle(
        'cv',
        backgroundColor = styleInterval(8, c('lightgreen', 'red'))
      )
  })
  
  # Observe changes in the selected_cells input and update cell colors accordingly
  observe({
    selected <- input$selected_cells
    if (!is.null(selected)) {
      rows <- selected$row
      cols <- selected$col
      
      # Get the JavaScript code to update cell colors based on the selected cells
      js_code <- ""
      for (i in seq_along(rows)) {
        row <- rows[i]
        col <- cols[i]
        cell_css <- sprintf("#table1 tbody tr:eq(%d) td:eq(%d)", row, col)
        js_code <- paste0(js_code, sprintf("$('%s').toggleClass('selected-cell-color').toggleClass('default-cell-color');", cell_css))
      }
      session$sendCustomMessage(type = 'jsCode', list(code = js_code))
    }
  })
}
shinyApp(ui, server)

要实现点击单元格移除对应值并动态更新统计量，核心是使用反应式数据对象存储可修改的数据，并在单元格点击时更新数据、重新计算均值和CV。以下是修改后的完整代码：

library(shiny)
library(DT)

ui <- fluidPage(
  fluidRow(
    column(width = 8, DTOutput("table1")),
    column(width = 4, DTOutput("table2"))
  ),
  
  # Custom CSS to define the initial cell color
  tags$head(
    tags$style(HTML("
      .default-cell-color {
        background-color: lightgreen !important;
      }
      .selected-cell-color {
        background-color: lightcoral !important;
      }
    "))
  )
)

server <- function(input, output, session) {
  # 存储原始数据备份，用于恢复被移除的值
  original_data <- data.frame(
    ID = c(1, 2, 3),
    Measure1 = c(25, 30, 22),
    Measure2 = c(30, 32, 28),
    Measure3 = c(35, 40, 30),
    stringsAsFactors = FALSE
  )
  
  # 用反应式对象存储可修改的数据，支持动态更新
  current_data <- reactiveVal(
    cbind(original_data, row_mean = NA_real_, cv = NA_real_)
  )
  
  # 监听数据变化，动态计算均值和CV（排除NA值）
  observe({
    data <- current_data()
    # 计算行均值
    data$row_mean <- apply(data[, 2:4], 1, function(row) {
      vals <- row[!is.na(row)]
      if(length(vals) == 0) NA else mean(vals)
    })
    # 计算CV（至少需要2个有效数据）
    data$cv <- apply(data[, 2:4], 1, function(row) {
      vals <- row[!is.na(row)]
      if(length(vals) < 2) NA else (sd(vals)/mean(vals))*100
    })
    current_data(data)
  }) %>% bindEvent(current_data())
  
  # 渲染第一个表格（测量值）
  output$table1 <- DT::renderDataTable({
    data <- current_data()
    datatable(
      data[, c(1:4)],
      selection = "none",
      editable = FALSE,
      class = "cell-color-table",
      options = list(
        dom = "t",
        pageLength = 10,
        columnDefs = list(list(targets = "_all", className = "dt-center")),
        initComplete = JS(
          "function(settings, json) {",
          "  var table = settings.oInstance.api();",
          "  table.cells().every(function() {",
          "    // 根据单元格是否为NA设置初始样式",
          "    if(this.data() === null || this.data() === 'NA') {",
          "      $(this.node()).addClass('selected-cell-color');",
          "    } else {",
          "      $(this.node()).addClass('default-cell-color');",
          "    }",
          "  });",
          "  table.on('click.dt', 'td', function() {",
          "    var cell = $(this);",
          "    var table = cell.closest('table').DataTable();",
          "    var row = table.cell(this).index().row;",
          "    var col = table.cell(this).index().column;",
          "    var isSelected = cell.hasClass('selected-cell-color');",
          "    cell.toggleClass('selected-cell-color').toggleClass('default-cell-color');",
          "    Shiny.setInputValue('selected_cells', {row: row, col: col, isSelected: !isSelected});",
          "  });",
          "}"
        )
      )
    )
  })
  
  # 渲染第二个表格（均值和CV）
  output$table2 <- DT::renderDataTable({
    data <- current_data()
    datatable(
      data[, c("row_mean", "cv")],
      selection = "none",
      editable = FALSE,
      class = "cell-color-table",
      options = list(
        dom = "t",
        pageLength = 10,
        columnDefs = list(list(targets = "_all", className = "dt-center"))
      )
    ) %>% 
      formatStyle(
        'cv',
        backgroundColor = styleInterval(8, c('lightgreen', 'red'))
      )
  })
  
  # 处理单元格点击事件，更新数据
  observe({
    selected <- input$selected_cells
    if (!is.null(selected)) {
      # DT的索引从0开始，转换为R的1索引
      row_idx <- selected$row + 1
      col_idx <- selected$col + 1
      
      # 仅处理测量值列（第2-4列）
      if(col_idx %in% 2:4){
        data <- current_data()
        if(selected$isSelected){
          # 选中单元格，移除对应值（设为NA）
          data[row_idx, col_idx] <- NA
        } else {
          # 取消选中，恢复原始值
          data[row_idx, col_idx] <- original_data[row_idx, col_idx]
        }
        current_data(data)
      }
    }
  })
}
shinyApp(ui, server)

• 反应式数据管理：用reactiveVal存储可修改的数据，确保数据变化后自动触发UI和统计量的更新
• 动态统计计算：基于每行非NA的测量值重新计算均值和CV，同时处理了无有效数据或数据量不足的情况，避免报错
• 单元格交互逻辑：点击单元格时将对应测量值设为NA（标记为移除），取消选中时从原始数据备份中恢复值
• 样式同步：表格初始化时根据单元格是否为NA设置对应样式，确保数据状态与视觉样式一致

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