如何将同一响应式值插入rhandsontable单行的每一列？

我需要实现一个功能：用户通过下拉选择框选定一个值后，这个值会同步到rhandsontable表格的第2行（Term B）的每一列中。同时，当点击「添加」按钮新增列时，新列的第2行也要自动填充当前用户选择的这个值。下方是我写的示例代码，虽然行2所有列都用同一个值看起来有点奇怪，但这是为后续基于该值的批量计算做准备。

原代码 #

library(rhandsontable)
library(shiny)
library(shinyjs)

mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Term B','Term C','Term D') 

ui <- fluidPage(br(),
  useShinyjs(), 
  uiOutput("choices"),
  br(),
  rHandsontableOutput('hottable'),br(),
  fluidRow(
    column(1,actionButton("addSeries", "Add",width = '70px')),
    column(1,actionButton("delSeries","Delete",width = '70px')),
    column(3,hidden(uiOutput("delSeries2"))) 
  )
)

server <- function(input, output) {
  uiTable <- reactiveVal(mydata)
  
  observeEvent(input$hottable, {uiTable(hot_to_r(input$hottable))})
  
  output$hottable <- renderRHandsontable({
    rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)%>%
      hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE) %>%
      hot_cols(
        colWidths = 80,
        renderer = "function(instance, td, row, col, prop, value, cellProperties) {
           Handsontable.renderers.NumericRenderer.apply(this, arguments);
           if (instance.params && 0 === row || instance.params && 1 === row) {
               td.innerHTML = `${value}`
           } else if (instance.params && 2 === row || instance.params && 3 === row) {
               td.innerHTML = `${Number.parseFloat(value*100)}%`
           }
           if(instance.params && 1 === row) {td.style.background = '#eff0f1'} // shade row 2 only
         }"
      ) %>%
    hot_row(c(2), readOnly = TRUE)  # makes row 2 non-editable
  })
  
  observeEvent(input$choices,{
    tmpTable <- uiTable()
    tmpTable[2,]<- as.numeric(input$choices)
    uiTable(tmpTable)
  })
  
  output$choices <- 
    renderUI({
      selectInput(
        "choices", 
        label = "User selects value to reflect in row 2 of table below:",
        choices = c(1,2,3)
      )
    })
  
  observeEvent(input$addSeries, {
    newCol <- data.frame(c(1,1,0,1)) # I don't know how to insert a reactive value in 2nd position
    names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable)) + 1)
    uiTable(cbind(uiTable(), newCol))
  })
  
  observeEvent(input$delSeries3, {
    tmp <- uiTable()                                       
    delCol <- input$delSeries3                              
    tmp <- tmp[ , !(names(tmp) %in% delCol), drop = FALSE]  
    newNames <- sprintf("Series %d",seq(1:ncol(tmp)))        
    names(tmp) <- newNames                                  
    uiTable(tmp)                                         
  })

  observeEvent(input$delSeries, show("delSeries2"))
  observeEvent(input$addSeries, hide("delSeries2")) 
  
  output$delSeries2 <- 
    renderUI(
      selectInput("delSeries3", 
                  label = NULL,
                  choices = colnames(hot_to_r(input$hottable)), 
                  selected = "",
                  multiple = TRUE,
                  width = '110px')
      )

}

shinyApp(ui,server)

解决方案 #

核心问题在于添加新列时，没有将用户当前选择的响应式值填充到新列的第2行。同时优化了部分中文显示逻辑，修改后的完整代码如下：

library(rhandsontable)
library(shiny)
library(shinyjs)

mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Term B','Term C','Term D') 

ui <- fluidPage(br(),
  useShinyjs(), 
  uiOutput("choices"),
  br(),
  rHandsontableOutput('hottable'),br(),
  fluidRow(
    column(1,actionButton("addSeries", "添加",width = '70px')),
    column(1,actionButton("delSeries","删除",width = '70px')),
    column(3,hidden(uiOutput("delSeries2"))) 
  )
)

server <- function(input, output) {
  uiTable <- reactiveVal(mydata)
  
  observeEvent(input$hottable, {uiTable(hot_to_r(input$hottable))})
  
  output$hottable <- renderRHandsontable({
    rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)%>%
      hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE) %>%
      hot_cols(
        colWidths = 80,
        renderer = "function(instance, td, row, col, prop, value, cellProperties) {
           Handsontable.renderers.NumericRenderer.apply(this, arguments);
           if (instance.params && 0 === row || instance.params && 1 === row) {
               td.innerHTML = `${value}`
           } else if (instance.params && 2 === row || instance.params && 3 === row) {
               td.innerHTML = `${Number.parseFloat(value*100)}%`
           }
           if(instance.params && 1 === row) {td.style.background = '#eff0f1'} // 仅高亮第2行
         }"
      ) %>%
    hot_row(c(2), readOnly = TRUE)  # 设置第2行为只读
  })
  
  observeEvent(input$choices,{
    tmpTable <- uiTable()
    tmpTable[2,]<- as.numeric(input$choices)
    uiTable(tmpTable)
  })
  
  output$choices <- 
    renderUI({
      selectInput(
        "choices", 
        label = "请选择要填充到表格第2行的值：",
        choices = c(1,2,3)
      )
    })
  
  observeEvent(input$addSeries, {
    # 获取当前用户选择的值，若未选择则用表格中现有行2的值作为备选
    selected_val <- if(!is.null(input$choices)) as.numeric(input$choices) else uiTable()[2,1]
    # 构建新列向量，第2个元素使用用户选择的值
    newCol_vec <- c(1, selected_val, 0, 1)
    newCol <- data.frame(newCol_vec, check.names = FALSE)
    names(newCol) <- paste("Series", ncol(uiTable()) + 1)
    uiTable(cbind(uiTable(), newCol))
  })
  
  observeEvent(input$delSeries3, {
    tmp <- uiTable()                                       
    delCol <- input$delSeries3                              
    tmp <- tmp[ , !(names(tmp) %in% delCol), drop = FALSE]  
    newNames <- sprintf("Series %d",seq(1:ncol(tmp)))        
    names(tmp) <- newNames                                  
    uiTable(tmp)                                         
  })

  observeEvent(input$delSeries, show("delSeries2"))
  observeEvent(input$addSeries, hide("delSeries2")) 
  
  output$delSeries2 <- 
    renderUI(
      selectInput("delSeries3", 
                  label = NULL,
                  choices = colnames(uiTable()), 
                  selected = "",
                  multiple = TRUE,
                  width = '110px')
      )

}

shinyApp(ui,server)

关键修改点 #

1. 新增列逻辑优化：在addSeries事件中，不再使用固定值填充新列第2行，而是获取当前用户选择的input$choices值，同时处理了用户未选择时的备选情况
2. 界面文本汉化：将按钮、选择框标签等改为中文，提升易用性
3. 列名获取优化：删除列时直接从uiTable()获取列名，避免重复调用hot_to_r

内容的提问来源于stack exchange，提问作者Village.Idyot