This document is stand-alone interactive dashboard viewable from most modern Internet browsers. The dashboard is meant to be a high-level summary of an rFreight scenario. All of the data, charts, and maps viewable in this dashboard are embedded directly into the HTML file, so users are encouraged to share their scenario results with others via this document. An Internet connection is necessary for the best user experience, but is not required.
Users may navigate to different areas of the dashboard using the navigation bar at the top of the page, and may interact directly with most tables, charts, and maps.
This document is best viewed using the most recent versions of the following web browsers:
Note: Each data point represents 10 firms and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Note: Each data point represents 100 employees and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Note: Each data point represents 10 firms and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Note: Each data point represents 100 employees and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Note: “Mode” refers to the mode of the long distance movement.
Note: Internal-to-Internal shipments are counted as both production and consumption for the model region.
Note: Internal-to-Internal shipments are counted as both production and consumption for the model region.
Note: “Mode” refers to the mode of the long distance movement.
Note: Internal-to-Internal tonnage is counted as both production and consumption for the model region.
Note: Internal-to-Internal tonnage is counted as both production and consumption for the model region.
Note: 5% of trips are longer than 92 miles and are not displayed.
Note: 5% of trips are longer than 48 miles and are not displayed.
Note: 5% of trips are longer than 392 minutes and are not displayed.
Note: 5% of trips are longer than 52 minutes and are not displayed.
Note: 5% of stops are longer than 65 minutes and are not displayed.
Note: 5% of stops are longer than 65 minutes and are not displayed.
Note: These are a sampling of peddling-tours from a few distribution centers for illustrative purposes.
Note: Each data point represents 25 stops and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Note: Each data point represents 25 stops and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Note: The proportion of single-stop tours is not directly calibrated.
Note: 5% of stops are longer than 65 minutes and are not displayed.
Note: 5% of trips are longer than 59 miles and are not displayed.
Note: 5% of trips are longer than 19 miles and are not displayed.
Note: 5% of trips are longer than 502 minutes and are not displayed.
Note: 5% of trips are longer than 24 minutes and are not displayed.
Note: 5% of stops are longer than 194 minutes and are not displayed.
Note: 5% of stops are longer than 194 minutes and are not displayed.
Note: These are a sampling of tours of a single firm in the selected industry for illustrative purposes.
Note: Each data point represents 25 stops and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Note: Each data point represents 25 stops and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Note: Bar whiskers represent one standard deviation.
---
title: "`r paste(SCENARIO_NAME, 'Scenario Summary')`"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
theme: yeti
source_code: embed
css: "ReportDashboardStyles.css"
includes:
after_body: "TAZ_Layer.html"
---
```{r Setup}
opts_knit$set(root.dir = SYSTEM_APP_PATH)
```
```{r Map_Settings}
shp_outline <- gUnaryUnion(shp)
map_type <- "OpenStreetMap.HOT"
```
```{r Common_Values}
# TODO: vectors like these could be moved into an rFreight function
tod_breaks30 <- seq(from = 0, to = 1440, by = 30)
tod_labels30 <- c("12:00am - 12:29am", "12:30am - 12:59am", "1:00am - 1:29am",
"1:30am - 1:59am", "2:00am - 2:29am", "2:30am - 2:59am",
"3:00am - 3:29am", "3:30am - 3:59am", "4:00am - 4:29am",
"4:30am - 4:59am", "5:00am - 5:29am", "5:30am - 5:59am",
"6:00am - 6:29am", "6:30am - 6:59am", "7:00am - 7:29am",
"7:30am - 7:59am", "8:00am - 8:29am", "8:30am - 8:59am",
"9:00am - 9:29am", "9:30am - 9:59am", "10:00am - 10:29am",
"10:30am - 10:59am", "11:00am - 11:29am", "11:30am - 11:59am",
"12:00pm - 12:29pm", "12:30pm - 12:59pm", "1:00pm - 1:29pm",
"1:30pm - 1:59pm", "2:00pm - 2:29pm", "2:30pm - 2:59pm",
"3:00pm - 3:29pm", "3:30pm - 3:59pm", "4:00pm - 4:29pm",
"4:30pm - 4:59pm", "5:00pm - 5:29pm", "5:30pm - 5:59pm",
"6:00pm - 6:29pm", "6:30pm - 6:59pm", "7:00pm - 7:29pm",
"7:30pm - 7:59pm", "8:00pm - 8:29pm", "8:30pm - 8:59pm",
"9:00pm - 9:29pm", "9:30pm - 9:59pm", "10:00pm - 10:29pm",
"10:30pm - 10:59pm", "11:00pm - 11:29pm", "11:30pm - 11:59pm")
tod_breaks60 <- seq(from = 0, to = 1440, by = 60)
tod_labels60 <- c("12:00am - 12:59am", "1:00am - 1:59am", "2:00am - 2:59am",
"3:00am - 3:59am", "4:00am - 4:59am", "5:00am - 5:59am",
"6:00am - 6:59am", "7:00am - 7:59am", "8:00am - 8:59am",
"9:00am - 9:59am", "10:00am - 10:59am", "11:00am - 11:59am",
"12:00pm - 12:59pm", "1:00pm - 1:59pm", "2:00pm - 2:59pm",
"3:00pm - 3:59pm", "4:00pm - 4:59pm", "5:00pm - 5:59pm",
"6:00pm - 6:59pm", "7:00pm - 7:59pm", "8:00pm - 8:59pm",
"9:00pm - 9:59pm", "10:00pm - 10:59pm", "11:00pm - 11:59pm")
```
```{r ggplot_Theme}
theme_db <- theme_bw() + theme(plot.margin = unit(c(10,10,20,10),"pt")) # this should eventually be replaced with an RSG theme, which can be substituted for client themes in conjunction with the dashboard's css file in the YAML header
```
```{r Helper_Functions}
getLeafletScaleFactor <- function(n, n.max = 5000) {
raw.factor <- n/n.max
rounded.factors <- c(1, 5, 10, 25, 50, 100, 250, 500, 1000, 2500, 5000, 10000)
diffs <- raw.factor - rounded.factors
scale.factor <- rounded.factors[which(diffs < 0)[1]]
return(scale.factor)
}
sort_levels <- function(x, decreasing = TRUE, weight = NULL) {
x <- factor(x)
if (is.null(weight)) {
levels.sorted <- names(sort(table(x), decreasing = decreasing))
} else {
levels.sorted <- as.character(x)[order(weight, decreasing = decreasing)]
}
return(levels.sorted)
}
labelMAM <- function(x) {
x <- as.mam(x)
hour <- x %/% 60
min <- x %% 60
lab <- rep("", length(x))
lab[hour < 12 & hour > 0] <- paste0(hour[hour < 12 & hour > 0], ":",
str_pad(min[hour < 12 & hour > 0], width = 2, pad = "0"),
" a.m.")
lab[hour > 12] <- paste0(hour[hour > 12] - 12, ":",
str_pad(min[hour > 12], width = 2, pad = "0"),
" p.m.")
lab[hour == 0] <- paste0(12, ":",
str_pad(min[hour == 0], width = 2, pad = "0"),
" a.m.")
lab[hour == 12] <- paste0(hour[hour == 12], ":",
str_pad(min[hour == 12], width = 2, pad = "0"),
" p.m.")
return(lab)
}
chart_sort <- function(dt, col, weight = NULL) {
# This monster of a function that I insisted on putting on one line does the
# following: counts number of unique entries of "col", either weighted by
# the column "weight" or straight by N; sorts in ascending order by the
# counted column (either N or V1); pulls the indices of that sort; cross-
# references those indices back into the counted column; returns the
# respective value of "col."
if (is.null(weight)) {
return(dt[, .N, by = col][sort.int(dt[, .N, by = col][, N], index.return = TRUE, decreasing = TRUE)$ix, get(col)])
}
return(dt[, sum(get(weight)), by = col][sort.int(dt[, sum(get(weight)), by = col][, V1], index.return = TRUE, decreasing = TRUE)$ix, get(col)])
}
leaflet_custom <- function(data = NULL, width = NULL, height = NULL, padding = 0, elementId = NULL) {
htmlwidgets::createWidget(
'leaflet',
structure(
list(),
leafletData = data
),
width = width, height = height,
sizingPolicy = htmlwidgets::sizingPolicy(
defaultWidth = '100%',
defaultHeight = 400,
padding = padding,
browser.fill = TRUE
),
elementId = elementId
)
}
addTAZPoints <- function(map, data, group, shp, TAZcol = "TAZ", scale.factor = 1,
rad.px = 2, checkBoxes = TRUE, weight = NULL) {
# The layers of points to plot (drop any without records)
g <- data[[group]]
if (is.factor(g)) {
g.table <- table(g)
layers <- names(g.table)[g.table > 0]
} else {
layers <- sort(unique(g))
}
if (length(layers) > 24) warning("(DEVELOPER) Attempting to add more than 24 dot-density layers. This may result in a very large and unresponsive map. Recommend that you check your data.", immediate. = TRUE, call. = FALSE)
for (level in layers) {
if (is.null(weight)) {
counts <- data[get(group) == level, .N, by = TAZcol]
} else {
counts <- data[get(group) == level, .(N = sum(get(weight))), by = TAZcol]
}
points.list <- list()
for (i in seq(1, nrow(counts))) {
points <- NULL
n <- floor(counts[i, N] / scale.factor)
if (n < 1) {
next
}
tryCatch(
{
points <- spsample(shp[shp@data$TAZ == counts[i, get(TAZcol)], ],
n = n, type = "random")@coords
points.list <- rbind(points.list, points)
},
error = function(e) {
NULL
}
)
}
if (length(points.list) > 0) {
lngs <- unlist(points.list[, 1])
lats <- unlist(points.list[, 2])
map <- map %>% addCircleMarkers(lng = lngs, lat = lats,
radius = rad.px, fillOpacity = 1,
stroke = FALSE, group = level)
}
}
if (checkBoxes) {
map <- map %>% addLayersControl(overlayGroups = c(layers, "Background Map"),
options = layersControlOptions(collapsed = FALSE))
} else {
map <- map %>% addLayersControl(overlayGroups = "Background Map",
baseGroups = layers,
options = layersControlOptions(collapsed = FALSE))
}
return(map)
}
bar_plotter <- function(data, xvar, yvar, fill = "", position = "stack", xlabel = xvar, ylabel = yvar, xrotate = FALSE, yrotate = FALSE, coord_flip = FALSE, legend_label = TRUE) {
if (fill == "") {
p <- ggplot(data, aes_q(x = quote(get(xvar)), y = quote(get(yvar)))) +
geom_bar(stat = "identity", position = position, fill = "#08519c")
} else {
p <- ggplot(data, aes_q(x = quote(get(xvar)), y = quote(get(yvar)), fill = quote(get(fill)))) +
geom_bar(stat = "identity", position = position) +
labs(fill = fill)
}
p <- p + xlab(xlabel) + ylab(ylabel) +
theme_db
if (xrotate) {
p <- p + theme(axis.text.x = element_text(angle = 45, hjust = 1))
}
if (yrotate) {
p <- p + theme(axis.text.y = element_text(angle = 45, hjust = 1))
}
if (coord_flip) {
p <- p + coord_flip()
}
if (max(data[, get(yvar)]) >= 1000) {
p <- p + scale_y_continuous(labels = comma)
}
if (max(data[, get(yvar)]) <= 1) {
p <- p + scale_y_continuous(labels = percent)
}
if (!legend_label) {
p <- p + labs(fill = "")
}
p <- plotly_build(p)
p[["data"]] <- lapply(p[["data"]], function(x) {
x[["text"]] <- gsub(x[["text"]], pattern = "get\\(xvar\\)", replacement = xlabel)
x[["text"]] <- gsub(x[["text"]], pattern = "get\\(yvar\\)", replacement = ylabel)
x[["text"]] <- gsub(x[["text"]], pattern = "get\\(fill\\)", replacement = fill)
x[["text"]] <- sapply(x[["text"]], function(y) {
long_num <- as.numeric(gsub(y, pattern = gsub(gsub(y, pattern = "[\\+\\*\\(\\)\\[\\]]*", replacement = "."), pattern = "\\d{4,}\\.{0,1}\\d*", replacement = ""), replacement = ""))
if (!is.na(long_num)) {
y <- gsub(y, pattern = "\\d{4,}", replacement = format(floor(long_num), big.mark = ","))
}
if (max(data[, get(yvar)]) < 1) {
short_num <- as.numeric(gsub(y, pattern = gsub(gsub(y, pattern = "[\\+\\*\\(\\)\\[\\]]*", replacement = "."), pattern = "0\\.\\d*", replacement = ""), replacement = ""))
if (!is.na(short_num)) {
y <- gsub(y, pattern = "0\\.\\d*", replacement = percent(short_num))
}
}
return(y)
}, USE.NAMES = FALSE)
return(x)
})
return(p)
}
```
Overview
============================================
Summary {data-width=200}
--------------------------------------------
### About this Document
This document is stand-alone interactive dashboard viewable from most modern Internet browsers. The dashboard is meant to be a high-level summary of an __rFreight__ scenario. All of the data, charts, and maps viewable in this dashboard are embedded directly into the HTML file, so users are encouraged to share their scenario results with others via this document. An Internet connection is necessary for the best user experience, but is not required.
Users may navigate to different areas of the dashboard using the navigation bar at the top of the page, and may interact directly with most tables, charts, and maps.
This document is best viewed using the most recent versions of the following web browsers:
* [Google Chrome](https://www.google.com/chrome/browser/desktop/)
* [Mozilla Firefox](https://www.mozilla.org/en-US/firefox/new/)
* [Microsoft Internet Explorer](https://www.microsoft.com/en-us/download/internet-explorer.aspx)
Highlights {data-width=150}
--------------------------------------------
### Run Date
```{r Run_Date_ValueBox}
valueBox(Sys.Date(), "Model Run Date", icon = "fa-calendar")
```
### Run Duration
```{r Run_Duration_ValueBox}
value <- round(SCENARIO_RUN_DURATION, 1)
caption <- paste0("Model Runtime (", attr(value, "units"), ")")
valueBox(value, caption = caption, icon = "fa-clock-o")
```
### Synthesized Firms
```{r Synthesized_Firms_ValueBox}
value <- format(RegionalFirms[, .N], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Synthesized Firms", icon = "fa-building-o")
```
### Shipments Delivered
```{r Shipments_Delivered_ValueBox}
value <- format(AnnualShipments[, .N], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Freight Shipments", icon = "fa-cube")
```
### Freight Truck Tours
```{r Freight_Truck_Tours_ValueBox}
value <- format(ft_trips[, uniqueN(TourID)], big.mark = ",", trim = TRUE)
FreightTruckTours.ValueBox <- valueBox(value, caption = "Freight Truck Tours", icon = "fa-truck")
FreightTruckTours.ValueBox
```
### Commercial Vehicle Tours
```{r Commercial_Vehicle_Tours_ValueBox}
value <- format(cv_trips[, .N, by = .(BusID, Vehicle, TourID)][, .N], big.mark = ",", trim = TRUE)
CommercialVehicleTours.ValueBox <- valueBox(value, caption = "Commercial Vehicle Tours", icon = "fa-truck")
CommercialVehicleTours.ValueBox
```
### Total Stops
```{r Total_Stops_ValueBox}
value <- format(cv_trips[Activity != "Return", .N] + ft_trips[Activity != "Return", .N],
big.mark = ",", trim = TRUE)
valueBox(value, caption = "Total Stops", icon = "fa-map-marker")
```
### Intermediate Stops
```{r Intermediate_Stops_ValueBox}
value <- format(cv_trips[Scheduled == 0L, .N] + ft_trips[Scheduled == 0L, .N],
big.mark = ",", trim = TRUE)
valueBox(value, caption = "Intermediate Stops", icon = "fa-cutlery")
```
Model Region Map {data-width=650}
--------------------------------------------
### Model Region and Traffic Analysis Zone (TAZ) System
```{r Model_Region_Map}
colorFun <- colorFactor(palette = "Dark2", domain = shp@data[["Organization"]])
map <- leaflet_custom(elementId = "test") %>%
addProviderTiles(map_type, group = "Background Map") %>%
addLayersControl(
overlayGroups = "Background Map", options = layersControlOptions(collapsed = FALSE)
) %>%
setView(-79.84229, 35.93984, 10) %>%
addLegend(position = "bottomright", pal = colorFun, values = levels(shp@data[["Organization"]]))
map
```
Charts {data-navmenu="Firm Synthesis"}
============================================
Highlights {data-width=150}
--------------------------------------------
### Synthesized Firms
```{r Synthesized_Firms_ValueBox2}
value <- format(RegionalFirms[, .N], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Synthesized Firms", icon = "fa-building-o")
```
### Synthesized Employment
```{r Synthesized_Employment_ValueBox}
value <- format(RegionalFirms[, sum(Employees)], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Synthesized Employees", icon = "fa-briefcase")
```
Chart Column 1 {data-width=283}
--------------------------------------------
### Firms by Industry
```{r Chart_Firms_By_Industry}
# Organize
dat <- RegionalFirms[, .N, by = .(Industry = Industry10)][order(Industry)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Firms_by_Industry.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Industry", yvar = "N", ylabel = "Firms", xrotate = TRUE)
p
```
### Firms by Size
```{r Chart_Firms_By_Size}
# Organize
dat <- RegionalFirms[, .N, by = .(Size = esizecat)][order(Size)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Firms_by_Size.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Size", yvar = "N", xlabel = "Firm Size Category", ylabel = "Firms", xrotate = TRUE)
p
```
Chart Column 2 {data-width=283}
--------------------------------------------
### Employment by Industry
```{r Chart_Employment_By_Industry}
# Organize
dat <- RegionalFirms[, .(Employees = sum(Employees)), by = .(Industry = Industry10)][order(Industry)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Employees_by_Industry.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Industry", yvar = "Employees", xrotate = TRUE)
p
```
### Employment by Size
```{r Chart_Employment_By_Size}
# Organize
dat <- RegionalFirms[, .(Employees = sum(Employees)), by = .(Size = esizecat)][order(Size)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Employees_by_Size.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Size", yvar = "Employees", xlabel = "Firm Size Category", xrotate = TRUE)
p
```
Chart Column 3 {.tabset .tabset-fade data-width=283}
--------------------------------------------
### Firms by Commodity Produced
```{r Chart_Firms_By_Commodity_Produced}
# Organize
dat <- RegionalFirms[!is.na(SCTG), .(SCTG)]
dat <- dat[SCTGCodes, Commodity := factor(i.Label), on = "SCTG", nomatch = 0]
dat[, Commodity := factor(Commodity, levels = sort_levels(Commodity))]
dat <- dat[, .N, by = .(SCTG, Commodity)][order(SCTG)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Firms_by_Commodity.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Commodity", yvar = "N", xlabel = "Commodity Produced", ylabel = "Firms", coord_flip = TRUE)
p
```
### Firms by Industry and Size
```{r Chart_Firms_By_Commodity_And_Size}
# Organize
dat <- RegionalFirms[, .N, by = .(Industry = Industry10, Size = esizecat)][order(Industry, Size)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Firms_by_Commodity_and_Size.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Industry", yvar = "N", fill = "Size", ylabel = "Firms", coord_flip = TRUE)
p
```
Maps {data-navmenu="Firm Synthesis"}
============================================
Column-1 {.tabset .tabset-fade}
--------------------------------------------
### Firms by Industry
```{r Map_Firms_By_Industry, eval=USER_GENERATE_DASHBOARD_MAPS}
k <- 10
map <- leaflet(width = "100%") %>%
addProviderTiles(map_type, group = "Background Map")
map <- map %>% addTAZPoints(data = RegionalFirms, shp = shp, group = "Industry10",
scale.factor = k)
map
```
> Note: Each data point represents `r comma(k)` firms and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
### Employment by Industry
```{r Map_Employment_By_Industry, eval=USER_GENERATE_DASHBOARD_MAPS}
k <- 100
map <- leaflet(shp, width = "100%") %>%
addProviderTiles(map_type, group = "Background Map")
map <- map %>% addTAZPoints(data = RegionalFirms, shp = shp,
group = "Industry10", weight = "Employees",
scale.factor = k)
map
```
> Note: Each data point represents `r comma(k)` employees and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
### Firms by Size
```{r Map_Firms_By_Size, eval=USER_GENERATE_DASHBOARD_MAPS}
k <- 10
map <- leaflet(shp, width = "100%") %>%
addProviderTiles(map_type, group = "Background Map")
map <- map %>% addTAZPoints(data = RegionalFirms, shp = shp,
group = "esizecat", scale.factor = k)
map
```
> Note: Each data point represents `r comma(k)` firms and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
### Employment by Size
```{r Map_Employment_By_Size, eval=USER_GENERATE_DASHBOARD_MAPS}
k <- 100
map <- leaflet(shp, width = "100%") %>%
addProviderTiles(map_type, group = "Background Map")
map <- map %>% addTAZPoints(data = RegionalFirms, shp = shp,
group = "esizecat", weight = "Employees",
scale.factor = k)
map
```
> Note: Each data point represents `r comma(k)` employees and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Shipments {data-navmenu="Annual Shipments"}
============================================
Highlights {data-width=150}
--------------------------------------------
### Annual Shipments
```{r Annual_Shipments_ValueBox}
value <- format(AnnualShipments[, sum(NumShipments)], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Annual Shipments", icon = "fa-cube")
```
### Annual Shipments (II)
```{r Annual_II_Shipments_ValueBox}
value <- format(AnnualShipments[Movement.Type == "II", sum(NumShipments)], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Internal-to-Internal (II)", icon = "fa-arrows")
```
### Annual Shipments (IX)
```{r Annual_IX_Shipments_ValueBox}
value <- format(AnnualShipments[Movement.Type == "IX", sum(NumShipments)], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Internal-to-External (IX)", icon = "fa-arrow-up")
```
### Annual Shipments (XI)
```{r Annual_XI_Shipments_ValueBox}
value <- format(AnnualShipments[Movement.Type == "XI", sum(NumShipments)], big.mark = ",", trim = TRUE)
valueBox(value, caption = "External-to-Internal (XI)", icon = "fa-arrow-down")
```
Chart Column 1 {data-width=283}
--------------------------------------------
### Movement Type and Mode
```{r Chart_Shipments_By_MovementType_And_Mode}
# Organize
dat <- AnnualShipments[, .(Shipments = sum(NumShipments)),
by = .(Mode, `Movement Type` = Movement.Type)][order(Mode, `Movement Type`)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Shipments_by_MovementType_and_Mode.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Movement Type", yvar = "Shipments", fill = "Mode")
p
```
> Note: "Mode" refers to the mode of the long distance movement.
### Movement Type and Production/Consumption
```{r Chart_Shipments_By_MovementType_And_ProCon}
# Organize
dat <- AnnualShipments[, .(Shipments = sum(NumShipments)), by = .(`Movement Type` = Movement.Type)]
dat[`Movement Type` %in% c("II", "XI"), ProCon := "Consume"]
dat[`Movement Type` == "IX", ProCon := "Produce"]
dat <- rbind(dat, dat[`Movement Type` == "II", .(`Movement Type`, Shipments, ProCon = "Produce")])
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Shipments_by_MovementType_and_ProductionConsumption.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Movement Type", yvar = "Shipments", fill = "ProCon")
p
```
> Note: Internal-to-Internal shipments are counted as both production and consumption for the model region.
Chart Column 2 {data-width=283}
--------------------------------------------
### Shipment Size
```{r Chart_Shipments_By_ShipmentSize}
# Organize
dat <- AnnualShipments[, .(Shipments = sum(NumShipments)),
by = .(`Shipment Size` = ShipmentSize)][order(`Shipment Size`)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Shipments_by_ShipmentSize.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Shipment Size", yvar = "Shipments", xrotate = TRUE, coord_flip = TRUE)
p
```
Chart Column 3 {.tabset data-width=283}
--------------------------------------------
### Commodity and Movement Type
```{r Chart_Shipments_By_Commodity_And_Movement_Type}
# Organize
dat <- AnnualShipments[, .(Shipments = sum(NumShipments)),
by = .(SCTG, `Movement Type` = Movement.Type)][order(SCTG, `Movement Type`)]
dat[SCTGCodes, Commodity := i.Label, on = "SCTG", nomatch = 0]
setcolorder(dat, neworder = c("SCTG", "Commodity", "Movement Type", "Shipments"))
sorted.levels <- dat[, .(Shipments = sum(Shipments)), by = Commodity][, sort_levels(Commodity, weight = Shipments)]
dat[, Commodity := factor(Commodity, levels = sorted.levels)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Shipments_by_Commodity_and_MovementType.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Commodity", yvar = "Shipments", fill = "Movement Type", xrotate = TRUE, coord_flip = TRUE)
p
```
### Commodity and Production/Consumption
```{r Chart_Shipments_By_Commodity_And_ProCon}
# Organize
dat <- AnnualShipments[, .(Shipments = sum(NumShipments)), by = .(SCTG, Movement.Type)][order(SCTG, Movement.Type)]
dat[Movement.Type %in% c("II", "XI"), ProCon := "Consume"]
dat[Movement.Type == "IX", ProCon := "Produce"]
dat <- rbind(dat, dat[Movement.Type == "II", .(SCTG, Movement.Type, Shipments, ProCon = "Produce")])
dat <- dat[, .(Shipments = sum(Shipments)), by = .(SCTG, ProCon)]
dat[SCTGCodes, Commodity := i.Label, on = "SCTG", nomatch = 0]
setcolorder(dat, neworder = c("SCTG", "Commodity", "ProCon", "Shipments"))
sorted.levels <- dat[, .(Shipments = sum(Shipments)), by = Commodity][, sort_levels(Commodity, weight = Shipments)]
dat[, Commodity := factor(Commodity, levels = sorted.levels)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Shipments_by_Commodity_and_ProductionConsumption.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Commodity", yvar = "Shipments", fill = "ProCon", xrotate = TRUE, coord_flip = TRUE, legend_label = FALSE)
p
```
> Note: Internal-to-Internal shipments are counted as both production and consumption for the model region.
Tonnage {data-navmenu="Annual Shipments"}
============================================
Highlights {data-width=150}
--------------------------------------------
### Annual Tonnage
```{r Annual_Tonnage_ValueBox}
value <- format(AnnualShipments[, sum(ShipmentWeight)/2000], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Annual Tonnage", icon = "fa-cube")
```
### Annual Tonnage (II)
```{r Annual_II_Tonnage_ValueBox}
value <- format(AnnualShipments[Movement.Type == "II", sum(ShipmentWeight)/2000], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Internal-to-Internal (II)", icon = "fa-arrows")
```
### Annual Tonnage (IX)
```{r Annual_IX_Tonnage_ValueBox}
value <- format(AnnualShipments[Movement.Type == "IX", sum(ShipmentWeight)/2000], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Internal-to-External (IX)", icon = "fa-arrow-up")
```
### Annual Tonnage (XI)
```{r Annual_XI_Tonnage_ValueBox}
value <- format(AnnualShipments[Movement.Type == "XI", sum(ShipmentWeight)/2000], big.mark = ",", trim = TRUE)
valueBox(value, caption = "External-to-Internal (XI)", icon = "fa-arrow-down")
```
Chart Column 1 {data-width=283}
--------------------------------------------
### Movement Type and Mode
```{r Chart_Tonnage_By_MovementType_And_Mode}
# Organize
dat <- AnnualShipments[, .(Tonnage = sum(ShipmentWeight)/2000),
by = .(Mode, `Movement Type` = Movement.Type)][order(Mode, `Movement Type`)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Tonnage_by_MovementType_and_Mode.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Movement Type", yvar = "Tonnage", fill = "Mode")
p
```
> Note: "Mode" refers to the mode of the long distance movement.
### Movement Type and Production/Consumption
```{r Chart_Tonnage_By_MovementType_And_ProCon}
# Organize
dat <- AnnualShipments[, .(Tonnage = sum(ShipmentWeight)/2000), by = .(`Movement Type` = Movement.Type)]
dat[`Movement Type` %in% c("II", "XI"), ProCon := "Consume"]
dat[`Movement Type` == "IX", ProCon := "Produce"]
dat <- rbind(dat, dat[`Movement Type` == "II", .(`Movement Type`, Tonnage, ProCon = "Produce")])
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Tonnage_by_MovementType_and_ProductionConsumption.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Movement Type", yvar = "Tonnage", fill = "ProCon")
p
```
> Note: Internal-to-Internal tonnage is counted as both production and consumption for the model region.
Chart Column 2 {data-width=283}
--------------------------------------------
### Shipment Size
```{r Chart_Tonnage_By_ShipmentSize}
# Organize
dat <- AnnualShipments[, .(Tonnage = sum(ShipmentWeight)/2000),
by = .(`Shipment Size` = ShipmentSize)][order(`Shipment Size`)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Tonnage_by_ShipmentSize.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Shipment Size", yvar = "Tonnage", xrotate = TRUE, coord_flip = TRUE)
p
```
Chart Column 3 {.tabset data-width=283}
--------------------------------------------
### Commodity and Movement Type
```{r Chart_Tonnage_By_Commodity_And_Movement_Type}
# Organize
dat <- AnnualShipments[, .(Tonnage = sum(ShipmentWeight)/2000),
by = .(SCTG, `Movement Type` = Movement.Type)][order(SCTG, `Movement Type`)]
dat[SCTGCodes, Commodity := i.Label, on = "SCTG", nomatch = 0]
setcolorder(dat, neworder = c("SCTG", "Commodity", "Movement Type", "Tonnage"))
sorted.levels <- dat[, .(Tonnage = sum(Tonnage)), by = Commodity][, sort_levels(Commodity, weight = Tonnage)]
dat[, Commodity := factor(Commodity, levels = sorted.levels)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Tonnage_by_Commodity_and_MovementType.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Commodity", yvar = "Tonnage", fill = "Movement Type", xrotate = TRUE, coord_flip = TRUE)
p
```
### Commodity and Production/Consumption
```{r Chart_Tonnage_By_Commodity_And_ProCon}
# Organize
dat <- AnnualShipments[, .(Tonnage = sum(ShipmentWeight)/2000), by = .(SCTG, Movement.Type)][order(SCTG, Movement.Type)]
dat[Movement.Type %in% c("II", "XI"), ProCon := "Consume"]
dat[Movement.Type == "IX", ProCon := "Produce"]
dat <- rbind(dat, dat[Movement.Type == "II", .(SCTG, Movement.Type, Tonnage, ProCon = "Produce")])
dat <- dat[, .(Tonnage = sum(Tonnage)), by = .(SCTG, ProCon)]
dat[SCTGCodes, Commodity := i.Label, on = "SCTG", nomatch = 0]
setcolorder(dat, neworder = c("SCTG", "Commodity", "ProCon", "Tonnage"))
sorted.levels <- dat[, .(Tonnage = sum(Tonnage)), by = Commodity][, sort_levels(Commodity, weight = Tonnage)]
dat[, Commodity := factor(Commodity, levels = sorted.levels)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Tonnage_by_Commodity_and_ProductionConsumption.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Commodity", yvar = "Tonnage", fill = "ProCon", xrotate = TRUE, coord_flip = TRUE, legend_label = FALSE)
p
```
> Note: Internal-to-Internal tonnage is counted as both production and consumption for the model region.
Tables {data-navmenu="Freight Truck Tours"}
============================================
Table Column 1 {.tabset .tabset-fade}
--------------------------------------------
### External Station Truck Counts
```{r Table_Freight_Truck_ExternalStation_Counts}
# Organize
dat <- ft_trips[Movement.Type != "II", .(Count = .N), by = .(ExternalStation, `Movement Type` = Movement.Type, Vehicle)][order(ExternalStation, `Movement Type`, Vehicle)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Freight_Truck_Counts_ExternalStations.csv"), row.names = FALSE)
# Plot
datatable(dat)
```
Charts {data-navmenu="Freight Truck Tours"}
============================================
Highlights {data-width=150}
--------------------------------------------
### Freight Truck Tours
```{r Freight_Truck_Tours_ValueBox2}
FreightTruckTours.ValueBox
```
### Freight Truck Peddling Tours
```{r Freight_Truck_Peddling_Tours}
value <- format(ft_trips[Peddled == 1L, uniqueN(TourID)], big.mark = ",", trim = TRUE)
valueBox(value, caption = "Peddling Tours", icon = "fa-truck")
```
### Total Stops
```{r Freight_Truck_Total_Stops_ValueBox}
value <- format(ft_trips[Activity != "Return", .N], big.mark = ",", trim = TRUE)
valueBox(value, "Total Stops", icon = "fa-map-marker", color = "success")
```
### Intermediate Stops
```{r Freight_Truck_Intermediate_Stops_ValueBox}
value <- format(ft_trips[Scheduled == 0L, .N], big.mark = ",", trim = TRUE)
valueBox(value, "Intermediate Stops", icon = "fa-cutlery")
```
Chart Column 1 {data-width=283}
--------------------------------------------
### Placeholder
### Placeholder
### Placeholder
Chart Column 2 {data-width=283}
--------------------------------------------
### Placeholder
### External Station Truck Counts
```{r Table_Freight_Truck_ExternalStationGroup_Counts}
# Organize
dat <- ft_trips[Movement.Type != "II", .(Count = .N), by = .(Direction, `Movement Type` = Movement.Type)][order(Direction, `Movement Type`)]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Freight_Truck_Counts_ExternalStationGroups.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Direction", yvar = "Count", fill = "Movement Type",
xrotate = TRUE, coord_flip = TRUE)
p
```
Densities {data-navmenu="Freight Truck Tours"}
============================================
Density Column 1
--------------------------------------------
### First Stop Arrival Time by Vehicle
```{r Density_Freight_Arrival_Time_By_Vehicle}
# Organize
dat <- ft_trips[TripID == 1L, .(`Arrival Time` = as.numeric(MAMArrive), Vehicle)]
# Save
# Plot
breaks <- seq(from = 0, to = 1439, 60)
p <- ggplot(dat, aes(x = `Arrival Time`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") +
scale_x_continuous(breaks = breaks, labels = labelMAM(breaks)) +
theme_db + theme(axis.text = element_text(angle = 90, hjust = 1))
ggplotly(p)
```
### First Stop Arrival Time by Activity
```{r Density_Freight_Arrival_Time_By_Activity}
# Organize
ft_trips[Scheduled == 1L, MinTripID := min(TripID), by = .(Vehicle, TourID)]
dat <- ft_trips[TripID == MinTripID, .(`Arrival Time` = as.numeric(MAMArrive), Activity)]
# Save
# Plot
breaks <- seq(from = 0, to = 1439, 60)
p <- ggplot(dat, aes(x = `Arrival Time`, fill = Activity)) +
geom_density(alpha = 0.25) + ylab("Density") +
scale_x_continuous(breaks = breaks, labels = labelMAM(breaks)) +
theme_db + theme(axis.text = element_text(angle = 90, hjust = 1))
ggplotly(p)
```
Density Column 2 {.tabset .tabset-fade}
--------------------------------------------
### Tour Length by Vehicle
```{r Density_Freight_Tour_Length_By_Vehicle}
# Organize
dat <- ft_trips[, .(`Tour Length (miles)` = sum(Distance)), by = .(Vehicle, TourID)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Tour Length (miles)`, alpha))
p <- ggplot(dat, aes(x = `Tour Length (miles)`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of trips are longer than `r round(x.limits[2])` miles and are not displayed.
### Trip Length by Vehicle
```{r Density_Freight_Trip_Length_By_Vehicle}
# Organize
dat <- ft_trips[, .(Vehicle, `Trip Length (miles)` = Distance)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Trip Length (miles)`, alpha))
p <- ggplot(dat, aes(x = `Trip Length (miles)`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of trips are longer than `r round(x.limits[2])` miles and are not displayed.
### Tour Duration by Vehicle
```{r Density_Freight_Tour_Duration_By_Vehicle}
# Organize
dat <- ft_trips[, .(`Tour Duration (mins)` = sum(TravelTime + StopDuration)),
by = .(Vehicle, TourID)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Tour Duration (mins)`, alpha))
p <- ggplot(dat, aes(x = `Tour Duration (mins)`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of trips are longer than `r round(x.limits[2])` minutes and are not displayed.
### Trip Duration by Vehicle
```{r Density_Freight_Trip_Duration_By_Vehicle}
# Organize
dat <- ft_trips[, .(Vehicle, `Trip Duration (mins)` = TravelTime)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Trip Duration (mins)`, alpha))
p <- ggplot(dat, aes(x = `Trip Duration (mins)`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of trips are longer than `r round(x.limits[2])` minutes and are not displayed.
### Stop Duration by Vehicle
```{r Density_Freight_Stop_Duration_By_Vehicle}
# Organize
dat <- ft_trips[Activity != "Return",
.(Vehicle, `Stop Duration (minutes)` = StopDuration)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Stop Duration (minutes)`, alpha))
p <- ggplot(dat, aes(x = `Stop Duration (minutes)`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of stops are longer than `r round(x.limits[2])` minutes and are not displayed.
### Stop Duration by Activity
```{r Density_Freight_Stop_Duration_By_Activity}
# Organize
dat <- ft_trips[Activity != "Return",
.(Activity, `Stop Duration (minutes)` = StopDuration)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Stop Duration (minutes)`, alpha))
p <- ggplot(dat , aes(x = `Stop Duration (minutes)`, fill = Activity)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of stops are longer than `r round(x.limits[2])` minutes and are not displayed.
Maps {data-navmenu="Freight Truck Tours"}
============================================
Maps {.tabset .tabset-fade}
--------------------------------------------
### Stops Over Time
```{r Map_Freight_Stops_Over_Time, eval=USER_GENERATE_DASHBOARD_MAPS}
stops_total <- ft_trips[, TimeBins := as.factor(floor(MAMArrive / 60))]
stops_total <- stops_total[, .N, by = .(TAZ.Destination, TimeBins)]
stops_total[, nPts := floor(log(N) / 3)]
stops_total <- stops_total[nPts > 0]
map <- leaflet_custom(elementId = "ftstoptime") %>%
addProviderTiles(map_type, group = "Background Map") %>%
setView(-79.84229, 35.93984, 10)
map$dependencies <- c(map$dependencies, list(htmlDependency(
name = "leaflet-timeline",
version = "1.0.0",
src = c("file" = SYSTEM_TEMPLATES_PATH),
script = "javascripts/leaflet.timeline.js",
stylesheet = "stylesheets/leaflet.timeline.css"
)))
map_center <- coordinates(shp_outline)
dimnames(map_center)[[2]] <- c("lon", "lat")
ghost_df <- data.frame()
points_df <- data.frame()
setkey(stops_total, TAZ.Destination)
for (time_bin in levels(stops_total[["TimeBins"]])) {
stops_time <- stops_total[TimeBins == time_bin, .(TAZ.Destination, nPts)]
for (i in seq_len(nrow(stops_time))) {
points <- NULL
n <- stops_time[i, nPts]
if (n < 1) {
next
}
polygon_TAZ <- shp[shp@data$TAZ == stops_time[i, TAZ.Destination], ]
tryCatch(
{
points <- spsample(polygon_TAZ, n = n, type = "random")@coords
},
error = function(e) {
NULL
}
)
if (!is.null(points)) {
dimnames(points)[[2]] <- c("lon", "lat")
start <- strptime(sprintf("2000-01-01 %02d:00", as.integer(time_bin)), format = "%Y-%m-%d %H:%M")
end <- strptime(sprintf("2000-01-01 %02d:59", as.integer(time_bin)), format = "%Y-%m-%d %H:%M")
points_df <- rbind(points_df, data.frame(points, "start" = start, "end" = end))
}
}
start <- strptime(sprintf("2000-01-01 %02d:00", as.integer(time_bin) ), format = "%Y-%m-%d %H:%M")
end <- strptime(sprintf("2000-01-01 %02d:00", (as.integer(time_bin) + 1)), format = "%Y-%m-%d %H:%M")
ghost_df <- rbind(ghost_df, data.frame(map_center, "start" = start, "end" = end))
}
ghost_json <- geojson_json(ghost_df, lat = "lat", lon = "lon")
points_json <- geojson_json(points_df, lat = "lat", lon = "lon")
map %>%
onRender(sprintf(
'function(el,x){
var slider = L.timelineSliderControl({
steps: 48,
duration: 24000,
showTicks: true,
waitToUpdateMap: true,
formatOutput: function(date){
return new Date(date).toLocaleTimeString("en-US", { hour12: false, second: undefined });
}
});
HTMLWidgets.find("#ftstoptime").addControl(slider);
var timeline = L.timeline(%s, {
pointToLayer: function(data, latlng){
return L.circle(latlng, 200, {
fillOpacity: 1,
opacity: 1
});
}
});
timeline.addTo(HTMLWidgets.find("#ftstoptime"));
var ghostTimeline = L.timeline(%s, {
pointToLayer: function(data, latlng){
return L.circle(latlng, 1, {
fillOpacity: 0,
opacity: 0
});
}
});
ghostTimeline.addTo(HTMLWidgets.find("#ftstoptime"));
slider.addTimelines(timeline, ghostTimeline);
}',
points_json,
ghost_json
))
```
### Sampled Tours
```{r Map_Freight_Sample_Tours, eval=USER_GENERATE_DASHBOARD_MAPS}
javascript <- 'function(el, x) {
var basemaps = {};'
map <- leaflet_custom(elementId = "ft_sampletours") %>%
addProviderTiles(map_type, group = "Background Map") %>%
setView(-79.84229, 35.93984, 10) %>%
addControl(
'Delivery
Return
Pick-Up
Break/Meal
Transfer
Other
Vehicle Service
',
position = "bottomright"
)
map$dependencies <- c(map$dependencies, list(htmlDependency(
name = "leaflet-polylinedecorator",
version = "1.1.0",
src = c("file" = SYSTEM_TEMPLATES_PATH),
script = "javascripts/leaflet.polylineDecorator.js"
)))
used_bus <- numeric(0)
for (bus_num in 1:5) {
i <- 1
max <- 5
possible_businesses <- Facilities[ID %in% unique(ft_trips[, TourID, by = DistID])[, .N, by = DistID][N == max, DistID] & !(ID %in% used_bus), ID]
while (TRUE) {
business <- ft_trips[DistID == possible_businesses[i], ]
if (nrow(business) > 0) {
if (length(business[NintStops == 1, TourID]) >= 4) {
business <- business[TourID %in% unique(business[!TourID %in% business[NintStops == 1, TourID]][, TourID])[1:4]]
break
}
}
i <- i + 1
if (i > length(possible_businesses)) {
max <- max + 1
possible_businesses <- Facilities[ID %in% unique(ft_trips[, TourID, by = DistID])[, .N, by = DistID][N == max, DistID] & !(ID %in% used_bus), ID]
i <- 1
}
}
used_bus[bus_num] <- business[1, DistID]
pal <- colorFactor(palette = "Set1", levels = unique(business$TourID))
javascript <- paste0(javascript, sprintf('var lG_%s = L.layerGroup();', bus_num))
for (tour in unique(business$TourID)) {
coords <- coordinates(shp[shp@data$TAZ %in% business[TourID == tour, TAZ.Origin], ])
coords <- rbind(coords, coords[1, c(1, 2)]) # This assumes that the tour is a closed walk (beginning and ending vertices are identical)
coords[ , c(1,2)] <- coords[ , c(2,1)]
javascript <- paste0(javascript, sprintf(
'var pl_%s = L.polyline(%s, {opacity: 1, weight: 3, color: "%s"});
lG_%s.addLayer(pl_%s);',
tour,
toJSON(coords),
pal(tour),
bus_num,
tour
))
for (i in 1:(nrow(coords) - 1)) {
javascript <- paste0(javascript, sprintf(
'var plDec_%s = L.polylineDecorator(%s, {
patterns: [{offset: "100%%", repeat: 0, symbol: L.Symbol.arrowHead({pixelSize: 15, pathOptions: {fillOpacity: 1, weight: 0, color: "%s"}})}]
});
lG_%s.addLayer(plDec_%s);',
paste0(tour, i),
toJSON(coords[i:(i + 1),c(1,2)]),
pal(tour),
bus_num,
paste0(tour, i)
))
}
}
for (activity in unique(business$Activity)) {
coords <- coordinates(shp[shp@data$TAZ %in% business[Activity == activity, TAZ.Destination], ])
coords <- rbind(coords, coords[1, c(1, 2)])
coords[ , c(1,2)] <- coords[ , c(2,1)]
for (i in 1:(nrow(coords) - 1)) {
javascript <- paste0(javascript, sprintf(
'var plDec_%s = L.polylineDecorator(%s, {
patterns: [{offset: 0, repeat: 0, symbol: L.Symbol.marker({markerOptions: {icon: L.divIcon({className: "leaflet-div-icon-ft-%s"})}})}]
});
lG_%s.addLayer(plDec_%s);',
paste0(tolower(gsub("[^[:alpha:]]", "_", activity)), i),
toJSON(coords[i:(i + 1),c(1,2)]),
tolower(gsub("[^[:alpha:]]", "_", activity)),
bus_num,
paste0(tolower(gsub("[^[:alpha:]]", "_", activity)), i)
))
}
}
javascript <- paste0(javascript, sprintf(
'basemaps["Facility %s"] = lG_%s;',
bus_num,
bus_num
))
}
javascript <- paste0(javascript, sprintf(
'lG_%s.addTo(HTMLWidgets.find("#%s"));
L.control.layers(basemaps, {}).addTo(HTMLWidgets.find("#%s"));
}',
1,
"ft_sampletours",
"ft_sampletours"
))
map <- onRender(map, javascript)
map
```
> Note: These are a sampling of peddling-tours from a few distribution centers for illustrative purposes.
### Stops by Vehicle Type
```{r Map_Freight_Stops_By_Vehicle, eval=USER_GENERATE_DASHBOARD_MAPS}
k <- 25
map <- leaflet() %>%
addProviderTiles(map_type, group = "Background Map")
map <- map %>% addTAZPoints(data = ft_trips[!Activity %in% c("Return", "Transfer")],
shp = shp, group = "Vehicle",
scale.factor = k, TAZcol = "TAZ.Destination")
map
```
> Note: Each data point represents `r comma(k)` stops and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
### Stops by Activity
```{r Map_Freight_Stops_By_Activity, eval=USER_GENERATE_DASHBOARD_MAPS}
k <- 25
map <- leaflet() %>%
addProviderTiles(map_type, group = "Background Map")
map <- map %>% addTAZPoints(data = ft_trips[!Activity %in% c("Return", "Transfer")],
shp = shp, group = "Activity",
scale.factor = k, TAZcol = "TAZ.Destination")
map
```
> Note: Each data point represents `r comma(k)` stops and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Calibration {data-navmenu="Freight Truck Tours"}
============================================
Chart Column 1
--------------------------------------------
### Vehicle Shares
```{r Calibration_Freight_Vehicle_Shares}
# Organize
dat <- ft_trips[, .N, by = Vehicle][order(Vehicle), .(Vehicle, Simulated = N/sum(N))]
targets <- data.table(Vehicle = c("Light", "Medium", "Heavy"),
Target = c(0.082, 0.692, 0.226))
dat[targets, Target := i.Target, on = "Vehicle", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Freight_Truck_Vehicle_Shares.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Vehicle", value.name = "Share")
p <- bar_plotter(dat, xvar = "Vehicle", yvar = "Share", fill = "variable", position = "dodge", legend_label = FALSE)
p
```
### Stops per Peddling Tour
```{r Calibration_Freight_Stops_Per_Tour}
# Organize
dat <- ft_trips[Peddled == 1L, .N, by = .(TourID, Vehicle)][, .(`Simulated` = mean(N)), by = Vehicle][order(Vehicle)]
targets <- data.table(Vehicle = c("Light", "Medium", "Heavy"),
Target = c(2.6, 15.1, 6.8))
dat[targets, Target := i.Target, on = "Vehicle", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Freight_Truck_Stops_per_Tour.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Vehicle", value.name = "Stops/Tour")
p <- bar_plotter(dat, xvar = "Vehicle", yvar = "Stops/Tour", fill = "variable", position = "dodge", legend_label = FALSE)
p
```
### Single-Stop Peddling Tours
```{r Calibration_Freight_Single_Stop_Tours}
# Organize
dat <- ft_trips[Peddled == 1L, .(N = sum(Scheduled) - 1L),
by = .(TourID, Vehicle)][, .(`Simulated` = sum(N==1L)/.N), by = Vehicle][order(Vehicle)]
targets <- data.table(Vehicle = c("Light", "Medium", "Heavy"),
Target = c(0.414, 0.070, 0.182))
dat[targets, Target := i.Target, on = "Vehicle", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Freight_Truck_Single_Stop_Tour_Shares.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Vehicle", value.name = "Share")
p <- bar_plotter(dat, xvar = "Vehicle", yvar = "Share", fill = "variable", position = "dodge", legend_label = FALSE)
p
```
> Note: The proportion of single-stop tours is not directly calibrated.
Chart Column 2
--------------------------------------------
### First Stop Arrival Time
```{r Freight_Truck_First_Stop_Arrival_Time}
# Organize
dat <- ft_trips[TripID == 1L, .(TourID, MAMArrive)]
dat[, `Arrival Time` := cut(MAMArrive, breaks = tod_breaks30, labels = tod_labels30, ordered_result = TRUE, right = FALSE)]
dat <- dat[, .N, by = `Arrival Time`][order(`Arrival Time`), .(`Arrival Time`, Share = N/sum(N))]
targets <- data.table(`Arrival Time` = tod_labels30,
Share = c(0.004388279, 0.013164838, 0.013164838, 0.008776559,
0.000000000, 0.017553117, 0.013164838, 0.013164838,
0.013164838, 0.026329676, 0.035106234, 0.032609484,
0.030717955, 0.032609484, 0.062116995, 0.049557379,
0.069607246, 0.078383805, 0.049633242, 0.048952157,
0.038284070, 0.019444646, 0.008171337, 0.032004262,
0.023832925, 0.018839424, 0.036392541, 0.030112733,
0.023832925, 0.025119232, 0.015056367, 0.017553117,
0.016342674, 0.004388279, 0.008171337, 0.004388279,
0.003783057, 0.008776559, 0.004388279, 0.001891529,
0.010668087, 0.000000000, 0.008776559, 0.008171337,
0.000000000, 0.008776559, 0.006279808, 0.004388279))
dat[targets, Target := i.Share, on = "Arrival Time", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Freight_Truck_Arrival_Time_Shares.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Arrival Time")
p <- bar_plotter(dat, xvar = "Arrival Time", yvar = "value", fill = "variable", position = "dodge", coord_flip = TRUE, legend_label = FALSE)
p
```
Chart Column 3
--------------------------------------------
### Intermediate Stops per Scheduled Stop
```{r Calibration_Freight_Intermediate_Per_Scheduled_Stop}
# Organize
dat <- ft_trips[, .(Simulated = sum(Scheduled == 0L)/(sum(Scheduled == 1L) - 1L)),
by = Vehicle][order(Vehicle)]
targets <- data.table(Vehicle = c("Light", "Medium", "Heavy"),
Target = c(0.094, 0.067, 0.040))
dat[targets, Target := i.Target, on = "Vehicle", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Freight_Truck_IntermediateStops_per_ScheduledStop.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Vehicle", value.name = "Intermediate Stops/Scheduled Stop")
p <- ggplot(dat, aes(x = Vehicle, y = `Intermediate Stops/Scheduled Stop`, fill = variable)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = comma) +
theme_db + theme(legend.title=element_blank())
ggplotly(p)
```
### Meal or Break Stops per 8 Hours
```{r Calibration_Freight_MealBreak_Stops_Per_8Hours}
# Organize
dat <- ft_trips[, .(Simulated = sum(Activity == "Break/Meal")/(sum(TravelTime + StopDuration)/(8*60))),
by = Vehicle][order(Vehicle)]
targets <- data.table(Vehicle = c("Light", "Medium", "Heavy"),
Target = c(0.219, 0.290, 0.229))
dat[targets, Target := i.Target, on = "Vehicle", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Freight_Truck_MealBreak_Stops_per_8Hours.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Vehicle", value.name = "Meal or Break Stops/8 Hours")
p <- ggplot(dat, aes(x = Vehicle, y = `Meal or Break Stops/8 Hours`, fill = variable)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = comma) +
theme_db + theme(legend.title=element_blank())
ggplotly(p)
```
### Refueling Stops per 100 miles
```{r Calibration_Freight_Refueling_Stops_Per_100Miles}
# Organize
dat <- ft_trips[, .(Simulated = sum(Activity == "Vehicle Service")/(sum(Distance)/100)),
by = Vehicle][order(Vehicle)]
targets <- data.table(Vehicle = c("Light", "Medium", "Heavy"),
Target = c(0.205, 0.191, 0.100))
dat[targets, Target := i.Target, on = "Vehicle", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Freight_Truck_Refueling_Stops_per_100Miles.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Vehicle", value.name = "Refueling Stops/100 Miles")
p <- ggplot(dat, aes(x = Vehicle, y = `Refueling Stops/100 Miles`, fill = variable)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = comma) +
theme_db + theme(legend.title=element_blank())
ggplotly(p)
```
Charts {data-navmenu="Commercial Vehicle Tours"}
============================================
Highlights {data-width=150}
--------------------------------------------
### Commercial Vehicle Tours
```{r Commercial_Vehicle_Tours_ValueBox2}
CommercialVehicleTours.ValueBox
```
### Total Stops
```{r Commercial_Vehicle_Total_Stops_ValueBox}
value <- format(cv_trips[Activity != "Return", .N], big.mark = ",", trim = TRUE)
valueBox(value, "Total Stops", icon = "fa-map-marker", color = "success")
```
### Goods Stops
```{r Commercial_Vehicle_Goods_Stops_ValueBox}
value <- format(cv_trips[Activity == "Goods", .N], big.mark = ",", trim = TRUE)
valueBox(value, "Goods Deliveries", icon = "fa-cube")
```
### Service Stops
```{r Commercial_Vehicle_Service_Stops_ValueBox}
value <- format(cv_trips[Activity == "Service", .N], big.mark = ",", trim = TRUE)
valueBox(value, "Service Stops", icon = "fa-wrench")
```
### Meeting Stops
```{r Commercial_Vehicle_Meeting_Stops_ValueBox}
value <- format(cv_trips[Activity == "Meeting", .N], big.mark = ",", trim = TRUE)
valueBox(value, "Meeting Stops", icon = "fa-briefcase")
```
### Intermediate Stops
```{r Commercial_Vehicle_Intermediate_Stops_ValueBox}
value <- format(cv_trips[Scheduled == 0L, .N], big.mark = ",", trim = TRUE)
valueBox(value, "Intermediate Stops", icon = "fa-cutlery")
```
### Number of Stops per Tour by Activity
```{r Density_Commercial_Stops_per_Tour_By_Activity}
# # Organize
# dat <- cv_trips[, .(`Number of Stops` = .N), by = .(TourID, Activity)]
#
# # Save
#
# # Plot
# alpha <- 0.95
# x.limits <- c(0, quantile(dat$`Number of Stops`, alpha))
# p <- ggplot(dat, aes(x = `Number of Stops`, fill = Activity)) +
# geom_density(alpha = 0.25, position = "stack") + ylab("Density") + xlim(x.limits) +
# theme_db
# ggplotly(p)
```
> Note: `r percent(1 - alpha)` of stops are longer than `r round(x.limits[2])` minutes and are not displayed.
Chart Column 1 {data-width=283}
--------------------------------------------
### Placeholder
### Placeholder
### Placeholder
Chart Column 2 {data-width=283}
--------------------------------------------
### Placeholder
### Placeholder
### Placeholder
Densities {data-navmenu="Commercial Vehicle Tours"}
============================================
Density Column 1
--------------------------------------------
### First Stop Arrival Time by Vehicle
```{r Density_Commercial_Arrival_Time_By_Vehicle}
# Organize
dat <- cv_trips[TripID == 1L, .(`Arrival Time` = as.numeric(MAMArrive), Vehicle)]
# Save
# Plot
breaks <- seq(from = 0, to = 1439, 60)
p <- ggplot(dat, aes(x = `Arrival Time`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") +
scale_x_continuous(breaks = breaks, labels = labelMAM(breaks)) +
theme_db + theme(axis.text = element_text(angle = 90, hjust = 1))
ggplotly(p)
```
### First Stop Arrival Time by Activity
```{r Density_Commercial_Arrival_Time_By_Activity}
# Organize
cv_trips[Scheduled == 1L, MinTripID := min(TripID), by = .(BusID, Vehicle, TourID)]
dat <- cv_trips[TripID == MinTripID, .(`Arrival Time` = as.numeric(MAMArrive), Activity)]
# Save
# Plot
breaks <- seq(from = 0, to = 1439, 60)
p <- ggplot(dat, aes(x = `Arrival Time`, fill = Activity)) +
geom_density(alpha = 0.25) + ylab("Density") +
scale_x_continuous(breaks = breaks, labels = labelMAM(breaks)) +
theme_db + theme(axis.text = element_text(angle = 90, hjust = 1))
ggplotly(p)
```
Density Column 2 {.tabset .tabset-fade}
--------------------------------------------
### Tour Length by Vehicle
```{r Density_Commercial_Tour_Length_By_Vehicle}
# Organize
dat <- cv_trips[, .(`Tour Length (miles)` = sum(Distance)), by = .(BusID, Vehicle, TourID)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Tour Length (miles)`, alpha))
p <- ggplot(dat, aes(x = `Tour Length (miles)`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of trips are longer than `r round(x.limits[2])` miles and are not displayed.
### Trip Length by Vehicle
```{r Density_Commercial_Trip_Length_By_Vehicle}
# Organize
dat <- cv_trips[, .(Vehicle, `Trip Length (miles)` = Distance)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Trip Length (miles)`, alpha))
p <- ggplot(dat, aes(x = `Trip Length (miles)`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of trips are longer than `r round(x.limits[2])` miles and are not displayed.
### Tour Duration by Vehicle
```{r Density_Commercial_Tour_Duration_By_Vehicle}
# Organize
dat <- cv_trips[, .(`Tour Duration (mins)` = sum(TravelTime+StopDuration)),
by = .(BusID, Vehicle, TourID)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Tour Duration (mins)`, alpha))
p <- ggplot(dat, aes(x = `Tour Duration (mins)`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of trips are longer than `r round(x.limits[2])` minutes and are not displayed.
### Trip Duration by Vehicle
```{r Density_Commercial_Trip_Duration_By_Vehicle}
# Organize
dat <- cv_trips[, .(Vehicle, `Trip Duration (mins)` = TravelTime)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Trip Duration (mins)`, alpha))
p <- ggplot(dat, aes(x = `Trip Duration (mins)`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of trips are longer than `r round(x.limits[2])` minutes and are not displayed.
### Stop Duration by Vehicle
```{r Density_Commercial_Stop_Duration_By_Vehicle}
# Organize
dat <- cv_trips[Activity != "Return", .(Vehicle, `Stop Duration (minutes)` = StopDuration)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Stop Duration (minutes)`, alpha))
p <- ggplot(dat, aes(x = `Stop Duration (minutes)`, fill = Vehicle)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of stops are longer than `r round(x.limits[2])` minutes and are not displayed.
### Stop Duration by Activity
```{r Density_Commercial_Stop_Duration_By_Activity}
# Organize
dat <- cv_trips[Activity != "Return", .(Activity, `Stop Duration (minutes)` = StopDuration)]
# Save
# Plot
alpha <- 0.95
x.limits <- c(0, quantile(dat$`Stop Duration (minutes)`, alpha))
p <- ggplot(dat, aes(x = `Stop Duration (minutes)`, fill = Activity)) +
geom_density(alpha = 0.25) + ylab("Density") + xlim(x.limits) +
theme_db
ggplotly(p)
```
> Note: `r percent(1 - alpha)` of stops are longer than `r round(x.limits[2])` minutes and are not displayed.
Maps {data-navmenu="Commercial Vehicle Tours"}
============================================
Maps {.tabset .tabset-fade}
--------------------------------------------
### Stops Over Time
```{r Map_Commercial_Stops_Over_Time, eval=USER_GENERATE_DASHBOARD_MAPS}
stops_total <- cv_trips[, TimeBins := as.factor(floor(MAMArrive / 60))]
stops_total <- stops_total[, .N, by = .(DTAZ, TimeBins)]
stops_total[, nPts := floor(log(N) / 3.5)]
stops_total <- stops_total[nPts > 0]
map <- leaflet_custom(elementId = "cvstoptime") %>%
addProviderTiles(map_type, group = "Background Map") %>%
setView(-79.84229, 35.93984, 10)
map$dependencies <- c(map$dependencies, list(htmlDependency(
name = "leaflet-timeline",
version = "1.0.0",
src = c("file" = SYSTEM_TEMPLATES_PATH),
script = "javascripts/leaflet.timeline.js",
stylesheet = "stylesheets/leaflet.timeline.css"
)))
map_center <- coordinates(shp_outline)
dimnames(map_center)[[2]] <- c("lon", "lat")
ghost_df <- data.frame()
points_df <- data.frame()
setkey(stops_total, DTAZ)
for (time_bin in levels(stops_total[["TimeBins"]])) {
stops_time <- stops_total[TimeBins == time_bin, .(DTAZ, nPts)]
for (i in seq_len(nrow(stops_time))) {
points <- NULL
n <- stops_time[i, nPts]
if (n < 1) {
next
}
polygon_TAZ <- shp[shp@data$TAZ == stops_time[i, DTAZ], ]
tryCatch(
{
points <- spsample(polygon_TAZ, n = n, type = "random")@coords
},
error = function(e) {
NULL
}
)
if (!is.null(points)) {
dimnames(points)[[2]] <- c("lon", "lat")
start <- strptime(sprintf("2000-01-01 %02d:00", as.integer(time_bin)), format = "%Y-%m-%d %H:%M")
end <- strptime(sprintf("2000-01-01 %02d:59", as.integer(time_bin)), format = "%Y-%m-%d %H:%M")
points_df <- rbind(points_df, data.frame(points, "start" = start, "end" = end))
}
}
start <- strptime(sprintf("2000-01-01 %02d:00", as.integer(time_bin) ), format = "%Y-%m-%d %H:%M")
end <- strptime(sprintf("2000-01-01 %02d:00", (as.integer(time_bin) + 1)), format = "%Y-%m-%d %H:%M")
ghost_df <- rbind(ghost_df, data.frame(points, "start" = start, "end" = end))
}
ghost_json <- geojson_json(ghost_df, lat = "lat", lon = "lon")
points_json <- geojson_json(points_df, lat = "lat", lon = "lon")
map %>%
onRender(sprintf(
'function(el,x){
var slider = L.timelineSliderControl({
steps: 48,
duration: 24000,
showTicks: true,
waitToUpdateMap: true,
formatOutput: function(date){
return new Date(date).toLocaleTimeString("en-US", { hour12: false, second: undefined });
}
});
HTMLWidgets.find("#cvstoptime").addControl(slider);
var timeline = L.timeline(%s, {
pointToLayer: function(data, latlng){
return L.circle(latlng, 200, {
fillOpacity: 1,
opacity: 1
});
}
});
timeline.addTo(HTMLWidgets.find("#cvstoptime"));
var ghostTimeline = L.timeline(%s, {
pointToLayer: function(data, latlng){
return L.circle(latlng, 1, {
fillOpacity: 0,
opacity: 0
});
}
});
ghostTimeline.addTo(HTMLWidgets.find("#cvstoptime"));
slider.addTimelines(timeline, ghostTimeline);
}',
points_json,
ghost_json
))
```
### Sampled Tours
```{r Map_Commercial_Sample_Tours, eval=USER_GENERATE_DASHBOARD_MAPS}
javascript <- 'function(el, x) {
var basemaps = {};'
map <- leaflet_custom(elementId = "cv_sampletours") %>%
addProviderTiles(map_type, group = "Background Map") %>%
setView(-79.84229, 35.93984, 10) %>%
addControl(
'Service
Return
Other
Break/Meal
Goods
Meeting
Vehicle Service
',
position = "bottomright"
)
map$dependencies <- c(map$dependencies, list(htmlDependency(
name = "leaflet-polylinedecorator",
version = "1.1.0",
src = c("file" = SYSTEM_TEMPLATES_PATH),
script = "javascripts/leaflet.polylineDecorator.js"
)))
for (industry in levels(RegionalFirms$Industry5)) {
i <- 1
max <- 6
possible_businesses <- RegionalFirms[BusID %in% unique(cv_trips[, TourID, by = BusID])[, .N, by = BusID][N == max, BusID] & Industry5 == industry, BusID]
while (TRUE) {
business <- cv_trips[BusID == possible_businesses[i], ]
if (uniqueN(business[, .(TripID, OTAZ, DTAZ)]) == nrow(business)) {
break
}
i <- i + 1
if (i > length(possible_businesses)) {
max <- max - 1
possible_businesses <- RegionalFirms[BusID %in% unique(cv_trips[, TourID, by = BusID])[, .N, by = BusID][N == max, BusID] & Industry5 == industry, BusID]
i <- 1
}
}
pal <- colorFactor(palette = "Set1", levels = unique(business$TourID))
javascript <- paste0(javascript, sprintf('var lG_%s = L.layerGroup();', gsub("[^[:alpha:]]", "_", industry)))
for (tour in unique(business$TourID)) {
coords <- coordinates(shp[shp@data$TAZ %in% business[TourID == tour, OTAZ], ])
coords <- rbind(coords, coords[1, c(1, 2)]) # This assumes that the tour is a closed walk (beginning and ending vertices are identical)
coords[ , c(1,2)] <- coords[ , c(2,1)]
javascript <- paste0(javascript, sprintf(
'var pl_%s = L.polyline(%s, {opacity: 1, weight: 3, color: "%s"});
lG_%s.addLayer(pl_%s);',
tour,
toJSON(coords),
pal(tour),
gsub("[^[:alpha:]]", "_", industry),
tour
))
for (i in 1:(nrow(coords) - 1)) {
javascript <- paste0(javascript, sprintf(
'var plDec_%s = L.polylineDecorator(%s, {
patterns: [{offset: "100%%", repeat: 0, symbol: L.Symbol.arrowHead({pixelSize: 15, pathOptions: {fillOpacity: 1, weight: 0, color: "%s"}})}]
});
lG_%s.addLayer(plDec_%s);',
paste0(tour, i),
toJSON(coords[i:(i + 1),c(1,2)]),
pal(tour),
gsub("[^[:alpha:]]", "_", industry),
paste0(tour, i)
))
}
}
for (activity in unique(business$Activity)) {
coords <- coordinates(shp[shp@data$TAZ %in% business[Activity == activity, DTAZ], ])
coords <- rbind(coords, coords[1, c(1, 2)])
coords[ , c(1,2)] <- coords[ , c(2,1)]
for (i in 1:(nrow(coords) - 1)) {
javascript <- paste0(javascript, sprintf(
'var plDec_%s = L.polylineDecorator(%s, {
patterns: [{offset: 0, repeat: 0, symbol: L.Symbol.marker({markerOptions: {icon: L.divIcon({className: "leaflet-div-icon-cv-%s"})}})}]
});
lG_%s.addLayer(plDec_%s);',
paste0(tolower(gsub("[^[:alpha:]]", "_", activity)), i),
toJSON(coords[i:(i + 1),c(1,2)]),
tolower(gsub("[^[:alpha:]]", "_", activity)),
gsub("[^[:alpha:]]", "_", industry),
paste0(tolower(gsub("[^[:alpha:]]", "_", activity)), i)
))
}
}
javascript <- paste0(javascript, sprintf(
'basemaps["%s"] = lG_%s;',
industry,
gsub("[^[:alpha:]]", "_", industry)
))
}
javascript <- paste0(javascript, sprintf(
'lG_%s.addTo(HTMLWidgets.find("#%s"));
L.control.layers(basemaps, {}).addTo(HTMLWidgets.find("#%s"));
}',
gsub("[^[:alpha:]]", "_", levels(RegionalFirms$Industry5)[1]),
"cv_sampletours",
"cv_sampletours"
))
map <- onRender(map, javascript)
map
```
> Note: These are a sampling of tours of a single firm in the selected industry for illustrative purposes.
### Stops by Vehicle Type
```{r Map_Commercial_Stops_By_Vehicle, eval=USER_GENERATE_DASHBOARD_MAPS}
k <- 25
map <- leaflet() %>%
addProviderTiles(map_type, group = "Background Map")
map <- map %>% addTAZPoints(data = cv_trips[Activity != "Return"],
shp = shp, group = "Vehicle",
scale.factor = k, TAZcol = "DTAZ")
map
```
> Note: Each data point represents `r comma(k)` stops and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
### Stops by Activity
```{r Map_Commercial_Stops_By_Activity, eval=USER_GENERATE_DASHBOARD_MAPS}
k <- 25
map <- leaflet() %>%
addProviderTiles(map_type, group = "Background Map")
map <- map %>% addTAZPoints(data = cv_trips[Activity != "Return"],
shp = shp, group = "Activity",
scale.factor = k, TAZcol = "DTAZ")
map
```
> Note: Each data point represents `r comma(k)` stops and precise locations are illustrative as firms are only identified geographically at the TAZ-level.
Calibration {data-navmenu="Commercial Vehicle Tours"}
============================================
Chart Column 1
--------------------------------------------
### Firm-to-Stop Distance
```{r Calibration_Commercial_Firm-Stop_Distance}
# Organize
dat <- cv_trips[Scheduled == 1L & Activity != "Return", .(BusID, DTAZ)]
dat[RegionalFirms, c("BusTAZ", "Industry") := .(i.TAZ, i.Industry5),
on = "BusID", nomatch = 0]
dat[skims[, .(BusTAZ = OTAZ, DTAZ, distance.avg)],
Distance := i.distance.avg/100,
on = c("BusTAZ", "DTAZ"), nomatch = 0]
dat <- dat[, .(`Mean Distance` = mean(Distance), `Std. Dev.` = sd(Distance)), by = Industry]
dat[, Industry := factor(as.character(Industry))]
dat <- dat[order(Industry)]
targets <- data.table(Industry = c("Industrial", "Retail", "Service", "Transportation Handling", "Wholesale"),
`Target Distance` = c(7.0, 9.2, 6.3, 18.2, 16.2),
`Target Std. Dev.` = c(8.7, 10.4, 8.1, 16.5, 14.2))
dat[targets, c("Target Distance", "Target Std. Dev.") := .(`i.Target Distance`, `i.Target Std. Dev.`),
on = "Industry", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Commercial_Vehicle_Firm-Stop_Distance.csv"), row.names = FALSE)
# Plot
dat <- rbind(dat[, .(Industry, variable = "Simulated", `Mean Distance`, `Std. Dev.`)],
dat[, .(Industry, variable = "Target", `Mean Distance` = `Target Distance`, `Std. Dev.` = `Target Std. Dev.`)])
p <- ggplot(dat, aes(x = Industry, y = `Mean Distance`, fill = variable)) +
geom_bar(stat = "identity", position = "dodge") +
geom_errorbar(aes(ymax = `Mean Distance` + `Std. Dev.`, ymin = `Mean Distance` - `Std. Dev.`), position = "dodge") +
scale_y_continuous(labels = comma) +
theme_db + theme(axis.text.x = element_text(angle = 45, hjust = 1),
legend.title = element_blank())
ggplotly(p)
```
> Note: Bar whiskers represent one standard deviation.
### Scheduled Stops per Tour
```{r Calibration_Commercial_Stops_Per_Tour}
# Organize
dat <- cv_trips[Scheduled == 1L, .(BusID, TourID, TripID)]
dat[RegionalFirms, Industry := i.Industry5, on = "BusID", nomatch = 0]
dat <- dat[, .N, by = .(TourID, Industry)][, .(`Simulated` = mean(N)), by = Industry][order(as.character(Industry))]
targets <- data.table(Industry = c("Industrial", "Retail", "Service", "Transportation Handling", "Wholesale"),
Target = c(2.0, 2.5, 2.9, 2.7, 8.6))
dat[targets, Target := i.Target, on = "Industry", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Commercial_ScheduledStops_per_Tour.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Industry", value.name = "Scheduled Stops/Tour")
p <- bar_plotter(dat, xvar = "Industry", yvar = "Scheduled Stops/Tour", fill = "variable", position = "dodge", xrotate = TRUE, legend_label = FALSE)
p
```
### Single-Stop Tours
```{r Calibration_Commercial_Single_Stop_Tours}
# Organize
dat <- cv_trips[Activity != "Return", .(BusID, TourID, TripID, Scheduled)]
dat[RegionalFirms, Industry := i.Industry5, on = "BusID", nomatch = 0]
dat <- dat[, .(N = sum(Scheduled)),
by = .(TourID, Industry)][, .(`Simulated` = sum(N==1L)/.N), by = Industry][order(as.character(Industry))]
targets <- data.table(Industry = c("Industrial", "Retail", "Service", "Transportation Handling", "Wholesale"),
Target = c(0.541, 0.394, 0.498, 0.715, 0.203))
dat[targets, Target := i.Target, on = "Industry", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Commercial_Single_Stop_Tour_Shares.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Industry", value.name = "Share")
p <- bar_plotter(dat, xvar = "Industry", yvar = "Share", fill = "variable", position = "dodge", xrotate = TRUE, legend_label = FALSE)
p
```
Chart Column 2 {.tabset}
--------------------------------------------
### Vehicle Shares (Simulated)
```{r Calibration_Commercial_Vehicle_Shares1}
# Organize
dat <- cv_trips[, .N, by = .(BusID, Vehicle)]
dat[RegionalFirms, Industry := i.Industry10, on = "BusID", nomatch = 0]
dat <- dat[, .(N = sum(N)), by = .(Industry, Vehicle)][order(Industry, Vehicle)]
dat[, Simulated := N/sum(N), by = Industry]
Industry10 <- c("Agriculture", "Construction", "Government", "Health",
"Hotel & Real Estate", "Manufacturing", "Other Services",
"Retail", "Transportation Handling", "Wholesale")
Vehicles <- c("Light", "Medium", "Heavy")
targets <- data.table(Industry = rep(Industry10, each = length(Vehicles)),
Vehicle = rep(c("Light", "Medium", "Heavy"), times = length(Industry10)),
Share = c(0.40, 0.52, 0.08, 0.71, 0.22, 0.07,
0.90, 0.07, 0.03, 0.96, 0.04, 0.00,
0.93, 0.07, 0.00, 0.36, 0.35, 0.29,
0.89, 0.09, 0.02, 0.68, 0.21, 0.11,
0.04, 0.22, 0.74, 0.29, 0.46, 0.25))
targets[, Vehicle := factor(Vehicle, levels = Vehicles, ordered = TRUE)]
dat[targets, Target := i.Share, on = c("Industry", "Vehicle"), nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Commercial_Vehicle_Shares.csv"), row.names = FALSE)
# Plot
p <- bar_plotter(dat, xvar = "Industry", yvar = "Simulated", fill = "Vehicle", coord_flip = TRUE, ylabel = "Share")
p
```
### Vehicle Shares (Target)
```{r Calibration_Commercial_Vehicle_Shares2}
# Plot
p <- bar_plotter(dat, xvar = "Industry", yvar = "Target", fill = "Vehicle", coord_flip = TRUE, ylabel = "Share")
p
```
Chart Column 3
--------------------------------------------
### First Stop Arrival Time
```{r Calibration_Commercial_First_Stop_Arrival_Time}
# Organize
dat <- cv_trips[TripID == 1L, .(TourID, MAMArrive)]
dat[, `Arrival Time` := cut(MAMArrive, breaks = tod_breaks30, labels = tod_labels30, ordered_result = TRUE, right = FALSE)]
dat <- dat[, .N, by = `Arrival Time`][order(`Arrival Time`), .(`Arrival Time`, Share = N/sum(N))]
targets <- data.table(`Arrival Time` = tod_labels30,
Share = c(0.0039, 0.0010, 0.0009, 0.0007, 0.0005, 0.0013,
0.0010, 0.0031, 0.0010, 0.0013, 0.0030, 0.0023,
0.0037, 0.0109, 0.0359, 0.0539, 0.0651, 0.0754,
0.0783, 0.0723, 0.0839, 0.0611, 0.0372, 0.0444,
0.0445, 0.0375, 0.0442, 0.0367, 0.0337, 0.0437,
0.0208, 0.0155, 0.0236, 0.0104, 0.0116, 0.0089,
0.0044, 0.0006, 0.0043, 0.0034, 0.0015, 0.0007,
0.0045, 0.0014, 0.0018, 0.0004, 0.0005, 0.0033))
dat[targets, Target := i.Share, on = "Arrival Time", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Commercial_Vehicle_Arrival_Time_Shares.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Arrival Time")
p <- bar_plotter(dat, xvar = "Arrival Time", yvar = "value", fill = "variable", position = "dodge", coord_flip = TRUE, legend_label = FALSE)
p
```
Chart Column 4
--------------------------------------------
### Intermediate Stops per Scheduled Stop
```{r Calibration_Commercial_Intermediate_Per_Scheduled_Stop}
# Organize
dat <- cv_trips[, .(Simulated = sum(Scheduled == 0L)/(sum(Scheduled == 1L) - 1L)),
by = Vehicle][order(Vehicle)]
targets <- data.table(Vehicle = c("Light", "Medium", "Heavy"),
Target = c(0.094, 0.067, 0.040))
dat[targets, Target := i.Target, on = "Vehicle", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Commercial_IntermediateStops_per_ScheduledStop.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Vehicle", value.name = "Intermediate Stops/Scheduled Stop")
p <- ggplot(dat, aes(x = Vehicle, y = `Intermediate Stops/Scheduled Stop`, fill = variable)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = comma) +
theme_db + theme(legend.title=element_blank())
ggplotly(p)
```
### Meal or Break Stops per 8 Hours
```{r Calibration_Commercial_MealBreak_Stops_Per_8Hours}
# Organize
dat <- cv_trips[, .(Simulated = sum(Activity == "Break/Meal")/(sum(TravelTime + StopDuration)/(8*60))),
by = Vehicle][order(Vehicle)]
targets <- data.table(Vehicle = c("Light", "Medium", "Heavy"),
Target = c(0.219, 0.290, 0.229))
dat[targets, Target := i.Target, on = "Vehicle", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Commercial_MealBreak_Stops_per_8Hours.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Vehicle", value.name = "Meal or Break Stops/8 Hours")
p <- ggplot(dat, aes(x = Vehicle, y = `Meal or Break Stops/8 Hours`, fill = variable)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = comma) +
theme_db + theme(legend.title=element_blank())
ggplotly(p)
```
### Refueling Stops per 100 miles
```{r Calibration_Commercial_Refueling_Stops_Per_100Miles}
# Organize
dat <- cv_trips[, .(Simulated = sum(Activity == "Vehicle Service")/(sum(Distance)/100)),
by = Vehicle][order(Vehicle)]
targets <- data.table(Vehicle = c("Light", "Medium", "Heavy"),
Target = c(0.205, 0.191, 0.100))
dat[targets, Target := i.Target, on = "Vehicle", nomatch = 0]
# Save
write.csv(dat, file = file.path(SCENARIO_OUTPUT_PATH, "Commercial_Refueling_Stops_per_100Miles.csv"), row.names = FALSE)
# Plot
dat <- melt(dat, id.vars = "Vehicle", value.name = "Refueling Stops/100 Miles")
p <- ggplot(dat, aes(x = Vehicle, y = `Refueling Stops/100 Miles`, fill = variable)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = comma) +
theme_db + theme(legend.title=element_blank())
ggplotly(p)
```