Skip to content

Commit

Permalink
updated the average mode shares across all cities in the global scena…
Browse files Browse the repository at this point in the history 
…rio set up
  • Loading branch information
@AnnaKS123
AnnaKS123 committed Nov 20, 2024
1 parent 4309d41 commit 5637d3b
Showing 1 changed file with 124 additions and 102 deletions.
226 changes: 124 additions & 102 deletions R/create_global_scenarios.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -123,195 +123,215 @@ create_global_scenarios <- function(trip_set) {
trip_set <- NULL

rd_list <- list()

# define the modes that can't be changed
modes_not_changeable <- c("bus_driver", "truck", "car_driver", "taxi")


# # to get overall trip shares for the distance bands - needed if want to updated global_modeshares
# rdr_modeshares <- rdr |>
# filter(participant_id !=0) |>
# distinct(trip_id, .keep_all = T) |>
# count(trip_mode, trip_distance_cat) |> mutate(freq = prop.table(n), .by = trip_mode) |>
# filter(trip_mode %in% c('cycle', 'car', 'bus', 'motorcycle')) |>
# dplyr::select(-n) |>
# dplyr::mutate(freq = round(freq * 100, 1)) |>
# pivot_wider(names_from = trip_distance_cat, values_from = freq) |>
# dplyr::mutate(cityname = city)
#
# # add these city specific numbers to a dataframe containing all the numbers
# if (exists('total_modeshares') && is.data.frame(get('total_modeshares'))){
# total_modeshares <- rbind(total_modeshares, rdr_modeshares)
# } else {
# total_modeshares <- rdr_modeshares
# }
#
# total_modeshares <<- total_modeshares # create global variable

# global modal split across the three distance categories for each mode
# cycle, car, bus, motorcycle
global_modeshares <- data.frame(
c(38.5, 9.4, 2.1, 10.7), # distance category 0-2km
c(50, 45.7, 33.5, 37.2), # distance category 2-6km
c(11.5, 44.9, 64.4, 52.6)
c(39.0, 10.4, 4.8, 10.8), # distance category 0-2km
c(50.0, 45.5, 39.7, 38.0), # distance category 2-6km
c(11.0, 44.1, 55.5, 51.2)
)

colnames(global_modeshares) <- DIST_CAT
rownames(global_modeshares) <- c("cycle", "car", "bus", "motorcycle")

percentage_change <- SCENARIO_INCREASE
percentage_change <- SCENARIO_INCREASE # increase of each mode as percentage of total number of trips.


rdr_baseline <- rdr %>%
dplyr::select(c("trip_id", "trip_distance_cat", "scenario", "trip_mode")) %>%
filter()
rdr_baseline <- rdr_baseline %>% distinct()
rdr_baseline <- rdr_baseline %>% distinct() # remove any duplicates (for when there are multiple stages)

no_trips <- nrow(rdr_baseline)
prop_0_2 <- nrow(rdr_baseline %>% filter(trip_distance_cat == "0-2km")) / no_trips
prop_2_6 <- nrow(rdr_baseline %>% filter(trip_distance_cat == "2-6km")) / no_trips
prop_6 <- nrow(rdr_baseline %>% filter(trip_distance_cat == "6+km")) / no_trips
no_trips <- nrow(rdr_baseline) # total number of trips

# proportion of total trips in each distance category
prop <- list()
for (i in DIST_CAT) {
prop[[i]] <- nrow(rdr_baseline %>% filter(trip_distance_cat == i)) / no_trips
}


# initialise the proportions to be added in each scenario
scenario_proportions <- data.frame(
c(0, 0, 0, 0), # distance category 0-2km
c(0, 0, 0, 0), # distance category 2-6km
c(0, 0, 0, 0)
)
# add the correct values
for (r in 1:3) {
for (c in 1:4) {
if (r == 1) {
percentage_trips <- prop_0_2
} else if (r == 2) {
percentage_trips <- prop_2_6
} else {
percentage_trips <- prop_6
}
scenario_proportions[c, r] <- percentage_change * global_modeshares[c, r] / percentage_trips

# add row and column names
colnames(scenario_proportions) <- colnames(global_modeshares)
rownames(scenario_proportions) <- rownames(global_modeshares)

# find the proportion of trips to be converted for each distance category and scenario
for (c in colnames(scenario_proportions)) {
for (r in rownames(scenario_proportions)) {
scenario_proportions[r, c] <- percentage_change * global_modeshares[r, c] / prop[[c]]
}
}


colnames(scenario_proportions) <- target_distances <- DIST_CAT
rownames(scenario_proportions) <- modes <- c("cycle", "car", "bus", "motorcycle")


SCENARIO_PROPORTIONS <<- scenario_proportions

# print(scenario_proportions)

# baseline scenario
rd_list[[1]] <- rdr
modes_not_changeable <- c("bus_driver", "truck", "car_driver")
rd_list[["baseline"]] <- rdr

# create data frame containing all the trips that are not going to be changed in a scenario
# i.e. bus_driver, truck and car_driver trips but also commercial motorcycle trips which have a participant id of 0
rdr_not_changeable <- rdr %>% filter(trip_mode %in% modes_not_changeable | participant_id == 0)
rdr_changeable <- rdr %>% filter(!trip_mode %in% modes_not_changeable & !participant_id == 0) # Trips that can be reassigned to another mode


# Split trips by distance band in a new list

# Trips that can be reassigned to another mode
rdr_changeable <- rdr %>% filter(!trip_mode %in% modes_not_changeable & !participant_id == 0)

# Split the changeable trips by distance band, save in a new list
rdr_changeable_by_distance <- list()
for (j in 1:ncol(SCENARIO_PROPORTIONS)) {
target_distance <- target_distances[j]
for (j in colnames(SCENARIO_PROPORTIONS)) {
rdr_changeable_by_distance[[j]] <- rdr_changeable %>%
filter(trip_distance_cat == target_distance)
filter(trip_distance_cat == j)
}
rdr_changeable <- NULL

# split all trips by distance band
rdr_all_by_distance <- list()
for (j in 1:ncol(SCENARIO_PROPORTIONS)) {
target_distance <- target_distances[j]
for (j in colnames(SCENARIO_PROPORTIONS)) {
rdr_all_by_distance[[j]] <- rdr %>%
filter(trip_distance_cat == target_distance)
filter(trip_distance_cat == j)
}

rdr <- NULL


###############################################################
# Creation of scenarios
scen_warning <- c()

for (i in 1:nrow(SCENARIO_PROPORTIONS)) { # Loop for each scenario
mode_name <- modes[i] # mode of the scenario

for (i in rownames(SCENARIO_PROPORTIONS)) { # Loop for each scenario
rdr_copy <- list()
for (j in 1:ncol(SCENARIO_PROPORTIONS)) { # Loop for each distance band

for (j in colnames(SCENARIO_PROPORTIONS)) { # Loop for each distance band
rdr_copy[[j]] <- rdr_changeable_by_distance[[j]] # Trips in the distance band
if (mode_name != "bus") {

if (i != "bus") {
# Identify the trips_id of trips that weren't made by the trip mode
potential_trip_ids <- unique(rdr_copy[[j]][!rdr_copy[[j]]$trip_mode %in% c(mode_name), ]$trip_id)

potential_trip_ids <- unique(rdr_copy[[j]][!rdr_copy[[j]]$trip_mode %in% c(i), ]$trip_id)
# Count the number of trips that were made by the trip mode
current_mode_trips <- rdr_copy[[j]] %>%
filter(trip_mode == mode_name) %>%
filter(trip_mode == i) %>%
distinct(trip_id) %>%
nrow()
} else {
} else { # consider bus and rail trips together

# Identify the trips_id of trips that weren't made by the trip mode
potential_trip_ids <- unique(rdr_copy[[j]][!rdr_copy[[j]]$trip_mode %in% c(mode_name, "rail"), ]$trip_id)

potential_trip_ids <- unique(rdr_copy[[j]][!rdr_copy[[j]]$trip_mode %in% c(i, "rail"), ]$trip_id)
# Count the number of trips that were made by the trip mode
current_mode_trips <- rdr_copy[[j]] %>%
filter(trip_mode %in% c(mode_name, "rail")) %>%
filter(trip_mode %in% c(i, "rail")) %>%
distinct(trip_id) %>%
nrow()
} # End else
target_percent <- SCENARIO_PROPORTIONS[i, j]
# n_trips_to_change <- round(length(unique(rdr_copy[[j]]$trip_id)) *
# target_percent / 100) # These trips will be reassigned

# These number of trips will be reassigned
n_trips_to_change <- round(length(unique(rdr_all_by_distance[[j]]$trip_id)) *
target_percent / 100) # These trips will be reassigned
# print(n_trips_to_change)
SCENARIO_PROPORTIONS[i, j] / 100)


if (length(potential_trip_ids) > 0 & n_trips_to_change > 0) {
# if the number of trips that could be changed equals the number of trips that need to be changed
if (length(potential_trip_ids) == n_trips_to_change) {
change_trip_ids <- potential_trip_ids

# if there are less trips to change than should be changed
} else if (length(potential_trip_ids) < n_trips_to_change) {
# save name of scenario
scen_warning <- c(scen_warning, rownames(SCENARIO_PROPORTIONS)[i])

scen_warning <- c(scen_warning, i)
# convert all trips possible
change_trip_ids <- potential_trip_ids

# if there are more trips that can be changed than need to be changed, sample
} else if (length(potential_trip_ids) > n_trips_to_change) {
} else { # if there are more trips that can be changed than need to be changed, sample
change_trip_ids <- base::sample(potential_trip_ids,
size = n_trips_to_change
size = n_trips_to_change
)
}
change_trips <- rdr_copy[[j]][rdr_copy[[j]]$trip_id %in% change_trip_ids, ]
change_trips$trip_mode <- mode_name
change_trips$stage_mode <- mode_name

# convert the trips to the new mode
change_trips <- rdr_copy[[j]][rdr_copy[[j]]$trip_id %in% change_trip_ids, ] # extract trips to be changed
change_trips$trip_mode <- i # assign a new trip mode name
change_trips$stage_mode <- i # assign a new stage mode name

# update the trip duration based on the new mode speeds
change_trips$stage_duration <- change_trips$stage_distance * 60 /
MODE_SPEEDS$speed[MODE_SPEEDS$stage_mode == mode_name]

# Replace trips reassigned in the trip dataset and save them in a new list
MODE_SPEEDS$speed[MODE_SPEEDS$stage_mode == i]
# Replace trips reassigned in the trip dataset and save all trips in a new list
rdr_copy[[j]] <-
rbind(
rdr_copy[[j]][!rdr_copy[[j]]$trip_id %in% change_trip_ids, ],
change_trips
)
}
} # End loop for distance bands
rdr_scen <- do.call(rbind, rdr_copy)
rdr_scen <- rbind(rdr_scen, rdr_not_changeable)


rdr_scen <- do.call(rbind, rdr_copy) # bind across all distance bands
rdr_scen <- rbind(rdr_scen, rdr_not_changeable) # add trips that could not be changed

# Remove bus_driver from the dataset, to recalculate them
if (ADD_BUS_DRIVERS) {
rdr_scen <- filter(rdr_scen, !trip_mode %in% "bus_driver")
rdr_scen <- add_ghost_trips(rdr_scen,
trip_mode = "bus_driver",
distance_ratio = BUS_TO_PASSENGER_RATIO * DISTANCE_SCALAR_PT,
reference_mode = "bus",
agerange_male = BUS_DRIVER_MALE_AGERANGE,
agerange_female = BUS_DRIVER_FEMALE_AGERANGE,
scenario = paste0("Scenario ", i)
trip_mode = "bus_driver",
distance_ratio = BUS_TO_PASSENGER_RATIO * DISTANCE_SCALAR_PT,
reference_mode = "bus",
agerange_male = BUS_DRIVER_MALE_AGERANGE,
agerange_female = BUS_DRIVER_FEMALE_AGERANGE,
scenario = paste0("sc_ ", i)
)
# print(paste("Scenario name: ", paste0('Scenario ',i)))
bus_dr_dist <- sum(rdr_scen[rdr_scen$stage_mode == "bus_driver", ]$stage_distance, na.rm = T)
bus_dist <- sum(rdr_scen[rdr_scen$stage_mode == "bus", ]$stage_distance, na.rm = T)
}


# print(bus_dr_dist/bus_dist)



# Remove car_driver from the dataset, to recalculate them
rdr_scen <- filter(rdr_scen, !trip_mode %in% "car_driver")
if (ADD_CAR_DRIVERS) {
rdr_scen <- add_ghost_trips(rdr_scen,
trip_mode = "car_driver",
distance_ratio = car_driver_scalar * DISTANCE_SCALAR_CAR_TAXI,
reference_mode = "car",
scenario = paste0("Scenario ", i)
trip_mode = "car_driver",
distance_ratio = car_driver_scalar * DISTANCE_SCALAR_CAR_TAXI,
reference_mode = "car",
scenario = paste0("sc_ ", i)
)
# print(paste("Scenario name: ", paste0('Scenario ',i)))
car_dr_dist <- sum(rdr_scen[rdr_scen$stage_mode == "car_driver", ]$stage_distance, na.rm = T)
car_dist <- sum(rdr_scen[rdr_scen$stage_mode == "car", ]$stage_distance, na.rm = T)
}

# print(car_dr_dist/car_dist)
rdr_scen$scenario <- paste0("sc_", rownames(SCENARIO_PROPORTIONS)[i])
rd_list[[i + 1]] <- rdr_scen

rdr_scen$scenario <- paste0("sc_", i) # add scenario name
rd_list[[i]] <- rdr_scen # create output list by adding trips for each scenario
} # End loop for scenarios




# print warning message if there weren't enough trips to be converted for a scenario
scen_warning <- unique(scen_warning)

if (length(scen_warning) > 0) {
for (j in 1:length(scen_warning)) {
print(paste0(
Expand All @@ -320,6 +340,8 @@ create_global_scenarios <- function(trip_set) {
))
}
}




return(rd_list)
}

0 comments on commit 5637d3b

Please sign in to comment.