Server: Reactive programming II

1 Basics

  • In the last section, you learned about what reactivity means in Shiny
  • Recall:
    • The programmer provides R with a “recipe”
    • R creates an order of expressions under the hood (or “reactive graph”)
    • R executes these expressions whenever an input changes
  • So far we have worked with inputs (e.g. input$slider), outputs (e.g. output$plot), and reactive functions (e.g. reactive(input$slider + 1))
  • In a Shiny app, these three elements are by far the most widely used
  • In this section, you will learn about new mechanisms to control the reactive graph:
    • Observers: Reactively perform side effects
    • Updaters: Change inputs
    • Events: Control when reactive elements are executed
    • Isolation: Sever expressions from the reactive graph
    • Truthiness: Stop reactivity based on arbitrary conditions

2 Overview of the reactivity workflow

  • This workflow chart is an overview of the most important mechanisms of Shiny’s server function
  • We do not address all elements on this map, but at the end of the workshop you should get the general idea of what is going on here

3 Reactives versus observers

3.1 Reactive

  • Reactives (reactive()) wrapped up:
    • Reactives wrap an R expression to create a reactive expression
    • They “react” to an input, i.e. are evaluated when an input changes.
    • They are both reactive producers and consumer. They take reactive values and return a reactive value.
    • They must be assigned to a name. They can be referred to by other reactive consumers by being called like a function.
    • They are evaluated lazily, i.e. they only run if they are forced to, for example when they are called by another reactive.
    • They are cached, i.e. when called back-to-back, without any dependency changing, then they return the same value twice
  • Reactives have two clear uses:
    • They reduce the amount of computation that needs to be done by Shiny
    • They reduce the mental strain in trying to understand complex Shiny code
val <- reactive({
  num <- input$number
  num + 1
})
Tip

Conceptually and technically, reactives may be compared to traditional R functions. Functional programming follows the “rule of three”: If code would be duplicated three times, wrap it in a function. Shiny follows the rule of two. This is because reactives not only simplify code for humans but also for machines: R only evaluates reactives if it has to. This can dramatically speed up an application.

Also, reactives literally are functions:

is.function(reactive({}))
[1] TRUE

Reactive graph without reactives

Reactive graph with reactives
Reactive graph without reactives Reactive graph with reactives

3.2 Observers

  • Observers (observe()) are similar to reactives:
    • They also take an arbitrary R expression.
    • They also react to an input.
  • But they also carry important differences:
    • They are not assigned to a name, thus they cannot be referred to from other reactive consumers and their return value is simply discarded. This also means they are terminal nodes (reactive consumers) in the reactive graphs – just like outputs.
    • They are evaluated eagerly, i.e. they run as soon as possible and do not wait for their dependencies.
    • They are forgetful, their previous output is not cached.
  • Since they are terminal nodes but do not produce a visible output, they are something between a reactive and an output
  • Their uses are manifold, but here are some examples:
    • Logging to the R console
    • Updating inputs (see below)
    • Reactively changing the UI
    • Communicating with a remote storage (e.g. a database or a cloud)
    • Essentially everything that does not require assigning to a name
Tip

Conceptually, observers may be compared to the tidyverse function purrr::walk, which iterates over a list or a vector and performs “side-effects” like writing to files. Unlike purrr::walk, though, observe is probably much more common-place.

# the reactive takes the inputs and produces a reactive value
# which can be re-used in other reactive expressions
filtered <- reactive({
  xvar <- input$xvar
  yvar <- input$yvar
  range <- input$range
  
  # select country
  if (!is.null(input$countries)) {
    ess <- ess[ess$country %in% input$countries, ]
  }
  
  # select variable
  ess[c("idno", "country", xvar, yvar)]
})

# the plot output is a "reactive consumer" that takes
# the reactive value and makes a plot out of it
output$plot <- renderPlot({
  xvar <- input$xvar
  yvar <- input$yvar
  plot_data <- filtered() %>%
    drop_na() %>%
    mutate(across(where(is.numeric), .fns = as.ordered))
  
  ggplot(plot_data) +
    aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
    geom_violin(fill = "lightblue", show.legend = FALSE) +
    theme_classic()
})

