In R Shiny, how to establish a reactivity chain for a series of linked matrix inputs?

Question

In the below "simplified" code, there are a series of 3 linked user input matrices. The user can opt to only modify Matrix 1 (giving a straight-line output, of value Y over slider input periods X). The user can opt to add a curve to the Matrix 1 "Y" value by inputting X and Y values into Matrix 2, with the matrix expanding vertically (adding rows) as the user adds inputs. The user can opt to add curve scenarios, in addition to the first curve generated in Matrix 2, by inputting X and Y values into Matrix 3 with this matrix expanding both horizontally and vertically. In plotting, Matrix 3 takes precedence over Matrix 2 and Matrix 2 takes precedence over Matrix 1. By "curve" I mean an interpolation/extrapolation function (UDF interpol()). Matrix 1 feeds into Matrix 2 which in turn feeds into Matrix 3. These downstream feeds seem to work fine except when going from Matrix 2 to Matrix 3 as described next.

When running the below, Matrix 1-only inputs work fine (as shown in the first image below). Matrix 3-only inputs work fine (as shown in the third image below). But Matrix 2 inputs don't work correctly: as you can see in the second image below, Matrix 2 inputs do not correctly downstream to Matrix 3.

What am I doing wrong here?

Code:

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

interpol <- function(a, b) { # [a] = modeled periods, [b] = matrix inputs
  c <- b
  c[,1][c[,1] > a] <- a
  d <- diff(c[,1, drop = FALSE])
  d[d <= 0] <- NA
  d <- c(1,d)
  c <- cbind(c,d)
  c <- na.omit(c)
  c <- c[,-c(3),drop=FALSE]
  e <- rep(NA, a)
  e[c[,1]] <- c[,2]
  e[seq_len(min(c[,1])-1)] <- e[min(c[,1])]
  if(max(c[,1]) < a){e[seq(max(c[,1]) + 1, a, 1)] <- 0}
  e <- approx(seq_along(e)[!is.na(e)], e[!is.na(e)], seq_along(e))$y # Interpolates
  return(e)
}

ui <- fluidPage(
  uiOutput("slider"),
  h5(strong("Matrix 1:")), uiOutput("mat1"),
  h5(strong("Matrix 2:")), uiOutput("mat2"),
  h5(strong("Matrix 3:")), uiOutput("mat3"),
  plotOutput("plot")
  )

