In nick-fournier/complete-streets-los: Multimodal level of service calculator

library(knitr)
library(data.table)
library(ggplot2)
knitr::opts_chunk$set(echo = TRUE, warning = FALSE, message = FALSE)
knitr::opts_knit$set(root.dir = "../")

R Markdown

This is a vignette going through a simple example use of MMLOS, the Multi-Modal Level of Service calculator from the Highway Capacity Manual in R. In this vignette we will go over basic usage of MMLOS for calculating the LOS of links, intersections, and segments for bicycles and pedestrians (automobiles and transit to be implemented in future versions). This includes loading the link and intersection data from CSV and the proper data format of the CSV data. We will also do a bit of plotting the results, and comparing the results from the existing HCM methodology to our proposed revisions.

Data formatting

Let's begin with with a description of data, shown below. There are two CSV files, one for links and one for segments. Templates can be found at data/input_intersection_template.csv and data/input_link_template.csv. These templates are based on data collected along Hearst Avenue, a site where complete streets improvements were recently made.

dat = fread("./data/input_descriptions.csv")[TYPE == "LINK", .(VAR,DESC)]
dat = setNames(dat, c("Variable","Description"))
kable(dat, caption = "Link data format:")

dat = fread("./data/input_descriptions.csv")[TYPE == "INT", .(VAR,DESC)]
dat = setNames(dat, c("Variable","Description"))
kable(dat, caption = "Intersection data format:")

General Usage

First install, if you haven't already, and load the package. MMLOS includes the dependency data.table", which provides efficient data handling functions coded in C++, offering a much faster alternative to base-R data frames.

# #Install the MMLOS package (commented out to avoid errors)
# library(devtools)
# install_github("nick-fournier/MMLOS")

#Activate the installed package.
library(MMLOS)

After roadway data has been properly formatted into the link and intersection CSV files, they can be imported to R. The dirs parameter is a string vector with the two file locations. If left empty, a GUI prompt will pop up. Otherwise if one of the templates "berkeley" or "pasadena" are entered, it'll just use the template files I have provided. For now we'll just use the template data.

dat <- MMLOSload("berkeley")

We can take a peak at this. Note the NAs in this example are because some intersections are only three-ways, so one approach is missing.

lapply(MMLOSload("berkeley"),function(x) head(x,8))

Now we can calculate the LOS. The "existing" result uses the current HCM methodology, and the "revised" result uses the proposed revisions. Let's display what the results look like for the existing methodology. The results have a list of data tables for each mode.

existing <- MMLOScalc(dat, revs = F)
revised <- MMLOScalc(dat, revs = T)

#Display results
print(existing)

The results can be exported to a CSV by using the command:

MMLOSsave(existing, "./some output folder/existing LOS.csv")
MMLOSsave(revised, "./some output folder/revised LOS.csv")

Differences between existing and revised HCM results

Alright now lets compare the results a bit for bikes to see how the revised methodology alters the outcome. The numeric scores then translate to letter grades, let's see how they compare. First we subset the letter grades in each result and combine them into a table. Although the row order is already sorted in each table, I like to use the merge command to ensure that nothing becomes mixed up. I then add the suffixed of " Existing" and " Revised" to distinguish the columns from each other.

# Add a new column with the methodology version
# This is data.table syntax for assigning to a column.
existing[['bike']][ , method := "Existing"]
revised[['bike']][ , method := "Revised"]

# Combine the data tables horizontally (add columns).
# We select only the letter grade columns
bike.grade <- merge(existing[['bike']][ , .(segment_id,direction, link_LOS, int_LOS, seg_LOS)],
      revised[['bike']][ , .(segment_id,direction, link_LOS, int_LOS, seg_LOS)],
      by = c("segment_id","direction"),
      suffixes = c(" Existing"," Revised"))

#Sort columns to my liking
bike.grade <- bike.grade[ , c(1:2,order(colnames(bike.grade)[-(1:2)])+2), with = F]

