Interactive reporting with Shiny (II)

Lecture 24

Dr. Benjamin Soltoff

Cornell University
INFO 3312/5312 - Spring 2025

April 24, 2025

Announcements

Announcements

• Homework 07
• Project draft

Review: Climate risk app UI

library(tidyverse)
library(scales)
library(shiny)
library(sf)
library(janitor)
library(ggthemes)
library(colorspace)
library(bslib)
library(bsicons)
library(gt)

# Import data ----------------------------------------------------------------
# climate risk
climate_risk <- read_rds(file = "data/climate-risk.rds")

# import state and county boundaries
state_sf <- st_read(dsn = "data/states.geojson")
county_sf <- st_read(dsn = "data/counties.geojson")

# combine climate risk with county_sf
climate_sf <- left_join(
  x = county_sf,
  y = climate_risk,
  by = join_by(GEOID == state_county_fips_code)
) |>
  as_tibble() |>
  st_as_sf()

# get county names
county_names <- climate_sf |>
  arrange(STATEFP) |>
  pull(county)

# define hazard types
hazard_types <- climate_risk |>
  select(contains("hazard")) |>
  colnames()

# create human-readable labels
hazard_types_labels <- hazard_types |>
  str_remove(pattern = "_hazard_type_risk_index_score") |>
  make_clean_names(case = "title")

# create a named character vector for the input
names(hazard_types) <- hazard_types_labels

# Define UI -----------------------------------------------------------------
ui <- page_navbar(
  title = "National Risk Index Counties",
  theme = bs_theme(version = 5, preset = "minty"),

  # National Risk Index page
  nav_panel(
    title = "National Risk Index",
    layout_sidebar(
      sidebar = sidebar(
        # select between the four risk ratings
        varSelectInput(
          inputId = "risk_var",
          label = "Risk index",
          # select specific columns of data to populate select options
          data = climate_risk |>
            select(`National Risk Index`, `Expected Annual Loss`, `Social Vulnerability`, `Community Resilience`)
        )
      ),
      # Main content
      card(
        card_header("National Risk Map"),
        plotOutput(outputId = "national_map")
      )
    )
  ),

  # County Details page
  nav_panel(
    title = "County Details",
    layout_sidebar(
      sidebar = sidebar(
        # extract county/state labels as character vector
        selectizeInput(
          inputId = "county",
          label = "Selected county",
          choices = county_names,
          selected = NULL,
          # custom selectize.js options
          options = list(
            # placeholder text
            placeholder = "Select a county",
            # limit to one county at a time
            maxItems = 1
          )
        ),

        # identify columns with hazard risks and extract column names
        checkboxGroupInput(
          inputId = "hazard_types",
          label = "Hazard types",
          # all possible choices
          choices = hazard_types,
          # initialize plot with all individual hazards
          selected = hazard_types
        )
      ),
      # Main content
      layout_column_wrap(
        width = "400px", # This width makes two columns when screen is > 800px, one column when narrower
        style = htmltools::css(gap = "10px", margin_bottom = "10px"),
        # Row 1 - Maps side by side on wider screens
        card(
          card_header("County Map"),
          plotOutput(outputId = "county_map")
        ),
        card(
          card_header("County Hazards"),
          plotOutput(outputId = "county_hazards")
        )
      ),
      layout_column_wrap(
        width = 1/4,
        height = "auto",
        style = htmltools::css(gap = "10px"),
        # Row 2 - Value boxes
        value_box(
          title = "Overall risk score",
          value = textOutput("county_risk"),
          showcase = bs_icon("radioactive")
        ),
        value_box(
          title = "Expected annual loss",
          value = textOutput("county_loss"),
          showcase = bs_icon("trash")
        ),
        value_box(
          title = "Social vulnerability",
          value = textOutput("county_vulnerability"),
          showcase = bs_icon("cone-striped")
        ),
        value_box(
          title = "Community resilience",
          value = textOutput("county_resilience"),
          showcase = bs_icon("emoji-sunglasses")
        )
      )
    )
  ),

  # Data page
  nav_panel(
    title = "Data",
    card(
      card_header("National Risk Index Data"),
      climate_risk |>
        gt() |>
        opt_interactive()
    )
  )
)

