使用DT与下拉选单时Shiny中值无法更新的问题

算力阿峰

2026-7-25

问题描述

需要开发一个Shiny应用用于动态编辑实验结构数据表，核心需求：

可重新加载本地CSV文件
为多水平实验因子的单元格生成下拉选单（仅因子水平数>1时添加）
非因子列支持手动编辑
点击「Save」按钮保存更新后的CSV并关闭应用

当前问题：手动编辑的内容能正常保存，但下拉选单选择的值无法同步到最终保存的CSV中。

原代码及环境信息

示例代码

require(shiny)
require(DT)

# Prepare mock data
wd <- getwd()
Factors <- c("Experiment", "Condition", "Replicate", "Genotype")
ExpMapNm <- "Experiment map"
ExpMapPath <- paste0(wd, "/", ExpMapNm, ".csv")
ExpMap <- data.frame(Experiment = "Exp1",
                     Sample = paste0("Sample", 1:20),
                     Condition = as.character(sapply(c("Treated", "Mock"), function(x) { rep(x, 10) })),
                     Genotype = as.character(sapply(c("KO", "WT"), function(x) { rep(x, 5) })),
                     Replicate = 1:5)
FactorsList <- setNames(lapply(Factors, function(x) { unique(ExpMap[[x]]) }), Factors)
#
# Users should be able to edit this table in two ways:
# - in Excel manually, hence why a local version is saved below and in server when closing the app
# - within the Shiny app
# In either case, the edited table will then be reloaded into r as a data.frame which will guide further data processing
if (!file.exists(ExpMapPath)) { write.csv(ExpMap, ExpMapPath, row.names = FALSE) }

ui <- shiny::fluidPage(shiny::titlePanel(ExpMapNm), # This is the name of the table
                       shiny::mainPanel(shiny::br(),
                                        shiny::actionButton("saveBtn", "Save"),
                                        DT::dataTableOutput("Data"),
                                        verbatimTextOutput(Factors)
                       ))
server <- function(input, output) {
  Data <- read.csv(ExpMapPath)
  for (Fact in Factors) {
    if (length(FactorsList[[Fact]]) > 1) { # We only want to have a drop-down selection if a factor has more than one level.
      # Thus, in this example we do not create a drop-down selection for factor Experiment.
      lvls <- FactorsList[[Fact]] # Allowed values
      for (i in 1:nrow(Data)) {
        val <- Data[[Fact]][i]
        dflt <- c(lvls[1], val)[(val %in% lvls)+1] # If the current value is not a valid level, revert to default (1st) level
        # Otherwise keep current value, but still apply drop-down selection so choices can be changed
        Data[[Fact]][i] <- as.character(selectInput(paste0(Fact, "_", i), NULL, lvls, dflt, width = "100px"))
      }
    } else { Data[[Fact]] <- FactorsList[[Fact]] }
  }
  output$Data <- DT::renderDataTable(
    Data, escape = FALSE, selection = "none", server = FALSE,
    editable = TRUE, # Non-drop-down fields can still be edited: this works
    options = list(paging = TRUE, searching = TRUE, fixedColumns = TRUE, autoWidth = TRUE,
                   ordering = TRUE, dom = "Bfrtip"),
    callback = JS("table.rows().every(function(i, tab, row) {
        var $this = $(this.node());
        $this.attr('id', this.data()[0]);
        $this.addClass('shiny-input-container');
      });
      Shiny.unbindAll(table.table().node());
      Shiny.bindAll(table.table().node());"),
    class = "display")
  shiny::observeEvent(input$Data_cell_edit, {
    Data[input$Data_cell_edit$row, input$Data_cell_edit$col] <<- input$Data_cell_edit$value
  })
  shiny::observeEvent(input$saveBtn, {
    # Hacky HTML cleanup
    # I am not interested in getting cells with html formatting in my table, I just want the value!
    # Moreover, this would clash with the code above when initiliazing the table and comparing values.
    #print(Data$Condition[[1]])
    for (Fact in Factors) {
      if (length(FactorsList[[Fact]]) > 1) {
        for (i in 1:nrow(Data)) {
          val <- Data[[Fact]][i]
          val <- gsub("^option value=\"[^\"]+\" selected>", "",
                      grep("^option value=\"[^\"]+\" selected>", unlist(strsplit(a, " *<|>[\n ]*<|> *$")), value = TRUE))
          Data[[Fact]][i] <- val
        }
      }
    }
    # Check if I have managed to change from the default value:
    print(Data$Condition[[1]])
    # When testing, I change from "Treated" to "Mock" in the table, hit save, but it prints "Treated", and sure enough the table saved contains "Treated".
    #
    write.csv(Data, ExpMapPath, row.names = FALSE)
    tstExpMap <<- Data # Another way to check table values
    stopApp()
  })
}
print(shiny::shinyApp(ui, server, options = list(launch.browser = TRUE)))

环境信息

> sessionInfo()
R version 4.2.3 (2023-03-15 ucrt)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows Server x64 (build 20348)

Matrix products: default

locale:
[1] LC_COLLATE=English_United Kingdom.utf8  LC_CTYPE=English_United Kingdom.utf8    LC_MONETARY=English_United Kingdom.utf8
[4] LC_NUMERIC=C                            LC_TIME=English_United Kingdom.utf8    

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
[1] DT_0.26     shiny_1.7.4

loaded via a namespace (and not attached):
 [1] Rcpp_1.0.9        rstudioapi_0.14   magrittr_2.0.3    xtable_1.8-4      R6_2.5.1          rlang_1.0.6       fastmap_1.1.0     tools_4.2.3      
 [9] aRmel_4.0.0.13    cli_3.5.0         jquerylib_0.1.4   htmltools_0.5.4   crosstalk_1.2.0   ellipsis_0.3.2    yaml_2.3.6        digest_0.6.31    
