Search code examples
rshinyshiny-reactivity

How to define separate reactive values from a common user input matrix in R Shiny?

In running the reactive code below, the user can input a variable "Y" into the first matrix rendered at the top (generated by function matInputBase()) to run a simple scenario where that variable Y appears in only one period in the output, with period set by the slider input for time window "W". The user can optionally input into the following two input matrixes (both generated by function matInputFlex()), additional variable Y's into other specified time periods ("X") so long as they fit into overall time window W. Function matInputFlex() allows the user to run more detailed scenarios than the basic matInputBase(). Note how an input into matInputBase() flows directly into the first row and second column of each matInputFlex(), as shown in the image below. This part works correctly.

However, if the user has input a scenario into one of the matInputFlex() matrixes, and then decides to change any one of the values in matInputBase(), then both of the matInputFlex() matrixes are reset. I don't want both of the matInputFlex() matrixes reset, I would like only the matInputFlex() matrix directly affected by the change to the matInputBase() matrix to be reset. I would like to preserve the matInputFlex() values unaffected by a change to its corresponding parent matInputBase() value. So, for if example, if I have built up a matInputFlex() scenario for Var_1 and then I change a matInputBase() value for Var_2, as shown in the second half of the image below, then only the matInputFlex() values for Var_2 should reset and not the matInputFlex() values for Var_1. How do I delink these reactive tables, so that Var_1 and Var_2 can process independently?

I have played around with isolate() and observeEvent() for input$base_input, but these changes stopped the flow of inputs from matInputBase() to matInputFlex().

Image of how the App works:

enter image description here

Code:

library(shiny)
library(shinyMatrix)

matInputBase <- function(name) {
  matrixInput(name,
              value = matrix(c(1,2), 2, 1, dimnames = list(c("Var_1", "Var_2"), NULL)),
              rows = list(extend = FALSE, names = TRUE),
              cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric"
  )
}

matInputFlex <- function(name, x,y) {
  matrixInput(
    name,
    value = matrix(c(x, y), 1, 2, dimnames = list(NULL, c("X", "Y"))),
    rows = list(extend = TRUE, names = FALSE),
    cols = list(extend = TRUE, delta = 0, names = TRUE, editableNames = FALSE),
    class = "numeric"
  )
}

matStretch <- function(mat, time_window, col_name) {
  mat[, 1] <- pmin(mat[, 1], time_window)
  df <- data.frame(matrix(nrow = time_window, ncol = 1, dimnames = list(NULL, col_name)))
  df[, col_name] <- ifelse(seq_along(df[, 1]) %in% mat[, 1], mat[match(seq_along(df[, 1]), mat[, 1]), 2], 0)
  return(df)
}

ui <- fluidPage(
  sliderInput("periods","Time window (W):", min = 1, max = 10, value = 10),
  h5(strong("Var (Y) over time window:")),
  matInputBase("base_input"),
  uiOutput("Vectors"),
  tableOutput("table2")
)

server <- function(input, output, session) {
  base_var_1 <- reactive(input$base_input[1,1])
  base_var_2 <- reactive(input$base_input[2,1])
  
  output$Vectors <- renderUI({
    tagList(
      h5(strong("Adjust Var_1 (Y) at time X:")),
      matInputFlex("var_1_input", input$periods, base_var_1()),
      h5(strong("Adjust Var_2 (Y) at time X:")),
      matInputFlex("var_2_input", input$periods, base_var_2())
      )
    })
  output$table2 <- renderTable(
    cbind(
      matStretch(input$var_1_input, input$periods, "Var_1"),
      matStretch(input$var_2_input, input$periods, "Var_2")
      )
    )
}

shinyApp(ui, server)
Solution

  • Edited input$periods event handling from base_input() to isolate(base_input()).

    The code below separates output$Vectors into two separate renderUI variables in the server, tracks the previous value of input$base_input to determine which row has changed (if any), and uses observeEvent for more explicit event handling.

    It appears to handle matInputBase and matInputFlex events correctly, and it will reset both matInputFlex if input$periods changes.

    library(shiny)
library(shinyMatrix)

matInputBase <- function(name) {
  matrixInput(name,
              value = matrix(c(1,2), 2, 1, dimnames = list(c("Var_1", "Var_2"), NULL)),
              rows = list(extend = FALSE, names = TRUE),
              cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric"
  )
}

matInputFlex <- function(name, x,y) {
  matrixInput(
    name,
    value = matrix(c(x, y), 1, 2, dimnames = list(NULL, c("X", "Y"))),
    rows = list(extend = TRUE, names = FALSE),
    cols = list(extend = TRUE, delta = 0, names = TRUE, editableNames = FALSE),
    class = "numeric"
  )
}

matStretch <- function(mat, time_window, col_name) {
  mat[, 1] <- pmin(mat[, 1], time_window)
  df <- data.frame(matrix(nrow = time_window, ncol = 1, dimnames = list(NULL, col_name)))
  df[, col_name] <- ifelse(seq_along(df[, 1]) %in% mat[, 1], mat[match(seq_along(df[, 1]), mat[, 1]), 2], 0)
  return(df)
}

ui <- fluidPage(
  sliderInput("periods","Time window (W):", min = 1, max = 10, value = 10),
  h5(strong("Var (Y) over time window:")),
  matInputBase("base_input"),
  # Modified to bring the h5 elements into the UI.
  tagList(
    h5(strong("Adjust Var_1 (Y) at time X:")),
    uiOutput("Vectors1"),
    h5(strong("Adjust Var_2 (Y) at time X:")),
    uiOutput("Vectors2")
  ),
  tableOutput("table2")
)

server <- function(input, output, session) {
  
  # Reactive variable storage
  base_input <- reactive(input$base_input)
  prev <- reactiveValues(
    dat = matrix(c(1,2), 2, 1, dimnames = list(c("Var_1", "Var_2"), NULL))
  )
  
  # Separate out the handling of input$base_input.
  observeEvent(
    input$base_input,
    {
      if (prev$dat[1,1] != base_input()[1,1]){
        output$Vectors1 <- renderUI({
          matInputFlex("var_1_input", input$periods, base_input()[1,1])
        })
      }
      if (prev$dat[2,1] != base_input()[2,1]){
        output$Vectors2 <- renderUI({
          matInputFlex("var_2_input", input$periods, base_input()[2,1])
        })
      }
      # Save the current value for testing the next event.
      prev$dat <- base_input()
    })
  
  # Deal with input$periods events separately.
  observeEvent(
    input$periods,
    {
      output$Vectors1 <- renderUI({
        matInputFlex("var_1_input", input$periods, isolate(base_input())[1,1])
      })
      output$Vectors2 <- renderUI({
        matInputFlex("var_2_input", input$periods, isolate(base_input())[2,1])
      })
      
    })
  
  output$table2 <- renderTable(
    cbind(
      matStretch(input$var_1_input, input$periods, "Var_1"),
      matStretch(input$var_2_input, input$periods, "Var_2")
    )
  )
}

shinyApp(ui, server)