inst/examples-shiny/flights/app.R

In bslib: Custom 'Bootstrap' 'Sass' Themes for 'shiny' and 'rmarkdown'

library(shiny)
library(bslib)
library(dplyr)
library(lubridate)
library(plotly)
library(chiflights22) # https://github.com/cpsievert/chiflights22
library(histoslider)  # https://github.com/cpsievert/histoslider
library(rlang)

# Data prep
flights <- flights %>%
  left_join(
    airports %>%
      transmute(dest_name = paste0(name, " (", faa, ")"), dest = faa, end_lat = lat, end_lon = lon)
  ) %>%
  filter(!is.na(dest_name)) %>%
  left_join(
    airports %>% select(origin = faa, start_lat = lat, start_lon = lon)
  ) %>%
  left_join(airlines, by = "carrier") %>%
  rename(carrier_name = name) %>%
  select(-time_hour) %>%
  left_join(weather) %>%
  mutate(
    # The overwhelming majority of precipation is 0 so transform
    # with some help from MASS::boxcox() https://stats.stackexchange.com/a/1452/48604
    precip = scales::rescale(precip^-1.55/-.55),
    date = lubridate::ymd(paste(year, month, day, sep = "-"))
  )

SLIDER_HEIGHT <- 150
CHOICES <- list(
  origin = c(
    "Choose origin(s)" = "",
    "O'Hare" = "ORD",
    "Midway" = "MDW",
    "Rockford" = "RFD"
  ),
  dest_name = c(
    "Choose destination(s)" = "",
    sort(unique(flights$dest_name))
  ),
  carrier_name = c(
    "Choose carrier(s)" = "",
    unique(flights$carrier_name)
  )
)


sidebar_acc <- accordion(
  open = c("Origin", "Destination"),
  accordion_panel(
    "Flight Path",
    # See https://github.com/rstudio/fontawesome/issues/114
    icon = fontawesome::fa("plane-departure"),
    uiOutput("flight_path_reset"),
    selectizeInput(
      "origin", "Origin",
      choices = CHOICES$origin,
      multiple = TRUE,
      options = list(plugins = "remove_button", closeAfterSelect = TRUE)
    ),
    selectizeInput(
      "dest_name", "Destination",
      choices = CHOICES$dest_name,
      multiple = TRUE,
      options = list(plugins = "remove_button", closeAfterSelect = TRUE)
    ),
    selectizeInput(
      "carrier_name", "Carrier",
      choices = CHOICES$carrier_name,
      multiple = TRUE,
      options = list(plugins = "remove_button", closeAfterSelect = TRUE)
    )
  ),
  accordion_panel(
    "Flight time",
    icon = fontawesome::fa("clock"),
    input_histoslider(
      "sched_dep_time", "Departure time",
      flights$sched_dep_time,
      height = SLIDER_HEIGHT,
      options = list(handleLabelFormat = "0d")
    ),
    input_histoslider(
      "sched_arr_time", "Arrival time",
      flights$sched_arr_time,
      height = SLIDER_HEIGHT,
      options = list(handleLabelFormat = "0d")
    ),
    input_histoslider(
      "date", "Date",
      flights$date,
      height = SLIDER_HEIGHT,
      breaks = "months",
      options = list(handleLabelFormat = "%b %e")
    )
  ),
  accordion_panel(
    "Weather",
    icon = fontawesome::fa("cloud-rain"),
    # TODO: problematic (many NAs)
    #input_histoslider(
    #  "precip", "Precipitation",
    #  flights$precip,
    #  height = SLIDER_HEIGHT
    #),
    input_histoslider(
      "wind_speed", "Wind speed",
      flights$wind_speed,
      height = SLIDER_HEIGHT
    ),
    input_histoslider(
      "wind_gust", "Wind gust",
      flights$wind_gust,
      height = SLIDER_HEIGHT
    )
  )
)


flights_card <- card(
  full_screen = TRUE,
  card_header(
    "Flight paths",
    tooltip(
      bsicons::bs_icon("info-circle", title = "About marker areas"),
      "Marker areas are proportional to mean arrival delay"
    ),
    class = "d-flex justify-content-between align-items-center"
  ),
  plotlyOutput("flight_paths")
)

avg_delay_by_category <- card(
  full_screen = TRUE,
  card_header(
    "Average delay by category",
    popover(
      bsicons::bs_icon("gear", title = "Settings"),
      selectInput(
        "avg_delay_category", "Category",
        c("Carrier", "Month", "Weekday")
      ),
      radioButtons(
        "avg_delay_type", "Delay type",
        c("Arrival", "Departure"),
        inline = TRUE
      )
    ),
    class = "d-flex justify-content-between align-items-center"
  ),
  plotlyOutput("scatter_delay")
)

