Chapter 5 Case Study: ER Injuries
Exercise 5.8.1
Draw the reactive graph for each app.
Solution
Prototype
The prototype application has a single input, input$code
, which is used to
generate the selected()
reactive. This reactive is used directly in 3
outputs, output$diag
, output$body_part
, and output$location
, and it is
also used indirectly in the output$age_sex
plot via the summary()
reactive.

Rate vs. Count
Building on the prototype, we create a second input input$y
which is used
along with the summary()
reactive to create the output$age_sex
plot.

Narrative
Building on the application once more, we create an output$narrative
that
depends on the selected()
reactive and a new input, input$story
.

Exercise 5.8.2
What happens if you flip fct_infreq()
and fct_lump()
in the code that
reduces the summary tables?
Solution
As in the book, we will use the datasets injuries
, products
, and
population
appearing here:
https://github.com/hadley/mastering-shiny/blob/master/neiss/data.R.
Flipping the order of fct_infreq()
and fct_lump()
will only change the
factor levels order. In particular, the function fct_infreq()
orders the
factor levels by frequency, and the function fct_lump()
also orders the
factor levels by frequency but it will only keep the top n
factors and label
the rest as Other
.
Let us look at the top five levels in terms of count within the diag
column
in the injuries
dataset:
## # A tibble: 5 x 2
## # Groups: diag [5]
## diag n
## <chr> <int>
## 1 Other Or Not Stated 44937
## 2 Fracture 43093
## 3 Laceration 39230
## 4 Strain, Sprain 37002
## 5 Contusion Or Abrasion 35259
If we apply fct_infreq()
first, then it will reorder the factor levels in
descending order as seen in the previous output. If afterwards we apply
fct_lump()
, then it will lump together everything after the nth most commonly
seen level.
## [1] "Other Or Not Stated" "Fracture" "Laceration"
## [4] "Strain, Sprain" "Contusion Or Abrasion" "Other"
Conversely, if we apply fct_lump()
first, then it will label the most
frequently seen factor level as “Other”. If afterwards we apply fct_infreq()
,
then it will label the first level as “Other” and not as “Other Or Not Stated”,
which was the case for the previous code.
## [1] "Other" "Other Or Not Stated" "Fracture"
## [4] "Laceration" "Strain, Sprain" "Contusion Or Abrasion"
Exercise 5.8.3
Add an input control that lets the user decide how many rows to show in the summary tables.
Solution
Our function count_top
is responsible for grouping our variables into a set
number of factors, lumping the rest of the values into “Other”. The function
has an argument n
which is set to 5
. By creating a numericInput
called
rows
we can let the user set the number of fct_infreq
dynamically. However,
because fct_infreq
is the number of factors + Other
, we need to subtract 1
from what the user selects in order to display the number of rows they input.
library(shiny)
library(forcats)
library(dplyr)
library(ggplot2)
# Note: these exercises use the datasets `injuries`, `products`, and
# `population` as created here:
# https://github.com/hadley/mastering-shiny/blob/master/neiss/data.R
count_top <- function(df, var, n = 5) {
df %>%
mutate({{ var }} := fct_lump(fct_infreq({{ var }}), n = n)) %>%
group_by({{ var }}) %>%
summarise(n = as.integer(sum(weight)))
}
ui <- fluidPage(
fluidRow(
column(8, selectInput("code", "Product",
choices = setNames(products$prod_code, products$title),
width = "100%")
),
column(2, numericInput("rows", "Number of Rows",
min = 1, max = 10, value = 5)),
column(2, selectInput("y", "Y Axis", c("rate", "count")))
),
fluidRow(
column(4, tableOutput("diag")),
column(4, tableOutput("body_part")),
column(4, tableOutput("location"))
),
fluidRow(
column(12, plotOutput("age_sex"))
),
fluidRow(
column(2, actionButton("story", "Tell me a story")),
column(10, textOutput("narrative"))
)
)
server <- function(input, output, session) {
selected <- reactive(injuries %>% filter(prod_code == input$code))
# Find the maximum possible of rows.
max_no_rows <- reactive(
max(length(unique(selected()$diag)),
length(unique(selected()$body_part)),
length(unique(selected()$location)))
)
# Update the maximum value for the numericInput based on max_no_rows().
observeEvent(input$code, {
updateNumericInput(session, "rows", max = max_no_rows())
})
table_rows <- reactive(input$rows - 1)
output$diag <- renderTable(
count_top(selected(), diag, n = table_rows()), width = "100%")
output$body_part <- renderTable(
count_top(selected(), body_part, n = table_rows()), width = "100%")
output$location <- renderTable(
count_top(selected(), location, n = table_rows()), width = "100%")
summary <- reactive({
selected() %>%
count(age, sex, wt = weight) %>%
left_join(population, by = c("age", "sex")) %>%
mutate(rate = n / population * 1e4)
})
output$age_sex <- renderPlot({
if (input$y == "count") {
summary() %>%
ggplot(aes(age, n, colour = sex)) +
geom_line() +
labs(y = "Estimated number of injuries") +
theme_grey(15)
} else {
summary() %>%
ggplot(aes(age, rate, colour = sex)) +
geom_line(na.rm = TRUE) +
labs(y = "Injuries per 10,000 people") +
theme_grey(15)
}
})
output$narrative <- renderText({
input$story
selected() %>% pull(narrative) %>% sample(1)
})
}
shinyApp(ui, server)
Exercise 5.8.4
Provide a way to step through every narrative systematically with forward and backward buttons.
Advanced: Make the list of narratives “circular” so that advancing forward from the last narrative takes you to the first.
Solution
We can add two buttons prev_story
and next_story
to iterate through the
narrative. In addition, we can include a reactive value, story
, that keeps
track of the current position in the narrative. When the button prev_story
is
pressed, story
decreases by one. Similarly, when the button next_story
is
pressed, story
increases by one.
To do the advanced part, we use the mod function. This allows us to keep
story
between 1 and the current narrative’s length, and simulate the “circular” motion.
library(shiny)
library(forcats)
library(dplyr)
library(ggplot2)
# Note: these exercises use the datasets `injuries`, `products`, and
# `population` as created here:
# https://github.com/hadley/mastering-shiny/blob/master/neiss/data.R
count_top <- function(df, var, n = 5) {
df %>%
mutate({{ var }} := fct_lump(fct_infreq({{ var }}), n = n)) %>%
group_by({{ var }}) %>%
summarise(n = as.integer(sum(weight)))
}
ui <- fluidPage(
fluidRow(
column(8, selectInput("code", "Product",
choices = setNames(products$prod_code, products$title),
width = "100%")
),
column(2, numericInput("rows", "Number of Rows",
min = 1, max = 10, value = 5)),
column(2, selectInput("y", "Y Axis", c("rate", "count")))
),
fluidRow(
column(4, tableOutput("diag")),
column(4, tableOutput("body_part")),
column(4, tableOutput("location"))
),
fluidRow(
column(12, plotOutput("age_sex"))
),
fluidRow(
column(2, actionButton("prev_story", "Previous story")),
column(2, actionButton("next_story", "Next story")),
column(8, textOutput("narrative"))
)
)
server <- function(input, output, session) {
selected <- reactive(injuries %>% filter(prod_code == input$code))
# Find the maximum possible of rows.
max_no_rows <- reactive(
max(length(unique(selected()$diag)),
length(unique(selected()$body_part)),
length(unique(selected()$location)))
)
# Update the maximum value for the numericInput based on max_no_rows().
observeEvent(input$code, {
updateNumericInput(session, "rows", max = max_no_rows())
})
table_rows <- reactive(input$rows - 1)
output$diag <- renderTable(
count_top(selected(), diag, n = table_rows()), width = "100%")
output$body_part <- renderTable(
count_top(selected(), body_part, n = table_rows()), width = "100%")
output$location <- renderTable(
count_top(selected(), location, n = table_rows()), width = "100%")
summary <- reactive({
selected() %>%
count(age, sex, wt = weight) %>%
left_join(population, by = c("age", "sex")) %>%
mutate(rate = n / population * 1e4)
})
output$age_sex <- renderPlot({
if (input$y == "count") {
summary() %>%
ggplot(aes(age, n, colour = sex)) +
geom_line() +
labs(y = "Estimated number of injuries") +
theme_grey(15)
} else {
summary() %>%
ggplot(aes(age, rate, colour = sex)) +
geom_line(na.rm = TRUE) +
labs(y = "Injuries per 10,000 people") +
theme_grey(15)
}
})
# Store the maximum posible number of stories.
max_no_stories <- reactive(length(selected()$narrative))
# Reactive used to save the current position in the narrative list.
story <- reactiveVal(1)
# Reset the story counter if the user changes the product code.
observeEvent(input$code, {
story(1)
})
# When the user clicks "Next story", increase the current position in the
# narrative but never go beyond the interval [1, length of the narrative].
# Note that the mod function (%%) is keeping `current`` within this interval.
observeEvent(input$next_story, {
story((story() %% max_no_stories()) + 1)
})
# When the user clicks "Previous story" decrease the current position in the
# narrative. Note that we also take advantage of the mod function.
observeEvent(input$prev_story, {
story(((story() - 2) %% max_no_stories()) + 1)
})
output$narrative <- renderText({
selected()$narrative[story()]
})
}
shinyApp(ui, server)