Optimizing Shiny app (functions, reactive events, conditional formatting)

shiny
,
1

Hi,

I’m creating a Shiny app to view datasets interactively. I currently have the datasets in tab panels, which appear only when selected via checkbox/switch in the sidebar panel. For this reason, most of my code is in the server rather than the UI.

I’m wanting to add more features to each tab panel, which are shared across some of the panels. That is, I’m asking different panels to have the same funtions, but because they’re different panels, they all need unique ID’s in the server.

I’m finding that the more features I add, e.g. the bars in the background of the data tables, the longer the app takes to render. I currently have only added features to two datasets, and I’m concerned about this when adding more. I assume there are more efficient ways to code the reactive events and conditional formatting I want than what I’ve done, but I’m new to Shiny apps and unfamiliar with many of the packages. Can anyone suggest simpler/more efficient alternatives to some of my formatting and packages?

Please find the .rmd file below. I’ve replaced the datasets with Palmer’s penguins, so some filtering and tranpose features may not render correctly, but you get the general idea.

Loading packages

library(shiny)
library(bslib)
library(reactable)
library(dplyr)
library(crosstalk)
library(readr)
library(plotly)

Uploading/cleaning data

# load all CSVs
dfs <- list(
  ests_1_2.1 = penguins[,1:6],
  ests_2_2.1 = penguins[,1:6],
  ests_2_2.2 = penguins[,1:6],
  prod_1_2.1 = penguins[,1:6],
  prod_1_3.1 = penguins[,1:6],
  prod_2_2.1 = penguins[,1:6],
  prod_2_2.2 = penguins[,1:6]
)

# round all numeric columns in all data frames
dfs <- lapply(dfs, function(df) mutate(df, across(where(is.numeric), \(x) round(x, 2))))

# unpack back to individual variables
list2env(dfs, envir = .GlobalEnv)


# ests_1_2.1 <- ests_1_2.1[order(ests_1_2.1$`Site ID`),]
# ests_1_2.1 <- cbind(prod_1_2.1$`Site Name`, ests_1_2.1)
# colnames(ests_1_2.1)[1] <- "Site Name"

Custom functions

# helper function to transpose a df cleanly
transpose_df <- function(df) {
  site.ids <- df[,2]
  df <- df[,c(3:ncol(df))]
  df_t <- as.data.frame(t(df))
  colnames(df_t) <- site.ids
  df_t
}


# col def
sort_coldef <- colDef(
  headerClass = "sort-header",
  minWidth = 150,
  style = JS("function(rowInfo, column, state) {
    for (let i = 0; i < state.sorted.length; i++) {
      if (state.sorted[i].id === column.id) {
        return { background: 'rgba(0, 0, 0, 0.03)' }
      }
    }
  }")
)

UI

