R语言中如何自动删除矩阵列以规避Shiny场景下的下标越界错误

以下图片展示了运行下方最小可复现示例（MWE）代码时出现的现象及待解决的问题：

• 第一张图显示用户在默认「Scenario 1」之外额外输入了两个插值场景，光标停留在Scenario 3下方，用户正准备删除Scenario 2。
• 第二张图显示用户在光标仍停留在Scenario 3的情况下，点击Scenario 2列标题的[x]按钮删除该场景后触发的错误。注意如果删除时光标放置在Scenario 2下方则不会出现该错误，但需要适配实际用户的各类操作场景。
• 第三张图显示用户点击第二张图中多余的空白Scenario 3列的[x]删除符号后，错误被修复的效果。

在这类可动态扩展/收缩的矩阵场景中，很容易出现下标越界错误。待解决的核心问题是：当即将触发下标越界错误时，如何实现自动删除最后一列的逻辑，避免报错？

MWE 代码 #

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)

相关截图 #

错误根因 #

该下标越界错误的核心触发逻辑是：每个插值场景对应2列配置，而shinyMatrix的删除操作默认仅删除单列，删除整个场景后会导致剩余列数为奇数，后续按双位下标读取场景配置时就会出现越界。

修复代码 #

仅需调整服务端的矩阵监听逻辑，增加奇偶列校验，出现奇数列时自动删除最后一列，保证列数永远为偶数即可，修改后的完整代码如下：

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
    # 奇数列自动删除最后一列，保证永远双列对应一个场景
    if(ncol(tmpMatrix) %% 2 != 0){
      tmpMatrix <- tmpMatrix[, -ncol(tmpMatrix), drop = FALSE]
    }
    # 用修正后的列数重命名，避免命名错位
    colnames(tmpMatrix) <- paste("Scenario", trunc(1:ncol(tmpMatrix)/2+1))
    updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
    sanitizedMat(na.omit(tmpMatrix))
  })
  
  plotData <- reactive({
    # 增加非空校验，避免矩阵为空时报错
    req(ncol(sanitizedMat()) >= 2)
    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)

改动说明 #

1. 新增列数校验逻辑：每次矩阵更新时判断列数是否为奇数，是则自动删除最后一列，从根源避免越界
2. 列名生成逻辑改为基于修正后的矩阵列数计算，避免出现列名和实际列不匹配的问题
3. 绘图逻辑前增加非空校验，避免无有效场景时触发报错

内容的提问来源于stack exchange，提问作者Curious Jorge - user9788072