Interactive reporting with Shiny (II)

Lecture 21

Dr. Benjamin Soltoff

Cornell University
INFO 3312/5312 - Spring 2024

April 16, 2024

Announcements

Announcements

• Homework 06

Review: Climate risk app UI

---
title: National Risk Index Counties
format: dashboard
server: shiny
---

```{r}
#| label: setup
#| context: setup
#| include: false

# load libraries
library(tidyverse)
library(scales)
library(shiny)
library(sf)
library(tigris)
library(janitor)
library(ggthemes)
library(colorspace)
library(bslib)
library(bsicons)
library(gt)

options(tigris_use_cache = TRUE)
```

```{r}
#| label: import-data
#| context: data
#| include: false

# climate risk
climate_risk <- read_csv(file = "data/National_Risk_Index_Counties_807384124455672111.csv") |>
  # clean column names
  clean_names() |>
  # generate county label character strings
  mutate(
    county = str_glue("{county_name} {county_type}, {state_name}")
  ) |>
  # select relevant variables
  select(
    state_county_fips_code, county,
    population_2020, building_value, agriculture_value, area_sq_mi,
    national_risk_index_score_composite, national_risk_index_rating_composite,
    expected_annual_loss_score_composite, expected_annual_loss_rating_composite,
    social_vulnerability_score, social_vulnerability_rating,
    community_resilience_score, community_resilience_rating,
    contains("type_risk_index_score")
  ) |>
  # format rating colums
  mutate(
    across(
      .cols = contains("rating"),
      .fns = \(col) fct_relevel(
        .f = col, "Very High", "Relatively High",
        "Relatively Moderate", "Relatively Low", "Very Low"
      )
    )
  ) |>
  # rename overall ratings columns for variable selection
  rename_with(
    .cols = c(contains("rating"), -contains("hazard")),
    .fn = \(col) str_remove(string = col, pattern = "_rating_composite|_rating") |>
      make_clean_names(case = "title")
  )

# import state and county boundaries
state_sf <- states(cb = TRUE, keep_zipped_shapefile = TRUE) |>
  filter(STUSPS %in% state.abb) |>
  shift_geometry()

county_sf <- counties(cb = TRUE, keep_zipped_shapefile = TRUE) |>
  filter(STUSPS %in% state.abb) |>
  shift_geometry()

# 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()
```

# National Risk Index

## {.sidebar}

```{r}
#| label: select-national-risk

# 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`)
)
```

## Column

```{r}
#| label: national-map

plotOutput(outputId = "national_map")
```

# County Details

## {.sidebar}

```{r}
#| label: select-county

# extract county/state labels as character vector
county_names <- climate_sf |>
  arrange(STATEFP) |>
  pull(county)

# select specific county
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
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

# select specific hazards
checkboxGroupInput(
  inputId = "hazard_types",
  label = "Hazard types",
  # all possible choices
  choices = hazard_types,
  # initialize plot with all individual hazards
  selected = hazard_types
)
```

## Column

### Row

```{r}
#| label: county-map

plotOutput(outputId = "county_map")
```

```{r}
#| label: county-hazards

plotOutput(outputId = "county_hazards")
```

### Row

```{r}
#| label: county-risk

value_box(
  title = "Overall risk score",
  value = textOutput("county_risk"),
  showcase = bs_icon("radioactive")
)
```

```{r}
#| label: county-expected-loss

value_box(
  title = "Expected annual loss",
  value = textOutput("county_loss"),
  showcase = bs_icon("trash")
)
```

```{r}
#| label: county-social-vulnerability

value_box(
  title = "Social vulnerability",
  value = textOutput("county_vulnerability"),
  showcase = bs_icon("cone-striped")
)
```

```{r}
#| label: county-community-resilience

value_box(
  title = "Community resilience",
  value = textOutput("county_resilience"),
  showcase = bs_icon("emoji-sunglasses")
)
```

# Data

```{r}
#| label: print-data
#| context: data

# print interactive table of all data
climate_risk |>
  gt() |>
  opt_interactive()
```

```{r}
#| label: server
#| context: server

# add code here
```

Remaining TODOs

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

Inputs: national map

```{r}
#| label: select-national-risk

# 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`)
)
```

Inputs: county details

```{r}
#| label: select-county

# extract county/state labels as character vector
county_names <- climate_sf |>
  arrange(STATEFP) |>
  pull(county)

# select specific county
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
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

