ben/wisconsin_crashes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added crash_summary_charts.R script

Browse Source
This commit is contained in:
Ben Varick 2024-04-03 13:21:15 -05:00
parent 1a7a2bf3f8
commit 644d591fc8
Signed by: ben
SSH Key Fingerprint: SHA256:758jG979jvr5HnQJl1AQ/NYTyzXRgnuoVM/yCR024sE
4 changed files with 150 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
figures/crash_summaries/counties_year.pdf Normal file
View File

Binary file not shown.

6
figures/dynamic_crash_maps/dynamic_crash_map.html
View File

File diff suppressed because one or more lines are too long

130
scripts/crash_summary_charts.R Normal file
View File

@ -0,0 +1,130 @@
library(tidyverse)
library(RColorBrewer)
library(tidycensus)
library(ggrepel)
## Load TOPS data ----
## To load TOPS data for the whole state for crashes involving bikes and pedestrians):
## Step 1 - download csv from the TOPS Data Retrieval Tool with the query: SELECT * FROM DTCRPRD.SUMMARY_COMBINED C WHERE C.CRSHDATE BETWEEN TO_DATE('2023-JAN','YYYY-MM') AND LAST_DAY(TO_DATE('2023-DEC','YYYY-MM')) AND (C.BIKEFLAG = 'Y' OR C.PEDFLAG = 'Y') ORDER BY C.DOCTNMBR
## Step 2 - include RACE1 and RACE2 for download in preferences
## Step 3 - save the csv in the "data" directory as crash-data-download_2023.csv
TOPS_data <- as.list(NULL)
for (file in list.files(path = "data/TOPS/", pattern = "crash-data-download")) {
message(paste("importing data from file: ", file))
year <- substr(file, 21, 24)
csv_run <- read_csv(file = paste0("data/TOPS/",file), col_types = cols(.default = "c"))
TOPS_data[[file]] <- csv_run
}
rm(csv_run, file, year)
TOPS_data <- bind_rows(TOPS_data)
## clean up data ----
TOPS_data <- TOPS_data %>%
mutate(date = mdy(CRSHDATE),
age1 = as.double(AGE1),
age2 = as.double(AGE2),
latitude = as.double(LATDECDG),
longitude = as.double(LONDECDG)) %>%
mutate(month = month(date, label = TRUE),
year = as.factor(year(date)))
# Injury Severy Index and Color -----
injury_severity <- data.frame(InjSevName = c("No apparent injury", "Possible Injury", "Suspected Minor Injury","Suspected Serious Injury","Fatality"),
code = c("O", "C", "B", "A", "K"),
color = c("#fafa6e", "#edc346", "#d88d2d", "#bd5721", "#9b1c1c"))
TOPS_data <- left_join(TOPS_data, injury_severity %>% select(InjSevName, code), join_by(INJSVR1 == code)) %>%
mutate(InjSevName = factor(InjSevName, levels = injury_severity$InjSevName)) %>%
rename(InjSevName1 = InjSevName)
TOPS_data <- left_join(TOPS_data, injury_severity %>% select(InjSevName, code), join_by(INJSVR2 == code)) %>%
mutate(InjSevName = factor(InjSevName, levels = injury_severity$InjSevName)) %>%
rename(InjSevName2 = InjSevName)
TOPS_data <- TOPS_data %>% mutate(ped_inj = ifelse(ROLE1 %in% c("BIKE", "PED"),
INJSVR1,
ifelse(ROLE2 %in% c("BIKE", "PED"),
INJSVR2,
NA)))
TOPS_data <- left_join(TOPS_data, injury_severity %>% select(InjSevName, code), join_by(ped_inj == code)) %>%
mutate(InjSevName = factor(InjSevName, levels = injury_severity$InjSevName)) %>%
rename(ped_inj_name = InjSevName)
# Race names
race <- data.frame(race_name = c("Asian", "Black", "Indian","Hispanic","White"),
code = c("A", "B", "I", "H", "W"))
TOPS_data <- left_join(TOPS_data, race %>% select(race_name, code), join_by(RACE1 == code)) %>% rename(race_name1 = race_name)
TOPS_data <- left_join(TOPS_data, race %>% select(race_name, code), join_by(RACE2 == code)) %>% rename(race_name2 = race_name)
## make mutate TOPS_data
TOPS_data <- TOPS_data %>%
mutate(Year = year,
PedestrianInjurySeverity = ped_inj_name,
CrashDate = CRSHDATE,
CrashTime = CRSHTIME,
County = CNTYNAME,
Street = ONSTR,
CrossStreet = ATSTR) %>%
mutate(PedestrianAge = ifelse(ROLE1 %in% c("BIKE", "PED"), age1, age2))
# add population census data ----
census_api_key(key = substr(read_file(file = "api_keys/census_api_key"), 1, 40))
county_populations <- get_estimates(geography = "county", year = 2022, product = "population", state = "Wisconsin") %>%
filter(variable == "POPESTIMATE") %>%
mutate(County = str_to_upper(str_replace(NAME, " County, Wisconsin", "")))
## generate county charts ----
county_focus <- unique(TOPS_data %>%
group_by(CNTYNAME) %>%
summarise(TotalCrashes = n()) %>%
slice_max(TotalCrashes, n = 8) %>%
pull(CNTYNAME))
TOPS_data %>%
group_by(CNTYNAME, Year) %>%
summarise(TotalCrashes = n()) %>%
mutate(County = CNTYNAME) %>%
left_join(county_populations, join_by("County")) %>%
mutate(CrashesPerPopulation = TotalCrashes/value*100000) %>%
filter(County %in% county_focus) %>%
ggplot() +
geom_line(aes(x = Year,
y = CrashesPerPopulation,
color = str_to_title(CNTYNAME),
group = CNTYNAME),
size = 1) +
geom_label_repel(data = TOPS_data %>%
group_by(CNTYNAME, Year) %>%
summarise(TotalCrashes = n()) %>%
mutate(County = CNTYNAME) %>%
left_join(county_populations, join_by("County")) %>%
mutate(CrashesPerPopulation = TotalCrashes/value*100000) %>%
filter(County %in% county_focus,
Year == 2023),
aes(x = Year,
y = CrashesPerPopulation,
label = str_to_title(County),
fill = County),
size=3,
min.segment.length=0,
segment.size = 0.25,
nudge_x=0.5,
direction="y") +
scale_color_brewer(type = "qual", guide = NULL) +
scale_fill_brewer(type = "qual", guide = NULL) +
scale_x_discrete(expand = expansion(add = c(0.5,0.75))) +
labs(title = "Drivers crashing into pedestrians & bicyclists per 100,000 residents",
subtitle = "2017-2023",
x = "Year",
y = "Total crashes per year per 100,000 residents",
color = "County",
caption = "data from UW TOPS lab\nretrieved 3/2024 per direction of the WisDOT Bureau of Transportation Safety") +
theme(plot.caption = element_text(color = "grey"))
ggsave(file = paste0("figures/crash_summaries/counties_year.pdf"),
height = 8.5,
width = 11,
units = "in")

