Search code examples
rshinyshiny-reactivity

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

In the below MWE code, the two tabs generated by running the code, "Liabilities module" and "Interest rates", are identical. They are intended as two different paths to the same data table and plots (showing rates) currently generated by running the code.

But these 2 tabs need to diverge as they further develop, in terms of other action buttons in the sidebar panel and in terms of the action buttons appearing at the top of the main panels for each of the respective tabs. For sake of easy example, I'd like to add a "Test" action button to the "Liabilities module" but not to the "Interest rates" module.

How would I add multiple conditions to a conditional panel, so in this case "Test" action button appears in "Liabilities module" but not in "Interest rates" tabs? As shown in the image at the bottom.

My humble attempt to do this is marked # ATTEMPT # in the below MWE; naturally, it doesn't work so I had to comment it out.

MWE code:

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)

enter image description here

Solution

  • You can simply add another conditionalPanel using a different condition.

    Furthermore I dropped all renderUI's as it is not necessary to create conditionalPanels on the server side. This should result in a faster UI.

    I added some more buttons to show the concept:

    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)