R/map-gtfs-networks.R

In ropensci/gtfsr: Working with GTFS (General Transit Feed Specification) feeds in R

#' 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)

}