Search code examples
rshinyshiny-reactivity

How to give precedence to one observer over other observers in R Shiny code?

In the R Shiny code below there are two user input tables: parentTbl and childTbl. Both are generated using rhandsontable. The user can input two "Y" values into the parentTbl input table which in the full code applies these Y variables over time window "W". Values in parentTbl flow downstream into a group of two linked and detailed user input tables called “childTbl”. The user can optionally enter values into any one of the two childTbl user input tables. In childTbl the user can alter the variable Y at time period "X" by inserting new rows via right mouse click and entering values into the added rows of the rhandsontable. Regardless of which table the user inputs values into, whether parentTbl or childTbl or both or none, values flow from parentTbl to childTbl to a calculation model (not shown). Note that the first row of parentTbl is directly linked to and corresponds to childTbl “Var_A”, the second row of parentTbl is directly linked to and corresponds to childTbl “Var_B”. Basically, childTbl allows the user the explode the values input into parentTbl.

Variable "W" for time window (per the slider input$periods) serves as the outer perimeter for variable X in the childTbl.

If the user has built up a childTbl (without changing input$periods) and then enters a new value into the corresponding row of the parentTbl, then the associated childTbl correctly resets as shown in the 1st image below.

If the user has built up a childTbl and then changes input$periods to a value less than the value in an X column of a childTbl, then those childTbl rows are automatically and correctly deleted as shown in the 2nd image below.

However, if the user has built up a childTbl and then changes input$periods, then the corresponding childTbl no longer resets upon a change to parentTbl as shown in the 3rd image below.

How do I make this reset mechanism upon a parentTbl input take precedence over all other observers and operations in all scenarios? Changing a parentTbl value should always reset the corresponding childTbl, and only that childTbl and not all the childTbl tables. While not losing any other functionality, such as resetting only the childTbl associated with the parentTbl row that is modified by user input and deleting only those childTbl rows where its X value > value of new input$periods.

enter image description here enter image description here enter image description here

Here it the reduced code, I left in many print() statements for reactive variable tracking making the code look longer than it need be:

library(rhandsontable)
library(shiny)

testVars <- c("Var_A","Var_B")  
dft_vals <- c(18, 6)
names(dft_vals) <- testVars

ui <- 
  fluidPage(
    sliderInput("periods", "Time window (W):", min = 1, max = 60 * 2, value = 60), 
    h5(strong("Variable (Y) over window (W):")),
    rHandsontableOutput("parentTbl"), 
    uiOutput("childTbl")
  ) 

server <- function(input,output,session)({    
    parentVars <- lapply(testVars, function(var) reactiveValues(data = dft_vals[var]))
    grpInputs <- reactiveValues(tables = list())
    output$parentTbl <- renderRHandsontable({
      rhandsontable(
        data.frame(Inputs = sapply(parentVars, function(x) x$data)),
        readOnly = FALSE,
        colHeaders = NULL,
        rowHeaders = testVars,
        contextMenu = FALSE
      ) 
    })

    observeEvent(input$parentTbl, {
      newValues <- hot_to_r(input$parentTbl)$Inputs
      for (i in 1:2) {
        if (parentVars[[i]]$data != newValues[i]) {
          print(paste("Row ID:", testVars[i], "New Value:", newValues[i])) 
          grpInputs$tbl[[testVars[i]]] <- data.frame(X = 1, Y = newValues[i])
        }
        parentVars[[i]]$data <- newValues[i]
      }
    })
    
    observe({
      print("Contents of parentVars:")
      for (i in 1:length(parentVars)){print(parentVars[[i]]$data)}
      print("Contents of grpInputs:")
      print(reactiveValuesToList(grpInputs))
    })
    
    # Below block eliminates child table rows where column X > input$periods
    observeEvent(input$periods, {
      lapply(testVars, function(varInputId) {
        if (!is.null(grpInputs$tbl[[varInputId]])) {
          updated_tbl <- grpInputs$tbl[[varInputId]]
          updated_tbl <- subset(updated_tbl, X <= input$periods)
          grpInputs$tbl[[varInputId]] <- updated_tbl
          output[[varInputId]] <- renderRHandsontable({
            rhandsontable(updated_tbl, contextMenu = TRUE, rowHeaders = FALSE) %>%
              hot_validate_numeric(col = 1, min = 1, max = input$periods) 
          })
        }
      })
    })
    
    # Below block builds child X/Y tables 
    lapply(1:2, function(i) {
      varInputId <- testVars[i]
      output[[varInputId]] <- renderRHandsontable({
        df <- data.frame(X = 1, Y = parentVars[[i]]$data)
        rhandsontable(df, contextMenu = TRUE, minRows = 1, rowHeaders = FALSE) %>%
          hot_validate_numeric(col = 1, min = 1, max = input$periods)
      })
    })
    
    output$childTbl <- renderUI({
      lapply(1:2, function(i) {
        varInputId <- testVars[i]
        list(
          h5(strong(paste("Adjust ", varInputId, " (Y) at time X:"))),
          rHandsontableOutput(varInputId)
        )
      })
    })
    
    # Below keeps childTbl from resetting due to change in input$periods
    observe({
      lapply(1:2, function(i) {
        varInputId <- testVars[i]
        if (!is.null(input[[varInputId]])) {
          grpInputs$tbl[[i]] <- tryCatch({
            hot_to_r(input[[varInputId]])
          }, error = function(e) {
            grpInputs$tbl[[i]]
          })
          names(grpInputs$tbl)[i] <- varInputId
        }
      })
    })
})

