Блог

Приведенный ниже код MWE 1 отлично работает при вычислении итогового продукта из 2 столбцов чисел, при этом входная матрица итогового продукта расширяется горизонтально для размещения дополнительных сценариев итогового продукта.

Код MWE 2 ниже представляет собой модификацию кода MWE 1, чтобы входная матрица также была расширена по вертикали, чтобы пользователь мог добавлять строки элементов, которые будут суммироваться при расчете итогового продукта. Когда я запускаю MWE Code 2, код аварийно завершает работу, давая мне «Ошибку в [: (подстрочный индекс) логический подстрочный индекс слишком длинный».

Почему я получаю эту ошибку?

Изображения ниже иллюстрируют проблему.

MWE Код 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 Код 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)
 

Решение состояло в том, чтобы просто исключить автоматическое удаление пустых столбцов матрицы под одним observeEvent() и изменить UDF sumProd() , чтобы игнорировать NA (добавленные na.rm = T в sum() in sumProd() ). NA будут возникать в матрице, когда подколонцы (группы по 2 столбца в заголовке каждого сценария) имеют неодинаковую длину, поэтому игнорирование NA решает проблему. Также удалена функция UDF sanitizedMat() и автоматического удаления пустых столбцов в MWE2 для упрощения.

Пересмотренный кодекс:

 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)