--- title: "Hurricane Normalization App" runtime: shiny output: flexdashboard::flex_dashboard: orientation: columns vertical_layout: fill theme: version: 4 bootswatch: litera --- ```{r setup, include=FALSE} # TODO: # - update normalization to new 2024 data # - library(flexdashboard) library(shiny) library(leaflet) library(DT) library(dplyr) library(DBI) library(tidyr) library(ggplot2) library(plotly) library(viridis) library(lubridate) library(scales) library(readr) library(stringr) library(kableExtra) library(bslib) library(dygraphs) library(tidyverse) library(sf) library(shinyBS) library(xts) library(tigris) library(caret) library(scales) library(billboarder) library(shinyWidgets) # local testing env setup os <- Sys.info()["sysname"] linuxdir <- "/home/dylan/Personal/Projects/Hurricane Normalization/" macdir <- "~/Desktop/Personal/Projects/Hurricane Normalization/" widir <- "E/..." if(!is.null(os)) { if(grepl("darwin", os, ignore.case = T)) { cat("OS: Mac") baseDir <- macdir } else if(grepl("linux", os, ignore.case = T)) { cat("OS: Linux") baseDir <- linuxdir } else if(grepl("windows", os, ignore.case = T)) { cat("OS: Win") baseDir <- windir } else { cat("Cannot identify OS") } } config <- config::get(file = paste0(baseDir, "R/dataScripts/restructured/app/config.yml")) source(file = paste0(baseDir, "R/dataScripts/restructured/app/queries.R")) # SUPABASE CON #con <- dbConnect( # RPostgres::Postgres(), # host = config$db_host, # port = config$db_port, # dbname = config$db_dbname, # user = config$db_user, # password = config$db_password #) # ## lazy load DB tables #econ.normalized_landfalls <- tbl(con, I("econ.normalized_landfalls")) #econ.storm_base_loss <- tbl(con, I("econ.storm_base_loss")) #econ.usa_yearly <- tbl(con, I("econ.usa_yearly")) # #fatal.storm_fatalities_type <- tbl(con, I("fatal.storm_fatalities_type")) #fatal.storm_total_fatalities <- tbl(con, I("fatal.storm_total_fatalities")) # #fips.counties <- tbl(con, I("fips.counties")) #fips.states <- tbl(con, I("fips.states")) # #gis.affected_area_landfalls <- tbl(con, I("gis.affected_area_landfalls")) # #hurdat.best_track <- tbl(con, I("hurdat.best_track")) #hurdat.hurdat_storms <- tbl(con, I("hurdat.hurdat_storms")) # #metrics.geo_attributes <- tbl(con, I("metrics.geo_attributes")) #metrics.pop_and_housing <- tbl(con, I("metrics.pop_and_housing")) # #public.counties <- tbl(con, I("public.counties")) # pull static data loss_storms <- get_all_loss_storms() latest_normalized_losses <- get_latest_aggregate_losses() storm_selection <- reactiveValues( storm_year = NULL, storm_name = NULL, storm_basin = NULL, lf_id = NULL, is_selected = FALSE, is_table_selection = FALSE, ) async_reqs <- reactiveValues( hurdat_track = NULL, ) loading_states <- reactiveValues( hurdat_track = FALSE, track_error = NULL, ) onStop(function() { #dbDisconnect(con) #daemons(0) #if(!is.null(async_reqs$hurdat_track)) { # tryCatch({ # async_reqs$hurdat_track <- NULL # }, error = function(e) { # cat(e) # }) #} }) ``` Home ============================================= Col {data-width=500} ---------------------------------------------- ### {} ```{r} HTML( '

Welcome to the Hurricane Cost Normalization Web App!

Our platform provides access to normalized hurricane damage data spanning from 1900 to 2024, allowing researchers, policymakers, insurance professional, and the public to better understand how hurricane costs have changed over time.

Our Data

The core datasets used in this app are based on research by Muller et al. (2025) published in Bulletin of the American Meteorlogical Society. This study updates and refines hurricane damage normalization methodologies to provide a more accurate picture of how historical hurricanes would impact today\'s society.

Methodology Innovations

Our platform incoroprates several methodological innovations over previously used cost normalization formulas:

