在 R Shiny 中,如何从不同的条件面板控制同一个对象?

In R Shiny, how to control the same object from different conditional panels?

在我的应用程序中,我希望允许用户从两个不同的条件面板对同一对象进行更改。 (相信我 - 从用户的角度来看,这将有助于 运行 复杂的模型。我知道这听起来很奇怪)。

此对象的共同点是 table4 派生自 matrix4.... 用户应该能够从以下 MWE 代码中的两个条件面板之一查看和更改此 table4 ,来自 condition="input.tabselected==4"(“负债模块”)或来自 condition="input.tabselected==5"(“利率”)。

从“负债模块”(选项卡 = 4)对 table4 的更改也应在从“利率”模块(选项卡 = 5)访问 table4(或等效项)时反应性地反映出来), 反之亦然。

有没有干净简单的方法来做到这一点?

以我有限的经验,我的冲动是在选项卡 4 和 5 中复制 table4/matrix4... 进程的 2 个版本,然后 link 这两个版本。但这似乎是重复和麻烦的,我敢打赌有更多经验的人知道如何更容易地做到这一点。

如果解决方案附有解释,那肯定会有所帮助,因为我需要在 MWE 派生的完整代码中实现它。

下面是MWE代码:

library(shiny);library(shinyMatrix);library(shinyjs)

matrix4Default <- matrix(c(0.2), 4, 1,dimnames=list(c("A","B","C","D"),NULL))

matrix4Input <- function(x,matrix4Input){matrixInput(
  x, value = matrix4Input, rows = list(extend=FALSE,names=TRUE),
  cols = list(extend=FALSE,names=FALSE,editableNames=FALSE),class = "numeric")}

vectorBaseRate <- function(x,y){
  a <- rep(y,x)
  b <- seq(1:x)
  c <- data.frame(x = b, y = a)
  return(c)}

vectorBaseRatePlot <- function(w,x,y,z){plot(w[,1],sapply(w[,2],
    function(x)gsub("%","",x)),main=x,xlab=y,ylab=z)}

ui <- 
  pageWithSidebar(headerPanel("Model..."),
    sidebarPanel(fluidRow(helpText(h5(strong("Base Input Panel")))), uiOutput("Panels")), 
    mainPanel(
      tabsetPanel(
        tabPanel("Liabilities module", value=4,
                 fluidRow(h5(strong(helpText("Select model output to view:")))),
                 fluidRow(
                   actionButton('showRatesValueBtn','Rates values'),
                   actionButton('showRatesPlotBtn','Rates plots')), # close fluid row
                 uiOutput('showTab4Results') 
        ), # close tab panel
        tabPanel("Interest rates", value=5,
                 fluidRow(h5(strong(helpText("Select model output to view:")))),
                 fluidRow(
                   actionButton('showRatesValueBtn','Rates values'),
                   actionButton('showRatesPlotBtn','Rates plots')), # close fluid row
                 uiOutput('showTab5Results') 
        ), # close tab panel
        id = "tabselected"
      ))) # close tabset panel, main panel, page with sidebar

server <- function(input,output,session)({
  
  showTab4Results <- reactiveValues()
  showTab5Results <- reactiveValues()
  
  matrix4   <- reactive(input$matrix4)
  baseRate  <- function(){vectorBaseRate(60,input$matrix4[1,1])} # Must remain in server section
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(condition="input.tabselected==4",actionButton('modRates','Modify Rates')),
      conditionalPanel(condition="input.tabselected==5",actionButton('modRates','Modify Rates'))
    ) # close tagList
  }) # close renderUI

  vectorRates <- reactive({
    if (is.null(input$modRates)){df <- NULL}
    else {if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = 0.2)}
      else {req(input$matrix4)
        df <- cbind(Period = 1:60,BaseRate = baseRate()[,2])
      } # close 2nd else
    } # close 1st else
    df
  }) # close reactive
  
  output$table4 <- renderTable({vectorRates()})

  observeEvent(input$resetRatesStruct, {updateMatrixInput(session,'matrix4', matrix4Default)})

  observeEvent(input$showRatesValueBtn,
               {showTab4Results$showme <- tagList(
                 fluidRow(h5(strong(helpText("You are viewing Rates values:")))),
                 tableOutput("table4"))
               },ignoreNULL = FALSE)
  
  output$graph4 <-renderPlot(vectorBaseRatePlot(vectorRates(),"A Variable","Period","Rate"))
  observeEvent(input$showRatesPlotBtn,{showTab4Results$showme <- tagList(
    fluidRow(h5(strong(helpText("You are viewing Rates plots:")))),
    plotOutput("graph4"))})
  
  output$showTab4Results <- renderUI({showTab4Results$showme})
  output$showTab5Results <- renderUI({showTab5Results$showme})
  
  observeEvent(input$modRates,
               {showModal(modalDialog(
                 matrix4Input("matrix4",if(is.null(input$matrix4)) matrix4Default else input$matrix4),
                 useShinyjs(),
                 footer = tagList(
                   actionButton("resetRatesStruct","Reset"),
                   modalButton("Close")
                 )))
                 showTab4Results$showme <- tagList(tableOutput("table4"))
               } # close modalDialog, showModal, and showModal function
  ) # close observeEvent
  
}) # close server