# the observer also takes the reactive value and prints it to the console
# it is also a reactive consumer and does not return anything
observe({
  print(filtered())
})
Complete code 
library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotOutput("plot", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # filter data ----
  filtered <- reactive({
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess[c("idno", "country", xvar, yvar)]
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlot({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
  })
  
  # executes everytime `filtered()` is updated
  # prints the filtered dataset to the console
  observe({
    print(filtered())
  })
}

shinyApp(ui = ui, server = server)

4 Events

  • We talk about an event when a reactive expression is triggered
  • For example:
    • A user clicks a button
    • The Shiny session initializes
    • An input is updated (see below)
  • We are dealing with Shiny events all the time, but it is important to realize how to control them

4.1 bindEvent

  • The bindEvent function binds a reactive expression to one or multiple events
  • The reactive expression is evaluated if and only if the event is triggered
  • bindEvent locks up a reactive expression unless a specific event is triggered
  • You can use bindEvent on all sorts of reactive expressions: reactives, observers, and output renderers
reactive({
  # do something
}) %>%
  bindEvent(input$button)

4.2 Arguments to bindEvent

  • bindEvent takes three arguments:
    • ignoreNULL: By default, every event is an event, even if it is NULL. An unpressed button would then also count as an event. If you need your plot to render only before pressing that button, then ignoring NULL is the right choice.
    • ignoreInit: By default, events are triggered when the reactive expressions are first initialized. This can be bad news for dynamically created UI elements (which are beyond this workshop).
    • once: If used on an observer, this argument can be used to destroy that observer after its first use.

4.3 Example

  • To exemplify we will add an action button, that serves the following role:
    • If the inputs are changed, nothing should happen to the plot
    • Only if the button is pressed, shall the plot data be recalculated

In the UI:

actionButton(
  "button",
  label = "Update parameters",
  icon = icon("refresh")
)

In the server function:

filtered <- reactive({
  xvar <- input$xvar
  yvar <- input$yvar
  range <- input$range
  
  # select country
  if (!is.null(input$countries)) {
    ess <- ess[ess$country %in% input$countries, ]
  }
  
  # select variable
  ess[c("idno", "country", xvar, yvar)]
}) %>%
  bindEvent(input$button, ignoreNULL = FALSE)


output$plot <- renderPlot({
  plot_data <- filtered() %>%
    drop_na() %>%
    mutate(across(where(is.numeric), .fns = as.ordered))
  
  xvar <- names(plot_data)[[3]]
  yvar <- names(plot_data)[[4]]
  
  ggplot(plot_data) +
    aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
    geom_violin(fill = "lightblue", show.legend = FALSE) +
    theme_classic()
})
Complete code (important lines are highlighted) 
library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      actionButton(
        "button",
        label = "Update parameters",
        icon = icon("refresh")
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotOutput("plot", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # filter data ----
  filtered <- reactive({
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess[c("idno", "country", xvar, yvar)]
  }) %>%
    bindEvent(input$button, ignoreNULL = FALSE)
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlot({
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    xvar <- names(plot_data)[[3]]
    yvar <- names(plot_data)[[4]]
    
    ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
  })
}

shinyApp(ui = ui, server = server)

5 Updaters

  • Updaters are one of the more common uses of observers
  • They update the values and appearance of input widgets
  • There are update functions for most input widgets – and if there is not, updating becomes much more difficult
  • Some examples:
    • updateSelectInput: Updating an input selection can update a palette selection to match varying data types – continuous, categorical, divering.
    • updateTabsetPanel: Updating a tabset panel can automatically switch between tabs.
    • updateActionButton: Updating an action button can simulate a button click, without the user needing to physically click on the button.

5.1 Implementation

  • Updaters are usually found in an observer.
  • Because they often do not depend on any input, they are best coupled with bindEvent.
  • It can also be useful to combine them with freezeReactiveValue
    • Updating a value triggers an event
    • Freezing can prevent the event from triggering twice: when changing the input and when updating.
observe({
  freezeReactiveValue(input, "id_of_input")
  updateSelectInput(
    session = session,
    inputId = "id_of_input",
    choices = c("a", "b", "c")
    selected = "b"
  ) %>%
    bindEvent(input$button)
})
1
Freeze id_of_input to prevent it from triggering an event twice, first when clicking on the button, and second when updating the input.
2
The session object of the server function has to be passed to every update function. This has no deeper meaning.
3
The inputId argument takes the ID of the widget that is to be updated
4
Every update function has different arguments to alter different parts of the input widget
5
Bind the observer to an input that should trigger the input update

5.2 Example

  • To exemplify, we add a new slider to the app:
sliderInput(
  "slider",
  label = "Select a range for the independent variable",
  min = min(ess$left_right, na.rm = TRUE),
  max = max(ess$left_right, na.rm = TRUE),
  value = range(ess$left_right, na.rm = TRUE),
  step = 1
)
  • Note that min, max, and value are fixed
  • …, but the independent variable is not: we can select a different variable with a different range
  • We can thus implement an updater that dynamically updates the slider with new ranges:
observe({
  yvar <- input$yvar
  freezeReactiveValue(input, "slider")
  updateSliderInput(
    session = session,
    inputId = "slider",
    min = min(ess[[yvar]], na.rm = TRUE),
    max = max(ess[[yvar]], na.rm = TRUE),
    value = range(ess[[yvar]], na.rm = TRUE)
  )
}) %>%
  bindEvent(input$yvar)

filtered <- reactive({
  xvar <- input$xvar
  yvar <- input$yvar
  
  # select country
  ess <- ess[ess$country %in% input$countries, ]

  # apply range
  ess <- ess[
    ess[[yvar]] > input$slider[1] &
    ess[[yvar]] < input$slider[2],
  ]
  
  # select variable
  ess[c("idno", "country", xvar, yvar)]
})
1
The updater references the ID of the input that needs to change
2
Min, max, and value are adapted to the select Y variable
3
The updater only triggers when a new Y variable is selected
4
The dataset is filtered according to the slider
Complete code (important lines are highlighted) 
library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      sliderInput(
        "slider",
        label = "Select a range for the independent variable",
        min = min(ess$left_right, na.rm = TRUE),
        max = max(ess$left_right, na.rm = TRUE),
        value = range(ess$left_right, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotOutput("plot", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # filter data ----
  filtered <- reactive({
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$slider
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]

    # apply range
    ess <- ess[
      ess[[yvar]] > range[1] &
      ess[[yvar]] < range[2], 
    ]
    
    # select variable
    ess[c("idno", "country", xvar, yvar)]
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlot({
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    xvar <- names(plot_data)[[3]]
    yvar <- names(plot_data)[[4]]

    ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
  })
  
  observe({
    yvar <- input$yvar
    freezeReactiveValue(input, "slider")
    updateSliderInput(
      session = session,
      inputId = "slider",
      min = min(ess[[yvar]], na.rm = TRUE),
      max = max(ess[[yvar]], na.rm = TRUE),
      value = range(ess[[yvar]], na.rm = TRUE)
    )
  }) %>%
    bindEvent(input$yvar)
}

shinyApp(ui = ui, server = server)

6 Truthiness

  • Truthiness is Shiny’s flavor of logical or boolean values.
  • Shiny interprets truthiness much more liberally than base R
  • Truthiness answers questions such as:
    • Is this value missing or available?
    • Has the user provided an answer?
    • Has the button been clicked?
  • Concretely, a value is truthy unless it is:
    • FALSE
    • NULL
    • An empty character string ("")
    • An empty vector (e.g. numeric(0))
    • A vector full of NA (e.g. c(NA, NA, NA))
    • A vector full of NA or FALSE (e.g. c(NA, FALSE, NA))
    • A try-error (e.g. try(stop("an error")))
    • An unclicked action button
isTruthy(NULL)
[1] FALSE
isTruthy("")
[1] FALSE
isTruthy(0)
[1] TRUE

6.1 Required values (req)

  • Truthiness is useful for Shiny’s req function
  • req is equivalent to if statements in R with two exceptions:
    • They test for truthiness (instead of TRUE/FALSE)
    • They raise a “silent” exception, i.e. they cancel any ongoing computation without logging or displaying an error
  • req is useful to stop reactive behavior when certain conditions are not met

6.2 Example

  • In our Shiny app, we can use req to cancel plotting when no country is specified
  • selectizeInput, which is used to select a country, returns NULL when no value is specified
  • Now, if we do not specify a country, the plot simply will not render
filtered <- reactive({
  req(input$countries, cancelOutput = TRUE)
  
  xvar <- input$xvar
  yvar <- input$yvar
  range <- input$range
  
  # select country
  ess <- ess[ess$country %in% input$countries, ]
  
  # select variable
  ess[c("idno", "country", xvar, yvar)]
}) %>%
  bindEvent(input$button, ignoreNULL = FALSE)
Complete code (important lines are highlighted) 
library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotOutput("plot", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess[c("idno", "country", xvar, yvar)]
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlot({
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    xvar <- names(plot_data)[[3]]
    yvar <- names(plot_data)[[4]]
    
    ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
  })
}

shinyApp(ui = ui, server = server)

6.3 One step further: Validation

  • req() is useful for simply controlling reactivity in general
  • validate() is useful for also providing a user with feedback
  • validate() is fed with need() conditions which take two arguments:
    • An expression that is tested for truthiness
    • A message that is shown to the user if the expression is not truthy
  • validate() is very bare-bones! For more sophisticated input validation, check out shinyFeedback
  • Input validation is but one of many techniques in defensive programming which is a good principle for making Shiny apps
filtered <- reactive({
  validate(
    need(input$countries, message = "At least one country must be specified.")
  )
  
  xvar <- input$xvar
  yvar <- input$yvar
  range <- input$range
  
  # select country
  ess <- ess[ess$country %in% input$countries, ]
  
  # select variable
  ess[c("idno", "country", xvar, yvar)]
}) %>%
  bindEvent(input$button, ignoreNULL = FALSE)
Complete code (important lines are highlighted) 
library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotOutput("plot", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # filter data ----
  filtered <- reactive({
    validate(
      need(input$countries, message = "At least one country must be specified.")
    )
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess[c("idno", "country", xvar, yvar)]
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlot({
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    xvar <- names(plot_data)[[3]]
    yvar <- names(plot_data)[[4]]
    
    ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
  })
}

shinyApp(ui = ui, server = server)

7 Other important concepts

  • Shiny’s reactivity is easy to learn and hard to master
  • We have started with basic concepts (inputs, outputs, reactive graphs)
  • … and ended with more advanced concepts (observers, events, updaters, truthiness)
  • Nonetheless, there is still much to be explored that reaches far beyond this workshop
  • Here we provide a non-exhaustive list of concepts, functions, and extensions that might serve useful when dealing with Shiny’s reactivity
  • Base Shiny:
    • Dynamic UI
    • Isolation
    • Freezing
      • Prevent an event from triggering until the next flush
      • freezeReactiveValue
      • We have introduced this briefly in the section about updaters
    • Reactive values
      • Values or list-likes that are able to take dependencies in reactive expressions
      • reactiveVal and reactiveValues
      • Reactive values are essentially a bare-bones version of reactive(), but for a short introduction, see chapter 15.1 of Mastering Shiny
    • Flush events
      • Execute code after / before the reactive graphs finishes / starts
      • onFlush
      • See also this blog article about execution scheduling
    • Caching
      • Temporarily store computationally intensive results to improve performance
      • bindCache
    • Data storage
      • Improve input/output of large data using local or remote databases (e.g. SQLite, Google Sheets, Dropbox, Amazon S3)
      • See this blog article
    • Scheduled invalidation
      • Invalidate reactive expressions after some time has passed
      • invalidateLater
    • Input validation
      • A more sophisticated alternative to req allowing multiple tests and more flexible conditions.
      • validate
    • Safe execution
    • Modularization
    • Testing server logics
      • Set up a mocked Shiny server to use in unit tests
      • testServer
      • Particularly useful for making a robust Shiny package
      • Advanced approaches also exist, e.g. shinytest2 or reactor
    • Javascript
      • Shiny apps can be built without ever seeing a single line of Javascript – but Javascript can still come in handy for that last mile of customization
      • See chapter 17 of Engineering Production-Grade Shiny Apps and chapter 10 of Outstanding User Interfaces with Shiny for useful primers on Javascript in Shiny
  • Shiny extensions
    • Event-based reactivity
      • gargoyle
      • Create and trigger custom events to control the reactivity flow
    • Shiny event tracking
    • Parallelization and asynchronous programming
      • shiny.worker
      • Delegate heavy computation tasks to seperate processes to keep Shiny app responsive
    • URL routing
    • Reactivity logging
      • reactlog
      • Interactively supervise reactivity a posteriori
    • Flame graphs
      • profvis
      • Interactively understand bottlenecks of a Shiny app

8 Exercises

8.1 Observers and reactives

Exercise 1.1

Imagine you need to implement the following features in a Shiny app. In principle, would you rather use a reactive or an observer (or both) for these tasks?

  1. Filtering a dataset as input for both lm() and ggplot().
  2. Reading from a database.
  3. Writing to a database.
  4. Update an input selection with new selection values.
  5. Collect the results of a linear regression done in the Shiny app.
  6. Display a password prompt and check if the credentials are correct.
  1. Filtering a dataset for two different operations is a good use case for reactive() as its output value can be cached.
  2. Reading from a file or a database is generally a task for reactive() as the data read in R must be stored. This cannot be done using observers.
  3. Writing to a database, however, should be done in an observer because the return value does not matter for writing.
  4. Updating the UI is usually done in an observer due to their eager evaluation.
  5. Results of a calculation in Shiny are often used for further operations down the line (e.g. visualization). They are thus best handled by a reactive.
  6. Ideally, passwords should stay in the R session for as short as possible. Thus they should not be handled by a reactive because reactive values are cached until the next invalidation. Additionally, proper password checks are performed using external databases which calls for observers.
Exercise 1.2

The following code contains two observers. Both observers depend on the same input (input$button), so their execution order can only be determined by their position in the code. Thus, "2nd observer" is printed before "1st observer". Study the documentation of ?observe and fix the app such "1st observer" is always printed first.

ui <- fluidPage()

server <- function(input, output, session) {
  observe({
    input$button
    print("2nd observer")
  })
  
  observe({
    input$button
    print("1st observer")
  })
}

shinyApp(ui = ui, server = server)

observe() features an argument called priority which allows you to control the execution order. A higher value indicates a higher priority. Setting priority = 1 makes the “1st observer” run before the “2nd observer” which has a default priority of 0.

ui <- fluidPage()

server <- function(input, output, session) {
  observe({
    print("2nd observer")
  })
  
  observe({
    print("1st observer")
  }, priority = 1)
}

shinyApp(ui = ui, server = server)
Exercise 1.3

Taking the Shiny app below, gradually enter letters to the text input. Observe the printed messages in your R console. Why is the code in reactive() never run but the code in observe() is? Fix the example such that the code in reactive() is executed as well.

ui <- fluidPage(
  textInput("text", "enter a text")
)

server <- function(input, output, server) {
  val <- reactive({
    print("reactive is executed")
    input$text
  })
  
  observe({
    print("observer is executed")
    input$text
  })
}

shinyApp(ui, server)

Recall one of the main differences between observe() and reactive(): Reactives are lazy, observers are eager. Eagerly evaluated code triggers every time a dependency is invalidated, lazily evaluated triggers only when it is called from outside.

The code in observe() is run because the code takes a dependency on input$text. Whenever the text input is changed, the observer is re-run. The code in reactive() also takes a dependency on input$text, but since reactives are evaluated lazily, reactive() does not changes in the input. It only executes when it is called by a reactive consumer such as observe() or a render function. To make the code in reactive() run, we can let the observer call it:

ui <- fluidPage(
  textInput("text", "enter a text")
)

server <- function(input, output, server) {
  val <- reactive({
    print("reactive is executed")
    input$text
  })
  
  observe({
    print("observer is executed")
    val()
  })
}

shinyApp(ui, server)
Exercise 1.4

Given the code below, which takes a variable and plots a histogram, print the summary of the selected variable each time a new variable is selected. How can this task be done without duplicating code?

ess <- readRDS("ess_trust.rds")

ui <- fluidPage(
  selectInput(
    "var",
    "Select a variable",
    names(ess)[startsWith(names(ess), "trust")]
  ),
  selectInput(
    "country",
    "Select a country",
    unique(ess$country)
  ),
  plotOutput("plot")
)

server <- function(input, output, session) {
  output$plot <- renderPlot({
    ess <- ess[ess$country %in% input$country, ]
    ggplot(ess) +
      aes(.data[[input$var]]) +
      geom_histogram()
  })
}

shinyApp(ui, server)

To print the summary, implement an observer that prints the summary() of the selected variable. However, because the ess object is also filtered by the selected country, we would need to copy the filtering process to the observer as well, thus duplicating code. To avoid duplicating code, we can add a reactive() that performs the country filtering. The return value can then be forwarded to both observe() and renderPlot().

ui <- fluidPage(
  selectInput(
    "var",
    "Select a variable",
    names(ess)[startsWith(names(ess), "trust")]
  ),
  selectInput(
    "country",
    "Select a country",
    unique(ess$country)
  ),
  plotOutput("plot")
)

server <- function(input, output, session) {
  ess_country <- reactive({
    ess[ess$country %in% input$country, ]
  })

  observe({
    print(summary(ess_country()[[input$var]]))
  })

  output$plot <- renderPlot({
    ggplot(ess_country()) +
      aes(.data[[input$var]]) +
      geom_histogram()
  })
}

shinyApp(ui, server)

8.2 Updates and events

Exercise 2.1

The code below implements a UI that contains checkboxes with four European regions (Central, Eastern, Southern, Northern) and an input selection for the country. Change the app such that selectizeInput() only shows those countries belonging to a region selected in checkboxGroupInput().

regions <- list(
  Central = c("AT", "BE", "CH", "DE", "NL", "PL", "CZ"),
  Eastern = c("BG", "EE", "HR", "HU", "LT", "LV", "PL", "SI", "SK"),
  Southern = c("ES", "IT", "PT", "RS", "ME"),
  Northern = c("IS", "SE", "FI", "GB", "IE", "DK")
)

ui <- fluidPage(
  checkboxGroupInput(
    "region",
    label = "Select a European region",
    choices = names(regions)
  ),
  selectizeInput(
    "country",
    label = "Select a country",
    choices = regions
  )
)

server <- function(input, output, session) {

}

shinyApp(ui, server)

The function you need to update the input selection is called updateSelectizeInput().

In the solution, I add an observer with updateSelectizeInput() that updates selectizeInput(). The updated values correspond to the countries of the selected region in the regions list.

regions <- list(
  Central = c("AT", "BE", "CH", "DE", "NL", "PL", "CZ"),
  Eastern = c("BG", "EE", "HR", "HU", "LT", "LV", "PL", "SI", "SK"),
  Southern = c("ES", "IT", "PT", "RS", "ME"),
  Northern = c("IS", "SE", "FI", "GB", "IE", "DK")
)

ui <- fluidPage(
  checkboxGroupInput(
    "region",
    label = "Select a European region",
    choices = names(regions)
  ),
  selectizeInput(
    "country",
    label = "Select a country",
    choices = regions
  )
)

server <- function(input, output, session) {
  observe({
    updateSelectizeInput(
      inputId = "country",
      choices = regions[input$region]
    )
  })
}

shinyApp(ui, server)
Exercise 2.2

Looking at the app from exercise 2.1, selectizeInput() is updated every time a European region is selected. In this case, this is probably what we expect from the app. To get a little more control of the reactivity flow, implement an action button that needs to be pressed in order for selectizeInput() to be updated.

Code from exercise 2.1 
regions <- list(
  Central = c("AT", "BE", "CH", "DE", "NL", "PL", "CZ"),
  Eastern = c("BG", "EE", "HR", "HU", "LT", "LV", "PL", "SI", "SK"),
  Southern = c("ES", "IT", "PT", "RS", "ME"),
  Northern = c("IS", "SE", "FI", "GB", "IE", "DK")
)

ui <- fluidPage(
  checkboxGroupInput(
    "region",
    label = "Select a European region",
    choices = names(regions)
  ),
  selectizeInput(
    "country",
    label = "Select a country",
    choices = regions
  )
)

server <- function(input, output, session) {
  observe({
    updateSelectizeInput(
      inputId = "country",
      choices = regions[input$region]
    )
  })
}

shinyApp(ui, server)

In the solution, I add an observer with updateSelectizeInput() that updates selectizeInput(). The updated values correspond to the countries of the selected region in the regions list.

regions <- list(
  Central = c("AT", "BE", "CH", "DE", "NL", "PL", "CZ"),
  Eastern = c("BG", "EE", "HR", "HU", "LT", "LV", "PL", "SI", "SK"),
  Southern = c("ES", "IT", "PT", "RS", "ME"),
  Northern = c("IS", "SE", "FI", "GB", "IE", "DK")
)

ui <- fluidPage(
  checkboxGroupInput(
    "region",
    label = "Select a European region",
    choices = names(regions)
  ),
  selectizeInput(
    "country",
    label = "Select a country",
    choices = regions
  ),
  actionButton(
    "button",
    label = "Update",
    icon = icon("refresh")
  )
)

server <- function(input, output, session) {
  observe({
    updateSelectizeInput(
      inputId = "country",
      choices = regions[input$region]
    )
  }) %>%
    bindEvent(input$button)
}

shinyApp(ui, server)
Exercise 2.3

The (admittedly quite useless) Shiny app below implements two buttons, each of which adds 1 to either tab A or tab B. Right now, to see the result in either tab, you would need to manually click on the tabs. Change the app such that changing button A or B automatically opens the corresponding tab.

ui <- fluidPage(
  sidebarLayout(
    id = "tabset_panel",
    sidebarPanel(
      actionButton("button_a", "Add to A"),
      br(),
      actionButton("button_b", "Add to B")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel(
          title = "Tab A",
          verbatimTextOutput("tab_a")
        ),
        tabPanel(
          title = "Tab B",
          verbatimTextOutput("tab_b")
        )
      )
    )
  )
)

server <- function(input, output, session) {
  output$tab_a <- renderPrint(as.vector(input$button_a))
  output$tab_b <- renderPrint(as.vector(input$button_b))
}

shinyApp(ui, server)

The function that you need to update a tabset panel is called updateTabsetPanel(). It requires the ID assigned to tabsetPanel().

While there are technically many ways to solve this task, the most obvious one at this point requires two observers. If you want to implement the solution using only a single observer, consider using super assignment (see ?"<<-" or here).

In the server function, I add two observers. The first only triggers when tab_a is pressed, the second one when tab_b is pressed. Within each observer, the tabset panel is updated using updateTabsetPanel(). inputId takes "tabset_panel", the ID assigned to tabsetPanel() in the UI. selected takes the label of the tab that should be selected.

It is also possible to implement a solution with only a single observer, but this is much trickier. The code chunk below implements such a solution using the super assignment operator <<-. Since reactive expressions are technically functions, you can use <<- to conveniently store non-reactive values in the session.

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      actionButton("button_a", "Add to A"),
      br(),
      actionButton("button_b", "Add to B")
    ),
    mainPanel(
      tabsetPanel(
        id = "tabset_panel",
        tabPanel(
          title = "Tab A",
          verbatimTextOutput("tab_a")
        ),
        tabPanel(
          title = "Tab B",
          verbatimTextOutput("tab_b")
        )
      )
    )
  )
)

server <- function(input, output, session) {
  output$tab_a <- renderPrint(as.vector(input$button_a))
  output$tab_b <- renderPrint(as.vector(input$button_b))
  
  observe({
    updateTabsetPanel(inputId = "tabset_panel", selected = "Tab A")
  }) %>%
    bindEvent(input$button_a)
  
  observe({
    updateTabsetPanel(inputId = "tabset_panel", selected = "Tab B")
  }) %>%
    bindEvent(input$button_b)
}

shinyApp(ui, server)
Alternative solution 
ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      actionButton("button_a", "Add to A"),
      br(),
      actionButton("button_b", "Add to B")
    ),
    mainPanel(
      tabsetPanel(
        id = "tabset_panel",
        tabPanel(
          title = "Tab A",
          verbatimTextOutput("tab_a")
        ),
        tabPanel(
          title = "Tab B",
          verbatimTextOutput("tab_b")
        )
      )
    )
  )
)

server <- function(input, output, session) {
  output$tab_a <- renderPrint(as.vector(input$button_a))
  output$tab_b <- renderPrint(as.vector(input$button_b))
  
  last_a <- 0
  last_b <- 0
  observe({
    button_a <- input$button_a
    button_b <- input$button_b
    if (button_a != last_a) {
      last_a <<- button_a
      sel <- "Tab A"
    } else if (button_b != last_b) {
      last_b <<- button_b
      sel <- "Tab B"
    } else {
      return()
    }
    
    updateTabsetPanel(inputId = "tabset_panel", selected = sel)
  })
}

shinyApp(ui, server)

8.3 Truthiness and validation

Exercise 3.1

The Shiny app below implements three features:

  • A numeric input that lets you select a number to compute the natural logarithm of
  • A file input that lets you read and print an R object from a file
  • An input selection that shows you an emoji depending on the selected value

At its current state, the app does not go out of its way to check the input for correctness. What problems could this cause in the usage of the app? How can these problems be prevented? Implement an input validation that catches potential problems before they occur and gives appropriate feedback to the user.

ui <- fluidPage(
  fluidRow(
    column(
      4,
      numericInput(
        "number",
        label = "Select a number to compute the natural log of",
        value = 3
      )
    ),
    column(
      4,
      verbatimTextOutput("number_result")
    )
  ),
  
  fluidRow(
    column(
      4,
      fileInput(
        "file",
        label = "Select an RDS file"
      )
    ),
    column(
      4,
      verbatimTextOutput("file_result")
    )
  ),
  
  fluidRow(
    column(
      4,
      selectInput(
        "animal",
        label = "Select an animal",
        choices = c("dog", "cat", "mouse"),
        selected = "mouse",
        multiple = TRUE
      )
    ),
    column(
      4,
      htmlOutput("animal_result")
    )
  )
)

server <- function(input, output, session) {
  output$number_result <- renderPrint({
    log(input$number)
  })
  
  output$file_result <- renderPrint({
    readRDS(input$file)
  })
  
  output$animal_result <- renderUI({
    url <- switch(
      input$animal,
      dog = "https://images.emojiterra.com/google/noto-emoji/unicode-15.1/color/svg/1f415.svg",
      cat = "https://images.emojiterra.com/google/noto-emoji/unicode-15.1/color/svg/1f408.svg",
      mouse = "https://images.emojiterra.com/google/noto-emoji/unicode-15.1/color/svg/1f401.svg"
    )
    img(src = url, width = "30%")
  })
}

shinyApp(ui, server)

Experiment with the app to find out ways the app could fail or produce an undesirable result. An undesirable result can be an error, but it can also be an unexpected value like NA.

The validate() function can take an arbitrary amount of need()s to check for multiple conditions.

If one condition needs to be checked before the other conditions, you can wrap it in a separate call to validate():

validate(need(TRUE, "Necessary first condition"))

validate(
  need(TRUE, "all"),
  need(TRUE, "the"),
  need(TRUE, "other"),
  need(TRUE, "conditions")
)

One problem with the app can be observed directly upon starting the app: The default value of input$file (which is NULL) cannot be read by readRDS(): Shiny issues an error. Similar behavior can be seen when selecting a non-natural number of when selecting multiple animals.

A possible solution to this problem is to use validate() to check the input before processing it. The following code chunk implements several checks:

  • For numericInput(), it checks whether the selected number is larger than 0.
  • For fileInput(), it first checks whether the file is NULL. If not, it proceeds to check if the file exists and if it ends on .rds.
  • For selectInput(), it checks whether at least one, but not two or more animals are selected.
Alternative solution 
ui <- fluidPage(
  fluidRow(
    column(
      4,
      numericInput(
        "number",
        label = "Select a number to compute the natural log of",
        value = 3
      )
    ),
    column(
      4,
      verbatimTextOutput("number_result")
    )
  ),
  
  fluidRow(
    column(
      4,
      fileInput(
        "file",
        label = "Select an RDS file"
      )
    ),
    column(
      4,
      verbatimTextOutput("file_result")
    )
  ),
  
  fluidRow(
    column(
      4,
      selectInput(
        "animal",
        label = "Select an animal",
        choices = c("dog", "cat", "mouse"),
        selected = "mouse",
        multiple = TRUE
      )
    ),
    column(
      4,
      htmlOutput("animal_result")
    )
  )
)

server <- function(input, output, session) {
  output$number_result <- renderPrint({
    number <- input$number
    validate(
      need(number > 0, "Input must be a natural number.")
    )
    
    log(number)
  })
  
  output$file_result <- renderPrint({
    file <- input$file$datapath
    validate(need(!is.null(file), "Please select an RDS file"))
    validate(
      need(file.exists(file), "Input file must exist"),
      need(grepl("\\.rds$", file), "Input file must be .rds")
    )
    
    readRDS(file)
  })
  
  output$animal_result <- renderUI({
    animal <- input$animal
    validate(
      need(length(animal) > 0, "Please select an animal."),
      need(length(animal) < 2, "Please select a maximum of one animal.")
    )
    
    url <- switch(
      animal,
      dog = "https://images.emojiterra.com/google/noto-emoji/unicode-15.1/color/svg/1f415.svg",
      cat = "https://images.emojiterra.com/google/noto-emoji/unicode-15.1/color/svg/1f408.svg",
      mouse = "https://images.emojiterra.com/google/noto-emoji/unicode-15.1/color/svg/1f401.svg"
    )
    img(src = url, width = "30%")
  })
}

shinyApp(ui, server)