Search code examples
rshinyshiny-reactivityrhandsontable

Why does is the reactivity flow broken in this instance of R Shiny?

The below R Shiny code generates 3 linked user input tables using package rhandsontable: the first table, base_input, allows the user to make static inputs and the next 2 user input tables, var_1_input and var_2_input (collectively, "var_x_input"), are reactively fed values from base_input and the slider input (input$periods) for time horizon allowing the user to alter the time dimension in their respective left-most user input columns labeled "X". The image below shows the data flows with blue lines.

The code ensure that the user is not able to delete all the rows in a var_x_input table, and if the user tries deleting a last remaining row the last "good values" in that table are restored. Works fine so far. However, once the user has tried deleting that last remaining row, the reactivity flow between base_input and the var_x_input table the user tried last remaining row deletion in no longer works. Any suggestions for how to fix this?

Note (1) the reactive correspondence between the value in each cell in base_input and a corresponding var_x_input table, where for example the first cell of base_input connects with var_1_input, the second cell of base_input corresponds with var_2_input, etc., and (2) the var_x_input tables must remain independent of one another, whereby for example changing the value in the first cell of base_input object only resets the var_1_input table and not any other var_x_input table; or changing the value in the 2nd cell of base_input only resets var_2_input and not the other var_x_input tables. The below code maintains both features, and it seems tweaking the observers below easily interrupts with item (2) especially!

enter image description here

Code:

library(shiny)
library(rhandsontable)

ui <- fluidPage(
  sliderInput("periods", "Time window (W):", min = 1, max = 10, value = 5),
  h5(strong("Variable (Y) over window (W):")),
  rHandsontableOutput("base_input"),  
  uiOutput("Vectors")
)

server <- function(input, output, session) {
  numVars <- 2  # Number of variables to model
  varValues <- lapply(1:numVars, function(i) { reactiveValues(data = 20) })
  lastGoodFirstRows <- lapply(1:numVars, function(i) { reactiveVal() })
  
  output$base_input <- renderRHandsontable({
    rhandsontable(
      data.frame(Inputs = sapply(varValues, function(x) x$data)),
      readOnly = FALSE,
      colHeaders = c('Inputs'),
      rowHeaders = paste0("Var ", LETTERS[1:numVars]),
      contextMenu = FALSE
    )
  })
  
  observeEvent(input$base_input, {
    newValues <- hot_to_r(input$base_input)$Inputs
    for (i in 1:numVars) {varValues[[i]]$data <- newValues[i]}
  })
  
  output$Vectors <- renderUI({
    lapply(1:numVars, function(i) {
      varInputId <- paste0("var_", i, "_input")
      output[[varInputId]] <- renderRHandsontable({
        df <- data.frame(X = input$periods, Y = varValues[[i]]$data)
        if (is.null(lastGoodFirstRows[[i]]())) {
          lastGoodFirstRows[[i]](df[1, , drop = FALSE])  # Initialize with the first row
        }
        rhandsontable(df, contextMenu = TRUE, minRows = 1)
      })
      
      observeEvent(input[[varInputId]], {
        latest_data <- hot_to_r(input[[varInputId]])
        if (any(is.na(latest_data[1, ]))) {
          latest_data[1, ] <- lastGoodFirstRows[[i]]()  # Restore last good first row
          output[[varInputId]] <- renderRHandsontable(rhandsontable(latest_data, contextMenu = TRUE, minRows = 1))
        } else {
          lastGoodFirstRows[[i]](latest_data[1, , drop = FALSE])
        }
      }, ignoreInit = TRUE)
      list(
        h5(strong(paste("Adjust Var ", LETTERS[i], " (Y) at time X:"))),
        rHandsontableOutput(varInputId)
      )
    })
  })
}

shinyApp(ui, server)
Solution

  • I didn't try to understand your code. It is very strange: you have an output slot and an observer inside a renderUI...

    I didn't try because there's a simpler way to prevent the deletion of the row, by using the beforeRemoveRow hook:

    library(shiny)
library(rhandsontable)
library(htmlwidgets)

jsCode <- c(
  "function(el, x) {",
  "  var hot = this.hot;",
  "  Handsontable.hooks.add('beforeRemoveRow', function(index, amount){",
  "    var nrows = hot.countRows();",
  "    if(nrows === 1) {",
  "      return false;",
  "    }",
  "  }, hot);",
  "}"
)

ui <- fluidPage(
  sliderInput("periods", "Time window (W):", min = 1, max = 10, value = 5),
  h5(strong("Variable (Y) over window (W):")),
  rHandsontableOutput("base_input"),  
  uiOutput("Vectors")
)

server <- function(input, output, session) {
  numVars <- 2  # Number of variables to model
  varValues <- lapply(1:numVars, function(i) { reactiveValues(data = 20) })
  lastGoodFirstRows <- lapply(1:numVars, function(i) { reactiveVal() })
  
  output$base_input <- renderRHandsontable({
    rhandsontable(
      data.frame(Inputs = sapply(varValues, function(x) x$data)),
      readOnly = FALSE,
      colHeaders = c('Inputs'),
      rowHeaders = paste0("Var ", LETTERS[1:numVars]),
      contextMenu = FALSE
    )
  })
  
  observeEvent(input$base_input, {
    newValues <- hot_to_r(input$base_input)$Inputs
    for (i in 1:numVars) {varValues[[i]]$data <- newValues[i]}
  })

  lapply(1:numVars, function(i) {
    varInputId <- paste0("var_", i, "_input")
    output[[varInputId]] <- renderRHandsontable({
      df <- data.frame(X = input$periods, Y = varValues[[i]]$data)
      rhandsontable(df, contextMenu = TRUE, minRows = 1) %>% 
        onRender(jsCode)
    })
  })
  
  output$Vectors <- renderUI({
    lapply(1:numVars, function(i) {
      varInputId <- paste0("var_", i, "_input")
      list(
        h5(strong(paste("Adjust Var ", LETTERS[i], " (Y) at time X:"))),
        rHandsontableOutput(varInputId)
      )
    })
  })
  
}

shinyApp(ui, server)