matrix - In R, why am I getting "Error in [: (subscript) logical subscript too long"?

Question

The below MWE Code 1 works fine, in calculating the sumproduct of 2 columns of numbers, with the sumproduct input matrix expanding horizontally to accommodate additional sumproduct scenarios.

MWE Code 2 below is a modification of MWE Code 1 to make the input matrix vertically expandable too, so the user can add rows of elements to be summed in the sumproduct calculation. When I run MWE Code 2, the code crashes giving me "Error in [: (subscript) logical subscript too long".

Why am I getting this error?

The images below illustrate the issue.

MWE Code 1:

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

sumProd <- function(a, b) { # a = periods, b = matrix inputs
  c    <- rep(NA, a)
  c[]  <- sum(b[,1]) %*% sum(b[,2])
  return(c)
}

ui <- fluidPage(
  sliderInput('periods', 'X-axis periods:', min=1, max=10, value=10),
  matrixInput(
    "myMatrixInput",
    label = "Two columns to sumproduct are 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 = sumProd(input$periods,input$myMatrixInput[1,(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)
    ))
  })
  
}

shinyApp(ui, server)

MWE Code 2:

sumProd <- function(a, b) { # a = periods, b = matrix inputs
  c    <- rep(NA, a)
  c[]  <- sum(b[,1]) %*% sum(b[,2])
  return(c)
}

ui <- fluidPage(
  sliderInput('periods', 'X-axis periods:', min=1, max=10, value=10),
  matrixInput(
    "myMatrixInput",
    label = "Two columns to sumproduct are 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 = TRUE, delta = 1, names = FALSE, delete = FALSE),
    class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  sanitizedMat <- reactiveVal() # < for vertical matrix expansion
  
  observeEvent(input$myMatrixInput, {
    if(any(colnames(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)
      )
    }
    sanitizedMat(na.omit(input$myMatrixInput))
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(sanitizedMat())/2),
             function(i){
               tibble(
                 Scenario = colnames(sanitizedMat())[i*2-1],
                 X = seq_len(input$periods),
                 Y = sumProd(input$periods,sanitizedMat()[,(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)
    ))
  })
  
}

shinyApp(ui, server)

Answer 1

Solution was to simply eliminate automated matrix empty column deletion under the single observeEvent() and modify UDF sumProd() to ignore NA's (added na.rm = T to sum() in sumProd()). NA's will arise in the matrix when sub-columns (groupings of 2 columns under each scenario header) are of unequal lengths, so ignoring the NA's resolves the issue. Also removed UDF sanitizedMat() and automated empty column deletion feature in MWE2 to simplify.

Revised code:

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

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

ui <- fluidPage(
  sliderInput('periods', 'X-axis periods:', min=1, max=10, value=10),
  matrixInput(
    "myMatrixInput",
    label = "Two columns to sumproduct are 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 = TRUE, delta = 1, names = FALSE, delete = FALSE),
    class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  observeEvent(input$myMatrixInput, {
    if(any(colnames(input$myMatrixInput) == "")){
      tmpMatrix <- input$myMatrixInput
      colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
      isolate(updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix))
      }
    input$myMatrixInput
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$myMatrixInput)/2), # column counter to set matrix index as it expands
         function(i){
             tibble(
               Scenario = colnames(input$myMatrixInput)[i*2-1],
               X = seq_len(input$periods),
               Y = sumProd(input$periods,input$myMatrixInput[,(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)
    ))
  })
  
}

shinyApp(ui, server)