如何向使用 rhandsontable 呈现的表格中的单行添加下拉菜单，而其他行包含数值？

Question

在下面的 R Shiny 代码中，我尝试仅向使用

rhandsontable

呈现的表格的最后一行添加一个下拉菜单。请注意，用户可以通过操作按钮“添加系列”按列扩展该表。如何将下拉列表仅应用于表格的最后一行，而不是像以下代码当前出现的那样应用于表格的每一行？我尝试过

hot_row

、

hot_rows

和

hot_cell

，但我不确定他们是否支持这一点。请参阅下面的说明图。请注意，下拉列表也需要与每个添加的列一起呈现，目前可以工作，但下拉列表不应在 Row_A 和 Row_B 中呈现。下拉列表应仅在 Row_C 中呈现。

代码：

library(rhandsontable)
library(shiny)

ui <- 
  fluidPage(
    rHandsontableOutput('hottable_1'),
    actionButton("addSeries","Add series")
  ) 

server <- function(input,output,session)({
  seriesTbl_1 <- reactiveVal(
    data.frame(
      'Series 1' = c(1,24,NA),
      row.names = c("Row_A_numeric","Row_B_numeric","Row_C_dropdown")
    )
  ) 
  
  observeEvent(input$hottable_1, {seriesTbl_1(hot_to_r(input$hottable_1))})
  
  output$hottable_1 <- renderRHandsontable({
    tbl <- seriesTbl_1()
    select_option <- c(NA_character_, "Item A", "Item B") 
    rhandsontable(
      tbl,
      rowHeaderWidth = 200, 
      useTypes = TRUE,
      selectCallback = TRUE,
      overflow = "visible"
    ) %>%
      hot_table(id = "hottable_1") %>%
      hot_col(
        col = names(tbl),
        allowInvalid = FALSE,
        type = "dropdown",
        source = select_option
      )
  })
  
  observeEvent(input$addSeries, {
    newSeriesCol_1 <- data.frame(c(1,24,NA)) 
    names(newSeriesCol_1) <- paste("Series", ncol(hot_to_r(input$hottable_1)) + 1)
    seriesTbl_1(cbind(seriesTbl_1(), newSeriesCol_1))
  })
 
  seriesTbl_1_DF <- reactive({seriesTbl_1()})
})

shinyApp(ui, server)

Answer 1

下面是使用

Javascript

的解决方案，应该可以做到这一点：

• 我们使用 afterInit 事件来调用 updateSettings。这定义了最后一行的下拉设置。

  instance.updateSettings({
      cells: function(row, col, prop) {
          var cellProperties;
          if (row === 2) {
              cellProperties = {
                  type: 'dropdown',
                  allowInvalid: false,
                  source: select_option,
              };
              return cellProperties;
          }
      }
  });
  

  请注意，

  select_option

  是

  R

  中定义的向量，我将其传递给下面的

  rhandsontable

  对象，以便我可以通过访问

  JS

  在

  instance.params

  中使用它。然而，我将代码包装成一个小

  setTimeout

  ，因为看起来直接当

  afterInit

  被调用时，

  params

  不可用。使用这个的唯一原因是你可以在

  R

  中定义选项，如果直接在

  JS

  中定义它们没有问题，你可以把它放在下面。我还尝试了其他活动，但由于

  shiny

  环境，可能会出现一些问题。

• rhandsontable

  已经好几年没有维护了，特别依赖于

  handsontable 6.2.2

  。旧版本中存在一个错误（请参阅handsontable/handsontable#7689），其中使用

  updateSettings

  后列标题呈现错误。这至少与我也遇到的问题类似，因此我使用了 commited 来在

  afterRenderer

  事件中解决此问题：

  function(TD, row, column, prop, value, cellProperties) {
      this.view.wt.wtOverlays.adjustElementsSize();
  }
  

它看起来像这样：

library(rhandsontable)
library(shiny)

