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)