在 R 中，为什么我在运行这个函数时得到不正确的维数？

Question

如下所示的 MWE 代码可以正常运行。但是，当我注释掉当前未注释的自定义 interpol() 函数并取消注释已注释掉的较长 interpol() 函数时，我收到“维度数不正确”错误。当 2 个函数的输出在结构方面（我认为）是如此相似。运行第二个interpol() 时如何消除此错误？

第二个更长的 interpol() 函数不应该像第一个那样在这个缩减的 MWE 中插值（它在完全部署时会做其他事情，包括但不限于插值）：在默认情况下，它应该绘制一个 5在第 1 期和之后的第 0 期。如果用户输入 3 和 5，它应该为前 3 个周期绘制一个 5，之后绘制一个 0。

当我在 R Studio 控制台中运行这 2 个函数时，我得到了下图中显示的内容。第一个图像是较短的interpol()（它会进行插值），第二个是较长的interpol() 函数（它还没有准备好在这个MWE 中进行插值）。因此，两者都可以在 R Studio 控制台中正常工作，但第二个会使应用程序崩溃！

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)
}

# 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(
  sliderInput('periods', 'Periods to interpolate:', min=2, max=10, value=10),
  matrixInput(
    "myMatrixInput",
    label = "Values to interpolate:",
    value =  matrix(c(2, 5), 1, 2),
    cols = list(names = FALSE),
    rows = list(names = FALSE),
    class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  observeEvent(input$myMatrixInput, {
    tmpMatrix <- input$myMatrixInput
    # isolate( # isolate update to prevent infinite loop
      updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
    # )
  })
  
    plotData <- reactive({
    tibble(
      X = seq_len(input$periods),
      Y = interpol(input$periods, input$myMatrixInput[1,1:2])
    )
  })
  
  output$plot <- renderPlot({
    req(plotData())
    plotData() %>% ggplot() + geom_line(aes(
      x = X,
      y = Y
      ))  
    })
}

shinyApp(ui, server)

更短的interpol()函数：

更长的interpol()函数：

Answer 1

请参阅下面的可解决的功能代码。关键修复是将drop = FALSE 添加到每个原始评论的矩阵索引中。增强功能的其他更改包括添加 lapply()“循环”以创建动态矩阵索引以反映根据用户输入扩展/收缩的矩阵，以及隔离 updateMatrixInput() 函数。

interpol <- function(a, b) {
  
  # [a] = modeled periods, [b] = matrix inputs
  c <- b
  
  # Assign < of modeled periods [a] and max periods per matrix [b] left-col to matrix [c]
  c[,1][c[,1] > a] <- a
  
  # Ensure matrix [b] left-column period inputs are in increasing order
  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]
  
  ### Interpolate [b] matrix right-col variables###
  e <- rep(NA, a)
  
  # Places each [b] matrix right-col variable in position indicated by its left-col period
  e[c[,1]] <- c[,2]
  
  # If 1st period in [b] matrix left-col > 1, applies its right-col variable to all periods <= [b] matrix 1st period
  e[seq_len(min(c[,1])-1)] <- e[min(c[,1])]
  
  # Applies 0 to all periods after max period in [b] matrix left-col up to period [a]
  if(max(c[,1]) < a){e[seq(max(c[,1]) + 1, a, 1)] <- 0}
  
  # Interpolates
  e <- approx(seq_along(e)[!is.na(e)], e[!is.na(e)], seq_along(e))$y
  ### End interpolation ###
  return(e)
}

ui <- fluidPage(
  sliderInput('periods', 'Modeled periods:', min=1, max=10, value=10),
  matrixInput(
    "myMatrixInput",
    label = "Period (X) to apply variable (Y) 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 = TRUE, delete = TRUE),
    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 = interpol(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)
      )) +
      theme(legend.title=element_blank())
  })
  
}

shinyApp(ui, server)