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

Question

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.

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)

Stéphane Laurent · Accepted Answer · 2024-03-14 08:58:12Z

1

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;
    }
  });
}"

edited Mar 14, 2024 at 8:58

answered Mar 12, 2024 at 18:22

Stéphane Laurent

85.3k18 gold badges140 silver badges261 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

Village.Idyot Over a year ago

I ran this & added a row to X/Y child table and filled in XY values. When I then move the slider right increasing the "W" value (input$periods) & greater than any X value, the X/Y child table still completely resets. It should have left X/Y child table untouched because no X value exceeded the reset W value. In OP code with reviseTable object the table values I'd like to render after any input$periods change is printed to the console. I'd like to get the equivalent of those reviseTable values into the X/Y child table any time input$periods is changed, w/o eliminating reactivity.

Stéphane Laurent Over a year ago

@Village.Idyot Yes, I realized that later.. In fact tou have a input$periods in the rhandonstable (in the max argument), that's why it is reset each time input$periods changes.

Collectives™ on Stack Overflow

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

1 Answer 1

Edit

2 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

Edit

2 Comments

Your Answer

Sign up or log in

Post as a guest

Related