# Server function for the National Risk Index Counties Shiny app
server <- function(input, output) {}

# Run the app
shinyApp(ui = ui, server = server)

Remaining TODOs

• Define the inputs
  • Dropdown for hazard type
  • Dropdown for county
  • Checkboxes for overall risk measures

Dropdown for hazard type

# select between the four risk ratings
varSelectInput(
  inputId = "risk_var",
  label = "Risk index",
  # select specific columns of data to populate select options
  data = climate_risk |>
    select(
      `National Risk Index`, `Expected Annual Loss`,
      `Social Vulnerability`, `Community Resilience`
    )
)

Dropdown for county

# get county names
county_names <- climate_sf |>
  arrange(STATEFP) |>
  pull(county)

# extract county/state labels as character vector
selectizeInput(
  inputId = "county",
  label = "Selected county",
  choices = county_names,
  selected = NULL,
  # custom selectize.js options
  options = list(
    # placeholder text
    placeholder = "Select a county",
    # limit to one county at a time
    maxItems = 1
  )
)

Checkboxes for overall risk measures

# define hazard types
hazard_types <- climate_risk |>
  select(contains("hazard")) |>
  colnames()

# create human-readable labels
hazard_types_labels <- hazard_types |>
  str_remove(pattern = "_hazard_type_risk_index_score") |>
  make_clean_names(case = "title")

# create a named character vector for the input
names(hazard_types) <- hazard_types_labels

# identify columns with hazard risks and extract column names
checkboxGroupInput(
  inputId = "hazard_types",
  label = "Hazard types",
  # all possible choices
  choices = hazard_types,
  # initialize plot with all individual hazards
  selected = hazard_types
)

Implementing reactivity

Server: assemble input into outputs

sliderInput("bins", "Number of bins:",
  min = 1, max = 50, value = 30
)
plotOutput("distPlot")

output$distPlot <- renderPlot({
  ggplot(data = penguins, mapping = aes(x = body_mass_g)) +
    geom_histogram(bins = inputs$bins)
})

1. Save objects into output$
2. Build objects with render*()

Server: assemble input into outputs

#| standalone: true
#| viewerHeight: 700
library(shiny)
library(bslib)
library(ggplot2)
library(palmerpenguins)

# Define your Shiny UI here
ui <- page_sidebar(
  sidebar = sidebar(
    sliderInput("bins", "Number of bins:",
      min = 1, max = 50, value = 30
    )
  ),
  plotOutput("distPlot")
)

# Define your Shiny server logic here
server <- function(input, output) {
  # Your server code goes here
  output$distPlot <- renderPlot({
    ggplot(data = penguins, mapping = aes(x = body_mass_g)) +
      geom_histogram(bins = input$bins)
  })
}

# Create and launch the Shiny app
shinyApp(ui, server)

*Output() \(\rightarrow\) render*()

Output function	Render function
plotOutput()	renderPlot({})
tableOutput()	renderTable({})
uiOutput()	renderUI({})
textOutput()	renderText({})

render*() functions

renderPlot({
  ggplot(data = penguins, mapping = aes(x = body_mass_g)) +
    geom_histogram(bins = input$bins)
})

Server: assemble input into outputs

output$distPlot <- renderPlot({
  ggplot(data = penguins, mapping = aes(x = body_mass_g)) +
    geom_histogram(bins = input$bins)
})

1. Save objects into output$
2. Build objects with render*()
3. Access input values with input$

Reactivity

• Shiny uses reactive programming
• Reactive variables
  • When value of variable x changes, anything that relies on x is re-evaluated
  • Contrast with regular R

