Final Project
Prepared by Gregory Mallon
November 23rd, 2021
Transportation Demand Modeling
Package load and data connection
Preparation: read data into a R data frame:
#install.packages("tidyverse")
library(tidyverse)
library(readxl)
library(dplyr)
library(ipfr)
table1 <- read_csv("/Users/gregmallon/Desktop/TDM FInal Project/data/Table1.csv")
seed_matrix <- read_csv("/Users/gregmallon/Desktop/TDM FInal Project/data/2010_total_trip_distribution_matrix.csv")
td_skims <- read_csv("/Users/gregmallon/Desktop/TDM FInal Project/data/SKIMS_TIME.csv")
td_skims <- td_skims %>% rename(origin_taz=TAZ)
td_skims <- pivot_longer(td_skims,
-origin_taz,
names_to="destination_taz",
values_to="travel_time")
td_skims <- td_skims %>% mutate(
origin_taz=as.integer(origin_taz),
destination_taz=as.integer(destination_taz))
seed_matrix <- seed_matrix %>%
select(-TAZ) %>%
as.matrix()
dimnames(seed_matrix)[[1]] <- c(1, 2, 3, 4)
table1 <- table1 %>%
mutate(prod= 37.6 + 1.7 * HHI30 +2.4 * CI30 + 1.9 * WI30,
attr= 115 + 3.0 *EJ30 +2.5 * HHI30)
row_targets <- table1$prod
col_targets <- table1$attr
#print col_targets
col_targets## [1] 870.5 1770.0 1607.5 1212.0#balancing
col_targets <- col_targets * sum(row_targets)/sum(col_targets)
#Print col_targets again
col_targets## [1] 895.1004 1820.0203 1652.9281 1246.2512#iterative prop fitting
trips_matrix <- ipu_matrix(seed_matrix, row_targets, col_targets)
trips_df <- round(trips_matrix, 2) %>%
as_tibble() %>%
mutate(otaz=dimnames(seed_matrix)[[1]]) %>%
select(otaz, everything())
#2030trips_df
trips_df## # A tibble: 4 × 5
## otaz `1` `2` `3` `4`
## <chr> <dbl> <dbl> <dbl> <dbl>
## 1 1 298. 261. 610. 96.3
## 2 2 135. 946. 92.3 328.
## 3 3 265. 136. 396. 584.
## 4 4 197. 477. 554. 239.trips_df_flattened <- trips_df %>%
pivot_longer(-otaz,
names_to="dtaz",
values_to="trips") %>%
mutate(otaz=as.integer(otaz),
dtaz=as.integer(dtaz))
#2030trips_df_flattened
trips_df_flattened## # A tibble: 16 × 3
## otaz dtaz trips
## <int> <int> <dbl>
## 1 1 1 298.
## 2 1 2 261.
## 3 1 3 610.
## 4 1 4 96.3
## 5 2 1 135.
## 6 2 2 946.
## 7 2 3 92.3
## 8 2 4 328.
## 9 3 1 265.
## 10 3 2 136.
## 11 3 3 396.
## 12 3 4 584.
## 13 4 1 197.
## 14 4 2 477.
## 15 4 3 554.
## 16 4 4 239.trips_df_flattened <- trips_df_flattened %>%
left_join(td_skims, by=c("otaz"="origin_taz", "dtaz"="destination_taz"))
#trips_df_flattened again
trips_df_flattened## # A tibble: 16 × 4
## otaz dtaz trips travel_time
## <int> <int> <dbl> <dbl>
## 1 1 1 298. 5
## 2 1 2 261. 16
## 3 1 3 610. 13
## 4 1 4 96.3 18
## 5 2 1 135. 16
## 6 2 2 946. 7
## 7 2 3 92.3 20
## 8 2 4 328. 12
## 9 3 1 265. 13
## 10 3 2 136. 20
## 11 3 3 396. 2
## 12 3 4 584. 9
## 13 4 1 197. 18
## 14 4 2 477. 12
## 15 4 3 554. 9
## 16 4 4 239. 3trips_df_flattened %>%
summarize(avg_travltime=sum(trips * travel_time)/sum(trips))## # A tibble: 1 × 1
## avg_travltime
## <dbl>
## 1 10.2ggplot(trips_df_flattened) +
geom_density(aes(x=travel_time, weights=trips))
#3 Calc
od_matrix <- trips_matrix * 0.20 + t(trips_matrix) * 0.10
#5 Part 1
#OD_Matrix_Flattened
OD_Matrix_df_flattened <- od_matrix %>%
as_data_frame() %>%
mutate(otaz=row_number()) %>%
pivot_longer( -otaz,
names_to="dtaz",
values_to="trips") %>%
mutate(otaz=as.integer(otaz),
dtaz=as.integer(dtaz))
#4
## 2030 Modechoice
modechoice <- td_skims %>%
mutate(ucar=-.333 * travel_time , utransit= -7 - 0.5 * 1, Pcar = exp(ucar) / ( exp(ucar) + exp(utransit) ))
modechoice <- modechoice %>%
select(-travel_time) %>%
left_join(OD_Matrix_df_flattened, by=c("origin_taz"="otaz", "destination_taz"="dtaz")) %>%
mutate(
trips = as.integer(round(trips, 0)),
cartrips= as.integer(round(trips * Pcar, 0)),
bustrips= trips - cartrips ,
vtrips = cartrips / 1.1,
vtrips = as.integer(round(vtrips, 0))
)
modechoice## # A tibble: 16 × 9
## origin_taz destination_taz ucar utransit Pcar trips cartrips bustrips
## <int> <int> <dbl> <dbl> <dbl> <int> <int> <int>
## 1 1 1 -1.66 -7.5 0.997 90 90 0
## 2 1 2 -5.33 -7.5 0.898 66 59 7
## 3 1 3 -4.33 -7.5 0.960 149 143 6
## 4 1 4 -5.99 -7.5 0.818 39 32 7
## 5 2 1 -5.33 -7.5 0.898 53 48 5
## 6 2 2 -2.33 -7.5 0.994 284 282 2
## 7 2 3 -6.66 -7.5 0.698 32 22 10
## 8 2 4 -4.00 -7.5 0.971 113 110 3
## 9 3 1 -4.33 -7.5 0.960 114 109 5
## 10 3 2 -6.66 -7.5 0.698 36 25 11
## 11 3 3 -0.666 -7.5 0.999 119 119 0
## 12 3 4 -3.00 -7.5 0.989 172 170 2
## 13 4 1 -5.99 -7.5 0.818 49 40 9
## 14 4 2 -4.00 -7.5 0.971 128 124 4
## 15 4 3 -3.00 -7.5 0.989 169 167 2
## 16 4 4 -0.999 -7.5 0.999 72 72 0
## # … with 1 more variable: vtrips <int>odtable2030 <- modechoice %>%
select(origin_taz, destination_taz, vtrips) %>%
pivot_wider(id_cols="origin_taz", names_from="destination_taz", values_from="vtrips")
odtable2030## # A tibble: 4 × 5
## origin_taz `1` `2` `3` `4`
## <int> <int> <int> <int> <int>
## 1 1 82 54 130 29
## 2 2 44 256 20 100
## 3 3 99 23 108 155
## 4 4 36 113 152 65write_delim(odtable2030, delim="\t", file="~/Desktop/TDM FInal Project/data/2030year/odtable.tab")#3 AM Peak Trip 2010
td_skims2010 <- read_csv("/Users/gregmallon/Desktop/TDM FInal Project/data/Skims2010.csv")
td_skims2010 <- td_skims2010 %>% rename(origin_taz=TAZ)
td_skims2010 <- pivot_longer(td_skims2010,
-origin_taz,
names_to="destination_taz",
values_to="travel_time")
td_skims2010 <- td_skims2010 %>% mutate(
origin_taz=as.integer(origin_taz),
destination_taz=as.integer(destination_taz))
TripsOD2010 <- read_csv("/Users/gregmallon/Desktop/TDM FInal Project/data/2010_total_trip_distribution_matrix.csv")
##2010 Base AM PEAK
od_matrix2010AMScratch <- TripsOD2010 * 0.20 + t(TripsOD2010) * 0.10
##something happened in my code and od_matrix wasn't functioning without assigning to od_matrix2010
od_matrix2010 <- read_csv("/Users/gregmallon/Desktop/TDM FInal Project/data/TripMatrix2010.csv")
#3 Calc
od_matrix2010AM <- od_matrix2010 * 0.20 + t(od_matrix2010) * 0.10
od_matrix2010AM ## 1 2 3 4
## 1 75.0 35.0 95.5 30.5
## 2 32.5 120.0 16.0 66.5
## 3 78.5 17.0 67.5 116.0
## 4 38.5 65.5 106.0 52.5#5 Part 2
#OD_Matrix_Flattened2010_AM PEAK
OD_Matrix2010_df_flattened <- od_matrix2010AM %>%
as_data_frame() %>%
mutate(otaz=row_number()) %>%
pivot_longer( -otaz,
names_to="dtaz",
values_to="trips") %>%
mutate(otaz=as.integer(otaz),
dtaz=as.integer(dtaz))
##ModeChoice 2010
modechoice2010 <- td_skims2010 %>%
mutate(ucar=-.333 * travel_time , utransit= -7 - 0.5 * 0, Pcar = exp(ucar) / ( exp(ucar) + exp(utransit) ))
modechoice2010 <- modechoice2010 %>%
select(-travel_time) %>%
left_join(OD_Matrix2010_df_flattened, by=c("origin_taz"="otaz", "destination_taz"="dtaz")) %>%
mutate(
trips = as.integer(round(trips, 0)),
cartrips= as.integer(round(trips * Pcar, 0)),
bustrips= trips - cartrips ,
vtrips = cartrips / 1.1,
vtrips = as.integer(round(vtrips, 0))
)
modechoice2010## # A tibble: 16 × 9
## origin_taz destination_taz ucar utransit Pcar trips cartrips bustrips
## <int> <int> <dbl> <dbl> <dbl> <int> <int> <int>
## 1 1 1 -1.66 -7 0.995 75 75 0
## 2 1 2 -5.33 -7 0.842 35 29 6
## 3 1 3 -4.33 -7 0.935 96 90 6
## 4 1 4 -5.99 -7 0.732 30 22 8
## 5 2 1 -5.33 -7 0.842 32 27 5
## 6 2 2 -2.33 -7 0.991 120 119 1
## 7 2 3 -6.66 -7 0.584 16 9 7
## 8 2 4 -4.00 -7 0.953 66 63 3
## 9 3 1 -4.33 -7 0.935 78 73 5
## 10 3 2 -6.66 -7 0.584 17 10 7
## 11 3 3 -0.666 -7 0.998 68 68 0
## 12 3 4 -3.00 -7 0.982 116 114 2
## 13 4 1 -5.99 -7 0.732 38 28 10
## 14 4 2 -4.00 -7 0.953 66 63 3
## 15 4 3 -3.00 -7 0.982 106 104 2
## 16 4 4 -0.999 -7 0.998 52 52 0
## # … with 1 more variable: vtrips <int>##AM PEAK 2010 Mode Choice
AModtable2010 <- modechoice2010 %>%
select(origin_taz, destination_taz, vtrips) %>%
pivot_wider(id_cols="origin_taz", names_from="destination_taz", values_from="vtrips")
AModtable2010## # A tibble: 4 × 5
## origin_taz `1` `2` `3` `4`
## <int> <int> <int> <int> <int>
## 1 1 68 26 82 20
## 2 2 25 108 8 57
## 3 3 66 9 62 104
## 4 4 25 57 95 47## Saving base year to 2030 folder
write_delim(AModtable2010, delim="\t", file="~/Desktop/TDM FInal Project/data/baseyear/odtable.tab")Write Up All Parts
- Performance measures from AM Peak Hour base year and 2030. Tabulate: Base year (2010) AM PEAK Total Vehicle Miles Traveled = 7925 Average Speed = 33 MPH
Year 2030 AM PEAK Total Vehicle Miles Traveled = 7163 Average Speed = 2.4 MPH
Description Year 2010 functions okay with average speed of 33 MPH and moving 7925 vehicles on the system. In the year 2030 average speed reduces substantially and fewer vehicles are able to move on the system within the Peak Hour. This means that congestion hours of day will likely spill over in non-peak hours if the number of trips that need to use the system increases wiht the population growth.
6.) Congestion Relief 6A Alternative 1 - Increase Capacity
SKIMS_2010 <- read_csv("/Users/gregmallon/Desktop/TDM FInal Project/TripAssignmnet copyy/TripAssignmnet Complete - base - Copy/CongSkimsUE_2010.csv")
Alternative1_increaseCapcity <- read_csv("/Users/gregmallon/Desktop/TDM FInal Project/TripAssignmnet copyy/TripAssignmnet Complete2030 - Alternative 1 increase capacity/CongSkimsUE.csv")
###RESULTS Comparing base year to 2030 with increased capacity.
SKIMS_2010## # A tibble: 4 × 5
## Zones `1` `2` `3` `4`
## <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 0 18.3 33.4 25.7
## 2 2 37.3 0 29.5 20.3
## 3 3 36.6 20.2 0 19.6
## 4 4 29.9 13.6 22.0 0Alternative1_increaseCapcity## # A tibble: 4 × 5
## Zones `1` `2` `3` `4`
## <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 0 17.8 41.0 25.3
## 2 2 21.7 0 29.3 13.5
## 3 3 36.7 22.3 0 10.0
## 4 4 27.8 12.3 15.8 02010 SKIM Zones 1 2 3 4 1 0 18.2903 33.4444 25.7142 2 37.2821 0 29.5236 20.2969 3 36.6269 20.2387 0 19.627 4 29.947 13.5588 22.0494 `0
2030 SKIM WITH INCREASE LANE CAPACITY Zones 1 2 3 4 1 0 17.7751 41.048 25.2752 2 21.6983 0 29.2653 13.4924 3 36.7295 22.299 0 10.017 4 27.8062 12.2974 15.8394 0
Increasing capacity on links is one option to decrease 2030 congestion levels to 2021 congestion levels. However, inorder to maintain a healthy system that does not overload other roadways you would have to increase capacity on the following links: 1-5 increase by 1 lane * (5.5 miles) * $1 Million = 5.5 Million 2-4 increase by 2 lanes * (6 miles) * $1 Million = 12 Million 2-5 increase by 2 lanes * (2.5 miles) * $1 Million = 5 Million 2-6 increase by 2 lanes * (3.5 miles) * $1 Million = 7 Million 3-4 increase by 2 lanes * (4.5 miles) * $1 Million = 9 Million 4-2 increase by 2 lanes * (6 miles) * $1 Million = 12 Million 4-3 increase by 2 lanes * (4.5 miles) * $1 Million = 9 Million 5-1 increase by 2 lanes * (5.5 miles) * $1 Million = 11 Million 5-2 increase by 3.5 lanes * (2.5 miles) * $1 Million = 8.75 Million 6-2 increase by 3.5 lanes * (3.5 miles) * $1 Million = 12.25 Million
Even with capacity added to the links above, there are a couple instances where links on the network experience increased travel time.
By increasing capacity to the links above, and using the old 1 Million dollars per mile of road I would anticipate this project to cost about $91 Million to complete.
#6 Congestion Relief
##6B Alternative 2 - Free Bus Service
## 2030 Modechoice2 utility of transit turned down from -7 to -4 and Free Transit
modechoice2030_ALT2 <- td_skims %>%
mutate(ucar=-.333 * travel_time , utransit= -4 - 0.5 * 0, Pcar = exp(ucar) / ( exp(ucar) + exp(utransit) ))
modechoice2030_ALT2 <- modechoice2030_ALT2 %>%
select(-travel_time) %>%
left_join(OD_Matrix_df_flattened, by=c("origin_taz"="otaz", "destination_taz"="dtaz")) %>%
mutate(
trips = as.integer(round(trips, 0)),
cartrips= as.integer(round(trips * Pcar, 0)),
bustrips= trips - cartrips ,
vtrips = cartrips / 1.1,
vtrips = as.integer(round(vtrips, 0))
)
modechoice2030_ALT2## # A tibble: 16 × 9
## origin_taz destination_taz ucar utransit Pcar trips cartrips bustrips
## <int> <int> <dbl> <dbl> <dbl> <int> <int> <int>
## 1 1 1 -1.66 -4 0.912 90 82 8
## 2 1 2 -5.33 -4 0.209 66 14 52
## 3 1 3 -4.33 -4 0.418 149 62 87
## 4 1 4 -5.99 -4 0.120 39 5 34
## 5 2 1 -5.33 -4 0.209 53 11 42
## 6 2 2 -2.33 -4 0.841 284 239 45
## 7 2 3 -6.66 -4 0.0654 32 2 30
## 8 2 4 -4.00 -4 0.501 113 57 56
## 9 3 1 -4.33 -4 0.418 114 48 66
## 10 3 2 -6.66 -4 0.0654 36 2 34
## 11 3 3 -0.666 -4 0.966 119 115 4
## 12 3 4 -3.00 -4 0.732 172 126 46
## 13 4 1 -5.99 -4 0.120 49 6 43
## 14 4 2 -4.00 -4 0.501 128 64 64
## 15 4 3 -3.00 -4 0.732 169 124 45
## 16 4 4 -0.999 -4 0.953 72 69 3
## # … with 1 more variable: vtrips <int>odtable2030_ALT2 <- modechoice2030_ALT2 %>%
select(origin_taz, destination_taz, vtrips) %>%
pivot_wider(id_cols="origin_taz", names_from="destination_taz", values_from="vtrips")
odtable2030_ALT2## # A tibble: 4 × 5
## origin_taz `1` `2` `3` `4`
## <int> <int> <int> <int> <int>
## 1 1 75 13 56 5
## 2 2 10 217 2 52
## 3 3 44 2 105 115
## 4 4 5 58 113 63write_delim(odtable2030_ALT2, delim="\t", file="~/Desktop/TDM FInal Project/data/2030year_ALT2_modechoice/odtable.tab")6B Alternative 2 - Free Bus Service (impedance factor adjusted)
For Alternative 2 I initially tried decrease 2030 congestion levels to 2021 congestion levels by simply reducing the fare from 1 dollar to zero dollars. However, reducing the price of transit did not decrease travel times to 2010 levels. After a few iterations and tinkering with the mode choice logit model, I found that I increasing the utility of transit by reducing the model assumption impedance factor from -7 to -4 made a significant effect in alleviating congestion to the 2010 levels.
SKIMS_2010 <- read_csv("/Users/gregmallon/Desktop/TDM FInal Project/TripAssignmnet copyy/TripAssignmnet Complete - base - Copy/CongSkimsUE_2010.csv")
FreeBus_IncreasedUtility7to4 <- read_csv("/Users/gregmallon/Desktop/TDM FInal Project/TripAssignmnet copyy/TripAssignmnet Complete2030 - Alt 4 free bus -4/CongSkimsUE.csv")
###RESULTS Comparing base year to 2030 with increased bus utility.
SKIMS_2010## # A tibble: 4 × 5
## Zones `1` `2` `3` `4`
## <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 0 18.3 33.4 25.7
## 2 2 37.3 0 29.5 20.3
## 3 3 36.6 20.2 0 19.6
## 4 4 29.9 13.6 22.0 0FreeBus_IncreasedUtility7to4## # A tibble: 4 × 5
## Zones `1` `2` `3` `4`
## <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 0 16.0 15.1 18.3
## 2 2 16.1 0 28.8 14.8
## 3 3 15.8 20.3 0 19.6
## 4 4 18.4 13.3 26.7 02010 SKIM Zones 1 2 3 4 1 0 18.2903 33.4444 25.7142 2 37.2821 0 29.5236 20.2969 3 36.6269 20.2387 0 19.627 4 29.947 13.5588 22.0494 `0
2030 SKIM Free Transit and Reduced Impedance Factor Zones 1 2 3 4 1 0 16.0182 15.1483 1 8.3253 2 16.1135 0 28.8067 14.8218 3 15.84 20.2597 0 19.5538 4 18.4429 13.3062 26.745 0
In order to increase the utility of the bus for people past reducing the fare, you would like have to construct lanes to be dedicated to bus only lanes. Additionally, you might also have to increase the frequency of service to decrease waiting times. I don’t have a great understanding of the costs associated with all these elements, but I would guesstimate that to achieve this ridership level, improvements to the transit network would likely be substantial. if for example you are creating a lane for bus only lanes for every section of roadway. there are 94 miles of roadway (both directions) multiplied by 1 million dollars per mile would bring the cost of the alternative to 94 million which is greater than the expanded capacity approach in alternative 1. Additionally, there would be other costs associated with buying buses, opertations, and decreased revenue as the fare is free.
In conclusion alternative 1 would be the more efficient option for reducing 2030 levels of congestion back to 2010 levels.