delay_dist <- navset_card_underline(
  title = "Distribution of delay times",
  full_screen = TRUE,
  id = "delay_dist_nav",
  sidebar = sidebar(
    position = "right",
    open = FALSE,
    radioButtons(
      "delay_dist_type", "Delay type",
      c("Arrival" = "arr_delay", "Departure" = "dep_delay"),
      inline = TRUE
    ),
    conditionalPanel(
      "input.delay_dist_nav === 'Overall'",
      selectizeInput(
        "delay_dist_category", "Split by",
        c("Choose a category" = "", "Carrier", "Month", "Weekday"),
        options = list(plugins = "remove_button")
      )
    )
  ),
  nav_panel(
    "Overall",
    plotlyOutput("delay_dist")
  ),
  nav_panel(
    "Over time",
    plotlyOutput("arr_delay_series")
  )
)

PRIMARY <- "#0675DD"

ui <- page_navbar(
  theme = bs_theme(
    preset = "shiny",
    "primary" = PRIMARY
  ),
  lang = "en",
  title = tags$span(
    tags$img(
      src = "logo.png",
      width = "46px",
      height = "auto",
      class = "me-3",
      alt = "Shiny hex logo"
    ),
    "Chicago Flights"
  ),
  sidebar = sidebar(width = 275, sidebar_acc),
  nav_spacer(),
  nav_panel(
    "Delay overview",
    class = "bslib-page-dashboard",
    uiOutput("value_boxes"),
    layout_columns(
      flights_card, avg_delay_by_category
    ),
    delay_dist
  ),
  nav_panel(
    "Data export",
    card(
      card_header("Flight data"),
      DT::dataTableOutput("export")
    )
  ),
  nav_item(
    tags$a(
      tags$span(
        bsicons::bs_icon("code-slash"), "Source code"
      ),
      href = "https://github.com/rstudio/bslib/tree/main/inst/examples-shiny/flights",
      target = "_blank"
    )
  ),
  nav_item(
    input_dark_mode(id = "dark_mode", mode = "light")
  )
)

