在 R Shiny 中，如何响应 link 一系列可扩展的用户输入矩阵？

Question

在下面的缩短代码中，用户输入“链接”在一系列 3 个用户输入矩阵中（也在下图中说明）：

矩阵 1：如果用户想要运行粗略快速的场景，用户只需输入矩阵 1。一个变量，只有一种情况。
矩阵 2：如果用户想要运行更复杂的场景，用户可以选择输入矩阵 2，矩阵 1 输入“下游”到矩阵的第 1 行/第 2 列2 为了播种它。矩阵 2 垂直扩展以容纳用于生成曲线的额外用户输入。
矩阵 3：如果用户想要运行多个复杂场景，用户可以选择输入矩阵 3，矩阵 3 的场景 1 是矩阵 2 的下游镜像反射。矩阵 3垂直和水平扩展，以适应用户输入 + 其他场景。

注意更完整的App 运行s inter/extrapolation 生成曲线的计算。为了简单起见，下面的代码运行是一个简单的（无意义的）sumProduct。但是计算不是这个post.

的重点

我已经使用 observeEvent 成功下游了以下用户输入：

observeEvent(input$matrix1... 将用户输入从矩阵 1 下游到矩阵 2，并且
observeEvent(input$matrix2... 将用户输入从矩阵 2 下游到矩阵 3 的场景 1，同时保留矩阵 3 中场景 > 1 的所有输入。

我无法做到的是让用户输入到矩阵 1 中，而不是将用户输入到矩阵 3 场景 > 1 中，如底部最后一张图片所示。我试过各种 observeEvents 都没有成功。我应该改用 observe 吗？矩阵 3 只是观察矩阵 2 发生了什么？关于如何做到这一点有什么想法吗？

当使用 observeEvent(input$matrix2... 下显示的代码更改矩阵 2 时，我已经能够保留矩阵 3 场景 > 1 输入，但是当我尝试在 observeEvent(input$matrix1... 下包含此类代码时，它不起作用。

这是代码：

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, {
    tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2])
    tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1]
    updateMatrixInput(session,inputId="matrix2",value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
    )
  })
  
  observeEvent(input$matrix2, { 
    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)))
    
    if(any(rownames(input$matrix2) == "")){
      tmpMat3 <- input$matrix2
      rownames(tmpMat3) <- paste("Row", seq_len(nrow(input$matrix2)))
      isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMat3))
      isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMat3))
    }
    input$matrix2
    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), # column counter to set matrix index as it expands
             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)

以下图片显示了哪些有效，哪些无效：

Answer 1

不，简单的 observe 不能解决问题。继续使用 observeEvent。最初发布的代码存在错误，在 observeEvent(input$matrix2, {... 下的 server 部分开始 if(any(rownames(input$matrix2) == "")){...，其中矩阵 2 和矩阵 3 都已更新。在矩阵 2 输入的 observeEvent 下的本节中不应更新矩阵 3，其中为矩阵 2 添加了行标签。在下面解析的代码中，查看 rownames 函数如何移动到对于矩阵 3 的任何输入更改，单独 observeEvent。通过此修复，代码现在可以正常工作。

解析代码：

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, {
    tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2]) # convert to vector
    tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1] # drop matrix 1 value into row 1/col 2 of matrix 2
    updateMatrixInput(session,inputId="matrix2",value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y"))))
    })
  
  observeEvent(input$matrix2, {
    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)))

    if(any(rownames(input$matrix2) == "")){
      tmpMat2 <- input$matrix2
      rownames(tmpMat2) <- paste("Row", seq_len(nrow(input$matrix2)))
      updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
      }
    
    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)))
      updateMatrixInput(session, inputId = "matrix3", value = tmpMat3)
      }
    if(any(rownames(input$matrix3) == "")){
      tmpMat3 <- input$matrix3
      rownames(tmpMat3) <- paste("Row", seq_len(nrow(input$matrix3)))
      updateMatrixInput(session, inputId = "matrix3", value = tmpMat3)
      }
    input$matrix3
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$matrix3)/2), # column counter to set matrix index as it expands
             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)

在 R Shiny 中，如何响应 link 一系列可扩展的用户输入矩阵？

In R Shiny, how to reactively link a series of expandable user input matrices?

r

shiny

observers

shiny-reactivity