Make a Japanese-style timetable using AT timetable data (better version)

make-timetable-better.R

# Make a Japanese-style timetable using AT public transport data (better version)
# You'll need to download AT's GTFS data file first from https://at.govt.nz/about-us/at-data-sources/google-transit-feed/

library(magrittr)
library(tidyverse)
library(hms)
library(lubridate)
library(stringr)
library(ggthemes)

# Load data
calendar <- read_csv("gtfs/calendar.txt") %>%
  mutate(start_date = ymd(start_date), 
         end_date = ymd(end_date))
routes <- read_csv("gtfs/routes.txt")
stop_times <- read_csv("gtfs/stop_times.txt", 
                       col_types = "cccciciic")
stops <- read_csv("gtfs/stops.txt")
trips <- read_csv("gtfs/trips.txt")

# Function to get data for a stop
get_stop_data <- function(s) { 
  stop <- stops %>%
    filter(stop_code == s)
  stop_dat <- stop_times %>%
    filter(stop_id %in% stop$stop_id) %>%
    left_join(trips, by = "trip_id") %>%
    left_join(routes, by = "route_id") %>%
    left_join(calendar, by = "service_id")
  return(stop_dat)
}

# Function to get timetable data for a stop
get_timetable <- function(stop_data, routes, weekdays = TRUE, direction = 0) {
  # Gather relevant data
  timetable_data <- stop_data %>%
    filter(route_short_name %in% routes, 
           start_date <= today(tzone = "Pacific/Auckland"), 
           end_date >= today(tzone = "Pacific/Auckland"), 
           direction_id == direction)
  
  # Filter for weekdays
  if (weekdays) {
    timetable_data %<>% filter(saturday == 0, sunday == 0)
  } else {
    timetable_data %<>% filter(saturday == 1, sunday == 1)
  }
  timetable_data %<>% filter(!((monday == 0) & (tuesday == 0) & (wednesday == 0) & (thursday == 0) & (friday == 0) & (saturday == 0) & (sunday == 0)))   # A few entries seem to occur on no days??
  
  # Convert times
  timetable_data %<>% 
    separate(col = departure_time, into = c("dep_hour", "dep_min", "dep_sec"), convert = TRUE, remove = FALSE, sep = ":")
  
  # Handle Friday-only services
  timetable_data %<>% 
    mutate(friday_only = (friday == 1) & (monday == 0) & (tuesday == 0) & (wednesday == 0) & (thursday == 0) & (saturday == 0) & (sunday == 0))
  
  # Assemble data for printed timetable
  times_data <- timetable_data %>%
    select(departure_time, friday_only, dep_hour, dep_min, route_short_name) %>%
    arrange(dep_hour, dep_min, friday_only) %>%
    distinct(departure_time, route_short_name, .keep_all = TRUE)
  
  # Add positions for printed timetable
  times_data %<>%
    mutate(ypos = max(dep_hour) - dep_hour + 1) %>%
    group_by(dep_hour) %>%
    mutate(xpos = row_number()) %>%
    ungroup()
  
  # Add text labels
  times_data %<>%
    mutate(dep_hour = ifelse(dep_hour > 23, dep_hour - 24, dep_hour)) %>%
    mutate(hour_text = str_pad(dep_hour, 2, pad = "0"), 
           minute_text = str_pad(dep_min, 2, pad = "0"))
  
  return(list(timetable_data = timetable_data, times_data = times_data))
}

# Function to plot a timetable
plot_timetable <- function(tt, title = "") {
  tt_plot <- ggplot(tt) + 
    geom_text(aes(x = 0, y = ypos, label = hour_text), fontface = "bold") + 
    geom_text(aes(x = xpos, y = ypos, label = minute_text, colour = friday_only)) + 
    scale_colour_manual(values = c("black", "red"), 
                        breaks = c(FALSE, TRUE)) + 
    geom_vline(xintercept = 0.5) + 
    ggtitle(title) + 
    guides(colour = FALSE) + 
    theme_foundation() + 
    theme(
      plot.background = element_rect(fill = "white", colour = "white"), 
      axis.line.y = element_blank(), 
      axis.line.x = element_blank(), 
      axis.ticks.x = element_blank(), 
      axis.ticks.y = element_blank(), 
      axis.title = element_blank(), 
      axis.text = element_blank(), 
      panel.grid = element_blank(), 
      panel.border = element_blank(), 
      panel.background = element_rect(colour = "white") 
    )
  
  # Annotate "Friday only" if necessary
  friday_only_services <- tt %>%
    filter(friday_only == TRUE) %>%
    nrow()
  if (friday_only_services > 0) {
    friday_only_xpos <- tt %>%
      filter(ypos == 1) %>%
      summarise(max_xpos = max(xpos)) %>%
      as.integer() + 1
    
    tt_plot <- tt_plot + 
      annotate("text", label = "Friday only", x = friday_only_xpos, y = 1, colour = "red", hjust = 0)
  }
  
  print(tt_plot)
}

# Timetable for my local stop
my_stop_dat <- get_stop_data(3983)
my_timetable <- get_timetable(my_stop_dat, routes = c("973", "974", "972", "971"))
plot_timetable(my_timetable$times_data, "To Britomart (buses 971, 972, 973, 973)")

# Timetable for Britomart Western line
bm_stop_dat <- get_stop_data(133)
bm_timetable <- get_timetable(bm_stop_dat, routes = c("WEST"), direction = 1)
plot_timetable(bm_timetable$times_data, "Britomart Western Line")

A few notes. I using this against the Wellington GTFS. I also don't use R very often.... or really much at all since university.

• You'll need libxml-2.0 and libcurl to install the tidyverse dependency (i.e. the installation of the R dependencies will fail otherwise).
• I needed to use "cccciciicc" for the stop_times CSV (there was an additional, optional, column).
• A lot of published GTFS are borked, and I don't know how anything works generally. I had to remove the timetable_data %<>% filter(!((monday == 0) & (tuesday == 0) & (wednesday == 0) & (thursday == 0) & (friday == 0) & (saturday == 0) & (sunday == 0))) line entirely because otherwise it filtered out literally everything at my places of interest.

Awesome job!