# select specific hazards
checkboxGroupInput(
  inputId = "hazard_types",
  label = "Hazard types",
  # all possible choices
  choices = hazard_types,
  # initialize plot with all individual hazards
  selected = hazard_types
)
```

Remaining TODOs

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

Code chunk context

```{r}
#| label: setup
#| context: setup
```

```{r}
#| label: import-data
#| context: data
```

```{r}
#| label: print-data
#| context: data
```

```{r}
#| label: server
#| context: server
```

Remaining TODOs

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

Implementing reactivity

Server: assemble input into outputs

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

```{r}
#| context: server

output$distPlot <- renderPlot({
  x <- faithful[, 2]  # Old Faithful Geyser data
  bins <- seq(min(x), max(x), length.out = input$bins + 1)
  hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
```

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

Server: assemble input into outputs

#| standalone: true
#| viewerHeight: 600

library(shiny)

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

# Define your Shiny server logic here
server <- function(input, output, session) {
  # Your server code goes here
  output$distPlot <- renderPlot({
  x <- faithful[, 2]  # Old Faithful Geyser data
  bins <- seq(min(x), max(x), length.out = input$bins + 1)
  hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}

# 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({
  x <- faithful[, 2]  # Old Faithful Geyser data
  bins <- seq(min(x), max(x), length.out = input$bins + 1)
  hist(x, breaks = bins, col = 'darkgray', border = 'white')
})

Server: assemble input into outputs

output$distPlot <- renderPlot({
  x <- faithful[, 2] # Old Faithful Geyser data
  bins <- seq(min(x), max(x), length.out = input$bins + 1)
  hist(x, breaks = bins, col = "darkgray", border = "white")
})

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({
  x <- faithful[, 2] # Old Faithful Geyser data
  bins <- seq(min(x), max(x), length.out = input$bins + 1)
  hist(x, breaks = bins, col = "darkgray", border = "white")
})

• 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

```{r}
#| context: server

x <- input$num + 1
```

```{r}
#| context: server

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

Access variable

```{r}
#| context: server

print(input$num)
```

```{r}
#| context: server

observe({
  print(input$num)
})
```

Simple Shiny app using basic reactivity

---
title: "Simulate a normal distribution"
format: dashboard
server: shiny
---

```{r}
#| context: setup
#| include: false

library(tidyverse)
library(shiny)
```

# {.sidebar}

```{r}
sliderInput(
  inputId = "num",
  label = "Choose a sample size", 
  min = 0,
  max = 1000,
  value = 200
)
```

# Plot

```{r}
plotOutput(outputId = "myplot")
```

```{r}
#| context: server

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}"))
})
```

Create UI elements dynamically

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

Basic example of uiOutput()

---
title: "Simulate a probability distribution"
format: dashboard
server: shiny
---

```{r}
#| context: setup
#| include: false

library(tidyverse)
library(shiny)
```

# {.sidebar}

```{r}
# choose a type of distribution
selectInput(
  inputId = "type",
  label = "Probability distribution",
  choices = c("Normal", "Uniform"),
  selected = "Normal"
)

uiOutput(outputId = "dist_prop")
```

# Plot

```{r}
plotOutput(outputId = "myplot")
```

```{r}
#| context: server

set.seed(123)

output$dist_prop <- renderUI({
  # for normal distribution, choose mean
  # for uniform distribution, choose range
  if (input$type == "Normal") {
    numericInput(
      inputId = "mean",
      label = "Mean of the distribution",
      value = 0,
      min = -Inf,
      max = Inf
    )
  } else if (input$type == "Uniform") {
    sliderInput(
      inputId = "range",
      label = "Range of the distribution",
      min = 0,
      max = 100,
      value = c(0, 100)
    )
  }
})

# simulate the data
df <- reactive({
  if (input$type == "Normal") {
    tibble(
      x = rnorm(n = 1000, mean = input$mean)
    )
  } else if (input$type == "Uniform") {
    tibble(
      x = runif(n = 1000, min = input$range[[1]], max = input$range[[2]])
    )
  }
})

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

Application exercise

Developed climate risk app

• Quarto + Shiny dashboard

ae-18

• Go to the course GitHub org and find your ae-18 (repo name will be suffixed with your GitHub name).
• Clone the repo in RStudio Workbench, open the Quarto document in the repo, and follow along and complete the exercises.

Publishing Shiny applications

Share your app: shinyapps.io

• Go to http://www.shinyapps.io/ and make an account
• Make sure all your app files are in an isolated folder
• Click “Publish Application” in RStudio
  • You might be asked to install a couple packages
  • Follow instructions from RStudio

Additional documentation

• Quarto - Running Documents
• ShinyApps.io user guide

Wrap-up

Wrap-up

• 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