add fatality map test and heatmap

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)
+}

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}<extra></extra>"
+    ) %>%
+      layout(
+        xaxis = list(title = ""),
+        yaxis = list(title = ""),
+        margin = list(l = 60, r = 10, t = 10, b = 40)
+      ) %>%
+      config(displayModeBar = FALSE)
+  })
 }

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",
+        layout_columns(
+          col_widths = c(8, 4),
           card(
             full_screen = TRUE,
             layout_sidebar(
+              class = "p-0",
               sidebar = sidebar(
                 actionButton("hi", "test"),
                 open = "always"
               ),
-            leafletOutput("base_leaflet", height = "100%")
+              leafletOutput("fatality_map", height = "100%")
+            )
+          ),
+          layout_column_wrap(
+            width = 1,
+            card(
+              plotlyOutput("fatality_heatmap", height = "100%")
+            ),
+            card()
           )
         )
       ),