R Shiny如何响应式关联可扩展输入矩阵且不丢失下游多场景输入

问题根因 #

修改matrix1触发matrix2更新时，你给matrix2传入的新值未保留原有行名，导致matrix2的监听事件命中if(any(rownames(input$matrix2) == ""))分支，该分支直接用仅包含单场景的matrix2内容覆盖了整个matrix3，因此场景2及以后的用户输入全部丢失。 #

修复方案 #

只需调整两处逻辑即可，无需改用observe：

• 修改matrix1的监听逻辑，直接修改matrix2对应位置的值，保留matrix2原有行名，避免命中行名判断分支
• 优化matrix2监听逻辑中的行名补全分支，补全行名后仍保留matrix3的多场景数据

修正后完整代码 #

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

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

ui <- fluidPage(
  sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10),
  matrixInput("matrix1", 
              value = matrix(c(5), nrow = 1, ncol = 1, dimnames = list("Base rate (Y)",NULL)),
              cols =  list(names = FALSE),
              class = "numeric"),
  matrixInput("matrix2",
              value = matrix(c(10,5), nrow = 1, ncol = 2, dimnames = list(NULL,c("X","Y"))),
              rows = list(extend = TRUE, delete = TRUE),
              class = "numeric"),
  matrixInput("matrix3",
              value = matrix(c(10,5), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
              rows = list(extend = TRUE, delete = TRUE),
              cols = list(extend = TRUE, delta = 2, delete = TRUE, multiheader = TRUE),
              class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session){

  observeEvent(input$matrix1, {
    # 直接修改matrix2对应位置值，保留原有行名
    tmpMat2 <- input$matrix2
    tmpMat2[1,2] <- input$matrix1[1,1]
    updateMatrixInput(session,inputId="matrix2",value=tmpMat2)
  })
  
  observeEvent(input$matrix2, { 
    if(any(rownames(input$matrix2) == "")){
      tmpMat2 <- input$matrix2
      rownames(tmpMat2) <- paste("Row", seq_len(nrow(input$matrix2)))
      isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMat2))
      # 补全行名后仍保留matrix3多场景数据
      a <- apply(input$matrix3,2,'length<-',max(nrow(input$matrix3),nrow(tmpMat2)))
      b <- apply(tmpMat2,2,'length<-',max(nrow(input$matrix3),nrow(tmpMat2)))
      c <- if(length(a) == 2){c(b)} else {c(b,a[,-1:-2])}
      d <- ncol(input$matrix3)
      tmpMat3 <- matrix(c(c), ncol = d)
      colnames(tmpMat3) <- paste("Scenario",rep(1:ncol(tmpMat3),each=2,length.out=ncol(tmpMat3)))
      rownames(tmpMat3) <- rownames(tmpMat2)
      isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMat3))
      return()
    }
    
    a <- apply(input$matrix3,2,'length<-',max(nrow(input$matrix3),nrow(input$matrix2)))
    b <- apply(input$matrix2,2,'length<-',max(nrow(input$matrix3),nrow(input$matrix2)))
    c <- if(length(a) == 2){c(b)} else {c(b,a[,-1:-2])}
    d <- ncol(input$matrix3)
    tmpMat3 <- matrix(c(c), ncol = d)
    colnames(tmpMat3) <- paste("Scenario",rep(1:ncol(tmpMat3),each=2,length.out=ncol(tmpMat3)))
    
    updateMatrixInput(session, inputId = "matrix3", value = tmpMat3)
  })
  
  observeEvent(input$matrix3, {
    if(any(colnames(input$matrix3) == "")){
      tmpMat3 <- input$matrix3
      colnames(tmpMat3) <- paste("Scenario",rep(1:ncol(tmpMat3),each=2,length.out=ncol(tmpMat3)))
      isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMat3))
    }
    input$matrix3
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$matrix3)/2),
             function(i){
               tibble(
                 Scenario = colnames(input$matrix3)[i*2-1],
                 X = seq_len(input$periods),
                 Y = sumProd(input$periods,input$matrix3[,(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)

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