Javascript Question posted in
A very good W3school tutorial can be found here.

Javascript – How to add a dropdown menu to a single row in a table rendered with rhandsontable while other rows contain numeric values?

In the below R Shiny code, I am trying to add a dropdown menu to only the last row of the table rendered with rhandsontable. Note that the table is expandable by the user, column-wise, via the action button "Add series". How do I apply the dropdown to only the last row of the table, and not every row of the table as currently occurs with the below code? I’ve tried hot_row, hot_rows, and hot_cell, but I’m not sure they support this. See the explanatory illustration below. Note that the dropdown needs to render with every added column too, which currently works but the dropdowns should not render in Row_A and Row_B. The dropdown should only render in Row_C.

enter image description here

Code:

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)
Tags:

2

Answers


  1. Chosen as BEST ANSWER
    0

    Following ismirsehregal's comment, the below appears to work. Changes from OP code is replacing NA in data frame setup with NA_character_, and addition of the htmlwidgets::onRender(...) to the output$hottable:

    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)

  2. 0

    Below is solution using Javascript which should do it:

    • We use an afterInit event where updateSettings is called. This defines the dropdown settings in the last row.

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

      Notice here that select_option is the vector defined in R which I passed below to the rhandsontable object such that I can use it in JS by accessing instance.params. However, I wrapped the code into a small setTimeout because it seems that directly when afterInit is invoked, params is not available. The only reason for using this is that you can define the options in R, if you have no problem to define them directly in JS, you can drop it below. I also tried other events but had several problems which may occur due to the shiny environment.

    • rhandsontable is not maintained since several years and in particular relies on handsontable 6.2.2. There was a bug in an older version (see handsontable/handsontable#7689) where the column headers were rendered wrong after using updateSettings. This is at least similar to an issue which I also had and so I used what was committed in order to solve this issue in an afterRenderer event:

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

    It would look like this:

    enter image description here

    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)
    Login or Signup to reply.
Please signup or login to give your own answer.

Back To Top
Search