' ) ``` Col {data-width=500} ---------------------------------------------- ### Storm Selector {data-height=500} ```{r} #h5("Select a storm: ") #h6("Use either the select inputs or the data table below") fluidRow( column(4, selectInput("stormBasin", "Select Basin", choices = "AL") ), column(4, selectInput("stormYear", "Select Year", choices = loss_storms$storm_year) ), column(4, selectInput("stormName", "Select Storm", choices = NULL) ) ) actionButton("selectStorm", "Submit", class = "btn-primary") observeEvent(input$stormYear, { stormsByChosenYear <- loss_storms[loss_storms$storm_year == input$stormYear, ] stormsByYear <- loss_storms %>% filter(storm_year == input$stormYear) updateSelectInput(session, "stormName", choices = stormsByYear$storm_name, selected = NULL ) }) observeEvent(input$selectStorm, { storm_selection$storm_basin <- input$stormBasin storm_selection$storm_year <- input$stormYear storm_selection$storm_name <- input$stormName storm_selection$is_selected <- TRUE showNotification("Storm selection updated!", type = "message") }) ``` ### All Storms {data-height=500 .no-padding} ```{r} output$normalized_storms_table <- renderDT({ datatable( latest_normalized_losses %>% select(-hurdatId), rownames = F, colnames = c("Storm", "Year", "MMH24", "MMP24"), selection = "single", options = list( pageLength = 1000, order = list(2, 'desc'), searching = F, paging = F, info = F, lengthChange = F, server = T ) ) %>% formatCurrency(c("mmh", "mmp"), "$", digits = 0) }) DTOutput("normalized_storms_table") ``` Storm Overview {data-navmenu="Storm Details"} ==================================== ```{r} ### REACTIVE VALUES FOR STORM OVERVIEW storm_overview_reactive <- reactiveValues( lf_type = NULL, lf_id = NULL, full_lf_id = NULL, use_normalized_costs = FALSE ) growth_trends <- reactiveValues( lf_type = NULL, lf_id = NULL, full_lf_id = NULL ) observe({ req(storm_selection$is_selected) unique_lfs <- get_unique_lf_ids(storm_selection) updateSelectInput( session, "storm_overview_cost_index_lf", choices = unique_lfs$full_lf_id, selected = unique_lfs$full_lf_id[1] ) updateSelectInput( session, "growth_trend_lf_select", choices = unique_lfs$full_lf_id, selected = unique_lfs$full_lf_id[1] ) }) ``` Col {data-width=500 .tabset} ------------------------------------ ### Track Map {.no-padding} ```{r} storm_track <- reactive({ req(storm_selection$is_selected) result <- get_hurdat_track(storm_selection) return(result) }) output$track_map <- renderLeaflet({ leaflet() %>% addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18)) # %>% setView(lng = -89.8, lat = 29.6, zoom = 8) }) observe({ req(storm_selection$is_selected) storm_track <- storm_track() leafletProxy("track_map", data = storm_track) %>% clearShapes() %>% clearMarkers() %>% addPolylines( data = storm_track, lng = ~lon, lat = ~lat, weight = 4, color = "blue" ) %>% addCircleMarkers( data = storm_track %>% filter(record_identifier == "L"), lng = ~lon, lat = ~lat, radius = 5, weight = 0, color = "red", fillColor = "red", fillOpacity = 0.8 ) %>% addCircles( data = storm_track %>% filter(record_identifier == "L"), lng = ~lon, lat = ~lat, radius = ~rmw_meters, weight = 2, color = "red", fillColor = "red", fillOpacity = 0.3 ) }) leafletOutput("track_map", height = "100%") ``` ### Track Data {.no-padding} ```{r} output$track_data <- renderDT({ datatable( storm_track() %>% select(datetime, lon, lat, rmw, pressure, windspeed, record_identifier), rownames = F, colnames = c("Date", "Longitude", "Latitude", "RMW (NM)", "Pressure (mb)", "Windpseed (KT)", "Identifier"), selection = "none", options = list( pageLength = 1000, order = list(0, 'desc'), searching = F, paging = F, info = F, lengthChange = F, server = T ) ) }) DTOutput("track_data") ``` Col {data-width=500} ------------------------------------ ### Normalization Cost Index {data-height=500} ```{r} output$cost_index_chart <- renderDygraph({ req(storm_selection$is_selected, input$storm_overview_cost_index_lf) cost_index <- get_normalized_cost_index(storm_selection, input$storm_overview_cost_index_lf) %>% mutate(normalization_year = as.Date(paste0(normalization_year, "-01-01"))) cost_index_ts <- cost_index %>% select(-normalization_year) %>% xts(order.by = cost_index$normalization_year) dygraph(cost_index_ts, main = "Cost Index") %>% dySeries("mmh", label = "MMH24") %>% dySeries("mmp", label = "MMP24") %>% dyRangeSelector(height = 30) }) #observeEvent(input$storm_overview_select_base, { # TODO: add button to select normalized costs #}) fillCol( flex = c(.2, .8), fluidRow( column(4, selectInput("storm_overview_cost_index_lf", "Landfall Select", choices = NULL) ), column(4, # TODO: add button to select normalized costs #checkboxInput("storm_overview_select_base", "Include Normalized Losses", value = F) ), column(4, #checkboxInput("mmpSelect", "Display MMP", value = T) ) ), dygraphOutput("cost_index_chart") ) ``` ### Landfalls {data-height=500 .no-padding} ```{r} output$landfalls_table <- renderDT({ req(storm_selection$is_selected) hurdat_landfalls <- get_hurdat_landfalls(storm_selection) datatable( hurdat_landfalls, rownames = F, colnames = c("Date", "Longitude", "Latitude", "RMW", "Pressure", "Windspeed"), options = list( order = list(0, 'asc'), paging = F, searching = F, info = F, lengthChange = F, server = T ) ) %>% formatDate(columns = "datetime", method = "toUTCString") }) DTOutput("landfalls_table") ``` Growth Trends {data-navmenu="Storm Details"} ================================ Column {data-width=550 .tabset} ------------------------------- ### Growth Map {.no-padding} ```{r} observe({ req(storm_selection$is_selected) updateSliderInput(session, "growth_trend_map_slider", min = storm_selection$storm_year, value = storm_selection$storm_year) }) #storm_metrics_growth_geom <- reactive({ # req(storm_selection$is_selected) # # counties <- get_normalized_metric_growth(storm_selection, input$growth_trend_lf_select) # # result <- counties %>% # st_as_sf(wkt = "geom_wkt") # #%>% # # mutate( # # clamped_population = rescale(normalized_population, to = c(0.1, 0.9), from = range(normalized_population, na.rm = T)), # # clamped_housing = rescale(normalized_housing, to = c(0.1, 0.9), from = range(normalized_housing, na.rm = T)) # # ) %>% # # # cat(str(result)) # # return(result) #}) #observe({ # req(storm_selection$is_selected, input$growth_trend_map_slider) # # county_data <- storm_metrics_growth_geom() %>% # filter(year == input$growth_trend_map_slider) # # cat(str(county_data)) # # leafletProxy("pop_growth_map", session) %>% # clearShapes() %>% # addPolygons( # data = county_data, # fillColor = "red", # fillOpacity = 1 # ) #}) test_storm <- reactiveValues( storm_basin = "AL", storm_year = 2005, storm_name = "KATRINA", ) katrina_counties <- reactive({ req(storm_selection$is_selected) counties <- get_normalized_metric_growth(test_storm, "LF2") result <- counties %>% filter(year == 2024) %>% mutate( population_opacity = rescale(normalized_population, to = c(0.2, 0.8), from = range(normalized_population, na.rm = T)), housing_opacity = rescale(normalized_housing, to = c(0.2, 0.8), from = range(normalized_housing, na.rm = T)) ) %>% st_as_sf(wkt = "geom_wkt") return(result) }) output$pop_growth_map <- renderLeaflet({ leaflet() %>% addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18)) # %>% setView(lng = -89.8, lat = 29.6, zoom = 8) }) output$housing_growth_map <- renderLeaflet({ leaflet() %>% addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18)) # %>% setView(lng = -89.8, lat = 29.6, zoom = 8) }) observe({ req(katrina_counties) leafletProxy("pop_growth_map", data = katrina_counties()) %>% clearShapes() %>% addPolygons( fillColor = "red", color = "red", fillOpacity = ~population_opacity, weight = 2 ) leafletProxy("housing_growth_map", data = katrina_counties()) %>% clearShapes() %>% addPolygons( fillColor = "blue", color = "blue", fillOpacity = ~housing_opacity, weight = 2 ) }) fillCol( flex = c(.1, .45, .45), div( style = " padding-left: 15px; padding-right: 15px; padding-top: 15px; display: flex; justify-content: center; align-itmes: center; ", sliderInput("growth_trend_map_slider", label = NULL, min = 1900, max = 2024, step = 1, animate = T, value = 1700, sep = "", width = "100%", ticks = F) ), leafletOutput("pop_growth_map"), leafletOutput("housing_growth_map") ) ``` ### Growth Data {.no-padding} ```{r} ``` Column {data-width=450} ---------------------------------- ### Landfall Selection {data-height=550} ```{r} fillCol( flex = c(.2, .8), fluidRow( column(6, selectInput("growth_trend_lf_select", "Landfall Select", choices = NULL) ), column(6, # TODO: add button to select normalized costs #checkboxInput("storm_overview_select_base", "Include Normalized Losses", value = F) ) ), #dygraphOutput("popHu") ) #output$popHu <- renderDygraph({ # dygraph(aggregate_normalized_growth_metrics_lf_ts(), main = "Normalized Aggregate Growth") %>% # dySeries("normalized_population", label = "Population") %>% # dySeries("normalized_housing_units", label = "Housing Units") %>% # dyRangeSelector() #3}) ``` ### County Data {data-height=450 .no-padding} ```{r} ``` Storm Fatalities {data-navmenu="Storm Details"} === Fatalities {data-navmenu="Fatalities"} === Column {data-width=500} --- ### {data-height=500} ```{r} fatality_years <- seq(1900, 2010, by = 10) direct_deaths <- c(6000, 275, 0, 408, 26, 654, 466, 213, 104, 228, 1136, 321) indirect_deaths <- c(0, 0, 0, 0, 0, 1, 8, 15, 40, 54, 1171, 368) yearly_fatalities <- data.frame(fatality_years, direct_deaths, indirect_deaths) %>% mutate( fatality_years = as.Date(paste0(fatality_years, "-01-01")) ) yearly_fatalities_ts <- yearly_fatalities %>% select(-fatality_years) %>% xts(order.by = yearly_fatalities$fatality_years) output$decade_fatalities <- renderDygraph( dygraph(yearly_fatalities_ts, main = "Fatalities By Decade") %>% dySeries("direct_deaths", label = "Direct Deaths") %>% dySeries("indirect_deaths", label = "Indirect Deaths") %>% dyRangeSelector() ) dygraphOutput("decade_fatalities") ``` ### {data-height=500} ```{r} surge_yearly <- c(0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 410, 107) surf_yearly <- c(0, 0, 0, 0, 0, 0, 0, 14, 2, 12, 12, 17) rough_seas_yearly <- c(0, 0, 0, 0, 16, 0, 2, 0, 24, 17, 0, 14) rip_current_yearly <- c(0, 0, 0, 0, 0, 0, 0, 0, 0, 6, 14, 3) freshwater_floods_yearly <- c(0, 0, 0, 0, 0, 200, 12, 151, 0, 117, 50, 284) wind_yearly <- c(0, 0, 0, 0, 0, 0, 0, 8, 14, 23, 11, 82) tree_fall_yearly <- c(0, 0, 0, 0, 1, 0, 0, 1, 0, 9, 24, 56) tornado_yearly <- c(0, 0, 0, 0, 1, 12, 43, 7, 0, 7, 11, 7) traffic_yearly <- c(0, 0, 0, 0, 0, 0, 0, 4, 0, 3, 2, 1) traffic_accident_yearly <- c(0, 0, 0, 0, 0, 0, 5, 0, 0, 8, 26, 11) electrocution_yearly <- c(0, 0, 0, 0, 0, 0, 2, 0, 0, 5, 2, 7) other_yearly <- c(0, 0, 0, 0, 5, 0, 5, 11, 15, 13, 37, 7) yearly_fatalities_type <- data.frame(fatality_years, surge_yearly, surf_yearly, rough_seas_yearly, rip_current_yearly, freshwater_floods_yearly, wind_yearly, tree_fall_yearly, tornado_yearly, traffic_yearly, traffic_accident_yearly, electrocution_yearly, other_yearly) %>% mutate( fatality_years = as.Date(paste0(fatality_years, "-01-01")) ) yearly_fatalities_type_ts <- yearly_fatalities_type %>% select(-fatality_years) %>% xts(order.by = yearly_fatalities_type$fatality_years) output$decade_fatalities_type <- renderDygraph( dygraph(yearly_fatalities_type_ts, main = "Fatality Types By Decade") %>% dySeries("surge_yearly", label = "Surge") %>% dySeries("surf_yearly", label = "Surf") %>% dySeries("rough_seas_yearly", label = "Rough Seas") %>% dySeries("rip_current_yearly", label = "Rip Current") %>% dySeries("freshwater_floods_yearly", label = "Freshwater Floods") %>% dySeries("wind_yearly", label = "Wind") %>% dySeries("tree_fall_yearly", label = "Tree Fall") %>% dySeries("tornado_yearly", label = "Tornado") %>% dySeries("traffic_yearly", label = "Traffic") %>% dySeries("traffic_accident_yearly", label = "Traffic Accident") %>% dySeries("electrocution_yearly", label = "Electrocution") %>% dySeries("other_yearly", label = "Other") %>% dyRangeSelector() ) dygraphOutput("decade_fatalities_type") ``` Column {data-width=500} --- ### {data-height=500} ```{r} fatality_type <- c("Surge", "Surf", "Rough Seas", "Rip Current", "Floods", "Wind", "Tree Fall", "Tornado", "Traffic", "Traffic Accident", "Electrocution", "Other") fatality_totals <- c(520, 56, 77, 23, 826, 131, 91, 88, 10, 45, 16, 56) aggregate_fatality_types <- data.frame(fatality_type, fatality_totals) output$aggregate_fatalities <- renderBillboarder( billboarder() %>% bb_piechart(aggregate_fatality_types) #%>% bb_legend(position = "right") ) billboarderOutput("aggregate_fatalities") ``` ### {data-height=500} ```{r} ``` Normalization Calculator {data-navmenu="Compute"} === Column {data-width=700 .tabset} --- ### Impact Map {.no-padding} ```{r} output$impact_analysis_map <- renderLeaflet({ leaflet() %>% addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18)) # %>% setView(lng = -89.8, lat = 29.6, zoom = 8) }) leafletOutput("impact_analysis_map") ``` ### Impact Data {.no-padding} ```{r} ``` Column {data-width=300} --- ### {} ```{r} fillCol( flex = c(.5, .5), div( p("Storm Selector"), selectInput("impact_storm_basin", label = NULL, choices = "AL", width = "100%"), selectInput("impact_storm_year", label = NULL, choices = 2005, width = "100%"), selectInput("impact_storm_name", label = NULL, choices = "KATRINA", width = "100%"), fluidRow( column(6, selectInput("impact_storm_lf_type", label = NULL, choices = "LF", width = "100%") ), column(6, selectInput("impact_storm_lf_id", label = NULL, choices = "1", width = "100%") ) ), actionButton("impact_populate_storm", label = "Populate", width = "100%", class = "btn-primary rounded") ), div( p("Impact Area"), fluidRow( column(6, textInput("impact_lat", placeholder = "Lat", label = NULL, width = "100%") ), column(6, textInput("impact_lon", placeholder = "Lon", label = NULL, width = "100%") ) ), fluidRow( column(4, textInput("impact_rmw", placeholder = "RMW", label = NULL, width = "100%") ), column(8, sliderInput("impact_rmw_slider", label = NULL, min = 1, max = 20, value = 5, ticks = F, width = "100%") ) ), #fluidRow( # column(3, # actionButton("impact_rmw_one", label = "1x", width = "100%", class = "btn-primary") # ), # column(3, # actionButton("impact_rmw_two", label = "2x", width = "100%", class = "btn-outline-primary btn-#block") # ), # column(3, # actionButton("impact_rmw_three", label = "3x", width = "100%", class = "btn-outline-primary btn-#block") # ) #), radioGroupButtons("impact_rmw_multiplier", label = NULL, choices = c("1x", "2x", "3x"), status = "outline-primary rounded-0", justified = T), fluidRow( column(6, textInput("impact_base_year", placeholder = "Impact Year", label = NULL, width = "100%") ), column(6, textInput("impact_ref_year", placeholder = "Reference Year", label = NULL, width = "100%") ) ), textInput("impact_base_damage", placeholder = "Storm Base Damage", label = NULL, width = "100%"), actionButton("impact_calculate", label = "Calculate", width = "100%", class = "btn-primary rounded") ) ) ``` Data {data-navmenu="Compute"} === All Storms Table === ```{r} #DT with storm, hurdatid, base damage, mmh, mmp, maybe multipliers?, sparkline? output$normalized_storms_full_table <- renderDT({ datatable( latest_normalized_losses, rownames = F, colnames = c("HURDAT Code", "Storm", "Year", "MMH24", "MMP24"), selection = "none", options = list( pageLength = 20, order = list(0, 'asc'), #searching = F, #paging = F, #info = F, #lengthChange = F, server = T ) ) %>% formatCurrency(c("mmh", "mmp"), "$", digits = 0) }) DTOutput("normalized_storms_full_table") ``` About ===