4.9 DSLC Customs
Some people in the cohort were brainstorming ideas on how to continue to improve this Shiny app. Here are some of the ideas.
4.9.1 UI
library("gt")
library("shiny")
library("tidyverse")
injuries <- readr::read_csv("injuries.csv")
population <- readr::read_csv("population.csv")
products <- readr::read_csv("products.csv")
prod_codes <- setNames(products$prod_code, products$title)
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))) |>
# gt table
gt() |>
cols_align(align = "center") |>
tab_style(
style = list(cell_fill(color = "#F9E3D6")),
locations = cells_body(columns = {{ var }})
) |>
tab_style(
style = list(cell_fill(color = "lightcyan")),
locations = cells_body(columns = n)
)
}
ui <- fluidPage(
# choose product
fluidRow(
column(
width = 6,
selectInput(
inputId = "code",
label = "Product",
choices = prod_codes,
width = "100%"
)
),
column(
width = 2,
selectInput(inputId = "y", label = "Y axis", choices = c("rate", "count"))
),
column(
width = 4,
sliderInput(inputId = "n_products", label = "number of products",
min = 1, max = 20, value = 5, step = 1)
)
),
# display tables
fluidRow(
column(width = 4, tableOutput(outputId = "diag")),
column(width = 4, tableOutput(outputId = "body_part")),
column(width = 4, tableOutput(outputId = "location"))
),
# display plot
fluidRow(
column(width = 12, plotOutput(outputId = "age_sex"))
)
# narrative button
,
fluidRow(
column(
width = 2,
actionButton(inputId = "story", label = "Tell me a story")
),
column(width = 10, textOutput(outputId = "narrative"))
)
)
4.9.2 Server
server <- function(input, output, session) {
# reactive for filtered data frame
selected <- reactive(
injuries %>%
filter(prod_code == input$code)
)
num_products <- reactive(input$n_products)
# retrieve injury type
prod_name <- reactive(products$title[products$prod_code == input$code])
# reactive for plot data
summary <- reactive(
selected() %>%
count(age, sex, wt = weight) %>%
left_join(y = population, by = c("age", "sex")) %>%
mutate(rate = n / population * 1e4)
)
output$diag <- render_gt(count_top(selected(), diag, num_products()),
width = "100%")
output$body_part <- render_gt(count_top(selected(), body_part, num_products()),
width = "100%")
output$location <- render_gt(count_top(selected(), location, num_products()),
width = "100%")
# render plot
output$age_sex <- renderPlot(
expr = {
if (input$y == "count") {
summary() %>%
ggplot(mapping = aes(x = age, y = n, colour = sex)) +
geom_line() +
labs(title = "Accidents reported to emergency rooms in the US",
subtitle = prod_name(),
caption = "Source: NEISS",
x = "Age",
y = "Estimated number of injuries") +
theme_minimal()
} else {
summary() %>%
ggplot(mapping = aes(x = age, y = rate, colour = sex)) +
geom_line(na.rm = TRUE) +
labs(title = "Accidents reported to emergency rooms in the US",
subtitle = prod_name(),
caption = "Source: NEISS",
x = "Age",
y = "Injuries per 10,000 people") +
theme_minimal()
}
},
res = 96
)
# narrative reactive
narrative_sample <- eventReactive(
eventExpr = list(input$story, selected()),
valueExpr = selected() %>%
pull(narrative) %>%
sample(1)
)
output$narrative <- renderText(narrative_sample())
}
# Run the application
shinyApp(ui = ui, server = server)