[17] lifecycle_1.0.3   crayon_1.5.2      later_1.3.0       sass_0.4.4        htmlwidgets_1.6.0 promises_1.2.0.1  memoise_2.0.1     cachem_1.0.6     
[25] mime_0.12         compiler_4.2.3    bslib_0.4.2       jsonlite_1.8.4    httpuv_1.6.7

问题原因分析

下拉选单输入未被监听：原代码仅监听了DT的Data_cell_edit事件，该事件仅捕获手动编辑的单元格，无法响应下拉选单的选择变化。下拉选单是独立的Shiny输入控件，需单独监听每个控件的输入。
保存逻辑错误：保存时试图解析HTML提取选中值，但代码中使用了未定义的变量a，且HTML解析方法不稳定，无法正确获取当前选中值。
数据未用响应式对象存储：原代码中的Data是普通变量，无法实时同步下拉选单的变化，导致保存时仍用初始值。

修正方案及代码

核心改动

用reactiveVal存储数据表，确保数据能响应式更新
生成下拉选单时记录每个控件的ID，逐个监听输入变化并更新数据
保存时直接从input对象中获取下拉选单的当前值，无需解析HTML
保留DT手动编辑的监听逻辑

修正后的完整代码

require(shiny)
require(DT)

# Prepare mock data
wd <- getwd()
Factors <- c("Experiment", "Condition", "Replicate", "Genotype")
ExpMapNm <- "Experiment map"
ExpMapPath <- paste0(wd, "/", ExpMapNm, ".csv")
ExpMap <- data.frame(Experiment = "Exp1",
                     Sample = paste0("Sample", 1:20),
                     Condition = as.character(sapply(c("Treated", "Mock"), function(x) { rep(x, 10) })),
                     Genotype = as.character(sapply(c("KO", "WT"), function(x) { rep(x, 5) })),
                     Replicate = 1:5)
FactorsList <- setNames(lapply(Factors, function(x) { unique(ExpMap[[x]]) }), Factors)

if (!file.exists(ExpMapPath)) { 
  write.csv(ExpMap, ExpMapPath, row.names = FALSE) 
}

ui <- shiny::fluidPage(
  shiny::titlePanel(ExpMapNm),
  shiny::mainPanel(
    shiny::br(),
    shiny::actionButton("saveBtn", "Save"),
    DT::dataTableOutput("Data")
  )
)

server <- function(input, output) {
  # 用reactiveVal存储数据，支持响应式更新
  Data <- reactiveVal(read.csv(ExpMapPath))
  
  # 生成带下拉选单的显示用数据
  displayData <- reactive({
    dat <- Data()
    for (Fact in Factors) {
      if (length(FactorsList[[Fact]]) > 1) {
        lvls <- FactorsList[[Fact]]
        for (i in 1:nrow(dat)) {
          val <- dat[[Fact]][i]
          dflt <- ifelse(val %in% lvls, val, lvls[1])
          dat[[Fact]][i] <- as.character(selectInput(
            inputId = paste0(Fact, "_", i),
            label = NULL,
            choices = lvls,
            selected = dflt,
            width = "100px"
          ))
        }
      }
    }
    dat
  })
  
  output$Data <- DT::renderDataTable(
    displayData(),
    escape = FALSE,
    selection = "none",
    server = FALSE,
    editable = list(target = "cell", disable = list(columns = which(names(Data()) %in% Factors[lengths(FactorsList)>1]))),
    options = list(
      paging = TRUE,
      searching = TRUE,
      fixedColumns = TRUE,
      autoWidth = TRUE,
      ordering = TRUE,
      dom = "Bfrtip"
    ),
    callback = JS("
      table.rows().every(function(i, tab, row) {
        var $this = $(this.node());
        $this.addClass('shiny-input-container');
      });
      Shiny.unbindAll(table.table().node());
      Shiny.bindAll(table.table().node());
    "),
    class = "display"
  )
  
  # 监听DT手动编辑事件（仅非下拉列）
  observeEvent(input$Data_cell_edit, {
    info <- input$Data_cell_edit
    dat <- Data()
    dat[info$row, info$col] <- info$value
    Data(dat)
  })
  
  # 监听所有下拉选单的变化
  observe({
    dat <- Data()
    for (Fact in Factors) {
      if (length(FactorsList[[Fact]]) > 1) {
        for (i in 1:nrow(dat)) {
          inputId <- paste0(Fact, "_", i)
          # 检查输入是否存在并更新数据
          if (!is.null(input[[inputId]])) {
            dat[[Fact]][i] <- input[[inputId]]
          }
        }
      }
    }
    Data(dat)
  })
  
  # 保存数据并关闭应用
  observeEvent(input$saveBtn, {
    finalData <- Data()
    write.csv(finalData, ExpMapPath, row.names = FALSE)
    stopApp()
  })
}

shiny::shinyApp(ui, server, options = list(launch.browser = TRUE))

改动说明

响应式数据存储：使用reactiveVal(Data)存储数据表，确保所有修改能实时同步。
下拉选单监听：通过循环监听每个下拉选单的input值，实时更新响应式数据。
DT编辑限制：设置editable参数，禁止下拉列的手动编辑，避免冲突。
保存逻辑简化：直接从Data()获取最新数据，无需解析HTML，保证数据准确。

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

使用DT与下拉选单时Shiny中值无法更新的问题

原代码及环境信息 #

示例代码 #

环境信息 #

问题原因分析 #

修正方案及代码 #

核心改动 #

修正后的完整代码 #

改动说明 #

原代码及环境信息

示例代码

环境信息

问题原因分析

修正方案及代码

核心改动

修正后的完整代码

改动说明