diff --git a/app/queries.R b/app/queries.R index 4a78e3a..3a43b4b 100644 --- a/app/queries.R +++ b/app/queries.R @@ -546,3 +546,50 @@ get_county_and_state <- function(df) { return(result) } + +get_fatality_heatmap_data <- function(storm) { + query <- tbl(con, I("fatal.conus_direct_fatalities")) %>% + filter( + storm_basin == storm$storm_basin, + storm_year == storm$storm_year, + storm_name == storm$storm_name + ) %>% + select(state_fips, fatality_type, n = fatality_count) + + result <- query %>% + collect() %>% + left_join( + tbl(con, I("fips.states")) %>% + select(state_fips, state_abbreviation) %>% + collect(), + by = "state_fips" + ) %>% + mutate( + state_label = if_else(state_fips == "00", "Unknown", state_abbreviation) + ) + + return(result) +} + +get_fatality_map <- function(storm) { + query <- tbl(con, I("fatal.conus_direct_fatalities")) %>% + filter( + storm_basin == storm$storm_basin, + storm_year == storm$storm_year, + storm_name == storm$storm_name + ) %>% + inner_join( + tbl(con, I("gis.us_states_boundary")) %>% + rename(state_fips = statefp), + by = "state_fips" + ) %>% + mutate( + geom_wkt = sql( + "ST_AsText(ST_SimplifyPreserveTopology(ST_Transform(wkb_geometry, 4326), .001))" + ) + ) + + result <- query %>% collect() + + return(result) +} diff --git a/app/server.R b/app/server.R index c9f7fce..b25af77 100644 --- a/app/server.R +++ b/app/server.R @@ -831,4 +831,103 @@ server <- function(input, output, session) { ) } }) + + output$fatality_map <- renderLeaflet({ + req( + storm_selection$storm_basin, + storm_selection$storm_year, + storm_selection$storm_name + ) + + fatalities <- get_fatality_map(storm_selection) + + fatalities <- fatalities %>% + st_as_sf(wkt = "geom_wkt") + + map <- leaflet() %>% + addProviderTiles("Stadia.AlidadeSmooth") + + map <- map %>% + addPolygons( + data = fatalities %>% filter(fatality_type == "freshwater_floods"), + group = "Freshwater Floods", + fillColor = "red", + color = "red", + weight = 1, + ) + + return(map) + }) + + fatality_heatmap_data <- reactive({ + req( + storm_selection$storm_basin, + storm_selection$storm_year, + storm_selection$storm_name + ) + get_fatality_heatmap_data(storm_selection) + }) + + output$fatality_heatmap <- renderPlotly({ + data <- fatality_heatmap_data() + + heatmap_data <- data %>% + mutate( + category = case_when( + fatality_type %in% c("wind", "tree_fall") ~ "Wind", + fatality_type %in% c("surf", "rip_current") ~ "Surf", + fatality_type == "freshwater_floods" ~ "Freshwater Flood", + fatality_type == "offshore" ~ "Offshore", + fatality_type == "storm_surge" ~ "Storm Surge", + fatality_type == "tornado" ~ "Tornado", + fatality_type == "unknown" ~ "Unknown", + TRUE ~ NA_character_ + ) + ) %>% + filter(!is.na(category)) %>% + group_by(state_label, category) %>% + summarize(n = sum(n), .groups = "drop") %>% + complete( + state_label, + category = c( + "Freshwater Flood", + "Offshore", + "Storm Surge", + "Surf", + "Tornado", + "Unknown", + "Wind" + ), + fill = list(n = 0) + ) %>% + mutate( + category = factor( + category, + levels = c("Freshwater Flood", "Offshore", "Storm Surge", "Surf", "Tornado", "Wind", "Unknown") + ), + state_label = factor( + state_label, + levels = c(sort(setdiff(unique(state_label), "Unknown")), "Unknown") + ) + ) + + plot_ly( + data = heatmap_data, + x = ~category, + y = ~state_label, + z = ~n, + type = "heatmap", + colorscale = "Reds", + showscale = FALSE, + text = ~n, + texttemplate = "%{text}", + hovertemplate = "%{y} \u2014 %{x}: %{z}" + ) %>% + layout( + xaxis = list(title = ""), + yaxis = list(title = ""), + margin = list(l = 60, r = 10, t = 10, b = 40) + ) %>% + config(displayModeBar = FALSE) + }) } diff --git a/app/ui.R b/app/ui.R index ea01d12..033d929 100644 --- a/app/ui.R +++ b/app/ui.R @@ -193,7 +193,7 @@ ui <- page_navbar( nav_panel( "Human Factors", layout_column_wrap( - width = 1 / 2, + width = 1, layout_columns( col_widths = 12, row_heights = c("auto", "1fr", "auto"), @@ -246,14 +246,25 @@ ui <- page_navbar( nav_panel("Perils"), nav_panel( "Fatality Map", - card( - full_screen = TRUE, - layout_sidebar( - sidebar = sidebar( - actionButton("hi", "test"), - open = "always" + layout_columns( + col_widths = c(8, 4), + card( + full_screen = TRUE, + layout_sidebar( + class = "p-0", + sidebar = sidebar( + actionButton("hi", "test"), + open = "always" + ), + leafletOutput("fatality_map", height = "100%") + ) + ), + layout_column_wrap( + width = 1, + card( + plotlyOutput("fatality_heatmap", height = "100%") ), - leafletOutput("base_leaflet", height = "100%") + card() ) ) ),