From 1d4b847aac9dbd14dd24b1c71fc5bbe4fa17a1b4 Mon Sep 17 00:00:00 2001 From: Anna Schroeder Date: Mon, 18 Sep 2023 08:50:33 +0200 Subject: [PATCH] delete functions that aren't needed --- R/PA_dose_response.R | 75 -- R/compute_evppi.R | 59 - R/create_africa_india_scenarios.R | 207 ---- R/create_all_scenarios.R | 1585 -------------------------- R/create_cycle_scenarios.R | 38 - R/create_latam_scenarios.R | 207 ---- R/create_max_mode_share_scenarios.R | 88 -- R/create_scenario.R | 61 - R/create_walk_scenario.R | 44 - R/error_handling.R | 18 - R/parallel_evppi_for_AP.R | 28 - R/population_attributable_fraction.R | 16 - R/summarise_ithim_inputs.R | 38 - R/trim_glm_object.R | 30 - 14 files changed, 2494 deletions(-) delete mode 100644 R/PA_dose_response.R delete mode 100644 R/compute_evppi.R delete mode 100644 R/create_africa_india_scenarios.R delete mode 100644 R/create_all_scenarios.R delete mode 100644 R/create_cycle_scenarios.R delete mode 100644 R/create_latam_scenarios.R delete mode 100644 R/create_max_mode_share_scenarios.R delete mode 100644 R/create_scenario.R delete mode 100644 R/create_walk_scenario.R delete mode 100644 R/error_handling.R delete mode 100644 R/parallel_evppi_for_AP.R delete mode 100644 R/population_attributable_fraction.R delete mode 100644 R/summarise_ithim_inputs.R delete mode 100644 R/trim_glm_object.R diff --git a/R/PA_dose_response.R b/R/PA_dose_response.R deleted file mode 100644 index 88c09e7f..00000000 --- a/R/PA_dose_response.R +++ /dev/null @@ -1,75 +0,0 @@ -#' Calculate RR given PA - CURRENTLY NOT USED -#' -#' Calculate RR for a disease given PA -#' -#' @param cause name of disease -#' @param dose vector of doses of PA from individuals -#' @param confidence_intervals logic: whether or not to return confidence intervals -#' -#' @return data frame of relative risks -#' -#' @export -PA_dose_response <- function (cause, dose, confidence_intervals = F){ - - if (sum(is.na(dose))>0 || class(dose)!= "numeric"){ - stop ('Please provide dose in numeric') - } - if (!cause %in% c('all_cause', 'breast_cancer', 'cardiovascular_disease', - 'colon_cancer', 'coronary_heart_disease', 'diabetes', 'endometrial_cancer', - 'heart_failure', 'lung_cancer', 'stroke', 'total_cancer')){ - stop('Unsupported cause/disease. Please select from \n - all_cause \n - breast_cancer\n - cardiovascular_disease \n - colon_cancer \n - coronary_heart_disease \n - endometrial_cancer \n - heart_failure \n - lung_cancer \n - stroke \n - total_cancer') - } - # decide whether to use "all" or "mortality" - outcome_type <- ifelse(cause%in%c('lung_cancer','breast_cancer','endometrial_cancer','colon_cancer'), 'all' , 'mortality') - - # apply disease-specific thresholds - if(cause %in% c('total_cancer','coronary_heart_disease','breast_cancer','endometrial_cancer','colon_cancer')) dose[dose>35] <- 35 - else if(cause == 'lung_cancer') dose[dose>10] <- 10 - else if(cause == 'stroke') dose[dose>32] <- 32 - else if(cause == 'all_cause') dose[dose>16.08] <- 16.08 - - ## this function assumes the existence of a file with a name such as 'stroke_mortality.csv' - ## and column names 'dose', 'RR', 'lb' and 'ub'. - fname <- paste(cause, outcome_type, sep = "_") - lookup_table <- get(fname) - lookup_df <- setDT(lookup_table) - rr <- approx(x=lookup_df$dose,y=lookup_df$RR,xout=dose,yleft=1,yright=min(lookup_df$RR))$y - if (confidence_intervals || PA_DOSE_RESPONSE_QUANTILE==T) { - lb <- - approx( - x = lookup_df$dose, - y = lookup_df$lb, - xout = dose, - yleft = 1, - yright = min(lookup_df$lb) - )$y - ub <- - approx( - x = lookup_df$dose, - y = lookup_df$ub, - xout = dose, - yleft = 1, - yright = min(lookup_df$ub) - )$y - } - ## we assume that the columns describe a normal distribution with standard deviation defined by the upper and lower bounds. - if (PA_DOSE_RESPONSE_QUANTILE==T){ - rr <- qnorm(get(paste0('PA_DOSE_RESPONSE_QUANTILE_',cause)), mean=rr, sd=(ub-lb)/1.96) - rr[rr<0] <- 0 - } - if (confidence_intervals) { - return(data.frame (rr = rr, lb = lb, ub = ub)) - }else{ - return(data.frame(rr = rr)) - } -} diff --git a/R/compute_evppi.R b/R/compute_evppi.R deleted file mode 100644 index 0ae36813..00000000 --- a/R/compute_evppi.R +++ /dev/null @@ -1,59 +0,0 @@ -#' Compute evppi, designed to be run in parallel - ONLY USED in SAMPLING MODE -#' -#' Creates a list of EVPPI values one parameter (set) at a time across some pre-defined outcomes -#' Uses Chris Jackson's VoI Github package https://github.com/chjackson/voi -#' @param p input parameter index -#' @param global_para list of global input parameters that are the same across all cities -#' @param city_para list of city specific input parameters -#' @param city_outcome list of outcomes for a specific city -# -#' @return list of EVPPI vectors for specific city -#' -#' @export - - -compute_evppi <- function(p, global_para,city_para,city_outcomes, nsamples){ - - ncol_gen <- ncol(global_para) - - if (is.null(ncol_gen)) ncol_gen <- length(global_para) # in case of DR functions were several parameters are considered at the same time - - voi <- rep(0,length(city_outcomes)) # create empty output list - - if(p <= ncol_gen){# first loop through general parameters - sourcesj <- global_para[[p]] # look at each parameter at a time - } else { - p2 <- p - ncol_gen - sourcesj <- city_para[[p2]] # then loop through city specific parameters - } - - for(o in 1:length(city_outcomes)){ # loop through all outcomes - - y <- as.numeric(city_outcomes[[o]]) - # extract one outcome - vary <- var(y) #compute outcome variance - - # model outcome as a function of input(s) - if (nsamples >= 8){ # use Chris Jackson's VoI R package if sample size large enough - if(is.vector(sourcesj)){ # if only one parameter is considered at a time - evppi_jj <- evppivar(y,sourcesj) # uses Chris Jackson's VoI package - } - else { # if several input parameters are considered together, e.g. dose response alpha, beta, gamma, trml parameters - evppi_jj <- evppivar(y,sourcesj, par= c(colnames(sourcesj))) - } - - # compute evppi as percentage, i.e. percentage of variance we can reduce if we knew a certain input parameter - voi[o] <- evppi_jj$evppi / vary * 100 - } - else { # calculate EVPPI directly if sample size too small to use C Jackson's VoI package - model <- earth(y ~ sourcesj, degree=4) - voi[o] <- (vary - mean((y - model$fitted) ^ 2)) / vary * 100 # compute evppi as percentage - } - - } - voi # return evppi list -} - - - - diff --git a/R/create_africa_india_scenarios.R b/R/create_africa_india_scenarios.R deleted file mode 100644 index 35e866e2..00000000 --- a/R/create_africa_india_scenarios.R +++ /dev/null @@ -1,207 +0,0 @@ -#' Create scenarios for African and Indian cities - NOT CURRENTLY USED -#' -#' Creates three scenarios where in each one, the mode share of a given mode is elevated by a set -#' percentage of the total trips. The scenario-modes are cycle, car, and bus and motorcycle. -#' -#' -#' Add 5% of trips overall in such a way that the average mean mode share for each mode across the -#' three distance bands is preserved. -#' -#' -#' @param trip_set data frame, baseline scenario -#' -#' @return list of baseline scenario and four mode scenarios -#' -#' @export -create_africa_india_scenarios <- function(trip_set){ - - rdr <- trip_set - trip_set <- NULL - - rd_list <- list() - - # africa india modal split across the three distance categories for each mode - # cycle, car, bus, motorcycle - africa_india_modeshares <- data.frame(c(36.8, 8.0, 1.7, 11.1), # distance category 0-2km - c(47.2, 33.8, 25.8, 37.2), # distance category 2-6km - c(16.0, 58.2, 72.7, 53.1)) - - percentage_change <- SCENARIO_INCREASE - - - rdr_baseline <- rdr %>% dplyr::select(c('trip_id', 'trip_distance_cat','scenario','trip_mode')) %>% filter() - rdr_baseline <- rdr_baseline %>% distinct() - - 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 - - # 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 * africa_india_modeshares[c,r] / percentage_trips - } - } - - - 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') - 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 - rdr_changeable_by_distance <- list() - for (j in 1:ncol(SCENARIO_PROPORTIONS)) { - target_distance <- target_distances[j] - rdr_changeable_by_distance[[j]] <- rdr_changeable %>% - filter(trip_distance_cat == target_distance) - } - 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] - rdr_all_by_distance[[j]] <- rdr %>% - filter(trip_distance_cat == target_distance) - } - - 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 - rdr_copy <- list() - for (j in 1:ncol(SCENARIO_PROPORTIONS)) { # Loop for each distance band - rdr_copy[[j]] <- rdr_changeable_by_distance[[j]] # Trips in the distance band - if (mode_name != "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) - - # Count the number of trips that were made by the trip mode - current_mode_trips <- rdr_copy[[j]] %>% - filter(trip_mode == mode_name) %>% distinct(trip_id) %>% nrow() - } else { - # 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) - - # 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")) %>% 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 - 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) - 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]) - - # 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) { - change_trip_ids <- base::sample(potential_trip_ids, - 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 - 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 - 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) - - # 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)) - #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)) - #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 - } # 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('WARNING: There are less trips that can be converted in scenario ',scen_warning[j] , - ' than should be converted for ', city)) - } - } - - return(rd_list) -} diff --git a/R/create_all_scenarios.R b/R/create_all_scenarios.R deleted file mode 100644 index 5fae85c5..00000000 --- a/R/create_all_scenarios.R +++ /dev/null @@ -1,1585 +0,0 @@ -#' Creates specific scenarios for Accra and Sao Paulo - NOT CURRENTLY USED -#' -#' Creates five prespecified scenarios from the baseline for Accra and Sao Paulo -#' -#' @param trip_set data frame of baseline trips -#' -#' @return list of scenarios -#' -#' @export -create_all_scenarios <- function(trip_set){ - - # Default city is set to accra - - if(CITY == 'accra'){ - - ############################################################### - rdr <- trip_set - tt <- length(unique(rdr$trip_id)) - rd_list <- list() - rd_list[[1]] <- rdr - # Scenario 1 - source_modes <- c('bus', 'pedestrian') - target_modes <- c('car') - source_percentages <- round(c(0.16, 0.49)* tt) - rdr <- create_scenario(rdr, scen_name = 'Scenario 1', source_modes = source_modes, - target_modes = target_modes, source_distance_cats = DIST_CAT, - source_trips = source_percentages) - rd_list[[2]] <- rdr - ############################################################### - # Scenario 2 - rdr <- rd_list[[2]] - # 35 % of all trips are bus. - # These come from car and taxi. - # All car and taxi trips > 6 km go to bus. Then 35 car and taxi trips 0--6 km go to bus. - source_modes <- c('car', 'taxi') - target_modes <- c('bus') - target_new_trips <- round(0.35 * tt - sum(rdr$trip_mode=='bus')) - total_car_trips <- filter(rdr, trip_mode %in% source_modes) - long_trips <- sum(total_car_trips$trip_distance_cat!=DIST_CAT[1]) - long_car_trips_sample <- create_scenario(total_car_trips, scen_name = 'Scenario 2', source_modes = source_modes, combined_modes = T, - target_modes = target_modes, source_distance_cats = DIST_CAT[2:3],source_trips = long_trips) - short_trips <- min( target_new_trips - long_trips, sum(total_car_trips$trip_distance_cat==DIST_CAT[1])) - if(short_trips>0){ - short_car_trips_sample <- create_scenario(total_car_trips, scen_name = 'Scenario 2', source_modes = source_modes, combined_modes = T, - target_modes = target_modes, source_distance_cats = DIST_CAT[1],source_trips = short_trips) - long_car_trips_sample <- rbind(long_car_trips_sample, short_car_trips_sample) - } - bus_trips <- long_car_trips_sample - - # Update selected rows for mode and duration - rdr$trip_mode[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$trip_mode - rdr$trip_distance[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$trip_distance - rdr$stage_mode[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$stage_mode - rdr$stage_distance[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$stage_distance - rdr$stage_duration[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$stage_duration - rdr$trip_distance_cat[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$trip_distance_cat - - rdr$scenario <- "Scenario 2" - rd_list[[3]] <- rdr - ############################################################### - # Scenario 3 - rdr <- rd_list[[2]] - # 16 % bus remain as is - # 10 % Mcycle increase - # x decrease car - source_modes <- c('car') - target_modes <- c('motorcycle') - target_new_trips <- max(round(0.1 * tt) - sum(rdr$trip_mode=='motorcycle'),1) - mcycle_trips_sample <- create_scenario(rdr, scen_name = 'Scenario 3', source_modes = source_modes, - combined_modes = T, target_modes = target_modes, - source_distance_cats = DIST_CAT, source_trips = target_new_trips) - # Update selected rows for mode and duration - rdr$trip_mode[match(mcycle_trips_sample$trip_id,rdr$trip_id)] <- mcycle_trips_sample$trip_mode - rdr$trip_distance[match(mcycle_trips_sample$trip_id,rdr$trip_id)] <- mcycle_trips_sample$trip_distance - rdr$stage_mode[match(mcycle_trips_sample$trip_id,rdr$trip_id)] <- mcycle_trips_sample$stage_mode - rdr$stage_distance[match(mcycle_trips_sample$trip_id,rdr$trip_id)] <- mcycle_trips_sample$stage_distance - rdr$stage_duration[match(mcycle_trips_sample$trip_id,rdr$trip_id)] <- mcycle_trips_sample$stage_duration - rdr$scenario <- "Scenario 3" - rd_list[[4]] <- rdr - #return(rd_list) - ############################################################### - # Scenario 4 - rdr <- rd_list[[2]] - # 3.5 % Cycle - source_modes <- c('motorcycle', 'car', 'taxi') - target_modes <- c('cycle') - mtrips <- max(min(52,sum(rdr$trip_mode == 'motorcycle')),1) - btrips <- sum(rdr$trip_mode == 'cycle') - ctrips <- max(min(round(0.035 * tt) - btrips - mtrips, sum(rdr$trip_mode %in% c('car', 'taxi')&rdr$trip_distance_cat==DIST_CAT[1])),1) - target_new_trips <- c(mtrips, ctrips) - mbike_trips <- create_scenario(rdr, scen_name = 'Scenario 4', source_modes = source_modes[1],combined_modes = T, - target_modes = target_modes,source_distance_cats = DIST_CAT,source_trips = target_new_trips[1]) - car_trips <- create_scenario(rdr, scen_name = 'Scenario 4', source_modes = c(source_modes[2], source_modes[3]),combined_modes = T, - target_modes = target_modes,source_distance_cats = DIST_CAT[1],source_trips = target_new_trips[2]) # todo: source_modes has 2 elements, so source_trips should too, otherwise it'll return an error? - car_mbike_trips <- rbind(mbike_trips, car_trips) - # Update selected rows for mode and duration - rdr$trip_mode[match(car_mbike_trips$trip_id,rdr$trip_id)] <- car_mbike_trips$trip_mode - rdr$trip_distance[match(car_mbike_trips$trip_id,rdr$trip_id)] <- car_mbike_trips$trip_distance - rdr$stage_mode[match(car_mbike_trips$trip_id,rdr$trip_id)] <- car_mbike_trips$stage_mode - rdr$stage_distance[match(car_mbike_trips$trip_id,rdr$trip_id)] <- car_mbike_trips$stage_distance - rdr$stage_duration[match(car_mbike_trips$trip_id,rdr$trip_id)] <- car_mbike_trips$stage_duration - rdr$scenario <- "Scenario 4" - rd_list[[5]] <- rdr - ############################################################### - # Scenario 5 - rdr <- rd_list[[2]] - # 3.5 % Cycle - source_modes <- c('car', 'taxi') - target_modes <- c('pedestrian') - target_new_trips <- min(round(0.54 * tt) - sum(rdr$trip_mode == target_modes), sum(rdr$trip_mode%in%source_modes&rdr$trip_distance_cat==DIST_CAT[1])) - motorised_trips <- create_scenario(rdr, scen_name = 'Scenario 4', source_modes = source_modes, combined_modes = T, - target_modes = target_modes,source_distance_cats = DIST_CAT[1],source_trips = target_new_trips) - # Update selected rows for mode and duration - rdr$trip_mode[match(motorised_trips$trip_id,rdr$trip_id)] <- motorised_trips$trip_mode - rdr$trip_distance[match(motorised_trips$trip_id,rdr$trip_id)] <- motorised_trips$trip_distance - rdr$stage_mode[match(motorised_trips$trip_id,rdr$trip_id)] <- motorised_trips$stage_mode - rdr$stage_distance[match(motorised_trips$trip_id,rdr$trip_id)] <- motorised_trips$stage_distance - rdr$stage_duration[match(motorised_trips$trip_id,rdr$trip_id)] <- motorised_trips$stage_duration - rdr$scenario <- "Scenario 5" - rd_list[[6]] <- rdr - - - return(rd_list) - } - - if(CITY == 'sao_paulo'){ - - ############################################################### - rdr <- trip_set - tt <- length(unique(rdr$trip_id)) - rd_list <- list() - rd_list[[1]] <- rdr - # Scenario 1 - source_modes <- c('bus', 'pedestrian') - target_modes <- c('car') - source_percentages <- round(c(0.15, 0.20)* tt) - rdr <- create_scenario(rdr, scen_name = 'Scenario 1', source_modes = source_modes, - target_modes = target_modes, source_distance_cats = DIST_CAT, - source_trips = source_percentages) - rd_list[[2]] <- rdr - ############################################################### - # Scenario 2 - rdr <- rd_list[[2]] - # 35 % of all trips are bus. - # These come from car and taxi. - # All car and taxi trips > 6 km go to bus. Then 35 car and taxi trips 0--6 km go to bus. - source_modes <- c('car', 'taxi') - target_modes <- c('bus') - target_new_trips <- round(0.35 * tt - sum(rdr$trip_mode=='bus')) - total_car_trips <- filter(rdr, trip_mode %in% source_modes) - long_trips <- sum(total_car_trips$trip_distance_cat!=DIST_CAT[1]) - long_car_trips_sample <- create_scenario(total_car_trips, scen_name = 'Scenario 2', source_modes = source_modes, combined_modes = T, - target_modes = target_modes, source_distance_cats = DIST_CAT[2:3],source_trips = long_trips) - short_trips <- min( target_new_trips - long_trips, sum(total_car_trips$trip_distance_cat==DIST_CAT[1])) - if(short_trips>0){ - short_car_trips_sample <- create_scenario(total_car_trips, scen_name = 'Scenario 2', source_modes = source_modes, combined_modes = T, - target_modes = target_modes, source_distance_cats = DIST_CAT[1],source_trips = short_trips) - long_car_trips_sample <- rbind(long_car_trips_sample, short_car_trips_sample) - } - bus_trips <- long_car_trips_sample - - # Update selected rows for mode and duration - rdr$trip_mode[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$trip_mode - rdr$trip_distance[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$trip_distance - rdr$stage_mode[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$stage_mode - rdr$stage_distance[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$stage_distance - rdr$stage_duration[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$stage_duration - rdr$trip_distance_cat[match(bus_trips$trip_id,rdr$trip_id)] <- bus_trips$trip_distance_cat - - rdr$scenario <- "Scenario 2" - rd_list[[3]] <- rdr - - ############################################################### - # Scenario 3 - rdr <- rd_list[[2]] - # 16 % bus remain as is - # 10 % Mcycle increase - # x decrease car - source_modes <- c('car') - target_modes <- c('motorcycle') - target_new_trips <- max(round(0.1 * tt) - sum(rdr$trip_mode=='motorcycle'),1) - mcycle_trips_sample <- create_scenario(rdr, scen_name = 'Scenario 3', source_modes = source_modes, - combined_modes = T, target_modes = target_modes, - source_distance_cats = DIST_CAT, source_trips = target_new_trips) - # Update selected rows for mode and duration - rdr$trip_mode[match(mcycle_trips_sample$trip_id,rdr$trip_id)] <- mcycle_trips_sample$trip_mode - rdr$trip_distance[match(mcycle_trips_sample$trip_id,rdr$trip_id)] <- mcycle_trips_sample$trip_distance - rdr$stage_mode[match(mcycle_trips_sample$trip_id,rdr$trip_id)] <- mcycle_trips_sample$stage_mode - rdr$stage_distance[match(mcycle_trips_sample$trip_id,rdr$trip_id)] <- mcycle_trips_sample$stage_distance - rdr$stage_duration[match(mcycle_trips_sample$trip_id,rdr$trip_id)] <- mcycle_trips_sample$stage_duration - rdr$scenario <- "Scenario 3" - rd_list[[4]] <- rdr - - - ############################################################### - # Scenario 4 - rdr <- rd_list[[2]] - # 3.5 % Cycle - source_modes <- c('motorcycle', 'car', 'taxi') - target_modes <- c('cycle') - mtrips <- max(min(52,sum(rdr$trip_mode == 'motorcycle')),1) - btrips <- sum(rdr$trip_mode == 'cycle') - ctrips <- max(min(round(0.035 * tt) - btrips - mtrips, sum(rdr$trip_mode %in% c('car', 'taxi')&rdr$trip_distance_cat==DIST_CAT[1])),1) - target_new_trips <- c(mtrips, ctrips) - mbike_trips <- create_scenario(rdr, scen_name = 'Scenario 4', source_modes = source_modes[1],combined_modes = T, - target_modes = target_modes,source_distance_cats = DIST_CAT,source_trips = target_new_trips[1]) - car_trips <- create_scenario(rdr, scen_name = 'Scenario 4', source_modes = c(source_modes[2], source_modes[3]),combined_modes = T, - target_modes = target_modes,source_distance_cats = DIST_CAT[1],source_trips = target_new_trips[2]) - car_mbike_trips <- rbind(mbike_trips, car_trips) - # Update selected rows for mode and duration - rdr$trip_mode[match(car_mbike_trips$trip_id,rdr$trip_id)] <- car_mbike_trips$trip_mode - rdr$trip_distance[match(car_mbike_trips$trip_id,rdr$trip_id)] <- car_mbike_trips$trip_distance - rdr$stage_mode[match(car_mbike_trips$trip_id,rdr$trip_id)] <- car_mbike_trips$stage_mode - rdr$stage_distance[match(car_mbike_trips$trip_id,rdr$trip_id)] <- car_mbike_trips$stage_distance - rdr$stage_duration[match(car_mbike_trips$trip_id,rdr$trip_id)] <- car_mbike_trips$stage_duration - rdr$scenario <- "Scenario 4" - rd_list[[5]] <- rdr - ############################################################### - # Scenario 5 - rdr <- rd_list[[2]] - # 3.5 % Cycle - source_modes <- c('car', 'taxi') - target_modes <- c('pedestrian') - target_new_trips <- min(round(0.54 * tt) - sum(rdr$trip_mode == target_modes), sum(rdr$trip_mode%in%source_modes&rdr$trip_distance_cat==DIST_CAT[1])) - motorised_trips <- create_scenario(rdr, scen_name = 'Scenario 4', source_modes = source_modes, combined_modes = T, - target_modes = target_modes,source_distance_cats = DIST_CAT[1],source_trips = target_new_trips) - # Update selected rows for mode and duration - rdr$trip_mode[match(motorised_trips$trip_id,rdr$trip_id)] <- motorised_trips$trip_mode - rdr$trip_distance[match(motorised_trips$trip_id,rdr$trip_id)] <- motorised_trips$trip_distance - rdr$stage_mode[match(motorised_trips$trip_id,rdr$trip_id)] <- motorised_trips$stage_mode - rdr$stage_distance[match(motorised_trips$trip_id,rdr$trip_id)] <- motorised_trips$stage_distance - rdr$stage_duration[match(motorised_trips$trip_id,rdr$trip_id)] <- motorised_trips$stage_duration - rdr$scenario <- "Scenario 5" - rd_list[[6]] <- rdr - - return(rd_list) - } - - #---- - if (CITY == 'bogota_wb') { - - ############################################################### - # Scenario 1: women's mode share is equal to men's - rd_list <- list() - - rdr_full <- trip_set - - rd_list[[1]] <- rdr_full # baseline - - # names(rdr) - # cbind(table(trip_set$trip_mode, trip_set$sex), - # prop.table(table(trip_set$trip_mode, trip_set$sex),margin = 2)) #Proportion of each sex - # table(trip_set$trip_distance_cat, trip_set$trip_mode) - - # subset of trips that are going to be changed - rdr <- trip_set[trip_set$sex == "female",] - - # Total number of trips made by female - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.08327304572973, # cycle instead of bicycle - 0.31468225259871, - 0.12532840878803, - 0.08327304572973, - 0.01913338156342, - 0.40378098465522, # Pedestrian instead of walk - 0.05380192666489)) - # 0.05380192666489, - # 0.40378098465522)) - - # Difference of trips between baseline and scenario 1 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Redistribution of bus trips to bicycle on any distance - source_modes <- c('bus') - target_modes <- c('cycle') - b2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 1', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[1]*-1) - - # Redistribution of car trips to bicycle on any distance - source_modes <- c('car') - target_modes <- c('cycle') - c2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 1', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[2]*-1) - - # Redistribution of motorcycle trips to bicycle on any distance - source_modes <- c('motorcycle') - target_modes <- c('cycle') - m2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 1', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[4]*-1) - - # Redistribution of taxi trips to bicycle on any distance - source_modes <- c('taxi') - target_modes <- c('cycle') - t2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 1', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[6]*-1) - - # Redistribution of walking trips to bicycle on any distance - source_modes <- c('pedestrian') - target_modes <- c('cycle') - w2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 1', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[5]*-1) - - redistribute_trips <- rbind(b2bb_trips, c2bb_trips, m2bb_trips, - t2bb_trips, w2bb_trips) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - rdr_full <- rbind(rdr_full[rdr_full$sex == "male",], rdr[,-ncol(rdr)]) - rdr_full$scenario <- "Scenario 1" - rd_list[[2]] <- rdr_full - - rm(rdr_full, rdr, tt, new_trips, diff_trips, rdr2, b2bb_trips, c2bb_trips, - m2bb_trips, t2bb_trips, w2bb_trips, redistribute_trips, source_modes, - target_modes) - - # ############################################################### - # Scenario 2 - # To proportion of bicycle is the same for each socio-economical stratum. - # The value assigned is the stratum that have the highest proportion, which in - # this case is stratum 2. - rdr_full <- trip_set - - # cbind(table(trip_set$trip_mode, trip_set$strata), - # prop.table(table(trip_set$trip_mode, trip_set$strata),margin = 2)) #Proportion of each sex - # table(trip_set$trip_distance_cat, trip_set$trip_mode) - - # strata 1 - # subset of trips that are going to be changed - rdr <- trip_set[trip_set$strata == 1,] - - # Total number of trips made by strata 1 - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.06476578411405, # cycle instead of bicycle - 0.38932790224033, - 0.03934826883910, - 0.06476578411405, - 0.05409368635438, - 0.43560081466395, # Pedestrian instead of walk - 0.01694501018330)) - # 0.01694501018330, - # 0.43560081466395)) - - # Difference of trips between baseline and scenario 2 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Redistribution of bus trips to bicycle on any distance - source_modes <- c('bus') - target_modes <- c('cycle') - b2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[1]*-1) - - # Redistribution of car trips to bicycle on any distance - source_modes <- c('car') - target_modes <- c('cycle') - c2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[2]*-1) - - # Redistribution of motorcycle trips to bicycle on any distance - source_modes <- c('motorcycle') - target_modes <- c('cycle') - m2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[4]*-1) - - # Redistribution of taxi trips to bicycle on any distance - source_modes <- c('taxi') - target_modes <- c('cycle') - t2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[6]*-1) - - # Redistribution of walking trips to bicycle on any distance - source_modes <- c('pedestrian') - target_modes <- c('cycle') - w2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[5]*-1) - - redistribute_trips <- rbind(b2bb_trips, c2bb_trips, m2bb_trips, t2bb_trips, - w2bb_trips) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - # Save updated trips in other object - rdr_1 <- rdr - - ##### - ### strata 3 - # subset of trips that are going to be changed - rdr <- trip_set[trip_set$strata == 3,] - - # Total number of trips made by strata 3 - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.06474470699163, # cycle instead of bicycle - 0.31338038229664, - 0.15077573644961, - 0.06474470699163, - 0.04405840166862, - 0.37515357581645, # Pedestrian instead of walk - 0.05188719677705)) - # 0.05188719677705, - # 0.37515357581645)) - - # Difference of trips between baseline and scenario 2 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Redistribution of bus trips to bicycle on any distance - source_modes <- c('bus') - target_modes <- c('cycle') - b2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[1]*-1) - - # Redistribution of car trips to bicycle on any distance - source_modes <- c('car') - target_modes <- c('cycle') - c2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[2]*-1) - - # Redistribution of motorcycle trips to bicycle on any distance - source_modes <- c('motorcycle') - target_modes <- c('cycle') - m2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[4]*-1) - - # Redistribution of taxi trips to bicycle on any distance - source_modes <- c('taxi') - target_modes <- c('cycle') - t2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[6]*-1) - - # Redistribution of walking trips to bicycle on any distance - source_modes <- c('pedestrian') - target_modes <- c('cycle') - w2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[5]*-1) - - redistribute_trips <- rbind(b2bb_trips, c2bb_trips, m2bb_trips, t2bb_trips, - w2bb_trips) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - # Save updated trips in other object - rdr_3 <- rdr - - #### - # strata 4 - # subset of trips that are going to be changed - rdr <- trip_set[trip_set$strata == 4,] - - # Total number of trips made by strata 4 - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.06471421823335, # cycle instead of bicycle - 0.25980160604629, - 0.30278696268304, - 0.06471421823335, - 0.01747756258857, - 0.26337809568797, # Pedestrian instead of walk - 0.09177407382414)) - # 0.09177407382414, - # 0.26337809568797)) - - # Difference of trips between baseline and scenario 2 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Redistribution of bus trips to bicycle on any distance - source_modes <- c('bus') - target_modes <- c('cycle') - b2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[1]*-1) - - # Redistribution of car trips to bicycle on any distance - source_modes <- c('car') - target_modes <- c('cycle') - c2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[2]*-1) - - # Redistribution of motorcycle trips to bicycle on any distance - source_modes <- c('motorcycle') - target_modes <- c('cycle') - m2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[4]*-1) - - # Redistribution of taxi trips to bicycle on any distance - source_modes <- c('taxi') - target_modes <- c('cycle') - t2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[6]*-1) - - # Redistribution of walking trips to bicycle on any distance - source_modes <- c('pedestrian') - target_modes <- c('cycle') - w2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[5]*-1) - - redistribute_trips <- rbind(b2bb_trips, c2bb_trips, m2bb_trips, t2bb_trips, - w2bb_trips) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - # Save updated trips in other object - rdr_4 <- rdr - - ##### - # strata 5 - # subset of trips that are going to be changed - rdr <- trip_set[trip_set$strata == 5,] - - # Total number of trips made by strata 5 - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.06476545842217, # cycle instead of bicycle - 0.17937100213220, - 0.42057569296375, - 0.06476545842217, - 0.01918976545842, - 0.22547974413646, # Pedestrian instead of walk - 0.09035181236674)) - # 0.09035181236674, - # 0.22547974413646)) - - # Difference of trips between baseline and scenario 2 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Redistribution of bus trips to bicycle on any distance - source_modes <- c('bus') - target_modes <- c('cycle') - b2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[1]*-1) - - # Redistribution of car trips to bicycle on any distance - source_modes <- c('car') - target_modes <- c('cycle') - c2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[2]*-1) - - # Redistribution of motorcycle trips to bicycle on any distance - source_modes <- c('motorcycle') - target_modes <- c('cycle') - m2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[4]*-1) - - # Redistribution of taxi trips to bicycle on any distance - source_modes <- c('taxi') - target_modes <- c('cycle') - t2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[6]*-1) - - # Redistribution of walking trips to bicycle on any distance - source_modes <- c('pedestrian') - target_modes <- c('cycle') - w2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[5]*-1) - - redistribute_trips <- rbind(b2bb_trips, c2bb_trips, m2bb_trips, t2bb_trips, - w2bb_trips) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - # Save updated trips in other object - rdr_5 <- rdr - - # strata 6 - # subset of trips that are going to be changed - rdr <- trip_set[trip_set$strata == 6,] - - # Total number of trips made by strata 6 - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.06485484867202, # cycle instead of bicycle - 0.10809141445337, - 0.44379246448425, - 0.06485484867202, - 0.01142680667078, - 0.28752316244595, # Pedestrian instead of walk - 0.08431130327363)) - # 0.08431130327363, - # 0.28752316244595)) - - # Difference of trips between baseline and scenario 2 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Redistribution of bus trips to bicycle on any distance - source_modes <- c('bus') - target_modes <- c('cycle') - b2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[1]*-1) - - # Redistribution of car trips to bicycle on any distance - source_modes <- c('car') - target_modes <- c('cycle') - c2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[2]*-1) - - # Redistribution of motorcycle trips to bicycle on any distance - source_modes <- c('motorcycle') - target_modes <- c('cycle') - m2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[4]*-1) - - # Redistribution of taxi trips to bicycle on any distance - source_modes <- c('taxi') - target_modes <- c('cycle') - t2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[6]*-1) - - # Redistribution of walking trips to bicycle on any distance - source_modes <- c('pedestrian') - target_modes <- c('cycle') - w2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 2', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[5]*-1) - - redistribute_trips <- rbind(b2bb_trips, c2bb_trips, m2bb_trips, t2bb_trips, - w2bb_trips) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - # Save updated trips in other object - rdr_6 <- rdr - - # Join all trips in a single dataset - rdr_full <- rbind(rdr_full[rdr_full$strata == 2,], rdr_1[,-ncol(rdr_1)], - rdr_3[,-ncol(rdr_3)], rdr_4[,-ncol(rdr_4)], - rdr_5[,-ncol(rdr_5)], rdr_6[,-ncol(rdr_6)]) - rdr_full$scenario <- "Scenario 2" - rd_list[[3]] <- rdr_full - - rm(rdr_full, rdr, tt, new_trips, diff_trips, rdr2, b2bb_trips, c2bb_trips, m2bb_trips, t2bb_trips, w2bb_trips, redistribute_trips, source_modes, - target_modes, rdr_1, rdr_3, rdr_4, rdr_5, rdr_6) - - ############################################################### - # Scenario 3: Duplicar viajes en bici, todos vienen del carro - rdr_full <- trip_set - - # cbind(table(trip_set$trip_mode), prop.table(table(trip_set$trip_mode))) - # table(trip_set$trip_distance_cat, trip_set$trip_mode) - - # subset of trips that are going to be changed - rdr <- rdr_full - - # Total number of trips made by female - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.10327060481031, # cycle instead of bicycle - 0.31946261447117, - 0.10407567676361, - 0.10327060481031, - 0.04491295159505, - 0.37886686122572, # Pedestrian instead of walk - 0.04941129113415)) - # 0.04941129113415, - # 0.37886686122572)) - - # Difference of trips between baseline and scenario 3 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Define weights to give priority to short and medium distances - rdr2$w <- NA - rdr2$w[rdr2$trip_distance_cat == "0-6 km"] <- 10 - rdr2$w[rdr2$trip_distance_cat == "7-15 km"] <- 10 - rdr2$w[rdr2$trip_distance_cat == "16+ km"] <- 1 - - # Redistribution of car trips to bicycle on any distance - source_modes <- c('car') - target_modes <- c('cycle') - c2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 3', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT, - source_trips = diff_trips[2]*-1) - - redistribute_trips <- c2bb_trips - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - rdr_full <- rdr[,-ncol(rdr)] - rdr_full$scenario <- "Scenario 3" - rd_list[[4]] <- rdr_full - - rm(rdr_full, rdr, tt, new_trips, diff_trips, rdr2, c2bb_trips, - redistribute_trips, source_modes, target_modes) - # cbind(table(rd_list[[4]]$trip_mode), - # prop.table(table(rd_list[[4]]$trip_mode))) - - - ############################################################### - # Scenario 4: Duplicar viajes en bici, todos vienen de transporte privado, - # Carro y moto - rdr_full <- trip_set - - # cbind(table(trip_set$trip_mode), prop.table(table(trip_set$trip_mode))) - # table(trip_set$trip_distance_cat, trip_set$trip_mode) - - # subset of trips that are going to be changed - rdr <- rdr_full - - # Total number of trips made by female - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.10327060481031, # cycle instead of bicycle - 0.31946261447117, - 0.11651403844219, - 0.10327060481031, - 0.03247458991647, - 0.37886686122572, # Pedestrian instead of walk - 0.04941129113415)) - # 0.04941129113415, - # 0.37886686122572)) - - # Difference of trips between baseline and scenario 3 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Define weights to give priority to short and medium distances - rdr2$w <- NA - rdr2$w[rdr2$trip_distance_cat == "0-6 km"] <- 10 - rdr2$w[rdr2$trip_distance_cat == "7-15 km"] <- 10 - rdr2$w[rdr2$trip_distance_cat == "16+ km"] <- 1 - - # Redistribution of car trips to bicycle on any distance - source_modes <- c('car') - target_modes <- c('cycle') - c2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 4', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT, - source_trips = diff_trips[2]*-1) - - # Redistribution of motorcycle trips to bicycle on any distance - source_modes <- c('motorcycle') - target_modes <- c('cycle') - m2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 4', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[4]*-1) - - redistribute_trips <- rbind(c2bb_trips, m2bb_trips) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - rdr_full <- rdr[,-ncol(rdr)] - rdr_full$scenario <- "Scenario 4" - rd_list[[5]] <- rdr_full - - rm(rdr_full, rdr, tt, new_trips, diff_trips, rdr2, c2bb_trips, m2bb_trips, - redistribute_trips, source_modes, target_modes) - # cbind(table(rd_list[[5]]$trip_mode), - # prop.table(table(rd_list[[5]]$trip_mode))) - - ############################################################### - # Scenario 5: Duplicar viajes en bici, todos vienen del transporte publico - rdr_full <- trip_set - - # cbind(table(trip_set$trip_mode), prop.table(table(trip_set$trip_mode))) - # table(trip_set$trip_distance_cat, trip_set$trip_mode) - - # subset of trips that are going to be changed - rdr <- rdr_full - - # Total number of trips made by female - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.10327060481031, # cycle instead of bicycle - 0.26782731206602, - 0.15571097916876, - 0.10327060481031, - 0.04491295159505, - 0.37886686122572, # Pedestrian instead of walk - 0.04941129113415)) - # 0.04941129113415, - # 0.37886686122572)) - - # Difference of trips between baseline and scenario 3 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Define weights to give priority to short and medium distances - rdr2$w <- NA - rdr2$w[rdr2$trip_distance_cat == "0-6 km"] <- 10 - rdr2$w[rdr2$trip_distance_cat == "7-15 km"] <- 10 - rdr2$w[rdr2$trip_distance_cat == "16+ km"] <- 1 - - # Redistribution of bus trips to bicycle on any distance - source_modes <- c('bus') - target_modes <- c('cycle') - b2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 5', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT, - source_trips = diff_trips[1]*-1) - - redistribute_trips <- b2bb_trips - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - rdr_full <- rdr[,-ncol(rdr)] - rdr_full$scenario <- "Scenario 5" - rd_list[[6]] <- rdr_full - - rm(rdr_full, rdr, tt, new_trips, diff_trips, rdr2, b2bb_trips, - redistribute_trips, source_modes, target_modes) - - ############################################################### - # Scenario 6: Duplicar viajes en bici, todos vienen a pie - rdr_full <- trip_set - - # cbind(table(trip_set$trip_mode), prop.table(table(trip_set$trip_mode))) - # table(trip_set$trip_distance_cat, trip_set$trip_mode) - - # subset of trips that are going to be changed - rdr <- rdr_full - - # Total number of trips made by female - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.10327060481031, # cycle instead of bicycle - 0.31946261447117, - 0.15571097916876, - 0.10327060481031, - 0.04491295159505, - 0.32723155882057, # Pedestrian instead of walk - 0.04941129113415)) - # 0.04941129113415, - # 0.32723155882057)) - - # Difference of trips between baseline and scenario 3 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Redistribution of walking trips to bicycle on any distance - source_modes <- c('pedestrian') - target_modes <- c('cycle') - w2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 6', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[5]*-1) - - redistribute_trips <- w2bb_trips - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - rdr_full <- rdr[,-ncol(rdr)] - rdr_full$scenario <- "Scenario 6" - rd_list[[7]] <- rdr_full - - rm(rdr_full, rdr, tt, new_trips, diff_trips, rdr2, w2bb_trips, - redistribute_trips, source_modes, target_modes) - - ############################################################### - # Scenario 7: ciudad expandida y dependiente del carro - rdr_full <- trip_set - - # cbind(table(trip_set$trip_mode), prop.table(table(trip_set$trip_mode))) - # table(trip_set$trip_distance_cat, trip_set$trip_mode) - - # subset of trips that are going to be changed - rdr <- rdr_full - - # Total number of trips made by female - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.05121642758680, # cycle instead of bicycle - 0.28518396888884, - 0.18533738859104, - 0.05121642758680, - 0.05345833162812, - 0.37579342541177, # Pedestrian instead of walk - 0.04901045789343)) - # 0.04901045789343, - # 0.37579342541177)) - - # Difference of trips between baseline and scenario 7 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Redistribution of walking trips to motorcycle on medium and large distance - source_modes <- c('pedestrian') - target_modes <- c('motorcycle') - w2m_trips <- create_scenario(rdr, scen_name = 'Scenario 7', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-1], - source_trips = diff_trips[5]*-1) - - # Redistribution of taxi trips to motorcycle on any distance - source_modes <- c('taxi') - target_modes <- c('motorcycle') - t2m_trips <- create_scenario(rdr, scen_name = 'Scenario 7', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT, - source_trips = diff_trips[6]*-1) - - # Redistribution of bicycle trips to motorcycle on any distance - source_modes <- c('cycle') - target_modes <- c('motorcycle') - bb2m_trips <- create_scenario(rdr, scen_name = 'Scenario 7', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT, - source_trips = diff_trips[3]*-1) - - # Redistribution of bus trips to car on any distance - source_modes <- c('bus') - target_modes <- c('car') - b2c_trips <- create_scenario(rdr, scen_name = 'Scenario 7', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT, - source_trips = diff_trips[2]) - - # Redistribution of bus trips to motorcycle on any distance - source_modes <- c('bus') - target_modes <- c('motorcycle') - remaining_m <- diff_trips[4] + diff_trips[6] + diff_trips[5] + diff_trips[3] - rdr2 <- rdr[-match(b2c_trips$id,rdr$id),] - b2m_trips <- create_scenario(rdr2, scen_name = 'Scenario 7', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT, - source_trips = remaining_m) - - - redistribute_trips <- rbind(w2m_trips, t2m_trips, bb2m_trips, b2c_trips, - b2m_trips) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - rdr_full <- rdr[,-ncol(rdr)] - rdr_full$scenario <- "Scenario 7" - rd_list[[8]] <- rdr_full - - rm(rdr_full, rdr, tt, new_trips, diff_trips, rdr2, w2m_trips, t2m_trips, - bb2m_trips, b2c_trips, b2m_trips, remaining_m, - redistribute_trips, source_modes, target_modes) - - ############################################################### - # Scenario 8: ciudad densa y transporte público - rdr_full <- trip_set - - # cbind(table(trip_set$trip_mode), prop.table(table(trip_set$trip_mode))) - # table(trip_set$trip_distance_cat, trip_set$trip_mode) - - # subset of trips that are going to be changed - rdr <- rdr_full - - # Total number of trips made by female - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.05500569514238, # cycle instead of bicycle - 0.34031490787270, - 0.12440603015075, - 0.05500569514238, - 0.03588341708543, - 0.40359664991625, # Pedestrian instead of walk - 0.04079329983250)) - # 0.04079329983250, - # 0.40359664991625)) - - # Difference of trips between baseline and scenario 7 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Redistribution of car trips to bicycle on any distance - source_modes <- c('car') - target_modes <- c('cycle') - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - c2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 8', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[3]) - - # Redistribution of car trips to bus on any distance - source_modes <- c('car') - target_modes <- c('bus') - # bus trips shouldnt be the same as those chosen to be bicycle - rdr3 <- rdr[-match(c2bb_trips$id,rdr$id),] - c2b_trips <- create_scenario(rdr3, scen_name = 'Scenario 8', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT, - source_trips = diff_trips[1]) - - # Redistribution of car trips to walk on short distance - source_modes <- c('car') - target_modes <- c('pedestrian') - remaining_c <- (diff_trips[2] + diff_trips[3] + diff_trips[1])*-1 - # walking trips shouldnt be the same as those chosen to be bicycle - rdr4 <- rdr3[-match(c2b_trips$id,rdr3$id),] - c2w_trips <- create_scenario(rdr4, scen_name = 'Scenario 8', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[1], - source_trips = remaining_c) - - # Redistribution of motorcycle trips to walk on short distance - source_modes <- c('motorcycle') - target_modes <- c('pedestrian') - - # Define weights to give priority to short and medium distances - rdr5 <- rdr - rdr5$w <- NA - rdr5$w[rdr2$trip_distance_cat == "0-6 km"] <- 100 - rdr5$w[rdr2$trip_distance_cat == "7-15 km"] <- 10 - rdr5$w[rdr2$trip_distance_cat == "16+ km"] <- 1 - - m2w_trips <- create_scenario(rdr5, scen_name = 'Scenario 8', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[4]*-1) - - # Redistribution of taxi trips to walk on short distance - source_modes <- c('taxi') - target_modes <- c('pedestrian') - t2w_trips <- create_scenario(rdr5, scen_name = 'Scenario 8', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[6]*-1) - - redistribute_trips <- rbind(c2b_trips, c2bb_trips, c2w_trips, - m2w_trips[,-ncol(m2w_trips)], - t2w_trips[,-ncol(t2w_trips)]) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - rdr_full <- rdr[,-ncol(rdr)] - rdr_full$scenario <- "Scenario 8" - rd_list[[9]] <- rdr_full - - rm(rdr_full, rdr, tt, new_trips, diff_trips, c2b_trips, c2bb_trips, - c2w_trips, m2w_trips, t2w_trips, remaining_c, rdr2, rdr3, rdr4, - redistribute_trips, source_modes, target_modes) - - ############################################################### - # Scenario 9: ciudad compartida post COVID - rdr_full <- trip_set - - # cbind(table(trip_set$trip_mode), prop.table(table(trip_set$trip_mode))) - # table(trip_set$trip_distance_cat, trip_set$trip_mode) - - # subset of trips that are going to be changed - rdr <- rdr_full - - # Total number of trips made by female - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.05606484443955, # cycle instead of bicycle - 0.33138259403709, - 0.14189691819549, - 0.05606484443955, - 0.04092845252417, - 0.38565751013329, # Pedestrian instead of walk - 0.04406968067042)) - # 0.04406968067042, - # 0.38565751013329)) - - # Difference of trips between baseline and scenario 7 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Redistribution of motorcycle trips to bicycle on short and medium distance - source_modes <- c('motorcycle') - target_modes <- c('cycle') - m2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 9', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[4]*-1) - - # Redistribution of taxi trips to bicycle on short and medium distance - source_modes <- c('taxi') - target_modes <- c('cycle') - t2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 9', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[3] + diff_trips[4]) - - # Redistribution of taxi trips to bus on any distance - source_modes <- c('taxi') - target_modes <- c('bus') - remaining_t <- (diff_trips[6] + diff_trips[3] + diff_trips[4])*-1 - # bus trips shouldnt be the same as those chosen to be bicycle - rdr3 <- rdr[-match(t2bb_trips$id,rdr$id),] - t2b_trips <- create_scenario(rdr3, scen_name = 'Scenario 9', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT, - source_trips = remaining_t) - - # Redistribution of car trips to walking on short distance - source_modes <- c('car') - target_modes <- c('pedestrian') - c2w_trips <- create_scenario(rdr, scen_name = 'Scenario 9', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[1], - source_trips = diff_trips[5]) - - # Redistribution of car trips to bus on any distance - source_modes <- c('car') - target_modes <- c('bus') - # bus trips shouldnt be the same as those chosen to be walking - rdr4 <- rdr[-match(c2w_trips$id,rdr$id),] - c2b_trips <- create_scenario(rdr4, scen_name = 'Scenario 9', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT, - source_trips = (diff_trips[2] + diff_trips[5])*-1) - - redistribute_trips <- rbind(c2w_trips, c2b_trips, t2b_trips, t2bb_trips, - m2bb_trips) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - rdr_full <- rdr[,-ncol(rdr)] - rdr_full$scenario <- "Scenario 9" - rd_list[[10]] <- rdr_full - - rm(rdr_full, rdr, tt, new_trips, diff_trips, c2w_trips, c2b_trips, - t2b_trips, t2bb_trips, rdr2, rdr3, rdr4, remaining_t, m2bb_trips, - redistribute_trips, source_modes, target_modes) - - ############################################################### - # Scenario 10: Escenario de Javier Peña - rdr_full <- trip_set - - # cbind(table(trip_set$trip_mode), prop.table(table(trip_set$trip_mode))) - # table(trip_set$trip_distance_cat, trip_set$trip_mode) - - # subset of trips that are going to be changed - rdr <- rdr_full - - # Total number of trips made by female - tt <- nrow(rdr) - - # Define new proportions - # This is the order of proportions: bicycle, bus, car, motorcycle, taxi, walk - new_trips <- round(tt * c(#0.10359627867295, # cycle instead of bicycle - 0.30565187390953, - 0.13983792956414, - 0.10359627867295, - 0.04048315192109, - 0.36660415642052, # Pedestrian instead of walk - 0.04382660951177)) - # 0.04382660951177, - # 0.36660415642052)) - - # Difference of trips between baseline and scenario 3 - diff_trips <- new_trips - table(rdr$trip_mode) - - # Create new id to avoid duplicates at the end of the redistribution - rdr$id <- 1:nrow(rdr) - - # Subset dataset with restrictions - rdr2 <- subset(rdr, !(trip_motive %in% c(4,7,8)) & - (age >= 16 & age <= 62) & - (strptime(trip_start_time, "%H:%M") >= strptime("05:30", "%H:%M") & - strptime(trip_start_time, "%H:%M") <= strptime("23:30", "%H:%M")) & - (limitation == 0)) - - # Redistribution of bus trips to bicycle on short and medium distance - source_modes <- c('bus') - target_modes <- c('cycle') - b2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 10', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[1]*-1) - - # Redistribution of car trips to bicycle on short and medium distance - source_modes <- c('car') - target_modes <- c('cycle') - c2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 10', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[2]*-1) - - # Redistribution of motorcycle trips to bicycle on short and medium distance - source_modes <- c('motorcycle') - target_modes <- c('cycle') - m2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 10', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[4]*-1) - - # Redistribution of taxi trips to bicycle on short and medium distance - source_modes <- c('taxi') - target_modes <- c('cycle') - t2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 10', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[6]*-1) - - # Redistribution of walk trips to bicycle on short and medium distance - source_modes <- c('pedestrian') - target_modes <- c('cycle') - w2bb_trips <- create_scenario(rdr2, scen_name = 'Scenario 10', - source_modes = source_modes, - combined_modes = T, - target_modes = target_modes, - source_distance_cats = DIST_CAT[-3], - source_trips = diff_trips[5]*-1) - - redistribute_trips <- rbind(b2bb_trips, c2bb_trips, m2bb_trips, t2bb_trips, - w2bb_trips) - - # Update selected rows for mode and duration - rdr$trip_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_mode - rdr$trip_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$trip_distance - rdr$stage_mode[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_mode - rdr$stage_distance[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_distance - rdr$stage_duration[match(redistribute_trips$id, rdr$id)] <- redistribute_trips$stage_duration - - rdr_full <- rdr[,-ncol(rdr)] - rdr_full$scenario <- "Scenario 10" - rd_list[[11]] <- rdr_full - - rm(rdr_full, rdr, tt, new_trips, diff_trips, rdr2, b2bb_trips, c2bb_trips, - m2bb_trips, t2bb_trips, w2bb_trips, redistribute_trips, source_modes, - target_modes) - - return(rd_list) - } -} diff --git a/R/create_cycle_scenarios.R b/R/create_cycle_scenarios.R deleted file mode 100644 index 00e0c07d..00000000 --- a/R/create_cycle_scenarios.R +++ /dev/null @@ -1,38 +0,0 @@ -#' Creates cycling scenarios - NOT CURRENTLY USED -#' -#' Creates five scenarios with 10-50% cycling -#' -#' @param trip_set data frame of baseline trips -#' -#' @return list of scenarios -#' -#' @export -create_cycle_scenarios <- function(trip_set){ - rdr <- trip_set - rd_list <- list() - target_distance <- '2-5 km' - # baseline scenario - rd_list[[1]] <- rdr - print(c(sum(rdr$trip_distance_cat==target_distance),sum(rdr$trip_distance_cat==target_distance&rdr$trip_mode=='cycle'))) - ############################################################### - for(i in 1:5){ - # Scenario i: i*10% cycle - short_trips <- subset(rdr,trip_distance_cat==target_distance) - potential_trip_ids <- unique(subset(short_trips,trip_mode!='cycle')$trip_id) - current_cycle_trips <- sum(short_trips$trip_mode=='cycle') - target_percent <- 10*i - change_trip_ids <- base::sample(potential_trip_ids,size=max(1,round(length(unique(short_trips$trip_id))/100*target_percent)-current_cycle_trips)) - change_trips <- subset(short_trips,trip_id%in%change_trip_ids) - change_trips$trip_mode <- 'cycle' - change_trips$stage_mode <- 'cycle' - change_trips$stage_duration <- change_trips$stage_distance * 60 / MODE_SPEEDS$speed[MODE_SPEEDS$stage_mode=='cycle'] - - rdr <- rbind(subset(rdr,!trip_id%in%change_trip_ids),change_trips) - print(c(sum(rdr$trip_distance_cat==target_distance),sum(rdr$trip_distance_cat==target_distance&rdr$trip_mode=='cycle'))) - rdr$scenario <- paste0('Scenario ',i) - rd_list[[i+1]] <- rdr - } - ############################################################### - - return(rd_list) -} diff --git a/R/create_latam_scenarios.R b/R/create_latam_scenarios.R deleted file mode 100644 index 443632b9..00000000 --- a/R/create_latam_scenarios.R +++ /dev/null @@ -1,207 +0,0 @@ -#' Create scenarios for all Latin American cities - NOT CURRENTLY USED -#' -#' Creates three scenarios where in each one, the mode share of a given mode is elevated by a set -#' percentage of the total trips. The scenario-modes are cycle, car, and bus and motorcycle. -#' -#' -#' Add 5% of trips overall in such a way that the average mean mode share for each mode across the -#' three distance bands is preserved. -#' -#' -#' @param trip_set data frame, baseline scenario -#' -#' @return list of baseline scenario and three mode scenarios -#' -#' @export -create_latam_scenarios <- function(trip_set){ - - rdr <- trip_set - trip_set <- NULL - - rd_list <- list() - - - # cycle, car, bus, motorcycle - latam_modeshares <- data.frame(c(39.2, 9.9, 2.3, 10.5), # distance category 0-2km - c(51.1, 50.5, 36.5, 37.2), # distance category 2-6km - c(9.7, 39.6, 61.2, 52.3)) - - percentage_change <- SCENARIO_INCREASE - - - rdr_baseline <- rdr %>% dplyr::select(c('trip_id', 'trip_distance_cat','scenario','trip_mode')) %>% filter() - rdr_baseline <- rdr_baseline %>% distinct() - - 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 - - # 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 * latam_modeshares[c,r] / percentage_trips - } - } - - - 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') - 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 - rdr_changeable_by_distance <- list() - for (j in 1:ncol(SCENARIO_PROPORTIONS)) { - target_distance <- target_distances[j] - rdr_changeable_by_distance[[j]] <- rdr_changeable %>% - filter(trip_distance_cat == target_distance) - } - 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] - rdr_all_by_distance[[j]] <- rdr %>% - filter(trip_distance_cat == target_distance) - } - - 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 - rdr_copy <- list() - for (j in 1:ncol(SCENARIO_PROPORTIONS)) { # Loop for each distance band - rdr_copy[[j]] <- rdr_changeable_by_distance[[j]] # Trips in the distance band - if (mode_name != "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) - - # Count the number of trips that were made by the trip mode - current_mode_trips <- rdr_copy[[j]] %>% - filter(trip_mode == mode_name) %>% distinct(trip_id) %>% nrow() - } else { - # 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) - - # 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")) %>% 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 - 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) - 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]) - - # 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) { - change_trip_ids <- base::sample(potential_trip_ids, - 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 - 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 - 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) - - # 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)) - #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)) - #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 - } # 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('WARNING: There are less trips that can be converted in scenario ',scen_warning[j] , - ' than should be converted for ', city)) - } - } - - return(rd_list) -} \ No newline at end of file diff --git a/R/create_max_mode_share_scenarios.R b/R/create_max_mode_share_scenarios.R deleted file mode 100644 index c873fbd8..00000000 --- a/R/create_max_mode_share_scenarios.R +++ /dev/null @@ -1,88 +0,0 @@ -#' Create scenarios defined by maximum mode share - CURRENTLY NOT USED -#' -#' Creates five scenarios where, in each one, the mode share is elevated to the maximum observed across the cities. -#' The scenario-modes are pedestrian, cycle, car, motorcycle and bus -#' -#' @param trip_set data frame, baseline scenario -#' -#' @return list of baseline scenario and five mode scenarios -#' -#' @export -create_max_mode_share_scenarios <- function(trip_set){ - rdr <- trip_set - trip_set <- NULL - - rd_list <- list() - target_distances <- colnames(SCENARIO_PROPORTIONS) - modes <- rownames(SCENARIO_PROPORTIONS) - # baseline scenario - rd_list[[1]] <- rdr - rdr_not_changeable <- rdr[rdr$trip_mode%in%c('bus_driver','truck', 'car_driver'),] - rdr_changeable <- rdr[!rdr$trip_mode%in%c('bus_driver','truck', 'car_driver'),] - rdr <- NULL - - rdr_changeable_by_distance <- list() - for(j in 1:ncol(SCENARIO_PROPORTIONS)){ - target_distance <- target_distances[j] - rdr_changeable_by_distance[[j]] <- rdr_changeable[rdr_changeable$trip_distance_cat==target_distance,] - } - rdr_changeable <- NULL - - ############################################################### - for(i in 1:nrow(SCENARIO_PROPORTIONS)) { - mode_name <- modes[i] - rdr_copy <- list() - for(j in 1:ncol(SCENARIO_PROPORTIONS)){ - rdr_copy[[j]] <- rdr_changeable_by_distance[[j]] - if (mode_name != "bus") { - potential_trip_ids <- unique(rdr_copy[[j]][!rdr_copy[[j]]$trip_mode%in%c(mode_name),]$trip_id) - ## AA: Fix proportion of current mode by counting unique IDs - ## Remove counting rows by mode, as that would double count trips with multiple stages - current_mode_trips <- rdr_copy[[j]] %>% - filter(trip_mode == mode_name) %>% distinct(trip_id) %>% nrow() - } else { - potential_trip_ids <- unique(rdr_copy[[j]][!rdr_copy[[j]]$trip_mode%in%c(mode_name ,"rail"),]$trip_id) - ## AA: Fix proportion of current mode by counting unique IDs - ## Remove counting rows by mode, as that would double count trips with multiple stages - current_mode_trips <- rdr_copy[[j]] %>% - filter(trip_mode %in% c(mode_name, "rail")) %>% distinct(trip_id) %>% - nrow() - } - - target_percent <- SCENARIO_PROPORTIONS[i,j] - if(length(potential_trip_ids)>0&&round(length(unique(rdr_copy[[j]]$trip_id))/100*target_percent)-current_mode_trips>0){ - if(length(potential_trip_ids)==1){ - change_trip_ids <- potential_trip_ids - }else{ - change_trip_ids <- base::sample(potential_trip_ids,size=round(length(unique(rdr_copy[[j]]$trip_id))/100*target_percent)-current_mode_trips) - # t <- try(base::sample(potential_trip_ids,size=round(length(unique(rdr_copy[[j]]$trip_id))/100*target_percent)-current_mode_trips)) - # if ("try-error" %in% class(t)) - # change_trip_ids <- base::sample(potential_trip_ids,size=round(length(unique(rdr_copy[[j]]$trip_id))/100*target_percent)-current_mode_trips,replace = T) - # else - # change_trip_ids <- base::sample(potential_trip_ids,size=round(length(unique(rdr_copy[[j]]$trip_id))/100*target_percent)-current_mode_trips) - #print(c(CITY,mode_name,length(change_trip_ids))) - } - 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 - change_trips$stage_duration <- change_trips$stage_distance * 60 / MODE_SPEEDS$speed[MODE_SPEEDS$stage_mode == mode_name] - ## if bus scenario: - # if (mode_name == 'bus'){ - # walk_trips <- change_trips; - # walk_trips$stage_mode <- 'walk_to_pt'; - # walk_trips$stage_duration <- BUS_WALK_TIME; - # walk_trips$stage_distance <- walk_trips$stage_duration * MODE_SPEEDS$speed[MODE_SPEEDS$stage_mode == 'pedestrian'] / 60 - # change_trips <- rbind(change_trips, walk_trips) - # } - rdr_copy[[j]] <- rbind(rdr_copy[[j]][!rdr_copy[[j]]$trip_id%in%change_trip_ids,],change_trips) - } - } - rdr_scen <- do.call(rbind,rdr_copy) - rdr_scen <- rbind(rdr_scen,rdr_not_changeable) - rdr_scen$scenario <- paste0('Scenario ',i) - rd_list[[i+1]] <- rdr_scen - } - ############################################################### - - return(rd_list) -} diff --git a/R/create_scenario.R b/R/create_scenario.R deleted file mode 100644 index 2a641898..00000000 --- a/R/create_scenario.R +++ /dev/null @@ -1,61 +0,0 @@ -#' Create individual scenario - CURRENTLY NOT USED -#' -#' Function to create individual scenario for the five prespecified scenarios from the baseline for Accra and Sao Paulo (create_all_scenarios) -#' -#' @param rdr data frame of trips -#' @param scen_name name of scenario -#' @param source_modes which mode(s) to take trips from -#' @param combined_modes whether or not to combine source modes -#' @param target_modes mode to change to -#' @param source_distance_cats which categories to select trips from -#' @param source_trips how many trips to leave, or to take -#' @param target_trips -#' -#' @return list of scenarios -#' -#' @export -create_scenario <- function(rdr, scen_name, source_modes, combined_modes = F, target_modes, source_distance_cats, - source_trips, target_trips){ - ##!! RJ target_modes must be length 1 - if (!combined_modes){ - for (i in 1:length(source_modes)){ - local_source_trips <- sum(rdr$trip_mode == source_modes[i]) - source_trips[i] - candidate_trips <- filter(rdr,trip_mode == source_modes[i] & - trip_distance_cat %in% source_distance_cats) - sample_trips <- candidate_trips[sample(1:nrow(candidate_trips),local_source_trips),] - sample_trips$trip_mode <- target_modes - sample_trips$stage_mode <- target_modes - sample_trips$stage_distance <- sample_trips$trip_distance - sample_trips$stage_duration <- sample_trips$stage_distance / MODE_SPEEDS$speed[MODE_SPEEDS$stage_mode==target_modes] * 60 - # Update selected rows for mode and duration - ids <- match(sample_trips$trip_id,rdr$trip_id) - rdr$trip_mode[ids] <- sample_trips$trip_mode - rdr$trip_distance[ids] <- sample_trips$trip_distance - rdr$stage_mode[ids] <- sample_trips$stage_mode - rdr$stage_distance[ids] <- sample_trips$stage_distance - rdr$stage_duration[ids] <- sample_trips$stage_duration - } - rdr$scenario <- scen_name - return(rdr) - } else { - - candidate_trips <- filter(rdr,trip_mode %in% source_modes & - trip_distance_cat %in% source_distance_cats) - if (CITY == "bogota_wb"){ - sample_trips <- candidate_trips[sample(1:nrow(candidate_trips), - source_trips, replace = F, - candidate_trips$w),] - } - else{ - sample_trips <- candidate_trips[sample(1:nrow(candidate_trips),source_trips),] - } - - sample_trips$trip_mode <- target_modes - sample_trips$stage_mode <- target_modes - sample_trips$stage_distance <- sample_trips$trip_distance - sample_trips$stage_duration <- sample_trips$stage_distance / MODE_SPEEDS$speed[MODE_SPEEDS$stage_mode==target_modes] * 60 - sample_trips$scenario <- scen_name - - return(sample_trips) - } -} diff --git a/R/create_walk_scenario.R b/R/create_walk_scenario.R deleted file mode 100644 index 4aea64f2..00000000 --- a/R/create_walk_scenario.R +++ /dev/null @@ -1,44 +0,0 @@ -#' Create basic pedestrian scenario - NOT CURRENTLY USED -#' -#' Duplicate baseline scenario; give each person one 1km walk in the scenario -#' -#' @param trip_set data frame, baseline scenario -#' -#' @return list of baseline scenario and pedestrian scenario -#' -#' @export -create_walk_scenario <- function(trip_set){ - rdr <- trip_set - rd_list <- list() - - # baseline scenario - rd_list[[1]] <- rdr - ############################################################### - - # Scenario 1: walk - walk_scen <- SYNTHETIC_POPULATION[,colnames(SYNTHETIC_POPULATION)%in%colnames(trip_set)] - walk_scen$trip_id <- max(rdr$trip_id) + walk_scen$participant_id - walk_scen$trip_mode <- 'pedestrian' - walk_scen$trip_distance <- 1 - walk_scen$stage_mode <- 'pedestrian' - walk_scen$stage_distance <- 1 - walk_scen$stage_duration <- 12.5 - walk_scen$rid <- walk_scen$row_id <- walk_scen$trip_id ## redundant - walk_scen$trip_distance_cat <- DIST_CAT[1] ## redundant - - # set scenario name, `pedestrian' - walk_scen$scenario <- 'pedestrian' - rdr$scenario <- 'pedestrian' - - # join new walks to existing trips - ##!! RJ hack: to run with this scenario, we trim extra columns from the raw trip set so they match the above - rd_list[[1]] <- rd_list[[1]][,colnames(rd_list[[1]])%in%colnames(walk_scen)] - rdr <- rdr[,colnames(rdr)%in%colnames(walk_scen)] - walk_scen <- walk_scen[,match(colnames(rdr),colnames(walk_scen))] - rdr <- rbind(rdr,walk_scen) - - rd_list[[2]] <- rdr - ############################################################### - - return(rd_list) -} diff --git a/R/error_handling.R b/R/error_handling.R deleted file mode 100644 index ad1044f5..00000000 --- a/R/error_handling.R +++ /dev/null @@ -1,18 +0,0 @@ -#' CURRENTLY NOT BEING CALLED -#' @export -error_handling <- function(code, function_name, variable_name) { - output <- - switch( - code, - paste0( - "In ", - function_name, - "(", - variable_name, - "): Default values should be changed!" - ) - ) - - print(output) - -} \ No newline at end of file diff --git a/R/parallel_evppi_for_AP.R b/R/parallel_evppi_for_AP.R deleted file mode 100644 index 63a5421a..00000000 --- a/R/parallel_evppi_for_AP.R +++ /dev/null @@ -1,28 +0,0 @@ -#' Compute AP EVPPI - NOT USED IN CONSTANT MODE -#' -#' For use to compute AP EVPPI in parallel -#' -#' @param disease disease name -#' @param parameter_samples data frame of parameter samples -#' @param outcome data frame of outcomes -#' @param NSCEN number of scenarios -#' -#' @return vector of EVPPI values (one per scenario) -#' -#' @export - - -parallel_evppi_for_AP <- function(disease,parameter_samples,outcome,NSCEN){ - AP_DOSE_RESPONSE_QUANTILE <- c() - x1 <- parameter_samples[,which(colnames(parameter_samples)==paste0('AP_DOSE_RESPONSE_QUANTILE_ALPHA_',disease))]; - x2 <- parameter_samples[,which(colnames(parameter_samples)==paste0('AP_DOSE_RESPONSE_QUANTILE_BETA_',disease))]; - x3 <- parameter_samples[,which(colnames(parameter_samples)==paste0('AP_DOSE_RESPONSE_QUANTILE_GAMMA_',disease))]; - x4 <- parameter_samples[,which(colnames(parameter_samples)==paste0('AP_DOSE_RESPONSE_QUANTILE_TMREL_',disease))]; - for(j in 1:(NSCEN)){ - y <- rowSums(outcome[,seq(j,ncol(outcome),by=NSCEN)]) - vary <- var(y) - model <- gam(y ~ te(x1,x2,x3,x4)) - AP_DOSE_RESPONSE_QUANTILE[j] <- (vary - mean((y - model$fitted) ^ 2)) / vary * 100 - } - AP_DOSE_RESPONSE_QUANTILE -} diff --git a/R/population_attributable_fraction.R b/R/population_attributable_fraction.R deleted file mode 100644 index ab7a6a82..00000000 --- a/R/population_attributable_fraction.R +++ /dev/null @@ -1,16 +0,0 @@ -#' Calculate population attributable fraction - CURRENTLY NOT BEING USED -#' -#' -#' -#' @param pop -#' @param cn -#' @param mat -#' -#' @return population attributable fractions by demographic group -#' -#' @export -population_attributable_fraction <- function(pop, cn, mat){ - ##!! hard coding of indices: 1=sex, 2=age or age_cat - paf <- apply(mat,1,function(x)sum(pop[[cn]][pop[[1]]==x[1]&pop[[2]]==x[2]])) - paf -} diff --git a/R/summarise_ithim_inputs.R b/R/summarise_ithim_inputs.R deleted file mode 100644 index d5bb0985..00000000 --- a/R/summarise_ithim_inputs.R +++ /dev/null @@ -1,38 +0,0 @@ -#' Graphical processing of input data - CURRENTLY NOT BEING CALLED -#' -#' Produce graphs summarising some input data, e.g. travel, injury, AP -#' -#' @param ithim_object processed ithim_object from run_ithim_setup -#' -#' @export -summarise_ithim_inputs <- function(ithim_object){ - modenames <- unlist(ithim_object$dist[,1]) - - x11(width=10,height=10); par(mfrow=c(2,2),cex.axis=1.25,cex.lab=1.3) - distances <- as.matrix(ithim_object$dist[,-1]) - distances_pc <- apply(distances,2,function(x)x/sum(x)) - par(mar=c(6,5,2,9)); barplot(distances_pc,col=rainbow(length(modenames)),legend.text=modenames,args.legend = c(x=length(SCEN)+5),ylab=paste0(CITY,' mode share by distance'),las=2) - - trips <- sapply(SCEN,function(y)sapply(modenames,function(x)nrow(subset(subset(ithim_object$trip_scen_sets,trip_mode==x&scenario==y),!duplicated(trip_id))))) - trips <- apply(trips,2,function(x)x/sum(x)) - par(mar=c(6,5,2,9)); barplot(trips,col=rainbow(length(modenames)),legend.text=modenames,args.legend = c(x=length(SCEN)+5),ylab=paste0(CITY,' mode share by trip mode'),las=2) - - cas_modes <- unique(as.character(INJURY_TABLE$whw$cas_mode)) - injuries <- sapply(cas_modes,function(x)sum(subset(INJURY_TABLE$whw,cas_mode==x)$count)) - if(length(INJURY_TABLE)==2){ - cas_modes <- unique(c(cas_modes,as.character(INJURY_TABLE$nov$cas_mode))) - injuries <- sapply(cas_modes,function(x)sum(subset(INJURY_TABLE$whw,cas_mode==x)$count)+sum(subset(INJURY_TABLE$nov,cas_mode==x)$count)) - } - injury_modes <- c('pedestrian','cycle','car','motorcycle') - injury_rates <- sapply(injury_modes,function(x)injuries[match(c('pedestrian','cycle','car','motorcycle'),names(injuries))])/ - distances[match(c('pedestrian','cycle','car','motorcycle'),modenames),1] - - print(injuries) - par(mar=c(8,7,2,2)); barplot(injury_rates,col=rainbow(length(injury_rates)),ylab='',las=2) - mtext(2,line=4.5,cex=1.25,text = paste0(CITY,' injury rates')) - - emissions <- unlist(EMISSION_INVENTORY) - emissions <- emissions[emissions>0] - par(mar=c(2,5,4,5)); pie(emissions,main=paste0(CITY,' emissions'),cex=1.25) - -} diff --git a/R/trim_glm_object.R b/R/trim_glm_object.R deleted file mode 100644 index b57a7cfa..00000000 --- a/R/trim_glm_object.R +++ /dev/null @@ -1,30 +0,0 @@ -#' Reduce size of glm object - CURRENTLY NOT BEING CALLED -#' -#' Delete some attributes of glm object in order to save space -#' -#' @param obj glm object -#' -#' @return glm object -#' -#' @export -trim_glm_object <- function(obj){ - obj$y <- c() - obj$model <- c() - obj$R <- c() - obj$qr$qr <- c() - obj$residuals <- c() - obj$fitted.values <- c() - obj$effects <- c() - obj$linear.predictors <- c() - obj$weights <- c() - obj$prior.weights <- c() - obj$data <- c() - obj$family$variance = c() - obj$family$dev.resids = c() - obj$family$aic = c() - obj$family$validmu = c() - obj$family$simulate = c() - #attr(obj$terms,".Environment") = c() - attr(obj$formula,".Environment") = c() - obj -}