How create linked and expandable user input matrices?

In the below shortened code, user inputs are "linked" in a series of 3 user input matrices:

  1. Matrix 1: if user wants to run a rough and quick scenario, user inputs into matrix 1 only. One variable, one scenario only.
  2. Matrix 2: if user wants to run a more complex scenario, user optionally inputs into matrix 2 with the previous matrix 1 input "downstreaming" to row 1 / column 2 of matrix 2. Matrix 2 expands vertically to accommodate additional user inputs for generating a curve (curve build not functioning in this code for sake of simplicity).
  3. Matrix 3: if user wants to run multiple complex scenarios, user optionally inputs into matrix 3, with scenario 1 of matrix 3 a downstream mirror reflection of previous inputs into matrix 2. Matrix 3 expands vertically and horizontally, to accommodate user inputs + additional scenarios.

For the sake of simplicity, the below code plots a simple (and nonsensical) sumProduct calculation.

I've used observeEvent to successfully downstream the following user inputs:

  • observeEvent(input$matrix1... downstreams user input from matrix 1 to matrix 2, and
  • observeEvent(input$matrix2... downstreams user input from matrix 2 to matrix 3/scenario 1 while preserving all previous inputs into scenarios > 1 in matrix 3 as matrix 2 and matrix 3/scenario 1 simulatenously change.

What I have been unable to do is have user inputs into matrix 1 preserve (NOT ERASE) previous user inputs into matrix 3 scenarios > 1, the way observeEvent(input$matrix2... does this when matrix 2 is changed by the user. I've tried all sorts of observeEvent variations with no luck. I'm trying to nest observeEvents to get this to work but no luck yet (nesting observeEvent(input$matrix2... inside of observeEvent(input$matrix1... , for example). Any ideas on how to do this? Or should I be using a simple observe instead?

Here's the code:

library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)

sumProd <- function(a, b) {
  c    <- rep(NA, a)
  c[]  <- sum(b[,1], na.rm = T) %*% sum(b[,2],na.rm = T) 
  return(c)
}

ui <- fluidPage(
  sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10),
  matrixInput("matrix1", 
              value = matrix(c(5), nrow = 1, ncol = 1, dimnames = list("Base rate (Y)",NULL)),
              cols =  list(names = FALSE),
              class = "numeric"),
  matrixInput("matrix2",
              value = matrix(c(10,5), nrow = 1, ncol = 2, dimnames = list(NULL,c("X","Y"))),
              rows = list(extend = TRUE, delete = TRUE),
              class = "numeric"),
  matrixInput("matrix3",
              value = matrix(c(10,5), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
              rows = list(extend = TRUE, delete = TRUE),
              cols = list(extend = TRUE, delta = 2, delete = TRUE, multiheader = TRUE),
              class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session){

  observeEvent(input$matrix1, {
    tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2])
    tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1]
    updateMatrixInput(session,inputId="matrix2",value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
    )
  })
  
  observeEvent(input$matrix2, { 
    a <- apply(input$matrix3,2,'length<-',max(nrow(input$matrix3),nrow(input$matrix2)))
    b <- apply(input$matrix2,2,'length<-',max(nrow(input$matrix3),nrow(input$matrix2)))
    c <- if(length(a) == 2){c(b)} else {c(b,a[,-1:-2])}
    d <- ncol(input$matrix3)
    tmpMat3 <- matrix(c(c), ncol = d)
    colnames(tmpMat3) <- paste("Scenario",rep(1:ncol(tmpMat3),each=2,length.out=ncol(tmpMat3)))
    
    if(any(rownames(input$matrix2) == "")){
      tmpMat3 <- input$matrix2
      rownames(tmpMat3) <- paste("Row", seq_len(nrow(input$matrix2)))
      isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMat3))
      isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMat3))
    }
    input$matrix2
    updateMatrixInput(session, inputId = "matrix3", value = tmpMat3
    )
  })
  
  observeEvent(input$matrix3, {
    if(any(colnames(input$matrix3) == "")){
      tmpMat3 <- input$matrix3
      colnames(tmpMat3) <- paste("Scenario",rep(1:ncol(tmpMat3),each=2,length.out=ncol(tmpMat3)))
      isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMat3))
    }
    input$matrix3
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$matrix3)/2), # column counter to set matrix index as it expands
             function(i){
               tibble(
                 Scenario = colnames(input$matrix3)[i*2-1],
                 X = seq_len(input$periods),
                 Y = sumProd(input$periods,input$matrix3[,(i*2-1):(i*2), drop = FALSE])
               )
             }) %>% bind_rows(),
      error = function(e) NULL
    )
  })
  
  output$plot <- renderPlot({
    req(plotData())
    plotData() %>% ggplot() + 
      geom_line(aes(x = X, y = Y, colour = as.factor(Scenario))) +
      theme(legend.title=element_blank())
  })
}

