Mastering Shiny — 4.8 Exercise 1: Next and Back Button

Below is the 4th exercise in book Mastering Shiny, Chapter 4: Case study: ER injuries.

“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.”

Collin Berke provided a solution, where the %% was used for the circular purpose. However, employing %% is a little tricky in this exercise. Thus, I use if else in both Next and Previous arrows. Here is the code.

library(shiny)
library(ggplot2)
library(vroom)
library(tidyverse)

# set your own directory
setwd('../../../data')


injuries <- vroom::vroom("neiss/injuries.tsv.gz")

population <- vroom::vroom("neiss/population.tsv")

products <- vroom::vroom("neiss/products.tsv")

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

ui <- fluidPage(
  fluidRow(
    column(8,
           selectInput("code", "Product",
                       choices = setNames(products$prod_code, products$title),
                       width = "100%"
           )
    ),
    column(2, selectInput("y", "Y axis", c("rate", "count"))),
    column(2, numericInput("num_row", "Number of rows", 5, min = 1, max = 15))
  ),
    fluidRow(
      column(4, tableOutput("diag")),
      column(4, tableOutput("body_part")),
      column(4, tableOutput("location"))
    ),
    fluidRow(
      column(12, plotOutput("age_sex")),
      
    ),
  fluidRow(
    column(2, span("Narrative Display:", style = "-weight: bold")),
    column(1, actionButton(inputId ="Previous", label = icon("arrow-left"))),
    column(1, actionButton(inputId ="Next", label = icon("arrow-right"))),
    column(8, textOutput("narrative"))
  )
  
)

server <- function(input, output, session) {
  
  # use the last 6 records to test narrative
  selected <- reactive(injuries %>% filter(prod_code == input$code) %>% slice_tail(n=6))
  
  n_row <- reactive(input$num_row) # number of rows displayed in tables
  
  output$diag <- renderTable(count_top(selected(), diag, n = n_row()), width = "100%")
  output$body_part <- renderTable(count_top(selected(), body_part, n = n_row()), width = "100%")
  output$location <- renderTable(count_top(selected(), location, n = n_row()), 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")
    } else {
      summary() %>%
        ggplot(aes(age, rate, colour = sex)) +
        geom_line(na.rm = TRUE) +
        labs(y = "Injuries per 10,000 people")
    }
  }, res = 96)

  ### narrative
  num_narr <- reactive(
    length(selected()$narrative)
  )
  
  # a reactive value that can be easily changed later (in events)
  # ref: https://stackoverflow.com/questions/42183161/r-shiny-how-to-change-values-in-a-reactivevalues-object
  i <- reactiveValues(tmp=1)

  # reset i to 1 if code is changed by user
  # ref: https://www.collinberke.com/post/shiny-series-implementing-a-next-and-back-button/
  observeEvent(input$code, {
    i$tmp <- 1
  })
  
  output$narrative <- renderText({
    selected()$narrative[1]
  })
  
  observeEvent(input$Next, {
    
    i$tmp <- i$tmp + 1
    
    if(i$tmp <= num_narr()){
      output$narrative <- renderText({
        selected()$narrative[i$tmp]
      })
    } else{
      i$tmp <- 1
      output$narrative <- renderText({
        selected()$narrative[1]
      })
    }
  })
  
 observeEvent(input$Previous, {
   i$tmp <- i$tmp - 1
   
   if(i$tmp > 0){
     output$narrative <- renderText({
       selected()$narrative[i$tmp]
     })
   } else{
     i$tmp <- num_narr()
     output$narrative <- renderText({
       selected()$narrative[num_narr()]
     })
   }
 })
 
}

shinyApp(ui, server)