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

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

在下面的缩短代码中,用户输入“链接”在一系列 3 个用户输入矩阵中(也在下图中说明):

  1. 矩阵 1:如果用户想要 运行 粗略快速的场景,用户只需输入矩阵 1。一个变量,只有一种情况。

  2. 矩阵 2:如果用户想要 运行 更复杂的场景,用户可以选择输入矩阵 2,矩阵 1 输入“下游”到矩阵的第 1 行/第 2 列2 为了播种它。矩阵 2 垂直扩展以容纳用于生成曲线的额外用户输入。

  3. 矩阵 3:如果用户想要 运行 多个复杂场景,用户可以选择输入矩阵 3,矩阵 3 的场景 1 是矩阵 2 的下游镜像反射。矩阵 3垂直和水平扩展,以适应用户输入 + 其他场景。

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

的重点

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

我无法做到的是让用户输入到矩阵 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)

以下图片显示了哪些有效,哪些无效:

不,简单的 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)