31
scripts/dynamic_crash_map.R
View File

@ -1,6 +1,6 @@
library(tidyverse)
library(sf)
library(tmap)
#library(tmap)
library(leaflet)
library(RColorBrewer)
library(tidycensus)
@ -81,17 +81,17 @@ focus_columns <- c("PedestrianInjurySeverity", "CrashDate", "CrashTime", "County
focus_county <- "DANE"
## generate map with tmap ----
tmap_mode("view")
Pedestrian_Crash_Data <- TOPS_geom %>%
# filter(CNTYNAME == focus_county) %>%
select(all_of(focus_columns))
tm_basemap("Stadia.AlidadeSmooth") +
tm_shape(Pedestrian_Crash_Data) +
tm_dots("PedestrianInjurySeverity", palette = injury_severity$color, popup.vars = focus_columns)
tmap_save(file = "figures/dynamic_crash_maps/dynamic_crash_map.html")
# tmap_mode("view")
#
# Pedestrian_Crash_Data <- TOPS_geom %>%
# # filter(CNTYNAME == focus_county) %>%
# select(all_of(focus_columns))
#
# tm_basemap("Stadia.AlidadeSmooth") +
# tm_shape(Pedestrian_Crash_Data) +
# tm_dots("PedestrianInjurySeverity", palette = injury_severity$color, popup.vars = focus_columns)
#
# tmap_save(file = "figures/dynamic_crash_maps/dynamic_crash_map.html")
# generate map with leaflet ----
@ -138,7 +138,7 @@ tag.map.title <- tags$style(HTML("
"))
title <- tags$div(
tag.map.title, HTML("Pedestrian Crashes</br>2017-2023")
tag.map.title, HTML("Pedestrians & Bicyclists hit by cars</br>2017-2023")
)
tag.map.subtitle <- tags$style(HTML("
@ -156,7 +156,7 @@ tag.map.subtitle <- tags$style(HTML("
"))
subtitle <- tags$div(
tag.map.subtitle, HTML("data from UW TOPS lab - retrieved 4/2024</br>per direction of the WisDOT Bureau of Transportation Safety")
tag.map.subtitle, HTML("data from UW TOPS lab - retrieved 3/2024</br>per direction of the WisDOT Bureau of Transportation Safety")
)
leaflet() %>%
@ -193,3 +193,6 @@ leaflet() %>%
# addLegendSize(position = "bottomright", color = "black", shape = "circle", values = County_Crash_Data$value.y, group = "Counties", title = "Population of County") %>%
groupOptions(group ="Counties", zoomLevels = 1:9)