x <- 5
y <- x + 1
y

[1] 6

x <- 10
y

[1] 6

Reactivity

• input$bins is a reactive value

output$distPlot <- renderPlot({
  ggplot(data = penguins, mapping = aes(x = body_mass_g)) +
    geom_histogram(bins = input$bins)
})

• output$distPlot depends on input$bins
  • input$bins changes \(\rightarrow\) output$distPlot reacts
• All inputs are automatically reactive, so if you use any input inside a render* function, the output will re-render any time input changes

Reactive contexts

• You can define your own reactive variables
• Reactive values can only be used inside reactive contexts
• Any render* function is a reactive context
• Use reactive({...}) to assign a reactive variable
• Use observe({...}) to access a reactive variable
• Remember: reactive variable means anything that depends on it gets re-executed automatically

Reactive contexts

Assign variable

x <- input$num + 1

x <- reactive({
  input$num + 1
})

Access variable

print(input$num)

observe({
  print(input$num)
})

Simple Shiny app using basic reactivity

library(shiny)
library(dplyr)
library(ggplot2)
library(bslib)

ui <- page_sidebar(
  title = "Simulate a normal distribution",
  sidebar = sidebar(
    sliderInput(
      inputId = "num",
      label = "Choose a sample size",
      min = 0,
      max = 1000,
      value = 200
    )
  ),
  card(
    card_header("Plot"),
    plotOutput(outputId = "myplot")
  )
)

server <- function(input, output, session) {
  set.seed(123)

  # simulate the data
  df <- reactive({
    tibble(
      x = rnorm(n = input$num)
    )
  })

  # visualize the distribution
  output$myplot <- renderPlot({
    ggplot(data = df(), mapping = aes(x = x)) +
      geom_histogram() +
      theme_bw(base_size = 14)
  })

  # print a message to the console logs
  observe({
    message(str_glue("Current number of observations: {input$num}"))
  })
}

shinyApp(ui, server)

Create UI elements dynamically

• uiOutput()
• Changing input values based on other inputs

library(shiny)
library(bslib)

ui <- page_fluid(
  checkboxInput("show_slider", label = "Show slider", value = TRUE),
  uiOutput("slider_ui")
)

server <- function(input, output) {
  output$slider_ui <- renderUI({
    if (input$show_slider) {
      sliderInput("slider", "Slider", 1, 10, 5)
    }
  })
}

shinyApp(ui = ui, server = server)

#| label: checkbox-slider
#| standalone: true
#| viewerHeight: 475

library(shiny)
library(bslib)

ui <- page_fluid(
  checkboxInput("show_slider", label = "Show slider", value = TRUE),
  uiOutput("slider_ui") 
)

server <- function(input, output) {
  output$slider_ui <- renderUI({ 
    if (input$show_slider) { 
      sliderInput("slider", "Slider", 1, 10, 5) 
    } 
  }) 
}

shinyApp(ui = ui, server = server)

Application exercise

ae-23

Instructions

• Go to the course GitHub org and find your ae-23 (repo name will be suffixed with your GitHub name).
• Clone the repo in RStudio, run renv::restore() to install the required packages, open the Quarto document in the repo, and follow along and complete the exercises.
• Render, commit, and push your edits by the AE deadline – end of the day

Build a Shiny app for the NRI

Instructions

Implement server logic for reactive content

Deploying Shiny applications

Hosting Shiny apps on a server

• Shinyapps.io
• Posit Connect Cloud
• shinylive for server-less deployment
• Deploy as a mobile app

Extending Shiny apps

• Quarto + Shiny
• Shiny for Python
• Implement custom CSS
• Build generative AI powered Shiny apps using {shinychat} or ui.Chat

Wrap-up

Recap

• Use reactivity to build interactive Shiny apps
• User-viewable content always stored in the output list object
• Console logging is extremely useful for troubleshooting apps
• Validate inputs to ensure they are correct and avoid user-facing error messages