如何修改R Shiny响应式链 使最后修改对象控制其他链式对象

【新注1：最终解决代码发布在页面最底部，基于ismirsehregal 2021年12月3日的解决方案调整，少量修改标记为# ADDED和# MODIFIED。ADD用于修复matrix2添加值后删除matrix1行时遇到的bug，MODIFIED用于统一matrix1和matrix2的列标题，二者无需设置不同列标题。】

需求描述 #

运行下述代码时，我希望响应式链中最后被修改的对象可以「控制」或「主导」链内的其他对象。本示例中处于响应式链的对象为matrix1和matrix2：

• matrix1的输入会向下同步到matrix2
• matrix2前两列的输入会向上同步到matrix1

当前编写的代码中matrix2的输入优先级高于matrix1，我希望实现最后被操作的矩阵优先级高于另一个矩阵。

我尝试过使用isolate()等方法调整逻辑来实现需求，还遇到了两个矩阵陷入数值循环、数值在两个矩阵间反复同步的问题，目前我尚未完全掌握isolate()的用法。

原问题代码 #

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),ncol=2,dimnames=list(NULL,c("X","Y"))),
                  rows = list(extend = TRUE, delete = TRUE),
                  class = "numeric"),
      actionButton(inputId = "showMat2", "Add scenarios"),br(),br(),
    ),
    mainPanel(plotOutput("plot"))
  )
)

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

  observeEvent(input$matrix1, {
    tmpMat1 <- input$matrix1
    if(any(rownames(input$matrix1) == "")){rownames(tmpMat1) <- paste("Row", seq_len(nrow(input$matrix1)))    }
    isolate(updateMatrixInput(session, inputId = "matrix1", value = tmpMat1))
  })
  
  observeEvent(input$showMat2,{
    showModal(
      modalDialog(
        matrixInput("matrix2",
                    label = "Matrix 2:",
                    value = input$matrix1,
                    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)))
      isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMat2))
      isolate(updateMatrixInput(session, inputId = "matrix1", value = tmpMat2[,1:2]))
    })
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$matrix1)/2), 
             function(i){
               tibble(
                 Scenario= colnames(input$matrix1)[i*2-1],X=seq_len(10),
                 Y=sumMat(input$matrix1[,(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)

最终解决代码 #

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

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

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)))}
  
    # ADDED
    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])
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$matrix1) / 2),
             function(i) {
               tibble(
                 Scenario = colnames(input$matrix1)[i * 2 - 1],
                 X = seq_len(10),
                 Y = sumMat(input$matrix1[, (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)

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