如果否则会出现下标越界错误，如何自动删除 R 中的矩阵列？

Question

下面的图片显示了当运行下面的 MWE 代码和我试图解决的问题时会发生什么：

第一张图片显示除了默认的“场景 1”之外，用户还输入了两个额外的插值场景。注意当用户准备删除场景 2 时，光标如何保持在场景 3 下。
第二张图片显示了用户通过单击场景 2 列 header 中的 [x] 从第一张图片中删除场景 2 而导致的错误，而光标仍在场景下方3.（请注意，如果将光标置于场景 2 下，则不会发生此错误——但我正在尝试考虑 real-world 用户输入）。
第三张图片显示了用户通过单击第二张图片中无关的空场景 3 中的 [x] 删除符号来更正错误的结果。

像这样的expanding/contracting矩阵自然会出现下标越界错误。

我的问题是：当出现下标越界错误时，如何自动删除最后一列？

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)

图片：

Answer 1

我做了很多更改，所以我只强调最重要的：

关键的变化可能是这样的：我重新插入代码以从 observeEvent(input$myMatrixInput 中的矩阵中删除空单元格。该代码最初由 PO 提供，但在寻找解决方案时被删除。我在子设置语句 tmpMatrix <- tmpMatrix[, !empty_columns, drop=FALSE] 中添加了 drop=FALSE 以使其起作用，因为 we need to preserve the matrix type。如果不这样做，代码将会中断。
sanitizedMat 已删除。一切都可以用矩阵输入来完成，它没有带来任何价值。相反，它使它变得更复杂，更难理解......而复杂也总是意味着更容易出错。
在 updateMatrixInput 周围添加了一个 isolate 以避免依赖。
在 plotData 反应中添加了一个 tryCatch，因为 matrixInput 临时发送了无法解释的值。现在 returns NULL 当 matrixInput 无效并且 renderPlot 不会是运行因为 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)

如果否则会出现下标越界错误，如何自动删除 R 中的矩阵列？

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

r

matrix

shiny

shiny-reactivity