How to conditionally reset a user input table rendered with rhandsontable?

Question

In running the below R Shiny code, the user changing the sliderInput() (object input$periods) resets all of the variable user input tables that are generated by the block of code that begins lapply(1:numVars, function(i) {varInputId <- paste0("var_", i, "_input")…}), and as illustrated in the image below.

That block of code generates 2 user input tables ("X/Y tables") using rhandsontable, each with 2 columns with headers “X” and “Y”. Any change in input$periods resets both of the X/Y tables. How can the code be modified so that the only tables that are reset upon a change in input$periods are those tables where the maximum value in its leftmost “X” column exceeds the new, reset value of input$periods?

The input$periods serves as the upper limit for the overall time window. The variables in column X represent the time period in which to change variable Y. So X must always <= input$periods.

If it's possible to do this in js, I prefer it in js. When I make changes in R it's easy to lose key functionality of this App such as (a) the independence of the X/Y tables, were a change to a input$base_input value (top table) only resets the linked X/Y table and not all the X/Y tables, (b) the requirement that there be no less than 1 row in an X/Y table, and (c) the upper/lower bound limits on the column X inputs in the X/Y tables. In the more complete code this is extracted from (where there are many more input validation checks using js), additions to js are less disruptive to functionality than base R changes. But I'll take whatever I can get.

Code:

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 = 1, Y = varValues[[i]]$data)
      rhandsontable(df, contextMenu = TRUE, minRows = 1,rowHeaders = FALSE) %>%
        onRender(jsCode) %>%
        hot_validate_numeric(col = 1, min = 1, max = input$periods)
    })
  })

  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)

Answer 1

The below works but using base R and without using js. I'll keep this query open in hopes that someone has an efficient js solution. My understanding is that js will be more efficient because processing is on the client side without having to process back and forth with the server side.

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("parentTbl"),  
  uiOutput("childTbl")
)

server <- function(input, output, session) {
  numVars <- 2  # Number of variables to model
  parentVars <- lapply(1:numVars, function(i) { reactiveValues(data = 20) })
  
  # Builds parent parentTbl table
  output$parentTbl <- renderRHandsontable({
    rhandsontable(
      data.frame(Inputs = sapply(parentVars, function(x) x$data)),
      readOnly = FALSE,
      colHeaders = c('Inputs'),
      rowHeaders = paste0("Var ", LETTERS[1:numVars]),
      contextMenu = FALSE
    )
  })
  
  observeEvent(input$parentTbl, {
    newValues <- hot_to_r(input$parentTbl)$Inputs
    for (i in 1:numVars) {
      parentVars[[i]]$data <- newValues[i]
    }
  })
  
  # Create reactive home for reviseTable
  reviseTbl <- lapply(1:numVars, function(i) { reactiveVal() })
  
  # Observe changes to input$periods and update reviseTbl
  observeEvent(input$periods, {
    for (i in 1:numVars) {
      varInputId <- paste0("var_", i, "_input")
      reviseTable <- tryCatch({
        hot_to_r(input[[varInputId]])
      }, error = function(e) {
        reviseTbl[[i]]()
      })
      reviseTable <- subset(reviseTable, X <= input$periods)
      reviseTbl[[i]](reviseTable)  # Update the corresponding reactiveVal
    }
  }, ignoreInit = TRUE)
  
  # Builds child X/Y tables
  lapply(1:numVars, function(i) {
    varInputId <- paste0("var_", i, "_input")
    
    output[[varInputId]] <- renderRHandsontable({
      # Always base the Y value of the first row on the current parentVars[[i]]$data
      df <- data.frame(X = 1, Y = parentVars[[i]]$data)
      
      # If reviseTbl[[i]]() has been updated, use that data instead, 
      # but keep the Y value of the first row in sync with parentVars[[i]]$data
      if (!is.null(reviseTbl[[i]]())) {
        df <- reviseTbl[[i]]()
        if (nrow(df) > 0) {
          df[1, "Y"] <- parentVars[[i]]$data  # Ensure the Y value of the first row is updated
        }
      }
      
      rhandsontable(df, contextMenu = TRUE, minRows = 1, rowHeaders = FALSE) %>%
        hot_validate_numeric(col = 1, min = 1, max = input$periods)
    })
  })
  
  output$childTbl <- 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)