shinyApp(ui, server)

我不是 100% 确定我是否理解正确,但我猜你只需要 orconditionalPanel:

的 javascript 条件下
condition="input.tabselected==4 || input.tabselected==5"

请检查以下内容:

library(shiny);library(shinyMatrix);library(shinyjs)

matrix4Default <- matrix(c(0.2), 4, 1,dimnames=list(c("A","B","C","D"),NULL))

matrix4Input <- function(x,matrix4Input){matrixInput(
  x, value = matrix4Input, rows = list(extend=FALSE,names=TRUE),
  cols = list(extend=FALSE,names=FALSE,editableNames=FALSE),class = "numeric")}

vectorBaseRate <- function(x,y){
  a <- rep(y,x)
  b <- seq(1:x)
  c <- data.frame(x = b, y = a)
  return(c)}

vectorBaseRatePlot <- function(w,x,y,z){plot(w[,1],sapply(w[,2],
                                                          function(x)gsub("%","",x)),main=x,xlab=y,ylab=z)}

ui <- 
  pageWithSidebar(headerPanel("Model..."),
                  sidebarPanel(fluidRow(helpText(h5(strong("Base Input Panel")))), uiOutput("Panels")), 
                  mainPanel(
                    tabsetPanel(
                      tabPanel("Liabilities module", value=4,
                               fluidRow(h5(strong(helpText("Select model output to view:")))),
                               fluidRow(
                                 actionButton('showRatesValueBtnA','Rates values'),
                                 actionButton('showRatesPlotBtnA','Rates plots')), # close fluid row
                               uiOutput('showTab4Results') 
                      ), # close tab panel
                      tabPanel("Interest rates", value=5,
                               fluidRow(h5(strong(helpText("Select model output to view:")))),
                               fluidRow(
                                 actionButton('showRatesValueBtnB','Rates values'),
                                 actionButton('showRatesPlotBtnB','Rates plots')), # close fluid row
                               uiOutput('showTab5Results') 
                      ), # close tab panel
                      id = "tabselected"
                    ))) # close tabset panel, main panel, page with sidebar

server <- function(input,output,session)({
  
  showTab4Results <- reactiveValues()
  showTab5Results <- reactiveValues()
  
  matrix4   <- reactive(input$matrix4)
  baseRate  <- function(){vectorBaseRate(60,input$matrix4[1,1])} # Must remain in server section
  
  output$Panels <- renderUI({
    conditionalPanel(condition="input.tabselected==4 || input.tabselected==5",actionButton('modRates','Modify Rates'))
  }) # close renderUI
  
  vectorRates <- reactive({
    if (is.null(input$modRates)){df <- NULL}
    else {if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = 0.2)}
      else {req(input$matrix4)
        df <- cbind(Period = 1:60,BaseRate = baseRate()[,2])
      } # close 2nd else
    } # close 1st else
    df
  }) # close reactive
  
  output$table5 <- output$table4 <- renderTable({vectorRates()})
  
  observeEvent(input$resetRatesStruct, {updateMatrixInput(session,'matrix4', matrix4Default)})
  
  observeEvent(input$showRatesValueBtnA,
               {showTab4Results$showme <- tagList(
                 fluidRow(h5(strong(helpText("You are viewing Rates values:")))),
                 tableOutput("table4"))
               },ignoreNULL = FALSE)
  
  observeEvent(input$showRatesValueBtnB,
               {showTab5Results$showme <- tagList(
                 fluidRow(h5(strong(helpText("You are viewing Rates values:")))),
                 tableOutput("table5"))
               },ignoreNULL = FALSE)
  
  output$graph5 <- output$graph4 <- renderPlot(vectorBaseRatePlot(vectorRates(),"A Variable","Period","Rate"))
  
  observeEvent(input$showRatesPlotBtnA,{showTab4Results$showme <- tagList(
    fluidRow(h5(strong(helpText("You are viewing Rates plots:")))),
    plotOutput("graph4"))})
  
  observeEvent(input$showRatesPlotBtnB,{showTab5Results$showme <- tagList(
    fluidRow(h5(strong(helpText("You are viewing Rates plots:")))),
    plotOutput("graph5"))})
  
  output$showTab4Results <- renderUI({showTab4Results$showme})
  output$showTab5Results <- renderUI({showTab5Results$showme})
  
  observeEvent(input$modRates,
               {showModal(modalDialog(
                 matrix4Input("matrix4",if(is.null(input$matrix4)) matrix4Default else input$matrix4),
                 useShinyjs(),
                 footer = tagList(
                   actionButton("resetRatesStruct","Reset"),
                   modalButton("Close")
                 )))
                 showTab4Results$showme <- tagList(tableOutput("table4"))
               } # close modalDialog, showModal, and showModal function
  ) # close observeEvent
  
}) # close server

shinyApp(ui, server)

这是一个简化版本,避免了 reactiveValues:

library(shiny)
library(shinyMatrix)
library(shinyjs)

