在 R Shiny 中，可以在条件面板中使用多个条件吗？

Question

在下面的 MWE 代码中，运行代码生成的两个选项卡“负债模块”和“利率”是相同的。它们旨在作为相同数据 table 和当前由运行代码生成的图（显示速率）的两条不同路径。

但是这 2 个选项卡随着它们的进一步发展需要分开，在侧边栏面板中的其他操作按钮方面以及在每个相应选项卡的主面板顶部出现的操作按钮方面。为了简单的例子，我想在“负债模块”而不是“利率”模块中添加一个“测试”操作按钮。

我如何将多个条件添加到条件面板，所以在这种情况下，“测试”操作按钮出现在“负债模块”中，但不出现在“利率”选项卡中？如下图所示。

我的拙劣尝试在下面的 MWE 中标记为#ATTEMPT#；自然，它不起作用，所以我不得不将其注释掉。

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(
        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(
      "Interest rates",
      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'),
      # ATTEMPT # condition = "input.tabselected==4", actionButton('test','Test')
    ) # close conditional panel
  }) # 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'){tableOutput("table4")} 
    else {plotOutput("graph4")}
  })
  
  output$showTab5Results <- renderUI({
    if (input$showRates5 == 'Rates values'){tableOutput("table5")} 
    else {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)

Answer 1

您可以使用 if 语句，因为您正在服务器中呈现 UI。或者，您可以在服务器中创建整个侧边栏，为您提供更多的灵活性。您现在实际上可以删除整个条件面板，只生成要在 UI 中使用的按钮，使用 input$tabselected 值作为条件，这取决于您。

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

Answer 2

您可以简单地添加另一个 conditionalPanel 使用不同的条件。

此外，我删除了所有 renderUI，因为没有必要在服务器端创建条件面板。这应该会导致更快 UI.

我添加了更多按钮来展示概念：

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")
  ))),
  conditionalPanel(
    condition = "input.tabselected==4 || input.tabselected==5", actionButton('modRates', 'Modify Rates')
  ), # close conditional panel
  conditionalPanel(
    condition = "input.tabselected==4", actionButton('test1','Test')
  )
  ),
  mainPanel(
    conditionalPanel(
      condition = "input.tabselected==4", actionButton('test2','A mainPanel test button')
    ),
    conditionalPanel(
      condition = "input.tabselected==5", actionButton('test3','Another mainPanel test button')
    ),
    tabsetPanel(
      selected = 4,
      conditionalPanel(
        condition = "input.tabselected==4", actionButton('test4','A tabsetPanel test button')
      ),
      conditionalPanel(
        condition = "input.tabselected==5", actionButton('test5','Another tabsetPanel test button')
      ),
      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
          ),
          conditionalPanel(condition = "input.showRates4 == 'Rates values'", tableOutput("table4")),
          conditionalPanel(condition = "input.showRates4 == 'Rates plots'", plotOutput("graph4"))
        )
      ),
      # close tab panel
      tabPanel(
        "Interest rates",
        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
          ),
          conditionalPanel(condition = "input.showRates5 == 'Rates values'", tableOutput("table5")),
          conditionalPanel(condition = "input.showRates5 == 'Rates plots'", plotOutput("graph5"))
        )
      ),
      # 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
  
  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")
  })
  
  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)

Answer 3

下面是完整的 MWE 代码，用于解决这个问题，同时仍然使用 renderUI 在 server 部分渲染条件面板（也许我错了，将测试更多，但是这个 renderUI我认为解决了一些应用程序调用闪烁问题的方法。

这是条件面板的嵌套，它为我解决了这个问题：

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：

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(
      "Interest rates",
      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'),
        conditionalPanel(
          condition = "input.tabselected==4", actionButton('test', 'Test'),
        ) # close 2nd conditional panel
    ) # close 1st conditional panel
  }) # 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'){tableOutput("table4")} 
    else {plotOutput("graph4")}
  })
  
  output$showTab5Results <- renderUI({
    if (input$showRates5 == 'Rates values'){tableOutput("table5")} 
    else {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)

在 R Shiny 中，可以在条件面板中使用多个条件吗？

In R Shiny, possible to use multiple conditions in conditional panel?

r

shiny

shiny-reactivity