kable(bike.grade)

In general we can see that the revised version tends to have higher (worse) LOS score at intersections. This is because it now accounts for additional bicycle delay. We can also see that a few links (i.e., westbound Shattuck-Walnut, eastbound Spruce-Arch/Le Conte, and westbound Walnut-Oxford) had a reduced LOS score. This reduced LOS score is due to the revised LOS methodology accounting for separated bike lanes, specifically parking protected lanes that provide vertical separation. It is hard to tell exactly what's going on through, because the magnitude of score differences cannot be seen after the score is converted into a discrete letter grade. Let's see what the numbers look like visually. Basically what I am doing here is combining the two results into a single data table again, but stacked vertically (long format), and adding some row ID's to keep it organized.

# Add row number, help us to sort it later
existing[['bike']]$rn <- 1:nrow(existing[['bike']])
revised[['bike']]$rn <- 1:nrow(revised[['bike']])

# Combine the data tables vertically (stacking rows). Vertical format makes plotting easier
bike.scores <- rbind(existing[['bike']], revised[['bike']])

# Let's create a new unique ID column that contains the segment ID, direction, and methodology version
bike.scores[ , id := paste(segment_id, direction, method)]

library(data.table)
#Re-shape the data from wide into long format. This is for the numeric scores
bike.scores <- melt(bike.scores[ , .(id, rn, method, I_int, I_link, I_seg)], id.vars = c("id","rn","method"))

#Sort data
bike.scores <- bike.scores[order(rn), ]

#Labels
bike.scores[variable == "I_int", variable := "Intersection"]
bike.scores[variable == "I_link", variable := "Link"]
bike.scores[variable == "I_seg", variable := "Segment"]

#Reshape for another plot
bike.scoresxy <- dcast(bike.scores, rn+variable~method, value.var = "value")

Long format is generally easier to plot with because you are storing all the values in one column, which are then categorized by a "variable" column. To show what I mean, let's print the table out.

head(bike.scores)

The benefit of this is that instead of having to create separate plots of each possible combination of Existing/Revised X I_int/I_link/I_seg X segement_id, it is just a matter of putting segment_id on the x-axis, value on the y-axis, and then group by the variables (i.e., I_int/I_link/I_seg and Existing/Revised). For plotting, I am using ggplot2. ggplot is a great package that helps make pretty graphs.

library(ggplot2)
#Plot
ggplot(data = bike.scores, aes(x = id, y = value, fill = variable, alpha = method)) + 
  geom_col(position = "dodge") +
  scale_fill_brewer("LOS component", palette = "Set1") +
  scale_alpha_discrete("Methodology", range = c(0.5,1)) +
  labs(x = NULL, y = "LOS Score") +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1))

The resulting plot generally reflects what we saw in the table, but we can see that the segment LOS score is less sensitive to changes from intersections than from links. In another perspective we can compare the LOS from each methodology. Points above the diagonal line mean that the revised method yielded a higher (i.e., worse) LOS score, and points below the diagonal mean the revised method yielded a lower (i.e., better) LOS score.

ggplot(data = bike.scoresxy, aes(x = Existing, y = Revised, color = variable)) + 
  geom_point() +
  geom_abline(slope = 1) +
  scale_color_brewer("LOS component", palette = "Set1") +
  labs(x = "Existing HCM LOS score", y = "Revised HCM LOS Score") +
  theme_bw()

Existing versus revised HCM methodology

Getting a little bit more advanced, we can inspect how LOS score outputs vary while varying the input values. We can start by creating some starting default parameters. I start with the default template data, creating a list with every possible combination of speed and volume. Most parameters are constant except for average mid-segment speed $S_{85mj}$, and volume $v_v$, which will vary from 15 to 45 mph and 100 to 1200 vph in increments of 5 mph and 100 vph, respectively. The function "expand.grid" will then generate a data frame for all possible combinations of these sequences. I then do some house keeping, filling in some default values. Setting the right and left turn volume to be $\frac{1}{4}$ of total volume, proportionally. The right-on-red and permissive lefts are then further half of the left and right turn volumes.