server <- function(input, output, session){
  
  output$slider <- renderUI({sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10)})
  
  output$mat1 <- renderUI({
    matrixInput("matrix1", 
                value = matrix(c(5), 1, 1, dimnames = list("Base rate (Y)",NULL)),
                rows =  list(extend = FALSE, names = TRUE),
                cols =  list(names = FALSE),
                class = "numeric")    
  })
  
  output$mat2 <- renderUI({
    matrixInput("matrix2",
                value = matrix(c(input$periods, input$matrix1[1,1]), 1, 2, dimnames = list(NULL,c("X","Y"))),
                rows = list(extend = TRUE, names = TRUE, delete = TRUE),
                class = "numeric")
  })
  
  output$mat3 <- renderUI({
    matrixInput("matrix3",
                value = matrix(c(input$matrix2[,1], input$matrix2[,2]), 1, 2, dimnames = list(NULL, rep("Scenario 1", 2))),
                rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
                cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
                class = "numeric")
  })
  
  observeEvent(input$matrix2, { 
    if(any(rownames(input$matrix2) == "")){
      tmpMatrix <- input$matrix2
      rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
      isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
    }
    input$matrix2
  })
  
  observeEvent(input$matrix3, {
    if(any(colnames(input$matrix3) == "")){
      tmpMatrix <- input$matrix3
      colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
      isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
    }
    input$matrix3
  })
  
  plotData <- reactive({
    req(input$periods)
    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 = interpol(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)

Alternative code, without using renderUI and instead relying on observeEvent with embedded updateMatrixInput:

ui <- fluidPage(
  sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10),
  
  h5(strong("Matrix 1 is omitted for MWE")), 
  
  h5(strong("Matrix 2:")), 
  matrixInput("matrix2",
              value = matrix(c(10, 5), 1, 2, dimnames = list(NULL,c("X","Y"))),
              rows = list(extend = TRUE, names = TRUE, delete = TRUE),
              class = "numeric"),
  
  h5(strong("Matrix 3:")), 
  matrixInput("matrix3",
              value = matrix(c(10,5), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
              rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
              cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
              class = "numeric"),
  
  plotOutput("plot")
)

server <- function(input, output, session){
  
  observeEvent(input$periods, {
    updateMatrixInput(session, inputId = "matrix2", 
      value = matrix(c(input$periods, 5), 1, 2, dimnames = list(NULL,c("X","Y"))))
  })
  
  observeEvent(input$matrix2, { 
    if(any(rownames(input$matrix2) == "")){
      tmpMatrix <- input$matrix2
      rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
      isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
      isolate(updateMatrixInput(session, inputId = "matrix3", 
        value = tmpMatrix))
      }
    input$matrix2
    isolate(
      updateMatrixInput(
        session, 
        inputId = "matrix3", 
        value = matrix(
          c(input$matrix2[,1],input$matrix2[,2]), 
          ncol = 2, 
          dimnames = list(NULL, rep("Scenario 1", 2)))
      )
    )
  })
  
  observeEvent(input$matrix3, {
    if(any(colnames(input$matrix3) == "")){
      tmpMatrix <- input$matrix3
      colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
      isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
    }
    input$matrix3
  })
  
  plotData <- reactive({
    req(input$periods)
    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 = interpol(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)

Answer 1

In the renderUI call for mat3 you are defining nrow = 1, which is taken into account every time the matrixInput is re-rendered.

You need to drop this argument to allow adding rows.

As you might know by now, in general I'd recommend dropping those renderUI calls. I'd render the matrixInputs once on app start and modify them via updateMatrixInput - this is faster and keeps a clear separation between UI and server.

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

interpol <- function(a, b) { # [a] = modeled periods, [b] = matrix inputs
  c <- b
  c[,1][c[,1] > a] <- a
  d <- diff(c[,1, drop = FALSE])
  d[d <= 0] <- NA
  d <- c(1,d)
  c <- cbind(c,d)
  c <- na.omit(c)
  c <- c[,-c(3),drop=FALSE]
  e <- rep(NA, a)
  e[c[,1]] <- c[,2]
  e[seq_len(min(c[,1])-1)] <- e[min(c[,1])]
  if(max(c[,1]) < a){e[seq(max(c[,1]) + 1, a, 1)] <- 0}
  e <- approx(seq_along(e)[!is.na(e)], e[!is.na(e)], seq_along(e))$y # Interpolates
  return(e)
}

ui <- fluidPage(
  uiOutput("slider"),
  h5(strong("Matrix 1:")), uiOutput("mat1"),
  h5(strong("Matrix 2:")), uiOutput("mat2"),
  h5(strong("Matrix 3:")), uiOutput("mat3"),
  plotOutput("plot")
)

server <- function(input, output, session){
  
  output$slider <- renderUI({sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10)})
  
  output$mat1 <- renderUI({
    matrixInput("matrix1", 
                value = matrix(c(5), 1, 1, dimnames = list("Base rate (Y)",NULL)),
                rows =  list(extend = FALSE, names = TRUE),
                cols =  list(names = FALSE),
                class = "numeric")    
  })
  
  output$mat2 <- renderUI({
    req(input$periods)
    req(input$matrix1)
    matrixInput("matrix2",
                value = matrix(c(input$periods, input$matrix1[1,1]), 1, 2, dimnames = list(NULL,c("X","Y"))),
                rows = list(extend = TRUE, names = TRUE, delete = TRUE),
                class = "numeric")
  })
  
  output$mat3 <- renderUI({
    req(input$matrix2)
    matrixInput("matrix3",
                value = matrix(c(input$matrix2[,1], input$matrix2[,2]), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
                rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
                cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
                class = "numeric")
  })
  
  observeEvent(input$matrix2, { 
    if(any(rownames(input$matrix2) == "")){
      tmpMatrix <- input$matrix2
      rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
      isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
    }
    input$matrix2
  })
  
  observeEvent(input$matrix3, {
    if(any(colnames(input$matrix3) == "")){
      tmpMatrix <- input$matrix3
      colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
      isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
    }
    input$matrix3
  })
  
  plotData <- reactive({
    req(input$periods)
    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 = interpol(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)