shinyApp(ui = ui, server = server)
Solution

  • I didn't know about the priority parameter for observers, that is a very handy feature. Thank you ismirsehregal! However, I was able to resolve the issue by changing the logic. I now update the corresponding childTbl within the observeEvent(input$parentTbl, {...}) block when the parentTbl values change. This ensures that when a value is updated in parentTbl, the corresponding childTbl is also updated. Here is the corrected code:

    library(rhandsontable)
library(shiny)

testVars <- c("Var_A","Var_B")  
dft_vals <- c(18, 6)
names(dft_vals) <- testVars

ui <- 
  fluidPage(
    sliderInput("periods", "Time window (W):", min = 1, max = 60 * 2, value = 60), 
    h5(strong("Variable (Y) over window (W):")),
    rHandsontableOutput("parentTbl"), 
    uiOutput("childTbl")
  ) 

server <- function(input,output,session)({    
  parentVars <- lapply(testVars, function(var) reactiveValues(data = dft_vals[var]))
  grpInputs <- reactiveValues(tables = list())
  output$parentTbl <- renderRHandsontable({
    rhandsontable(
      data.frame(Inputs = sapply(parentVars, function(x) x$data)),
      readOnly = FALSE,
      colHeaders = NULL,
      rowHeaders = testVars,
      contextMenu = FALSE
    ) 
  })
  
  observeEvent(input$parentTbl, {
    newValues <- hot_to_r(input$parentTbl)$Inputs
    for (i in 1:2) {
      if (parentVars[[i]]$data != newValues[i]) {
        parentVars[[i]]$data <- newValues[i]
        
        # Update the corresponding childTbl
        child_var <- testVars[i]
        child_data <- data.frame(X = 1, Y = parentVars[[i]]$data)
        output[[child_var]] <- renderRHandsontable({
          rhandsontable(child_data, contextMenu = TRUE, minRows = 1, rowHeaders = FALSE) %>%
            hot_validate_numeric(col = 1, min = 1, max = input$periods)
        })
      }
    }
  })
  
  # Below block eliminates child table rows where column X > input$periods
  observeEvent(input$periods, {
    lapply(testVars, function(varInputId) {
      if (!is.null(grpInputs$tbl[[varInputId]])) {
        updated_tbl <- grpInputs$tbl[[varInputId]]
        updated_tbl <- subset(updated_tbl, X <= input$periods)
        grpInputs$tbl[[varInputId]] <- updated_tbl
        output[[varInputId]] <- renderRHandsontable({
          rhandsontable(updated_tbl, contextMenu = TRUE, rowHeaders = FALSE) %>%
            hot_validate_numeric(col = 1, min = 1, max = input$periods) 
        })
      }
    })
  })
  
  # Below block builds child X/Y tables 
  lapply(1:2, function(i) {
    varInputId <- testVars[i]
    output[[varInputId]] <- renderRHandsontable({
      df <- data.frame(X = 1, Y = parentVars[[i]]$data)
      rhandsontable(df, contextMenu = TRUE, minRows = 1, rowHeaders = FALSE) %>%
        hot_validate_numeric(col = 1, min = 1, max = input$periods)
    })
  })
  
  output$childTbl <- renderUI({
    lapply(1:2, function(i) {
      varInputId <- testVars[i]
      list(
        h5(strong(paste("Adjust ", varInputId, " (Y) at time X:"))),
        rHandsontableOutput(varInputId)
      )
    })
  })
  
  # Below keeps childTbl from resetting due to change in input$periods
  observe({
    lapply(1:2, function(i) {
      varInputId <- testVars[i]
      if (!is.null(input[[varInputId]])) {
        grpInputs$tbl[[i]] <- tryCatch({
          hot_to_r(input[[varInputId]])
        }, error = function(e) {
          grpInputs$tbl[[i]]
        })
        names(grpInputs$tbl)[i] <- varInputId
      }
    })
  })
})

shinyApp(ui = ui, server = server)