inst/apps/118-highcharter-births/app.R

In rstudio/shinycoreci: CI Testing for shiny

# Load packages -----------------------------------------------------
library(shiny)
library(highcharter)
library(dplyr)
library(tidyr)

# Load data ---------------------------------------------------------
births <- read.csv("data/births.csv")

# Determine years in data -------------------------------------------
years <- unique(births$year)


# UI ----------------------------------------------------------------
ui <- fluidPage(

  # App title -------------------------------------------------------
  titlePanel("The Friday the 13th effect"),

  # Sidebar layout with a input and output definitions --------------
  sidebarLayout(

    # Inputs --------------------------------------------------------
    sidebarPanel(

           sliderInput("year",
                       label = "Year",
                       min = min(years),
                       max = max(years),
                       step = 1,
                       sep = "",
                       value = range(years)),

           selectInput("plot_type",
                       label = "Plot type",
                       choices = c("Scatter" = "scatter",
                                   "Bar" = "column",
                                   "Line" = "line")),
           selectInput("theme",
                       label = "Theme",
                       choices = c("No theme",
                                   "Chalk" = "chalk",
                                   "Dark Unica" = "darkunica",
                                   "Economist" = "economist",
                                   "FiveThirtyEight" = "fivethirtyeight",
                                   "Gridlight" = "gridlight",
                                   "Handdrawn" = "handdrawn",
                                   "Sandsignika" = "sandsignika"))
    ),

    # Output --------------------------------------------------------
    mainPanel(
      highchartOutput("hcontainer", height = "500px")
    )

  )
)


# SERVER ------------------------------------------------------------
server = function(input, output) {

  # Calculate differences between 13th and avg of 6th and 20th ------
  diff13 <- reactive({
    births %>%
      filter(between(year, input$year[1], input$year[2])) %>%
      filter(date_of_month %in% c(6, 13, 20)) %>%
      mutate(day = ifelse(date_of_month == 13, "thirteen", "not_thirteen")) %>%
      group_by(day_of_week, day) %>%
      summarise(mean_births = mean(births)) %>%
      arrange(day_of_week) %>%
      spread(day, mean_births) %>%
      mutate(diff_ppt = ((thirteen - not_thirteen) / not_thirteen) * 100)
  })

  # Text string of selected years for plot subtitle -----------------
  selected_years_to_print <- reactive({
    if(input$year[1] == input$year[2]) {
      as.character(input$year[1])
    } else {
      paste(input$year[1], " - ", input$year[2])
    }
  })

  # Highchart -------------------------------------------------------
  output$hcontainer <- renderHighchart({

    hc <- highchart() %>%
      hc_add_series(data = diff13()$diff_ppt,
                    type = input$plot_type,
                    name = "Difference, in ppt",
                    showInLegend = FALSE) %>%
      hc_yAxis(title = list(text = "Difference, in ppt"),
               allowDecimals = FALSE) %>%
      hc_xAxis(categories = c("Monday", "Tuesday", "Wednesday", "Thursday",
                              "Friday", "Saturday", "Sunday"),
               tickmarkPlacement = "on",
               opposite = TRUE) %>%
      hc_title(text = "The Friday the 13th effect",
               style = list(fontWeight = "bold")) %>%
      hc_subtitle(text = paste("Difference in the share of U.S. births on 13th
                               of each month from the average of births on the 6th
                               and the 20th,",
                               selected_years_to_print())) %>%
      hc_tooltip(valueDecimals = 4,
                 pointFormat = "Day: {point.x} <br> Diff: {point.y}") %>%
      hc_credits(enabled = TRUE,
                 text = "Sources: CDC/NCHS, SOCIAL SECURITY ADMINISTRATION",
                 style = list(fontSize = "10px"))

    # Determine theme and apply to highchart ------------------------
    if (input$theme != "No theme") {
      theme <- switch(input$theme,
                      chalk = hc_theme_chalk(),
                      darkunica = hc_theme_darkunica(),
                      fivethirtyeight = hc_theme_538(),
                      gridlight = hc_theme_gridlight(),
                      handdrawn = hc_theme_handdrawn(),
                      economist = hc_theme_economist(),
                      sandsignika = hc_theme_sandsignika()
      )
      hc <- hc %>%
        hc_add_theme(theme)
    }

    # Print highchart -----------------------------------------------
    hc
  })

}

# Run app -----------------------------------------------------------
shinyApp(ui = ui, server = server)