inst/doc/fare_structure.R

## ---- include = FALSE---------------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  eval = identical(tolower(Sys.getenv("NOT_CRAN")), "true"),
  out.width = "100%"
)

## ---- message = FALSE---------------------------------------------------------
#  options(java.parameters = "-Xmx2G")
#  
#  library(r5r)
#  library(sf)
#  library(data.table)
#  library(ggplot2)
#  library(patchwork)
#  library(dplyr)
#  library(h3jsr)

## -----------------------------------------------------------------------------
#  # setup and load Porto Alegre multimodal network into memory
#  
#  # system.file returns the directory with example data inside the r5r package
#  # set data path to directory containing your own data if not using the examples
#  data_path <- system.file("extdata/poa", package = "r5r")
#  
#  r5r_core <- setup_r5(data_path)
#  
#  # load transit network as an SF
#  transit_network <- transit_network_to_sf(r5r_core)
#  
#  # map
#  ggplot() +
#    geom_sf(data=transit_network$routes, aes(color=mode)) +
#    theme_void()

## -----------------------------------------------------------------------------
#  fare_structure <- setup_fare_structure(r5r_core,
#                                         base_fare = 4.8,
#                                         by = "MODE")

## -----------------------------------------------------------------------------
#  head(fare_structure, n=7)
#  

## -----------------------------------------------------------------------------
#  fare_structure$max_discounted_transfers
#  fare_structure$transfer_time_allowance <- 60 # update transfer_time_allowance
#  fare_structure$fare_cap

## -----------------------------------------------------------------------------
#  fare_structure$fares_per_type

## -----------------------------------------------------------------------------
#  fare_structure$fares_per_type[type == "RAIL", unlimited_transfers := TRUE]
#  fare_structure$fares_per_type[type == "RAIL", fare := 4.50]
#  fare_structure$fares_per_type[type == "RAIL", allow_same_route_transfer := TRUE]

## -----------------------------------------------------------------------------
#  fare_structure$fares_per_type

## -----------------------------------------------------------------------------
#  fare_structure$fares_per_transfer

## -----------------------------------------------------------------------------
#  # conditional update fare value
#  fare_structure$fares_per_transfer[first_leg == "BUS" & second_leg == "BUS", fare := 7.2]

## -----------------------------------------------------------------------------
#  # conditional update fare value
#  fare_structure$fares_per_transfer[first_leg != second_leg, fare := 8.37]
#  
#  # use fcase instead ?
#  fare_structure$fares_per_transfer[, fare := fcase(first_leg == "BUS" & second_leg == "BUS", 7.2,
#                                                   first_leg != second_leg, 8.37)]
#  

## -----------------------------------------------------------------------------
#  # remove row
#  fare_structure$fares_per_transfer <- fare_structure$fares_per_transfer[!(first_leg == "RAIL" & second_leg == "RAIL")]
#  

## -----------------------------------------------------------------------------
#  fare_structure$fares_per_transfer

## -----------------------------------------------------------------------------
#  tail(fare_structure$fares_per_route)

## -----------------------------------------------------------------------------
#  ## load input data
#  points <- read.csv(system.file("extdata/poa/poa_hexgrid.csv", package = "r5r"))
#  
#  # calculate travel times function
#  calculate_travel_times <- function(fare) {
#  
#    ttm_df <- travel_time_matrix(r5r_core,
#                                 origins = points,
#                                 destinations = points,
#                                 departure_datetime = as.POSIXct("13-05-2019 14:00:00",
#                                                                 format = "%d-%m-%Y %H:%M:%S"),
#                                 mode = c("WALK", "TRANSIT"),
#                                 fare_structure = fare_structure,
#                                 max_fare = fare,
#                                 max_trip_duration = 45,
#                                 max_walk_time = 30)
#  
#    return(ttm_df)
#  }
#  
#  
#  # calculate travel times, and combine results
#  ttm <- calculate_travel_times(fare = Inf)
#  ttm_500 <- calculate_travel_times(fare = 5)
#  
#  # merge results
#  ttm[ttm_500, on = .(from_id, to_id), travel_time_500 := i.travel_time_p50]
#  ttm[, travel_time_unl := travel_time_p50]
#  ttm[, travel_time_p50 := NULL]

