R Shiny中含numericInput的DataTable切换车型后交互失效问题

我想在R Shiny里创建带numericInput组件的DataTable，实现用户输入值的即时调用。参考相关代码后，发现只有初始状态下功能正常，切换车型（选择不同的汽车型号）后，新输入的值无法正常打印出来。

原代码如下：

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


ui <- fluidPage(
  tags$head(tags$script(
    HTML(
      "Shiny.addCustomMessageHandler('unbindDT', function(id) {
        var $table = $('#'+id).find('table');
        if($table.length > 0){
          Shiny.unbindAll($table.DataTable().table().node());
        }
      })")
  )),
  title = 'selectInput or numericInput column in a table',
  sidebarLayout(
    sidebarPanel(
      selectizeInput(inputId = "cars", label = "Car model", choices = rownames(mtcars), selected = rownames(mtcars)[1:6], multiple = T )
    ),
    mainPanel(
      DT::dataTableOutput('carTable'),
      verbatimTextOutput('price')
    )
  )
  
)

server <- function(input, output, session) {
  
  
  rvar <- reactiveValues(
    DF = mtcars
  )
  observeEvent(input$cars,{
    for (i in 1:nrow(rvar$DF)) {
      rvar$DF$price[i] <- as.character(numericInput(paste0("price", i), "", 0, width = "100px"))
    }
    rvar$data <- rvar$DF[rownames(mtcars) %in% input$cars, ] %>% select(-price)
  })
  
  output$carTable = DT::renderDT({
    data <-  rvar$DF[rownames(mtcars) %in% input$cars, ] %>% mutate(carmodel = input$cars) %>% relocate(carmodel)
    datatable(
      data, escape = FALSE, selection = 'none',
      options = list(
        dom = 't', 
        paging = FALSE, 
        ordering = FALSE,
        preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
        drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); }')
      ),
      rownames = FALSE
    )
  }, server = FALSE)
  
  output$price = renderPrint({
    str(sapply(1:nrow(rvar$data), function(i) input[[paste0("price", i)]]))
  })
  
  
  
  observe({
    updatedPrice <- sapply(1:nrow(rvar$DF), function(i) input[[paste0("price", i)]]) %>% Reduce(c,.)
    if(is.null(updatedPrice) | length(updatedPrice) !=  nrow(rvar$data)){
      updatedPrice <- 0
    }
    isolate({
      rvar$data$price <- updatedPrice
    })
    
    print(sapply(1:nrow(rvar$data), function(i) input[[paste0("price", i)]]) %>% Reduce(c,.))
    print(rvar$data)
  })
  
  observeEvent(input$cars, {
    session$sendCustomMessage("unbindDT", "carTable")
  })
  
}

shinyApp(ui, server)

问题根源 #

1. Input ID与行位置绑定：原代码用原数据集的行号（1到nrow(mtcars)）作为numericInput的ID，切换车型后，筛选后的行位置和原行号不匹配，导致获取输入值时对应到错误的组件。
2. 重复生成Input组件：每次切换车型都重新生成所有numericInput，容易引发Shiny输入绑定混乱。
3. 输入值获取逻辑错误：用筛选后数据集的行号去匹配原行号的Input ID，无法正确获取新筛选车型的输入值。

修改后的完整代码 #

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

ui <- fluidPage(
  tags$head(tags$script(
    HTML(
      "Shiny.addCustomMessageHandler('unbindDT', function(id) {
        var $table = $('#'+id).find('table');
        if($table.length > 0){
          Shiny.unbindAll($table.DataTable().table().node());
        }
      })")
  )),
  title = '带numericInput的车型DataTable',
  sidebarLayout(
    sidebarPanel(
      selectizeInput(
        inputId = "cars", 
        label = "选择车型", 
        choices = rownames(mtcars), 
        selected = rownames(mtcars)[1:6], 
        multiple = TRUE
      )
    ),
    mainPanel(
      DT::dataTableOutput('carTable'),
      verbatimTextOutput('price')
    )
  )
)

server <- function(input, output, session) {
  
  # 初始化带numericInput的数据集，用行名作为Input ID的一部分
  rvar <- reactiveValues(
    DF = mtcars %>% 
      rownames_to_column("carmodel") %>% 
      mutate(price = map_chr(carmodel, ~as.character(numericInput(paste0("price_", .x), "", 0, width = "100px"))))
  )
  
  # 响应车型选择，更新显示的数据集
  filtered_data <- reactive({
    req(input$cars)
    rvar$DF %>% filter(carmodel %in% input$cars)
  })
  
  output$carTable = DT::renderDT({
    datatable(
      filtered_data(), 
      escape = FALSE, 
      selection = 'none',
      options = list(
        dom = 't', 
        paging = FALSE, 
        ordering = FALSE,
        preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
        drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); }')
      ),
      rownames = FALSE
    )
  }, server = FALSE)
  
  # 实时获取并打印输入的价格值
  output$price = renderPrint({
    req(input$cars)
    # 根据当前选中的车型行名获取对应Input值
    price_values <- sapply(input$cars, function(car) input[[paste0("price_", car)]])
    str(price_values)
  })
  
  # 切换车型时解绑表格输入组件，避免绑定混乱
  observeEvent(input$cars, {
    session$sendCustomMessage("unbindDT", "carTable")
  })
  
}

shinyApp(ui, server)

关键修改说明 #

1. 绑定Input ID到车型行名：将numericInput的ID设置为price_+车型行名，确保每个车型的输入框ID唯一且与自身绑定，不受筛选后行位置影响。
2. 初始化时一次性生成Input：在应用启动时就为所有车型生成对应的numericInput，避免重复生成引发的绑定问题。
3. 基于车型行名获取输入值：响应车型选择时，直接用选中的车型行名去匹配对应的Input ID，确保获取的是当前显示车型的输入值。
4. 简化数据集逻辑：用reactive对象处理筛选后的数据集，让代码逻辑更清晰。

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