combos <- data.table(expand.grid(vol = seq(100, 1200, by = 100),
                                 spd = seq(15, 45, by = 5)))

#Just grabbing the first link and intersection from the data. Just as filler data
int <- split(dat$intersections, by = "int_id")[[1]]
link <- split(dat$links, by = c("link_id","link_dir"))[[1]]

combodat <- lapply(1:nrow(combos), function(x) {
  link$S_85mj <- combos[x, spd]
  int$v_v <- combos[x, vol]

  int[ , v_rt := v_v/4]
  int[ , v_lt := v_v/4]
  int[ , v_th := v_v/2]
  int[ , v_rtor := v_rt/2]
  int[ , v_ltperm := v_lt/2]
  int[ , int_id := x]
  return( list("intersection" = int, "link" = link) )
})

You don't need to understand all of this, just know that I'm creating a big data table that has all possible combinations of speed and volume. Now we are going to actually calculate the LOS score using the data matrix we created. This goes through the data table twice, once using existing HCM and once using the revisions. There are a lot of combinations, this might take a few seconds to compute. Then, I again reshape the data into long form for plotting.

#Calculate Intersection LOS
LOS.dat <- lapply(combodat, function(x) {
  data.table("v_v" = x[['intersection']]$v_v[1],
             "S_85mj" = x[['link']]$S_85mj[1],
             Revised = bike.I_int(x[['link']], x[['intersection']]),
             Existing = ogbike.I_int(x[['link']], x[['intersection']]))
  })
#combine list items into data table
LOS.dat <- rbindlist(LOS.dat)

#Melt into long form
LOS.dat <- melt(LOS.dat, c("v_v","S_85mj"))

#Score
LOS.dat$LOS <- sapply(LOS.dat$value, score2LOS)

Now we can plot the two and compare them. I use another package here called ggpubr, which accompanies ggplot2 for presentation. In this case it let's me plot them side by side. So what we see here is that the revisions account for traffic speed exposure while existing HCM methodology does not.

plot.LOSint = lapply(c("Existing","Revised"), function(x) {
  ggplot(data = LOS.dat[variable == x, ], ) +
    #geom_tile(aes(x = v_v, y = S_85mj, fill = value)) +
    #scale_fill_distiller("LOS", palette = "RdYlGn", limits = range(LOS.int$value)) +
    geom_contour_filled(aes(x = v_v, y = S_85mj, z = value), breaks = c(-Inf,2.00,2.75,3.50,4.25,5.00,Inf)) +
    scale_fill_manual("LOS score", values = rev(RColorBrewer::brewer.pal(n = 6, name = "RdYlGn")),
                       labels = c("A","B","C","D","E","F"), drop = F) +
    scale_x_continuous("Automobile traffic volume (veh/hr)", expand = c(0,0)) +
    scale_y_continuous("Automobile traffic speed (mph)", expand = c(0,0)) +
    coord_fixed(ratio = 25) +
    theme_bw() + ggtitle(paste(x, "HCM Methodology")) +
    theme(text = element_text(family = "Times New Roman"), legend.position = "bottom")
})
names(plot.LOSint) <- c("rev","og")

library(ggpubr)
ggarrange(plotlist = plot.LOSint, ncol = 2, common.legend = T, legend = "right")

Final thoughts

Okay now that we've gone through a short example, that should be enough to get going. More to come in future revisions. For more methodological details, see the bicycle revisions working paper titled Improved Analysis Methodologies and Strategies for Complete Streets and for pedestrian revisions see the collection of working papers from NCHRP report 17-87.

nick-fournier/complete-streets-los documentation built on June 24, 2021, 3:09 p.m.