matrix4Default <- matrix(c(0.2), 4, 1, dimnames = list(c("A", "B", "C", "D"), NULL))

matrix4Input <- function(x, matrix4Input) {
  matrixInput(
    x,
    value = matrix4Input,
    rows = list(extend = FALSE, names = TRUE),
    cols = list(
      extend = FALSE,
      names = FALSE,
      editableNames = FALSE
    ),
    class = "numeric"
  )
}

vectorBaseRate <- function(x, y) {
  a <- rep(y, x)
  b <- seq(1:x)
  c <- data.frame(x = b, y = a)
  return(c)
}

vectorBaseRatePlot <- function(w, x, y, z) {
    plot(
      w[, 1],
      sapply(w[, 2], function(x)
        gsub("%", "", x)),
      main = x,
      xlab = y,
      ylab = z
    )
  }

ui <- pageWithSidebar(
  headerPanel("Model..."),
  sidebarPanel(fluidRow(helpText(h5(
    strong("Base Input Panel")
  ))), uiOutput("Panels")),
  mainPanel(tabsetPanel(
    tabPanel(
      "Liabilities module",
      value = 4,
      fluidRow(
        radioButtons(
          inputId = "showRates4",
          label = h5(strong(helpText(
            "Select model output to view:"
          ))),
          choices = c('Rates values', 'Rates plots'),
          selected = 'Rates values',
          inline = TRUE
        ),
        uiOutput('showTab4Results')
      )
    ),
    # close tab panel
    tabPanel(
      "Liabilities module",
      value = 5,
      fluidRow(
        radioButtons(
          inputId = "showRates5",
          label = h5(strong(helpText(
            "Select model output to view:"
          ))),
          choices = c('Rates values', 'Rates plots'),
          selected = 'Rates values',
          inline = TRUE
        ),
        uiOutput('showTab5Results')
      )
    ),
    # close tab panel
    id = "tabselected"
  ))
) # close tabset panel, main panel, page with sidebar

server <- function(input, output, session) {
  matrix4   <- reactive(input$matrix4)
  baseRate  <-
    function() {
      vectorBaseRate(60, input$matrix4[1, 1])
    } # Must remain in server section
  
  output$Panels <- renderUI({
    conditionalPanel(condition = "input.tabselected==4 || input.tabselected==5", actionButton('modRates', 'Modify Rates'))
  }) # close renderUI
  
  vectorRates <- reactive({
    if (is.null(input$modRates)) {
      DF <- NULL
    }
    else {
      if (input$modRates < 1) {
        DF <- cbind(Period = 1:60, BaseRate = 0.2)
      }
      else {
        req(input$matrix4)
        DF <- cbind(Period = 1:60, BaseRate = baseRate()[, 2])
      } # close 2nd else
    } # close 1st else
    DF
  }) # close reactive
  
  observeEvent(input$resetRatesStruct, {
    updateMatrixInput(session, 'matrix4', matrix4Default)
  })
  
  output$table5 <- output$table4 <- renderTable({
    vectorRates()
  })
  
  output$graph5 <- output$graph4 <- renderPlot({
    vectorBaseRatePlot(vectorRates(), "A Variable", "Period", "Rate")
  })
  
  output$showTab4Results <- renderUI({
    if (input$showRates4 == 'Rates values') {
      tagList(fluidRow(h5(strong(
        helpText("You are viewing Rates values:")
      ))),
      tableOutput("table4"))
    } else {
      tagList(fluidRow(h5(strong(
        helpText("You are viewing Rates plots:")
      ))),
      plotOutput("graph4"))
    }
  })
  
  output$showTab5Results <- renderUI({
    if (input$showRates5 == 'Rates values') {
      tagList(fluidRow(h5(strong(
        helpText("You are viewing Rates values:")
      ))),
      tableOutput("table5"))
    } else {
      tagList(fluidRow(h5(strong(
        helpText("You are viewing Rates plots:")
      ))),
      plotOutput("graph5"))
    }
  })
  
  observeEvent(input$modRates,
               {
                 showModal(modalDialog(
                   matrix4Input("matrix4", if (is.null(input$matrix4))
                     matrix4Default
                     else
                       input$matrix4),
                   useShinyjs(),
                   footer = tagList(
                     actionButton("resetRatesStruct", "Reset"),
                     modalButton("Close")
                   )
                 ))
               } # close modalDialog, showModal, and showModal function
              ) # close observeEvent
} # close server

shinyApp(ui, server)

另一个解决方案是嵌套条件面板。为了解决这个问题,我使用了以下内容:

output$Panels <- renderUI({
    conditionalPanel(
      condition = "input.tabselected==4 || input.tabselected==5", actionButton('modRates', 'Modify Rates'),
        conditionalPanel(
          condition = "input.tabselected==4", actionButton('test', 'Test'),
        ) # close 2nd conditional panel
    ) # close 1st conditional panel
  }) # close renderUI

代替原始 MWE 代码发布中使用的以下内容:

output$Panels <- renderUI({
    conditionalPanel(condition="input.tabselected==4 || input.tabselected==5",actionButton('modRates','Modify Rates'))
  }) # close renderUI