ui <- 
  fluidPage(
    rHandsontableOutput('hottable_1'),
    actionButton("addSeries","Add series")
  ) 

server <- function(input,output,session)({
  seriesTbl_1 <- reactiveVal(
    data.frame(
      'Series 1' = c(1,24,NA),
      row.names = c("Row_A_numeric","Row_B_numeric","Row_C_dropdown")
    )
  ) 
  
  observeEvent(input$hottable_1, {seriesTbl_1(hot_to_r(input$hottable_1))})
  
  output$hottable_1 <- renderRHandsontable({
    tbl <- seriesTbl_1()
    rhandsontable(
      tbl,
      rowHeaderWidth = 200, 
      useTypes = TRUE,
      selectCallback = TRUE,
      overflow = "visible",
      select_option = c(NA_character_, "Item A", "Item B"),
      afterInit = htmlwidgets::JS(" 
            function() {
              let instance = this;
              setTimeout(function (){
                select_option = instance.params.select_option
                select_option = select_option instanceof Array ? select_option : [select_option]
          
                instance.updateSettings({
                  cells: function(row, col, prop) {
                           var cellProperties;
                           if (row === 2) {
                             cellProperties = {
                               type: 'dropdown',
                               allowInvalid: false,
                               source: select_option,
                             };
                             return cellProperties;
                           }
                         }       
                });
             }, 50); 
           }"),
      afterRenderer =  htmlwidgets::JS(
        "function (TD, row, column, prop, value, cellProperties) {
            this.view.wt.wtOverlays.adjustElementsSize();
         }
        ")
    ) %>%
      hot_table(id = "hottable_1") 
  })
  
  observeEvent(input$addSeries, {
    newSeriesCol_1 <- data.frame(c(1,24,NA)) 
    names(newSeriesCol_1) <- paste("Series", ncol(hot_to_r(input$hottable_1)) + 1)
    seriesTbl_1(cbind(seriesTbl_1(), newSeriesCol_1))
  })
  
  seriesTbl_1_DF <- reactive({seriesTbl_1()})
})

shinyApp(ui, server)

Answer 2

根据 ismirsehregal 的评论，以下内容似乎有效：

library(rhandsontable)
library(shiny)

ui <- fluidPage(
  rHandsontableOutput('hottable_1'),
  actionButton("addSeries", "Add series")
)

server <- function(input, output, session) {
  seriesTbl_1 <- reactiveVal(
    data.frame(
      'Series 1' = c(1, 24, NA_character_),
      row.names = c("Row_A_numeric", "Row_B_numeric", "Row_C_dropdown"),
      stringsAsFactors = FALSE
    )
  )
  
  observeEvent(input$hottable_1, {seriesTbl_1(hot_to_r(input$hottable_1))})
  
  output$hottable_1 <- renderRHandsontable({
    tbl <- seriesTbl_1()
    rhandsontable(
      tbl, 
      rowHeaderWidth = 200, 
      useTypes = TRUE, 
      selectCallback = TRUE, 
      overflow = "visible"
      ) %>%
      hot_table(id = "hottable_1") %>%
      htmlwidgets::onRender("
        function(el, x) {
          var hot = this.hot;
          hot.updateSettings({
            cells: function (row, col, prop) {
              var cellProperties = {};
              if (row === 2) {  // Third row
                cellProperties.type = 'dropdown';
                cellProperties.source = ['Item A', 'Item B'];
              } else {  // First two rows
                cellProperties.type = 'numeric';
              }
              return cellProperties;
            }
          });
        }
      ")
  })
  
  observeEvent(input$addSeries, {
    newSeriesCol_1 <- data.frame(
      c(1, 24, NA_character_), 
      stringsAsFactors = FALSE
      ) 
    names(newSeriesCol_1) <- paste("Series", ncol(hot_to_r(input$hottable_1)) + 1)
    seriesTbl_1(cbind(seriesTbl_1(), newSeriesCol_1))
  })
}

shinyApp(ui, server)