#' Map all routes for an agency. If no agency is specified, the first observed agency is taken by default and all its routes are mapped.
#'
#' @param gtfs_obj A GTFS list object with components agency_df, etc.
#' @param agency_name Character. Provide the name of the agency whose routes are being mapped.
#' @param route_ids Vector (Character). IDs for routes of interest.
#' @param service_ids Vector (Character). Service IDs. NULL by Default.
#' @param shape_ids Vector (Character). Shape IDs. NULL by Default.
#' @param include_stops Boolean. Whether to layer on stops to the route shape. Default is TRUE.
#' @param only_stops Boolean. Whether to map only stops, no routes. Default is FALSE.
#' @param stop_opacity Numeric. Value must be between 0 and 1. Defaults is 0.5.
#' @param stop_details Boolean. Whether to generate detail stop information. Default is FALSE.
#' @param route_opacity Numeric. Value must be between 0 and 1. Default is 0.75
#' @param route_colors Character. Names of colors (e.g. "blue") or hex values (e.g. '#000000'). Default is NULL.
#' @noRd
#' @return Leaflet map object with all routes plotted for given agency ID.
map_gtfs_agency_network <- function(gtfs_obj, agency_name, route_ids, service_ids = NULL, shape_ids = NULL, include_stops = TRUE, only_stops = FALSE, stop_opacity = 0.5, stop_details = FALSE, route_opacity = 0.75, route_colors = NULL) {
stopifnot(length(agency_name) == 1)
# GET PLOTTING DATA --------------------------------
plotting_data <- get_routes_sldf(gtfs_obj, route_ids, service_ids, shape_ids, route_opacity, route_colors)
# PLOTTING -------------------------------
# create map with shapes
m <- plotting_data$gtfs_lines %>%
leaflet::leaflet(width = '100%') %>%
leaflet::addProviderTiles("OpenStreetMap.BlackAndWhite") %>%
leaflet::addLegend(
colors = plotting_data$routes_colors_df$color,
labels = paste("Route", plotting_data$routes_colors_df$route_short_name),
title = stringr::str_to_title(agency_name))
if(only_stops) {
include_stops <- TRUE
} else {
m %<>%
leaflet::addPolylines(
color = plotting_data$shapes_colors_df$color,
label = plotting_data$shapes_colors_df$labels,
group = plotting_data$shapes_colors_df$labels,
opacity = plotting_data$shapes_colors_df$opacity,
popup = plotting_data$shapes_colors_df$popups)
}
if(include_stops) {
# get stops data
stops <- get_agency_stops(gtfs_obj, agency_name = agency_name)
stops %<>%
dplyr::inner_join(plotting_data$routes_colors_df, by = 'route_id') %>%
dplyr::mutate(stop_route = paste("Route", route_short_name)) # add stop labels for layers
# whether to add stop details
if(stop_details) {
stops %<>%
dplyr::mutate(popups = gen_stop_popups(stop_name, stop_id, lat, lng))
} else {
stops %<>%
dplyr::mutate(popups = stop_name)
}
m %<>% leaflet::addCircleMarkers(
label = stops$stop_name,
group = stops$stop_route,
popup = stops$popups,
radius = 6,
weight = 4,
stroke = TRUE,
color = 'black',
opacity = stop_opacity,
fill = TRUE,
fillColor = stops$color,
fillOpacity = stop_opacity,
lat = stops$lat,
lng = stops$lng)
}
# add overlays
overlays <- unique(plotting_data$shapes_colors_df$labels)
m %>%
leaflet::addLayersControl(overlayGroups = overlays)
}
#' Get stops for all routes of an agency.
#'
#' @param gtfs_obj A GTFS list object with components agency_df, etc.
#' @param agency_name Character. Provide the name of the agency whose routes are being mapped. Default is NULL, which assumes only one agency exists, taking first agency name.
#'
#' @return dataframe of route and stop ids for given agency id
#' @noRd
get_agency_stops <- function(gtfs_obj, agency_name) {
stopifnot(class(gtfs_obj) == 'gtfs',
!is.null(gtfs_obj$stops_df),
!is.null(gtfs_obj$stop_times_df),
!is.null(gtfs_obj$trips_df),
!is.null(gtfs_obj$routes_df),
any(is.character(agency_name), is.null(agency_name)))
# rename agency name
agency <- agency_name
# find agency routes
if(!"agency_id" %in% names(gtfs_obj$routes_df)) {
# if no agency id, then assume all routes belong to agency_name
route_ids <- gtfs_obj$routes_df$route_id %>% unique
} else {
# find routes for a given agency
agency_ids <- gtfs_obj$agency_df %>%
dplyr::slice(which(agency_name %in% agency)) %>%
'[['('agency_id') %>%
unique
route_ids <- gtfs_obj$routes_df %>%
dplyr::slice(which(agency_id %in% agency_ids)) %>%
'[['('route_id') %>%
unique
}
# extract vector of all trips matching route_id
trip_ids <- gtfs_obj$trips_df %>%
dplyr::slice(which(route_id %in% route_ids)) %>%
'[['('trip_id') %>%
unique
if(length(trip_ids) == 0) {
s <- "No trips for Route ID '%s' were found." %>%
sprintf(agency)
stop(s)
}
possible_stops <- get_possible_stops(gtfs_obj, trip_ids)
stops <- gtfs_obj$stops_df %>%
dplyr::slice(which(stop_id %in% possible_stops)) %>%
dplyr::select(stop_id, stop_name, stop_lat, stop_lon) %>%
dplyr::rename(lat = stop_lat, lng = stop_lon)
# rs = routes, stops
rs_df <- gtfs_obj$trips_df %>%
dplyr::inner_join(gtfs_obj$routes_df, by = 'route_id') %>%
dplyr::select(trip_id, route_id) %>%
dplyr::distinct(trip_id, route_id) %>%
dplyr::left_join(gtfs_obj$stop_times_df, by = 'trip_id') %>%
dplyr::select(route_id, stop_id) %>%
dplyr::distinct(route_id, stop_id)
# update stops
# note: stops are shared between routes. {stops x routes} > {stops}
stops %<>%
dplyr::inner_join(rs_df, by = 'stop_id')
return(stops)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.