shinyApp(ui, server)

No nesting of ObserveEvent is required. A simple observe is not recommended; an ObserveEvent is what is required in this case. There is an error in the originally posted code, in the server section under observeEvent(input$matrix2, {... starting if(any(rownames(input$matrix2) == "")){... where both matrix 2 AND matrix 3 are updated. Matrix 3 should not be updated in this section under the observeEvent for matrix 2 input, where a row label is added for matrix 2. In the below resolved code, see how the rownames function is moved to the separate observeEvent for any input changes to matrix 3. With this fix the code now works.

Resolved code:

sumProd <- function(a, b) {
  c    <- rep(NA, a)
  c[]  <- sum(b[,1], na.rm = T) %*% sum(b[,2],na.rm = T) 
  return(c)
}

ui <- fluidPage(
  sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10),
  matrixInput("matrix1", 
              value = matrix(c(5), nrow = 1, ncol = 1, dimnames = list("Base rate (Y)",NULL)),
              cols =  list(names = FALSE),
              class = "numeric"),
  matrixInput("matrix2",
              value = matrix(c(10,5), nrow = 1, ncol = 2, dimnames = list(NULL,c("X","Y"))),
              rows = list(extend = TRUE, delete = TRUE),
              class = "numeric"),
  matrixInput("matrix3",
              value = matrix(c(10,5), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
              rows = list(extend = TRUE, delete = TRUE),
              cols = list(extend = TRUE, delta = 2, delete = TRUE, multiheader = TRUE),
              class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session){
  
  observeEvent(input$matrix1, {
    tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2]) # convert to vector
    tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1] # drop matrix 1 value into row 1/col 2 of matrix 2
    updateMatrixInput(session,inputId="matrix2",value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y"))))
    })
  
  observeEvent(input$matrix2, {
    a <- apply(input$matrix3,2,'length<-',max(nrow(input$matrix3),nrow(input$matrix2)))
    b <- apply(input$matrix2,2,'length<-',max(nrow(input$matrix3),nrow(input$matrix2)))
    c <- if(length(a) == 2){c(b)} else {c(b,a[,-1:-2])}
    d <- ncol(input$matrix3)
    tmpMat3 <- matrix(c(c), ncol = d)
    colnames(tmpMat3) <- paste("Scenario",rep(1:ncol(tmpMat3),each=2,length.out=ncol(tmpMat3)))

    if(any(rownames(input$matrix2) == "")){
      tmpMat2 <- input$matrix2
      rownames(tmpMat2) <- paste("Row", seq_len(nrow(input$matrix2)))
      updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
      }
    
    updateMatrixInput(session, inputId = "matrix3", value = tmpMat3)
    
  })
  
  observeEvent(input$matrix3, {
    if(any(colnames(input$matrix3) == "")){
      tmpMat3 <- input$matrix3
      colnames(tmpMat3) <- paste("Scenario",rep(1:ncol(tmpMat3),each=2,length.out=ncol(tmpMat3)))
      updateMatrixInput(session, inputId = "matrix3", value = tmpMat3)
      }
    if(any(rownames(input$matrix3) == "")){
      tmpMat3 <- input$matrix3
      rownames(tmpMat3) <- paste("Row", seq_len(nrow(input$matrix3)))
      updateMatrixInput(session, inputId = "matrix3", value = tmpMat3)
      }
    input$matrix3
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$matrix3)/2), # column counter to set matrix index as it expands
             function(i){
               tibble(
                 Scenario = colnames(input$matrix3)[i*2-1],
                 X = seq_len(input$periods),
                 Y = sumProd(input$periods,input$matrix3[,(i*2-1):(i*2), drop = FALSE])
               )
             }) %>% bind_rows(),
      error = function(e) NULL
    )
  })
  
  output$plot <- renderPlot({
    req(plotData())
    plotData() %>% ggplot() + 
      geom_line(aes(x = X, y = Y, colour = as.factor(Scenario))) +
      theme(legend.title=element_blank())
  })
}

shinyApp(ui, server)