add fatality map test and heatmap

2026-07-30 05:08:57 +00:00 · 2026-04-09 00:04:33 -04:00
parent 93961e2a6c
commit 9093a10d0e
3 changed files with 165 additions and 8 deletions
@@ -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}<extra></extra>"
+    ) %>%
+      layout(
+        xaxis = list(title = ""),
+        yaxis = list(title = ""),
+        margin = list(l = 60, r = 10, t = 10, b = 40)
+      ) %>%
+      config(displayModeBar = FALSE)
+  })
 }