server <- function(input, output, session) {
  # ---------------------------------------------------------
  # Flights tab logic
  #
  # WARNING: this server-side filtering logic is VERY experimental
  # at this point and won't be easily adapt to different use cases.
  # If you feel tempted to use it, use with caution.
  # ---------------------------------------------------------

  # Mapping from input id name to updating input function
  input_discrete_vars <- list(
    origin = updateSelectInput,
    dest_name = updateSelectInput,
    carrier_name = updateSelectInput
  )
  input_numeric_vars <- list(
    sched_dep_time = update_histoslider,
    sched_arr_time = update_histoslider,
    date = update_histoslider
  )
  input_vars <- c(
    input_discrete_vars,
    input_numeric_vars
  )

  filter_index <- function(d) {
    idx <- rep(TRUE, nrow(d))
    for (var in names(d)) {
      idx <- idx & filter_col(d, var)
    }
    idx & !is.na(idx)
  }

  filter_col <- function(d, var) {
    vals <- d[[var]]
    input_val <- input[[var]]
    if (is.null(input_val) || identical(input_val, "")) {
      return(TRUE)
    }

    if (is.character(vals) || is.factor(vals) || is.logical(vals)) {
      return(d[[var]] %in% input_val)
    }

    # N.B. between() will remove NAs, which we probably don't
    # want to remove until the slider is considered 'active'
    rng <- range(vals, na.rm = TRUE)
    active <- isTRUE(rng[1] <= input_val[1] || input_val[2] <= rng[2])

    if (!active) {
      return(TRUE)
    }

    dplyr::between(vals, input_val[1], input_val[2])
  }

  # Set up a listener for each input that effectively says update
  # every other input when my value changes
  lapply(names(input_vars), function(var) {
    # We don't want updates to other variables to then
    # cause an update to this variable
    do_update <- reactiveVal(TRUE)

    observeEvent(input[[var]], ignoreInit = TRUE, ignoreNULL = FALSE, {

      if (!do_update()) return()
      do_update(FALSE)
      on.exit(do_update(TRUE), add = TRUE)

      d <- flights[filter_index(flights), ]
      if (nrow(d) == 0) return()

      other_vars <- setdiff(names(input_vars), var)
      lapply(other_vars, function(v) {

        input_val <- input[[v]]
        update_input_func <- input_vars[[v]]

        if (v %in% names(input_discrete_vars)) {
          choices <- CHOICES[[v]] %||% sort(unique(d[[v]]))
          selected <- input_val %||% CHOICES[[v]][CHOICES[[v]] == ""]

          update_input_func(
            inputId = v, choices = choices,
            selected = selected
          )
        } else {
          update_input_func(
            id = v,
            values = d[[v]],
            start = input_val[1],
            end = input_val[2]
          )
        }
      })
    })
  })


  output$flight_path_reset <- renderUI({
    req(c(input$origin, input$dest_name, input$carrier_name))

    actionLink(
      "flight_path_reset", "Reset",
      style = htmltools::css(
        position = "absolute",
        right = "1rem",
        text_decoration = "none",
        font_weight = 700,
        font_size = ".875rem"
      )
    )
  })

  observeEvent(input$flight_path_reset, {
    updateSelectInput(
      inputId = "origin",
      choices = CHOICES$origin
    )
    updateSelectInput(
      inputId = "dest_name",
      choices = CHOICES$dest_name
    )
    updateSelectInput(
      inputId = "carrier_name",
      choices = CHOICES$carrier_name
    )
  })

  # Flights with all filters applied (i.e., data used for value boxes/plots)
  flight_dat <- reactive({
    flights[filter_index(flights), ]
  })

  summary_vals <- reactive({
    d <- flight_dat()

    list(
      n = scales::comma(nrow(d)),
      n_dest = length(unique(d$dest_name)),
      n_carriers = length(unique(d$carrier_name)),
      dep_delay = round(mean(d$dep_delay, na.rm = T), 0),
      dep_delay_perc = round(100 * sum(d$dep_delay > 0, na.rm = T) / nrow(d), 1),
      arr_delay = round(mean(d$arr_delay, na.rm = T), 0),
      arr_delay_perc = round(100 * sum(d$arr_delay > 0, na.rm = TRUE) / nrow(d), 1)
    )
  })

  output$value_boxes <- renderUI({
    vals <- summary_vals()
    n_flights <- value_box(
      "A TOTAL OF",
      paste(vals$n, "flights"),
      paste("Across", vals$n_dest, "destinations"),
      tags$p(paste(
        "On", vals$n_carriers, "different carriers"
      )),
      showcase = bsicons::bs_icon("airplane")
    )

    late <- if (vals$dep_delay > 0) "late" else "early"
    delay_dep <- value_box(
      "AVERAGE DEPARTURE",
      paste(vals$dep_delay, "mins", late),
      paste0(vals$dep_delay_perc, "% of flights depart ", late),
      showcase = bsicons::bs_icon("hourglass-split")
    )

    late <- if (vals$arr_delay > 0) "late" else "early"
    delay_arr <- value_box(
      "AVERAGE ARRIVAL",
      paste(vals$arr_delay, "mins", late),
      paste0(vals$arr_delay_perc, "% of flights arrive ", late),
      showcase = bsicons::bs_icon("hourglass-bottom")
    )

    layout_columns(class = "mb-0", n_flights, delay_dep, delay_arr)
  }) %>%
    bindCache(flight_dat())

  plotly_base <- function(..., geo = FALSE, color = I(PRIMARY)) {
    plot_func <- if (geo) plot_geo else plot_ly
    plot_func(..., color = color) %>%
      plotly::config(displayModeBar = FALSE) %>%
      plotly::layout(
        font = list(
          family = "Open Sans",
          color = if (input$dark_mode == "dark") "white" else "#1D1F21"
        ),
        plot_bgcolor = "transparent",
        paper_bgcolor = "transparent"
      )
  }

  output$flight_paths <- renderPlotly({
    flight_dat() %>%
      group_by(start_lon, start_lat, end_lon, end_lat, origin, dest) %>%
      summarise(mean_delay = mean(arr_delay, na.rm = TRUE)) %>%
      plotly_base(geo = TRUE, showlegend = FALSE) %>%
      add_segments(
        x = ~start_lon, xend = ~end_lon,
        y = ~start_lat, yend = ~end_lat,
        alpha = 0.5, size = I(1), hoverinfo = "none"
      ) %>%
      add_markers(
        x = ~end_lon, y = ~end_lat, size = ~mean_delay,
        hoverinfo = "text", alpha = 0.1,
        text = ~paste0(
          origin, " -> ", dest, "<br>",
          "Average delay: ", round(mean_delay, 1)
        )
      ) %>%
      layout(
        geo = list(
          bgcolor = "transparent",
          projection = list(
            type = 'orthographic',
            rotation = list(lon = -100, lat = 40, roll = 0)
          ),
          showland = TRUE,
          landcolor = toRGB("gray95"),
          countrycolor = toRGB("gray80")
        )
      )
  }) %>%
    bindCache(flight_dat(), input$dark_mode)

  output$scatter_delay <- renderPlotly({
    d <- flight_dat()
    req(nrow(d) > 0)

    d <- switch(
      input$avg_delay_category,
      Weekday = group_by(d, y = lubridate::wday(date, label = TRUE)),
      Month = group_by(d, y = lubridate::month(date, label = TRUE)),
      Carrier = group_by(d, y = carrier_name),
      stop("Category of ", input$avg_delay_category, "not implemented")
    )

    d <- switch(
      input$avg_delay_type,
      Arrival = summarise(d, avg = mean(arr_delay, na.rm = TRUE)),
      Departure = summarise(d, avg = mean(dep_delay, na.rm = TRUE)),
    )

    d %>%
      arrange(avg) %>%
      mutate(y = factor(y, levels = y)) %>%
      plotly_base(x = ~avg, y = ~y) %>%
      add_bars(hoverinfo = "x") %>%
      layout(
        yaxis = list(title = ""),
        xaxis = list(
          title = paste("Average", tolower(input$avg_delay_type), "delay"),
          hoverformat = ".1f",
          gridcolor = if (input$dark_mode == "dark") "#303030"
        )
      )
  }) %>%
    bindCache(flight_dat(), input$dark_mode, input$avg_delay_category, input$avg_delay_type)


  output$delay_dist <- renderPlotly({
    d <- flight_dat()
    x <- d[[input$delay_dist_type]]
    req(length(x) > 0)

    x_mean <- mean(x, na.rm = TRUE)
    end <- quantile(x, probs = 0.99, na.rm = TRUE)

    color <- switch(
      input$delay_dist_category,
      Carrier = d$carrier_name,
      Month = lubridate::month(d$date, label = TRUE),
      Weekday = lubridate::wday(d$date, label = TRUE),
      I(PRIMARY)
    )

    plotly_base(
      x = x, color = color,
      hovertemplate = "%{y} flights were<br>%{x} min late <extra></extra>"
    ) %>%
      rangeslider(start = min(x, na.rm = TRUE), end = as.numeric(end)) %>%
      add_annotations(
        text = paste(
          "Average",
          switch(
            input$delay_dist_type,
            arr_delay = "arrival",
            dep_delay = "departure"
          ),
          "<br> delay of",
          round(x_mean, 1), "min"
        ),
        x = x_mean, y = 0.5, yref = "paper",
        ax = 80, ay = -50,
        font = list(size = 14)
      ) %>%
      layout(
        barmode = "stack",
        yaxis = list(gridcolor = if (input$dark_mode == "dark") "#303030"),
        shapes = list(
          type = "line",
          x0 = x_mean, x1 = x_mean,
          y0 = 0, y1 = 1,
          yref = "paper",
          line = list(color = "lightgray", dash = "dash")
        )
      )
  }) %>%
    bindCache(flight_dat(), input$dark_mode, input$delay_dist_type, input$delay_dist_category)

  output$arr_delay_series <- renderPlotly({
    d <- flight_dat()
    req(nrow(d) > 0)

    d <- group_by(d, date)

    d <- switch(
      input$delay_dist_type,
      arr_delay = summarise(d, y = mean(arr_delay, na.rm = TRUE)),
      dep_delay = summarise(d, y = mean(dep_delay, na.rm = TRUE))
    )

    color <- switch(
      input$delay_dist_category,
      Carrier = d$carrier_name,
      Month = lubridate::month(d$date, label = TRUE),
      Weekday = lubridate::wday(d$date, label = TRUE),
      I(PRIMARY)
    )

    plotly_base(
      x = d$date, y = d$y, color = color,
      hovertemplate = "%{y:.1f}<extra></extra>",
    ) %>%
      add_lines() %>%
      layout(
        hovermode = "x",
        xaxis = list(title = "", tickformat = "%b %e"),
        yaxis = list(title = "Average delay", showgrid = FALSE)
      )
  }) %>%
    bindCache(flight_dat(), input$dark_mode, input$delay_dist_type, input$delay_dist_category)

  output$export <- DT::renderDataTable({
    DT::datatable(flight_dat(), fillContainer = TRUE)
  })

}

shinyApp(ui, server)