如何修改最后一个 object 修改的反应链控制其他链接的 objects？

Question

[新注释 1：在最底部发布的最终解决代码反映了 ismirsehregal 2021 年 12 月 3 日的解决方案，以及一些标记为“# ADDED”和“# MODIFIED”的小调整。 ADD 用于解决我在矩阵 2 添加值后从矩阵 1 删除行时遇到的错误（如下所述），“MODIFIED”是为了符合矩阵 1 和 2 的 headers 列（没有意义在他们有不同的列 headers).

当运行下面的代码时，我希望反应链中的最后一个 object 被修改为“控制”或“支配”该反应链中的其他 object .在此代码中，链式反应 object 是“matrix1”和“matrix2”。输入到 matrix2 下游的 matrix1，并输入到 matrix1 上游的 matrix2 的前 2 列。按照草案，matrix2 的输入胜过 matrix1 的输入。我希望最后输入的矩阵胜过另一个矩阵。有人可以帮我解决这个问题吗？

底部的图片有助于说明。

我搞砸了 isolate() 和其他事情，试图让它按照我想要的方式工作。我也遇到过矩阵陷入循环的问题，其中值在 2 个矩阵之间来回反弹。我还没有完全掌握 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)

新注释 1：下面是最终解决的代码

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)

Answer 1

以下似乎有效：

记得用drop = FALSE
从不嵌套观察者

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) {
  
  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, tmpMat2[,-1:-2]))
  })
  
  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)

如何修改最后一个 object 修改的反应链控制其他链接的 objects？

How to modify reactivity chain so last object modified controls other chained objects?

r

shiny

shiny-reactivity