## -----------------------------------------------------------------------------
#  tail(ttm, 10)

## -----------------------------------------------------------------------------
#  # plot of overall travel time differences between limited and unlimited cost travel time matrices
#  time_difference = ttm[!is.na(travel_time_500), .(count = .N),
#                        by = .(travel_time_unl, travel_time_500)]
#  
#  p1 <- ggplot(time_difference, aes(y = travel_time_unl, x = travel_time_500)) +
#    geom_point(size = 0.7) +
#    coord_fixed() +
#    scale_x_continuous(breaks = seq(0, 45, 5)) +
#    scale_y_continuous(breaks = seq(0, 45, 5)) +
#    theme_light() +
#    theme(legend.position = "none") +
#    labs(y = "travel time (minutes)\nunestricted monetary cost",
#         x = "travel time (minutes)\nmonetary cost restricted to BRL 5.00"
#         )
#  
#  # plot of unreachable destinations when the monetary cost limit is too low
#  unreachable <- ttm[, .(count = .N), by = .(travel_time_unl, is.na(travel_time_500))]
#  unreachable[, perc := count / sum(count, na.rm = T), by = .(travel_time_unl)]
#  unreachable <- unreachable[is.na == TRUE]
#  unreachable <- na.omit(unreachable)
#  
#  p2 <- ggplot(unreachable, aes(x=travel_time_unl, y=perc)) +
#    geom_col() +
#    coord_flip() +
#    scale_x_continuous(breaks = seq(0, 45, 5)) +
#    scale_y_continuous(limits = c(0, 1), breaks = seq(0, 1, 0.2),
#                       labels = paste0(seq(0, 100, 20), "%")) +
#    theme_light() +
#    labs(x = "travel time (minutes)\nwithout monetary cost restriction",
#         y = "% of unreachable destinations\nconsidering a R$ 5.00 monetary cost limit")
#  
#  # combine both plots using patchwork
#  p1 + p2 + plot_annotation(subtitle = "Comparing travel times with and without monetary cost restriction")
#  

## -----------------------------------------------------------------------------
#  # calculate accessibility function
#  calculate_accessibility <- function(fare, fare_string) {
#  
#    access_df <- accessibility(r5r_core,
#                               origins = points,
#                               destinations = points,
#                               departure_datetime = as.POSIXct("13-05-2019 14:00:00",
#                                                               format = "%d-%m-%Y %H:%M:%S"),
#                               opportunities_colname = "healthcare",
#                               mode = c("WALK", "TRANSIT"),
#                               cutoffs = c(60),
#                               fare_structure = fare_structure,
#                               max_fare = fare,
#                               max_trip_duration = 45,
#                               max_walk_time = 30,
#                               progress = FALSE)
#  
#    access_df$max_fare <- fare_string
#  
#  
#    return(access_df)
#  }
#  
#  # calculate accessibility, combine results, and convert to SF
#  access_500 <- calculate_accessibility(fare=5, fare_string="R$ 5.00 budget")
#  access_unl <- calculate_accessibility(fare=Inf, fare_string="Unlimited budget")
#  
#  access <- rbind(access_500, access_unl)
#  
#  # bring geometry
#  access$geometry <- h3jsr::cell_to_polygon(access$id)
#  access <- st_as_sf(access)
#  

## -----------------------------------------------------------------------------
#  # plot accessibility maps
#  ggplot(data = access) +
#    geom_sf(aes(fill = accessibility), color=NA, size = 0.2) +
#    scale_fill_distiller(palette = "Spectral") +
#    facet_wrap(~max_fare) +
#    labs(subtitle = "Effect of monetary cost on accessibility") +
#    theme_minimal() +
#    theme(legend.position = "bottom",
#          axis.text = element_blank())

## ---- message = FALSE---------------------------------------------------------
#  r5r::stop_r5(r5r_core)
#  rJava::.jgc(R.gc = TRUE)

Try the r5r package in your browser

Any scripts or data that you put into this service are public.

r5r documentation built on Aug. 8, 2023, 9:07 a.m.