How to automatically delete a matrix column in R if there otherwise would be subscript out of bounds error?

Question

The below images show what happens when running the below MWE code and what I'm trying to solve for:

1. The first image shows the user having input two additional interpolation scenarios, in addition to default "Scenario 1". Note how the cursor remains under Scenario 3, as the user prepares to delete Scenario 2.
2. The second image shows the error that results after the user deletes the Scenario 2 from the first image by having clicked on the [x] in the Scenario 2 column header, while the cursor was still under Scenario 3. (Note that this error WOULD NOT have occurred had the cursor been placed under Scenario 2 -- but I'm trying to account for real-world user inputs).
3. The third image shows the result of the user correcting for the error by clicking on the [x] deletion symbol in the extraneous, empty Scenario 3 in the second image.

It's natural in an expanding/contracting matrix like this that there would be subscript out of bounds errors.

My question is: how can I automate the deletion of the last column when there would otherwise be a subscript out of bounds error?

MWE code:

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

interpol <- function(a, b) { # a = periods, b = matrix inputs
  c <- rep(NA, a)
  c[1] <- b[1]
  c[a] <- b[2]
  c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # << interpolates
  return(c)
}

ui <- fluidPage(
  sliderInput('periods','Periods to interpolate:',min=2,max=10,value=10),
  matrixInput(
    "myMatrixInput",
    label = "Values to interpolate paired under each scenario heading:",
    value =  matrix(c(1, 5), 1, 2, dimnames = list(NULL, c("Scenario 1", "NULL"))),
    cols = list(extend = TRUE,  delta = 2, names = TRUE,  delete = TRUE,  multiheader = TRUE),
    rows = list(extend = FALSE, delta = 1, names = FALSE, delete = FALSE),
    class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  sanitizedMat <- reactiveVal()
  
  observeEvent(input$myMatrixInput, {
      tmpMatrix <- input$myMatrixInput
      colnames(tmpMatrix) <- paste("Scenario", trunc(1:ncol(input$myMatrixInput)/2+1))
      updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
      sanitizedMat(na.omit(input$myMatrixInput))
  })
  
  plotData <- reactive({
    lapply(seq_len(ncol(sanitizedMat())/2),
           function(i){
             tibble(
               Scenario = colnames(sanitizedMat())[i*2-1],
               X = seq_len(input$periods),
               Y = interpol(input$periods, sanitizedMat()[1,(i*2-1):(i*2)])
             )
           }) %>% bind_rows()
  })
  
  output$plot <- renderPlot({
    plotData() %>% ggplot() + geom_line(aes(
      x = X,
      y = Y,
      colour = as.factor(Scenario)
    ))
  })

}

shinyApp(ui, server)

Images:

Answer 1

I made quite a few changes so let me just highlight the most important ones:

• The crucial change probably was this: I re-inserted the code to remove empty cells from the matrix in observeEvent(input$myMatrixInput. The code had originally been provided by the PO but removed in search for a solution. I added drop=FALSE in the sub-setting statement tmpMatrix <- tmpMatrix[, !empty_columns, drop=FALSE] to make it work because we need to preserve the matrix type. If you do not do this, the code will break.
• sanitizedMat removed. Everything can be done with the matrix input and it did not bring any value. On the contrary, it made it more complex, more difficult to understand ... and complex also always means more error-prone.
• Added an isolate around updateMatrixInput to avoid dependencies.
• Added a tryCatch in the plotData reactive because matrixInput temporarily sent values that could not be interpreted. Now the reactive returns NULL when matrixInput is not valid and renderPlot won't be run because of the req(plotData()).

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

interpol <- function(a, b) { # a = periods, b = matrix inputs
  c <- rep(NA, a)
  c[1] <- b[1]
  c[a] <- b[2]
  c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # << interpolates
  return(c)
}

ui <- fluidPage(
  sliderInput('periods', 'Periods to interpolate:', min=2, max=10, value=10),
  matrixInput(
    "myMatrixInput",
    label = "Values to interpolate paired under each scenario heading:",
    value =  matrix(c(1, 5), 1, 2, dimnames = list(NULL, rep("Scenario 1", 2))),
    cols = list(extend = TRUE,  delta = 2, names = TRUE,  delete = TRUE, multiheader = TRUE),
    rows = list(extend = FALSE, delta = 1, names = FALSE, delete = FALSE),
    class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  observeEvent(input$myMatrixInput, {
      tmpMatrix <- input$myMatrixInput
      
      # Remove any empty matrix columns
      empty_columns <- sapply(tmpMatrix, function(x) all(is.na(x) | x == ""))
      tmpMatrix <- tmpMatrix[, !empty_columns, drop=FALSE]

      # Assign column header names
      colnames(tmpMatrix) <- paste("Scenario", rep(1:ncol(tmpMatrix), each = 2, length.out = ncol(tmpMatrix)))
      
        isolate( # isolate update to prevent infinite loop
          updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
        )
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$myMatrixInput)/2),
             function(i){
               tibble(
                 Scenario = colnames(input$myMatrixInput)[i*2-1],
                 X = seq_len(input$periods),
                 Y = interpol(input$periods, input$myMatrixInput[1,(i*2-1):(i*2)])
               )
             }) %>% bind_rows(),
      error = function(e) NULL
    )
  })
  
  output$plot <- renderPlot({
    req(plotData())
    
    plotData() %>% ggplot() + geom_line(aes(
      x = X,
      y = Y,
      colour = as.factor(Scenario)
    ))
  })

}

shinyApp(ui, server)