2024-04-02 12:36:56 -05:00
library ( tidyverse )
library ( sf )
library ( tmap )
2024-04-02 17:53:52 -05:00
library ( leaflet )
library ( RColorBrewer )
library ( tidycensus )
library ( htmltools )
2024-04-02 12:36:56 -05:00
## 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 ,
2024-04-02 17:53:52 -05:00
County = CNTYNAME ,
2024-04-02 12:36:56 -05:00
Street = ONSTR ,
CrossStreet = ATSTR ) %>%
mutate ( PedestrianAge = ifelse ( ROLE1 %in% c ( " BIKE" , " PED" ) , age1 , age2 ) )
TOPS_geom <- st_as_sf ( TOPS_data %>% filter ( ! is.na ( latitude ) ) , coords = c ( " longitude" , " latitude" ) , crs = 4326 )
2024-04-03 10:01:32 -05:00
## add county borders ----
CountyBoundaries <- read_sf ( " data/WI_County_Boundaries_24K.geojson" )
focus_columns <- c ( " PedestrianInjurySeverity" , " CrashDate" , " CrashTime" , " County" , " Street" , " CrossStreet" , " PedestrianAge" , " Year" )
2024-04-02 12:36:56 -05:00
focus_county <- " DANE"
2024-04-02 17:53:52 -05:00
## generate map with tmap ----
tmap_mode ( " view" )
2024-04-02 12:36:56 -05:00
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" )
2024-04-02 17:53:52 -05:00
# generate map with leaflet ----
Pedestrian_Crash_Data <- TOPS_data %>%
# filter(CNTYNAME == focus_county) %>%
select ( c ( all_of ( focus_columns ) , " longitude" , " latitude" ) )
injury_severity_pal <- colorFactor ( palette = injury_severity $ color , domain = injury_severity $ InjSevName )
County_Crash_Data <- Pedestrian_Crash_Data %>%
2024-04-03 10:01:32 -05:00
group_by ( County , Year ) %>%
2024-04-02 17:53:52 -05:00
summarise ( TotalCrashes = n ( ) ,
2024-04-03 10:01:32 -05:00
longitude = mean ( longitude , na.rm = TRUE ) ,
latitude = mean ( latitude , na.rm = TRUE ) ) %>%
group_by ( County ) %>%
summarise ( MeanCrashes = mean ( TotalCrashes , na.rm = TRUE ) ,
2024-04-02 17:53:52 -05:00
longitude = mean ( longitude , na.rm = TRUE ) ,
latitude = mean ( latitude , na.rm = TRUE ) )
# 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" , " " ) ) )
County_Crash_Data <- left_join ( County_Crash_Data , county_populations , join_by ( " County" ) )
County_Crash_Data <- County_Crash_Data %>%
2024-04-03 10:01:32 -05:00
mutate ( CrashesPerPopulation = MeanCrashes / value * 100000 )
2024-04-02 17:53:52 -05:00
county_pal <- colorNumeric ( palette = " YlOrRd" , domain = c ( min ( County_Crash_Data $ CrashesPerPopulation , na.rm = TRUE ) , max ( County_Crash_Data $ CrashesPerPopulation , na.rm = TRUE ) ) )
#title style
tag.map.title <- tags $ style ( HTML ( "
.leaflet - control.map - title {
transform : translate ( -50 %,20% ) ;
position : fixed ! important ;
left : 50 %;
text - align : center ;
padding - left : 10 px ;
padding - right : 10 px ;
background : rgba ( 255 , 255 , 255 , 0.75 ) ;
font - weight : bold ;
font - size : 28 px ;
}
" ) )
title <- tags $ div (
2024-04-03 10:01:32 -05:00
tag.map.title , HTML ( " Pedestrian Crashes</br>2017-2023" )
2024-04-02 17:53:52 -05:00
)
tag.map.subtitle <- tags $ style ( HTML ( "
.leaflet - control.map - subtitle {
2024-04-03 10:01:32 -05:00
transform : translate ( 0 %,0% ) ;
2024-04-02 17:53:52 -05:00
position : fixed ! important ;
2024-04-03 10:01:32 -05:00
left : 90 %;
2024-04-02 17:53:52 -05:00
text - align : center ;
padding - left : 10 px ;
padding - right : 10 px ;
background : rgba ( 255 , 255 , 255 , 0.75 ) ;
font - weight : regular ;
font - size : 12 px ;
}
" ) )
subtitle <- tags $ div (
2024-04-03 10:01:32 -05:00
tag.map.subtitle , HTML ( " data from UW TOPS lab - retrieved 4/2024</br>per direction of the WisDOT Bureau of Transportation Safety" )
2024-04-03 11:11:37 -05:00
)
2024-04-02 17:53:52 -05:00
leaflet ( ) %>%
addControl ( title , position = " topleft" , className = " map-title" ) %>%
2024-04-03 10:01:32 -05:00
addControl ( subtitle , position = " bottomleft" , className = " map-subtitle" ) %>%
2024-04-02 17:53:52 -05:00
addProviderTiles ( providers $ Stadia.AlidadeSmooth ) %>%
addCircleMarkers ( data = Pedestrian_Crash_Data ,
lng = Pedestrian_Crash_Data $ longitude ,
lat = Pedestrian_Crash_Data $ latitude ,
fillColor = injury_severity_pal ( Pedestrian_Crash_Data $ PedestrianInjurySeverity ) ,
radius = 3 ,
stroke = TRUE ,
color = " black" ,
weight = 1 ,
fillOpacity = 0.8 ,
group = " Crash Points" ) %>%
addLegend ( position = " bottomleft" , labels = injury_severity $ InjSevName , colors = injury_severity $ color , group = " Crash Points" , title = " Injury Severity" ) %>%
groupOptions ( group = " Crash Points" , zoomLevels = 10 : 20 ) %>%
2024-04-03 10:01:32 -05:00
addPolygons ( data = CountyBoundaries ,
fill = FALSE ,
color = " black" ,
weight = 1 ) %>%
2024-04-02 17:53:52 -05:00
addCircleMarkers ( data = County_Crash_Data ,
lng = County_Crash_Data $ longitude ,
lat = County_Crash_Data $ latitude ,
fillColor = county_pal ( County_Crash_Data $ CrashesPerPopulation ) ,
2024-04-03 10:01:32 -05:00
radius = County_Crash_Data $ value / 20000 ,
2024-04-02 17:53:52 -05:00
stroke = TRUE ,
color = " black" ,
weight = 1 ,
fillOpacity = 0.7 ,
group = " Counties" ) %>%
2024-04-03 10:01:32 -05:00
addLegend ( position = " bottomleft" , pal = county_pal , values = County_Crash_Data $ CrashesPerPopulation , group = " Counties" , title = " Mean Crashes/Year in County</br>(per 100,000 residents)" ) %>%
2024-04-02 17:53:52 -05:00
# 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 )