rshinyshiny-reactivityobserversrhandsontable

How to watch for a trigger event and apply a condition in R Shiny without using an observer?


In running the below R Shiny code, the user changing the sliderInput() (object input$periods) resets all of the variable user input tables called "X/Y child tables" as shown in the code with a comment before the lapply() block that generates them and as illustrated in the image below. Note that these X/Y child tables reactively receive values from a parent table base_input also commented in the code as such and also shown in the image below. The reactivity must always flow and changing a base_input value always correctly completely resets the applicable linked X/Y child table.

The idea is to eliminate any rows in an X/Y child table with an X column value > a new value of input$periods, while retaining the parent-child reactivity flows.

The block of code after comment # Observe changes to input$periods and print revised X/Y child tables partly gets me there via object reviseTable. That section of code removes any dataframe rows where its column X value > a revised input$periods value. How do I replace the tables generated by the lapply() block that generates X/Y tables with the reviseTable object, without wrapping that lapply() block in an observer? Wrapping with an observeEvent() stops the parent-child reactivity flows that need to be maintained.

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.

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  
  varValues <- lapply(1:numVars, function(i) {reactiveValues(data = 20)})
  
  # Parent table "base_input"
  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]
    }
  })
  
  # Observe changes to input$periods and print revised X/Y child tables
  observeEvent(input$periods, {
    for (i in 1:numVars) {
      varInputId <- paste0("var_", i, "_input")
      reviseTable <- hot_to_r(input[[varInputId]])
      reviseTable <- subset(reviseTable, X <= input$periods)
      print(paste("Revised X/Y table for Var", LETTERS[i], "after updating input$periods:"))
      print(reviseTable)
    }
  }, ignoreInit = TRUE)  
  
  # Builds X/Y child tables
  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) %>%
        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)

Solution

  • Seems to work fine:

    library(shiny)
    library(rhandsontable)
    library(htmlwidgets)
    
    js <- "function(el, x) {
      var hot = this.hot;
      Shiny.addCustomMessageHandler('removeRows', function(indices) {
        for(var i of indices) {
          hot.alter('remove_row', i, 1);
        }
      });
    }"
    
    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  
      varValues <- lapply(1:numVars, function(i) {reactiveValues(data = 20)})
      
      # Parent table "base_input"
      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]
        }
      })
      
      # Observe changes to input$periods and remove rows
      observeEvent(input$periods, {
        for (i in 1:numVars) {
          varInputId <- paste0("var_", i, "_input")
          reviseTable <- hot_to_r(input[[varInputId]])
          toRemove <- which(reviseTable$X > input$periods)
          if(length(toRemove)) {
            session$sendCustomMessage("removeRows", as.list(rev(toRemove) - 1))
          }
        }
      }, ignoreInit = TRUE)  
      
      # Builds X/Y child tables
      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) %>%
            hot_validate_numeric(col = 1, min = 1, max = input$periods) %>% 
            onRender(js)
        })
      })
      
      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)
    

    Edit

    To solve the problem mentioned in the comments, remove max = input$periods in the validator, and use this JS code:

    js <- "function(el, x) {
      var hot = this.hot;
      Shiny.addCustomMessageHandler('removeRows', function(indices) {
        for(var i of indices) {
          hot.alter('remove_row', i, 1);
        }
      });
      Handsontable.hooks.add('afterValidate', function(isValid, value, row, prop){
        if(value > $('#periods').val()) {
          return false;
        }
      });
    }"