ui <- page_sidebar(
  
  title = “Shiny Sharing",
  fillable = FALSE,
  sidebar = sidebar(
    width = 300,
    title = HTML("<b>Select dataset(s) to view</b>"),
    tags$style(HTML(
      ".nav-tabs { flex-wrap: nowrap; }
    .nav-tabs .nav-link { min-width: 300px }
    .sort-header[aria-sort]:hover { background: rgba(0, 0, 0, 0.15); }
    .sort-header[aria-sort='ascending'] { background: rgba(39, 245, 39, 0.15); }
    .sort-header[aria-sort='descending'] { background: rgba(245, 39, 39, 0.15); }")),
    
    card(
      card_header(HTML("<u> Data Project 1</u>")),
      checkboxInput("results1.prod","Production data"),
      input_switch("coprods1.prod", "Co-products"),
      input_switch("recovrates1.prod", "Recovery rates"),
      checkboxInput("results1.est", "Concentration estimates"),
      input_switch("coprods1.est", "Co-products"),
      input_switch("recovrates1.est", "Recovery rates")
    ),
    
    card(
      card_header(HTML("<u> Data Project 2</u>")),
      checkboxInput("results2.prod", "Production data"),
      input_switch("coprods2.prod", "Co-products"),
      input_switch("recovrates2.prod", "Recovery rates"),
      checkboxInput("results2.est", "Concentration estimates"),
      input_switch("coprods2.est", "Co-products"),
      input_switch("recovrates2.est", "Recovery rates")
    ),
  ),
  # main panel
  div(
    style = "width: 100%; overflow-x:auto; min-height: 1500px;",
    uiOutput("tabs")
  )
)

Server

server <- function(input, output) {
  
  transposed_ests_1_2.1 <- reactiveVal(FALSE)
  observeEvent(input$transpose_ests_1_2.1, { 
    transposed_ests_1_2.1(!transposed_ests_1_2.1()) 
  })
  
  transposed_ests_1_3.1 <- reactiveVal(FALSE)
  observeEvent(input$transpose_ests_1_3.1, { 
    transposed_ests_1_3.1(!transposed_ests_1_3.1()) 
  })
  
  transposed_ests_1_2.2 <- reactiveVal(FALSE)
  observeEvent(input$transpose_ests_1_2.2, { 
    transposed_ests_1_2.2(!transposed_ests_1_2.2()) 
  })
  
  transposed_ests_1_3.2 <- reactiveVal(FALSE)
  observeEvent(input$transpose_ests_1_3.2, { 
    transposed_ests_1_3.2(!transposed_ests_1_3.2()) 
  })
  
  transposed_ests_2_2.1 <- reactiveVal(FALSE)
  observeEvent(input$transpose_ests_2_2.1, { 
    transposed_ests_2_2.1(!transposed_ests_2_2.1()) 
  })
  
  transposed_ests_2_3.1 <- reactiveVal(FALSE)
  observeEvent(input$transpose_ests_2_3.1, { 
    transposed_ests_2_3.1(!transposed_ests_2_3.1()) 
  })
  
  transposed_ests_2_2.2 <- reactiveVal(FALSE)
  observeEvent(input$transpose_ests_2_2.2, { 
    transposed_ests_2_2.2(!transposed_ests_2_2.2()) 
  })
  
  transposed_ests_2_3.2 <- reactiveVal(FALSE)
  observeEvent(input$transpose_ests_2_3.2, { 
    transposed_ests_2_3.2(!transposed_ests_2_3.2()) 
  })
  
  output$tabs <- renderUI({
    tabs <- list()
    ##### data proj 1
    if(isTRUE(input$results1.prod) && 
       isTRUE(input$coprods1.prod) && 
       isTRUE(input$recovrates1.prod)){
      tabs <- c(
        tabs, 
        list(
          tabPanel(
            HTML("<b>Data Project 1</b>
                 <br>Production data
                 <br><i>+ Co-products</i>
                 <br><i>+Recovery rates</i>"),
            verbatimTextOutput("prod_1_3.2")
          )
        )
      )
    }else if(isTRUE(input$results1.prod) && isTRUE(input$coprods1.prod) && !isTRUE(input$recovrates1.prod)){
      tabs <- c(tabs, 
                list(
                  tabPanel(
                    HTML("<b>Data Project 1</b><br>
                           Production data<br>
                           <i>+ Co-products</i>"),
                    verbatimTextOutput("prod_1_2.2")
                  )
                )
      )
    }else if(isTRUE(input$results1.prod) && 
             isTRUE(input$recovrates1.prod) && 
             !isTRUE(input$coprods1.prod)){
      tabs <- c(tabs,
                list(tabPanel(
                  HTML("<b>Data Project 1</b><br>
                       Production data<br>
                       <i>+ Recovery rates</i>"),
                  card(
                    card_header("Filter dataset by:"),
                    fluidRow(
                      column(2, selectizeInput("filter_id", "Site ID:",
                                               choices = unique(prod_1_3.1$`Site ID`),
                                               selected = NULL, multiple = TRUE)),
                      column(2, selectizeInput("filter_name", "Site Name:",
                                               choices = unique(prod_1_3.1$`Site Name`),
                                               selected = NULL, multiple = TRUE)),
                      column(2, selectizeInput("filter_state", "State:",
                                               choices = unique(prod_1_3.1$`State`),
                                               selected = NULL, multiple = TRUE)),
                      column(2, selectizeInput("filter_dep_abbr", "Deposit Abbrv:",
                                               choices = unique(prod_1_3.1$`Deposit Abbreviation`),
                                               selected = NULL, multiple = TRUE)),
                      column(2, selectizeInput("filter_commodity", "Primary Commodity:",
                                               choices = unique(prod_1_3.1$`Primary Commodity`),
                                               selected = NULL, multiple = TRUE)),
                      column(2, selectizeInput("filter_dep_grp", "Deposit Group:",
                                               choices = unique(prod_1_3.1$`Deposit Group`),
                                               selected = NULL, multiple = TRUE))
                    ),
                    fluidRow(
                      column(8,
                             tags$label("Production (Kt):"),
                             div(
                               style = "display: flex; align-items: center; gap: 8px;",
                               numericInput("prod_min", label = NULL,
                                            value = min(prod_1_3.1$`Production (Kt)`, na.rm = TRUE),
                                            width = "120px"),
                               tags$span("to"),
                               numericInput("prod_max", label = NULL,
                                            value = max(prod_1_3.1$`Production (Kt)`, na.rm = TRUE),
                                            width = "120px")
                             )
                      ),
                      column(4, sliderInput("recov_slide", "Rate of Recovery (0-1):",
                                            min = min(prod_1_3.1$`Rate of Recovery (0-1)`, na.rm = TRUE),
                                            max = max(prod_1_3.1$`Rate of Recovery (0-1)`, na.rm = TRUE),
                                            value = c(min(prod_1_3.1$`Rate of Recovery (0-1)`, na.rm = TRUE),
                                                      max(prod_1_3.1$`Rate of Recovery (0-1)`, na.rm = TRUE))))
                    )),
                  reactableOutput("prod_1_3.1")
                )))
    }else if(isTRUE(input$results1.prod) && 
             !isTRUE(input$coprods1.prod) && 
             !isTRUE(input$recovrates1.prod)){
      tabs <- c(tabs,
                list(tabPanel(
                  HTML("<b>Data Project 1</b><br>
                       Production data"),
                  reactableOutput("prod_1_2.1"))
                ))
    }else if(!isTRUE(input$results1.prod) && 
             isTRUE(input$recovrates1.prod) && 
             !isTRUE(input$coprods1.prod)){
      # add an error message to produce (do not add to tabs)
    }else if(!isTRUE(input$results1.prod) && 
             !isTRUE(input$recovrates1.prod) && 
             isTRUE(input$coprods1.prod)){
      # add an error message to produce (do not add to tabs)
    }else if(!isTRUE(input$results1.prod) && 
             isTRUE(input$recovrates1.prod) && 
             isTRUE(input$coprods1.prod)){
      # add an error message to produce (do not add to tabs)
    } 

    if(isTRUE(input$results1.est) && 
       isTRUE(input$coprods1.est) && 
       isTRUE(input$recovrates1.est)){
      tabs <- c(
        tabs, 
        list(
          tabPanel(
            HTML("<b>Data Project 1</b>
                 <br>Concentration estimates
                 <br><i>+ Co-products</i>
                 <br><i>+Recovery rates</i>"),
            verbatimTextOutput("ests_1_3.2")
          )
        )
      )
    }else if(isTRUE(input$results1.est) && 
             isTRUE(input$coprods1.est) && 
             !isTRUE(input$recovrates1.est)){
      tabs <- c(tabs, 
                list(
                  tabPanel(
                    HTML("<b>Data Project 1</b><br>
                         Concentration estimates<br>
                         <i>+ Co-products</i>"),
                    verbatimTextOutput("ests_1_2.2")
                  )
                )
      )
    }else if(isTRUE(input$results1.est) && 
             isTRUE(input$recovrates1.est) && 
             !isTRUE(input$coprods1.est)){
      tabs <- c(tabs,
                list(tabPanel(
                  HTML("<b>Data Project 1</b><br>
                       Concentration estimates<br>
                       <i>+ Recovery rates</i>"),
                  verbatimTextOutput("ests_1_3.1"))
                ))
    }else if(isTRUE(input$results1.est) && 
             !isTRUE(input$coprods1.est) && 
             !isTRUE(input$recovrates1.est)){
      tabs <- c(tabs,
                list(tabPanel(
                  HTML("<b>Data Project 1</b><br>
                       Concentration estimates"),
                  #                  uiOutput("ests_1_2.1_header"),
                  reactableOutput("ests_1_2.1"),
                  actionButton("transpose_ests_1_2.1", "Transpose table"))
                ))
    }else if(!isTRUE(input$results1.est) && 
             isTRUE(input$recovrates1.est) && 
             !isTRUE(input$coprods1.est)){
      # add an error message to produce (do not add to tabs)
    }else if(!isTRUE(input$results1.est) && 
             !isTRUE(input$recovrates1.est) && 
             isTRUE(input$coprods1.est)){
      # add an error message to produce (do not add to tabs)
    }else if(!isTRUE(input$results1.est) && 
             isTRUE(input$recovrates1.est) && 
             isTRUE(input$coprods1.est)){
      # add an error message to produce (do not add to tabs)
    }
    
    if(isTRUE(input$results2.prod) && 
       isTRUE(input$coprods2.prod) && 
       isTRUE(input$recovrates2.prod)){
      tabs <- c(
        tabs, 
        list(
          tabPanel(
            HTML("<b>Data Project 2</b>
                 <br>Production data
                 <br><i>+ Co-products</i>
                 <br><i>+Recovery rates</i>"),
            verbatimTextOutput("prod_2_3.2")
          )
        )
      )
    }else if(isTRUE(input$results2.prod) && 
             isTRUE(input$coprods2.prod) && 
             !isTRUE(input$recovrates2.prod)){
      tabs <- c(tabs, 
                list(
                  tabPanel(
                    HTML("<b>Data Project 2</b><br>
                           Production data<br>
                           <i>+ Co-products</i>"),
                    reactableOutput("prod_2_2.2")
                  )
                )
      )
    }else if(isTRUE(input$results2.prod) && 
             isTRUE(input$recovrates2.prod) && 
             !isTRUE(input$coprods2.prod)){
      tabs <- c(tabs,
                list(tabPanel(
                  HTML("<b>Data Project 2</b><br>
                       Production data<br>
                       <i>+ Recovery rates</i>"),
                  verbatimTextOutput("prod_2_3.1"))
                ))
    }else if(isTRUE(input$results2.prod) && 
             !isTRUE(input$coprods2.prod) && 
             !isTRUE(input$recovrates2.prod)){
      tabs <- c(tabs,
                list(tabPanel(
                  HTML("<b>Data Project 2</b><br>
                       Production data"),
                  reactableOutput("prod_2_2.1"))
                ))
    }else if(!isTRUE(input$results2.prod) && 
             isTRUE(input$recovrates2.prod) && 
             !isTRUE(input$coprods2.prod)){
      # add an error message to produce (do not add to tabs)
    }else if(!isTRUE(input$results2.prod) && 
             !isTRUE(input$recovrates2.prod) && 
             isTRUE(input$coprods2.prod)){
      # add an error message to produce (do not add to tabs)
    }else if(!isTRUE(input$results2.prod) && 
             isTRUE(input$recovrates2.prod) && 
             isTRUE(input$coprods2.prod)){
      # add an error message to produce (do not add to tabs)
    } 
    ##### 2025 annual estimates
    if(isTRUE(input$results2.est) && 
       isTRUE(input$coprods2.est) && 
       isTRUE(input$recovrates2.est)){
      tabs <- c(
        tabs, 
        list(
          tabPanel(
            HTML("<b>Data Project 2</b>
                 <br>Concentration estimates
                 <br><i>+ Co-products</i>
                 <br><i>+Recovery rates</i>"),
            verbatimTextOutput("ests_2_3.2")
          )
        )
      )
    }else if(isTRUE(input$results2.est) && 
             isTRUE(input$coprods2.est) && 
             !isTRUE(input$recovrates2.est)){
      tabs <- c(tabs, 
                list(
                  tabPanel(
                    HTML("<b>Data Project 2</b><br>
                         Concentration estimates<br>
                         <i>+ Co-products</i>"),
                    reactableOutput("ests_2_2.2"),
                    actionButton("transpose_ests_2_2.2", "Transpose table")
                  )
                )
      )
    }else if(isTRUE(input$results2.est) && 
             isTRUE(input$recovrates2.est) && 
             !isTRUE(input$coprods2.est)){
      tabs <- c(tabs,
                list(tabPanel(
                  HTML("<b>Data Project 2</b><br>
                       Concentration estimates<br>
                       <i>+ Recovery rates</i>"),
                  verbatimTextOutput("ests_2_3.1"))
                ))
    }else if(isTRUE(input$results2.est) && 
             !isTRUE(input$coprods2.est) && 
             !isTRUE(input$recovrates2.est)){
      tabs <- c(tabs,
                list(tabPanel(
                  HTML("<b>Data Project 2</b><br>
                       Concentration estimates"),
                  reactableOutput("ests_2_2.1"),
                  actionButton("transpose_ests_2_2.1", "Transpose table"))
                ))
    }else if(!isTRUE(input$results2.est) && 
             isTRUE(input$recovrates2.est) && 
             !isTRUE(input$coprods2.est)){
      # add an error message to produce (do not add to tabs)
    }else if(!isTRUE(input$results2.est) && 
             !isTRUE(input$recovrates2.est) && 
             isTRUE(input$coprods2.est)){
      # add an error message to produce (do not add to tabs)
    }else if(!isTRUE(input$results2.est) && 
             isTRUE(input$recovrates2.est) && 
             isTRUE(input$coprods2.est)){
      # add an error message to produce (do not add to tabs)
    }
    do.call(tabsetPanel, tabs)
  })
  
  output$prod_1_2.1 <- renderReactable({
    reactable(prod_1_2.1, 
              searchable = TRUE,
              resizable = TRUE,
              defaultColDef = sort_coldef)
  })
  output$prod_1_2.2 <- renderText({"Not yet uploaded"})
  output$prod_1_3.1 <- renderReactable({
    req(input$prod_min,input$prod_max, input$recov_slide)
    
    df <- prod_1_3.1
    
    if (length(input$filter_id) > 0)
      df <- df[df$`Site ID` %in% input$filter_id, ]
    if (length(input$filter_name) > 0)
      df <- df[df$`Site Name` %in% input$filter_name, ]
    if (length(input$filter_state) > 0)
      df <- df[df$`State` %in% input$filter_state, ]
    if (length(input$filter_dep_abbr) > 0)
      df <- df[df$`Deposit Abbreviation` %in% input$filter_dep_abbr, ]
    if (length(input$filter_commodity) > 0)
      df <- df[df$`Primary Commodity` %in% input$filter_commodity, ]
    if (length(input$filter_dep_grp) > 0)
      df <- df[df$`Deposit Group` %in% input$filter_dep_grp, ]
    
    if (!is.na(input$prod_min))
      df <- df[df$`Production (Kt)` >= input$prod_min, ]
    if (!is.na(input$prod_max))
      df <- df[df$`Production (Kt)` <= input$prod_max, ]
    
    df <- df[df$`Rate of Recovery (0-1)` >= input$recov_slide[1] &
               df$`Rate of Recovery (0-1)` <= input$recov_slide[2], ]
    reactable(df,
              searchable = TRUE,
              resizable = TRUE,
              defaultColDef = sort_coldef)
  })
  output$prod_1_3.2 <- renderText({"Not yet uploaded"})
  
  output$prod_2_2.1 <- renderReactable({
    reactable(prod_2_2.1,  
              resizable = TRUE,
              searchable = TRUE,
              defaultColDef = sort_coldef)
  })
  output$prod_2_2.2 <- renderReactable({
    reactable(prod_2_2.2,  
              resizable = TRUE,
              searchable = TRUE,
              defaultColDef = sort_coldef)
  })
  output$prod_2_3.1 <- renderText({"Not yet uploaded"})
  output$prod_2_3.2 <- renderText({"Not yet uploaded"})
  
  output$ests_1_2.1 <- renderReactable({
    if (transposed_ests_1_2.1()){
      df <- transpose_df(ests_1_2.1)
      num_cols <- names(df)
    } else {
      df <- ests_1_2.1
      num_cols <- names(df[,3:ncol(df)])}
    
    # build bar columns only for numeric columns
    bar_cols <- lapply(setNames(num_cols, num_cols), function(col) {
      col_max <- max(df[[col]], na.rm = TRUE)
      colDef(
        headerClass = "sort-header",
        minWidth = 150,
        style = function(value) {
          if (is.numeric(value) && !is.na(value)) {
            bar_style(width = value / col_max, fill = "hsl(208, 70%, 90%)")
          }
        }
      )
    })
    
    reactable(df,  
              resizable = TRUE,
              searchable = TRUE,
              defaultColDef = sort_coldef,
              columns = bar_cols,
              bordered = TRUE)
  })

  output$ests_1_2.2 <- renderText({"Not yet uploaded"})
  output$ests_1_3.1 <- renderText({"Not yet uploaded"})
  output$ests_1_3.2 <- renderText({"Not yet uploaded"})
  
  output$ests_2_2.1 <- renderReactable({
    df <- if (transposed_ests_2_2.1()) transpose_df(ests_2_2.1) else ests_2_2.1
    reactable(df,  
              resizable = TRUE,
              searchable = TRUE,
              defaultColDef = sort_coldef)
  })
  output$ests_2_2.2 <- renderReactable({
    df <- if (transposed_ests_2_2.2()) transpose_df(ests_2_2.2) else ests_2_2.2
    reactable(df,  
              resizable = TRUE,
              searchable = TRUE,
              defaultColDef = sort_coldef)
  })
  output$ests_2_3.1 <- renderText({"Not yet uploaded"})
  output$ests_2_3.2 <- renderText({"Not yet uploaded"})
}

Run app

shinyApp(ui, server)
1 Like
2

First off you should not be library() your packages and instead should be calling each function using pkg::fnct(), secondly to optimize you need to make things into modules, and third ultimately making this into a package is the best route. See Hadley's section/book about this. Look up rhino for shiny and goelm for shiny as potential ways to help assist in this if you do not have package building experience.

3

I don't agree with @benjaminhlina's comments about not calling library()and turning it into a package - whether those are appropriate really depends on the use case and maturity of the project. I definitely agree with the comment about using modules, but I think there are probably other issues that need to be addressed first. It does appear as if the chunks producing card though could be modules as the outputs appear to be identical, just using different data.

Currently, every time one of the inputs changes, output$tabs is being rerun because it is a renderUI which is probably responsible for the slow rendering. An alternative is using conditionalPanel as this renders everything once and then uses javascript to control what is visible. Because that happens in the browser rather than the server, it is much faster.

Outputs like renderText({"Not yet uploaded"}) are not necessary. If outputs should not be rendered unless certain conditions are met, you should be using validate and need to produce these messages (see Shiny - Write error messages for your UI with validate ) or just req to stop their evaluation.

Beyond that, there is not much more I can help with without being able to run the app. If you are still struggling, it would help if you could make a simpler example which demonstrates the problem you are facing (but only that).

1 Like
4

Recently, I learned how much RAM is used during a session when loading entire packages using library(pkg). I was having pkgs loaded using library(pkg) which shiny development follows similar practices to pkg development where everything should be referred by its direct name using :: or :::. During initial development I had library(pkg) but went through and added :: and removed the loading of the pkgs and saw some pretty staggering results.

  1. The app load time went from 30 - 45 seconds or more to about 5 seconds as it no longer has to load all the pkg using library(pkg)
  2. RAM usage prior was about 330 - 360 mb - replacing with :: resulted in RAM usage of ~ 100 - 150 mb so over half if not more than half of the RAM usage. Given Shiny apps are usually deployed on server whether that's a posit/shiny-app server or a VPS you likely will want to minimize the amount of RAM being used both to speed up how the app functions and the overall workload on the server.

I was pretty shocked by this but it makes sense and thought it might be something useful for people to know.

As an example of making a shiny app that is a package see {glatar}. It does not use {rhino} or {golem} solely because by the time I had learned of those I was too far down the rabbit hole to implement.

If you're building a package which in developing a shiny app you should go that direction then explicitly calling each function using :: is preferred compared to having the namespace of the package load the package entirely.

Should also note I second using conditionalPanel()

1 Like
5

If you look at {rhino} and {golem} they can help set up the repository as a package if this is intimidating. Secondly

I think this is an excellent resource that can help streamline how to build a shiny app. Until {glatar} I had never built a shiny app and found this to be very helpful resource.

1 Like