如何将链接对象移动到模式对话框中？

Question

以下代码按预期工作，没有错误。矩阵 1，包括对矩阵 1 的任何用户输入，作为“场景 1”链接到（“下游”）矩阵 2，用户可以通过矩阵 2 添加场景。绘制结果。输入到矩阵 2 中的其他场景在图中显示为附加线。为了便于说明，所有矩阵输入都通过sumMat() 函数简单地求和并绘制了 10 个周期。

关于如何将矩阵 2 移动到模态对话框中的任何想法？在单击代码中的单个actionButton() 后，用户可以选择输入矩阵 2。矩阵 1 保留在 sidebarPanel() 中。在保持代码当前具有的完全相同的功能的同时，当用户输入矩阵 1 或矩阵 2 并且两个矩阵保持链接时，绘图会响应更新？

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

sumMat <- function(x){return(rep(sum(x,na.rm = TRUE), 10))}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      matrixInput("matrix1",
                  label ="Matrix 1 (scenario 1):",
                  value = matrix(c(60,5), nrow = 1, ncol = 2, dimnames = list(NULL,c("X","Y"))),
                  rows = list(extend = TRUE, delete = TRUE),
                  class = "numeric"),
      actionButton(inputId = "showMat2", "Add scenarios"),br(),br(),
      matrixInput("matrix2",
                  label = "Matrix 2:",
                  value = matrix(c(60,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")
      ),
      mainPanel(plotOutput("plot"))
  )
)

server <- function(input, output, session){
  
  observeEvent(input$matrix1, {
    a <- apply(input$matrix2,2,'length<-',max(nrow(input$matrix2),nrow(input$matrix1)))
    b <- apply(input$matrix1,2,'length<-',max(nrow(input$matrix2),nrow(input$matrix1)))
    c <- if(length(a) == 2){c(b)} else {c(b,a[,-1:-2])}
    d <- ncol(input$matrix2)
    tmpMat2 <- matrix(c(c), ncol = d)
    colnames(tmpMat2) <- paste("Scenario",rep(1:ncol(tmpMat2),each=2,length.out=ncol(tmpMat2)))

    if(any(rownames(input$matrix1) == "")){
      tmpMat1 <- input$matrix1
      rownames(tmpMat1) <- paste("Row", seq_len(nrow(input$matrix1)))
      updateMatrixInput(session, inputId = "matrix1", value = tmpMat1)
      }
    updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
  })
  
  observeEvent(input$matrix2, {
    if(any(colnames(input$matrix2) == "")){
      tmpMat2 <- input$matrix2
      colnames(tmpMat2) <- paste("Scenario",rep(1:ncol(tmpMat2),each=2,length.out=ncol(tmpMat2)))
      updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
      }
    if(any(rownames(input$matrix2) == "")){
      tmpMat2 <- input$matrix2
      rownames(tmpMat2) <- paste("Row", seq_len(nrow(input$matrix2)))
      updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
      }
    input$matrix2
  })
  
  observeEvent(input$showMat2,{
    showModal(
      modalDialog(
        h5("Matrix 2 needs to be shown here, with user ability to input into matrix 2"),
        h5("User inputs into matrix 1 would automatically downstream to the 2 left-most columns of matrix 2 as Scenario 1"),
        footer = tagList(modalButton("Close"))
      ))
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$matrix2)/2), 
             function(i){
               tibble(
                 Scenario= colnames(input$matrix2)[i*2-1],X=seq_len(10),
                 Y=sumMat(input$matrix2[,(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

下面的代码解决了这个问题。矩阵 2 已成功移入模态对话框。最后一个矩阵修改了“控件”，因为这两个矩阵是链接的。与发布的原始代码不同，矩阵 1 简单地“下游”到矩阵 2，在下面的代码中，矩阵 1 下游到矩阵 2 和矩阵 2（场景 1）将“上游”更改为矩阵 1，最后一个矩阵修改控制。

下面还在主面板中添加了一个表格输出，显示了绘制的反应矩阵currentMat() 的值。观察currentMat() 中发生的事情对于调试和使其正常工作很重要。

要查看此解决方案的演变，另请参阅帖子In R shiny, how to modify reactivity chain so last object modified controls other chained objects?

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

sumMat <- function(x) {return(rep(sum(x, na.rm = TRUE), 10))}

ui <- fluidPage(sidebarLayout(
  sidebarPanel(
    matrixInput(
      "matrix1",
      label = "Matrix 1:", 
      value = matrix(c(60,5),ncol=2,dimnames=list(NULL,rep("Scenario 1",2))), 
      rows = list(extend = TRUE, delete = TRUE),
      cols = list(multiheader = TRUE), 
      class = "numeric"
    ),
    actionButton(inputId = "showMat2", "Add scenarios"),br(),br(),
  ),
  mainPanel(plotOutput("plot"),
            h5("currentMat() values:"),
            tableOutput("table1"))
))

server <- function(input, output, session) {
  
  currentMat <- reactiveVal(isolate(input$matrix1))
  
  observeEvent(input$matrix1, {
    tmpMat1 <- input$matrix1
    if(any(rownames(input$matrix1)=="")){rownames(tmpMat1)<-paste("Row",seq_len(nrow(input$matrix1)))}
    updateMatrixInput(session, inputId = "matrix1", value = tmpMat1)
    
    tmpMat2 <- currentMat()
    if(nrow(tmpMat1) > nrow(tmpMat2)){tmpMat2 <- rbind(tmpMat2, rep(NA, ncol(tmpMat2)))}
    if(nrow(tmpMat2) > nrow(tmpMat1)){tmpMat1 <- rbind(tmpMat1, rep(NA, ncol(tmpMat1)))}
    currentMat(cbind(tmpMat1[drop=FALSE], tmpMat2[,-1:-2,drop=FALSE]))
  })
  
  observeEvent(input$showMat2, {
    showModal(modalDialog(
      matrixInput(
        "matrix2",
        label = "Matrix 2:",
        value = currentMat(),
        rows = list(extend = TRUE, delete = TRUE),
        cols = list(extend = TRUE,delta = 2,delete = TRUE,multiheader = TRUE),
        class = "numeric"
      ),
      footer = tagList(modalButton("Close"))
    ))
  })
  
  observeEvent(input$matrix2, {
    tmpMat2 <- input$matrix2
    rownames(tmpMat2) <- paste("Row", seq_len(nrow(input$matrix2)))
    colnames(tmpMat2) <-
      paste("Scenario", rep(1:ncol(tmpMat2),each = 2,length.out = ncol(tmpMat2)))
    currentMat(tmpMat2)
    updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
    updateMatrixInput(session, inputId = "matrix1", value = tmpMat2[, 1:2, drop = FALSE])
  })
  
  output$table1 <- renderTable(currentMat())
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(currentMat()) / 2),
             function(i) {
               tibble(
                 Scenario = colnames(currentMat())[i * 2 - 1],
                 X = seq_len(10),
                 Y = sumMat(currentMat()[, (i * 2 - 1):(i * 2), drop = FALSE])
               )
             }) %>% bind_rows(),
      error = function(e)
      NULL
    )
  })
  
  output$plot <- renderPlot({
    plotData() %>% ggplot() +
      geom_line(aes(
        x = X,
        y = Y,
        colour = as.factor(Scenario)
      )) +
      theme(legend.title = element_blank())
  })
}

shinyApp(ui, server)