From f7a09affec1a478f4f23dd193dad1e373a9e372d Mon Sep 17 00:00:00 2001 From: dylanbenzi Date: Sat, 4 Apr 2026 18:01:58 -0400 Subject: [PATCH] update entire app to begin using bslib instead of flexdashboard --- .vscode/tasks.json | 13 + app/app.R | 5 + app/global.R | 58 ++++ app/queries.R | 154 ++-------- app/server.R | 721 +++++++++++++++++++++++++++++++++++++++++++++ app/ui.R | 230 +++++++++++++++ 6 files changed, 1057 insertions(+), 124 deletions(-) create mode 100644 app/app.R create mode 100644 app/global.R create mode 100644 app/server.R create mode 100644 app/ui.R diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 06136b2..9b41586 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -25,6 +25,19 @@ "kind": "test", "isDefault": true } + }, + { + "label": "Run Shiny App", + "type": "shell", + "command": "Rscript", + "args": [ + "-e", + "\"options(shiny.autoreload = TRUE); shiny::runApp('app/app.R', port = 1234, )\"" + ], + "group": { + "kind": "test", + "isDefault": true + } } ] } \ No newline at end of file diff --git a/app/app.R b/app/app.R new file mode 100644 index 0000000..bd581fc --- /dev/null +++ b/app/app.R @@ -0,0 +1,5 @@ +source("global.R") +source("ui.R") +source("server.R") + +shinyApp(ui = ui, server = server) diff --git a/app/global.R b/app/global.R new file mode 100644 index 0000000..c4af04f --- /dev/null +++ b/app/global.R @@ -0,0 +1,58 @@ +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) +library(paletteer) +library(shinyjs) +library(quarto) + +APP_DIR <- getwd() + +cache_dir <- file.path(APP_DIR, "cache") +cache_logfile <- file.path(APP_DIR, "cachelog") + +source(file = "queries.R") + +useShinyjs() + +# pull static data +loss_storms <- get_all_loss_storms() + +latest_normalized_losses <- get_latest_aggregate_losses() + +all_conus_landfalls <- get_all_conus_landfalls() + +all_lf_type_storms <- get_all_lf_type_landfalls() + +onStop(function() { + disconnect_db() +}) + +storm_selection <- reactiveValues( + storm_year = NULL, + storm_name = NULL, + storm_basin = NULL, + hurdatid = NULL +) diff --git a/app/queries.R b/app/queries.R index dcf6636..22bba9d 100644 --- a/app/queries.R +++ b/app/queries.R @@ -4,11 +4,7 @@ library(tidyverse) library(dplyr) library(DBI) library(xts) -library(memoise) -library(cachem) -library(digest) -APP_DIR <- getwd() config <- config::get(file = "config.yml") @@ -22,21 +18,7 @@ con <- dbConnect( password = config$db_password ) -.tbl_cache <- new.env(parent = emptyenv()) -get_tbl <- function(name, schema = NULL) { - key <- if (is.null(schema)) name else paste0(schema, ".", name) - - if (!exists(key, .tbl_cache)) { - if (is.null(schema)) { - .tbl_cache[[key]] <- tbl(con, name) - } else { - .tbl_cache[[key]] <- tbl(con, I(paste0(schema, ".", name))) - } - } - - .tbl_cache[[key]] -} #qry <- econ.storm_base_loss %>% # left_join(view.hurdat_track, by = c("storm_basin", "storm_year", "storm_name")) @@ -83,7 +65,7 @@ split_full_lf_id <- function(full_lf_id) { # DB getters get_yearly_economics <- function(yr) { - query <- get_tbl("usa_yearly", "econ") %>% + query <- tbl(con, I("econ.usa_yearly")) %>% filter(year == yr) result <- query %>% collect() @@ -92,7 +74,7 @@ get_yearly_economics <- function(yr) { } get_latest_normalization_year <- function() { - query <- get_tbl("all_yearly_normalized_losses") %>% + query <- tbl(con, "all_yearly_normalized_losses") %>% summarize(latest_year = max(normalization_year)) result <- query %>% collect() @@ -101,7 +83,7 @@ get_latest_normalization_year <- function() { } get_storm_data_coverage <- function() { - query <- get_tbl("storm_data_coverage") + query <- tbl(con, "storm_data_coverage") result <- query %>% collect() @@ -109,7 +91,7 @@ get_storm_data_coverage <- function() { } get_yearly_usa_pop_hu <- function(yr) { - query <- get_tbl("usa_pop_hu", "metrics") %>% + query <- tbl(con, I("metrics.usa_pop_hu")) %>% filter(year == yr) result <- query %>% collect() @@ -118,7 +100,7 @@ get_yearly_usa_pop_hu <- function(yr) { } get_best_track_summary <- function(storm) { - query <- get_tbl("best_track_summary") %>% + query <- tbl(con, "best_track_summary") %>% filter( storm_basin == storm$storm_basin, storm_year == storm$storm_year, @@ -131,7 +113,7 @@ get_best_track_summary <- function(storm) { } get_hurdat_id <- function(storm) { - query <- get_tbl("hurdat_ids") %>% + query <- tbl(con, "hurdat_ids") %>% filter( storm_basin == storm$storm_basin, storm_year == storm$storm_year, @@ -145,7 +127,7 @@ get_hurdat_id <- function(storm) { # returns a list of loss storms we have data on get_all_loss_storms <- function() { - query <- get_tbl("all_loss_storms") + query <- tbl(con, "all_loss_storms") result <- query %>% collect() @@ -154,7 +136,7 @@ get_all_loss_storms <- function() { # returns a list of all stored hurdat ids get_all_hurdat_ids <- function() { - query <- get_tbl("hurdat_ids") + query <- tbl(con, "hurdat_ids") result <- query %>% collect() @@ -163,7 +145,7 @@ get_all_hurdat_ids <- function() { # returns a list of latest normalized losses get_latest_aggregate_losses <- function() { - query <- get_tbl("all_normalized_losses") + query <- tbl(con, "all_normalized_losses") result <- query %>% collect() @@ -171,7 +153,7 @@ get_latest_aggregate_losses <- function() { } get_latest_aggregate_loss <- function(storm) { - query <- get_tbl("all_normalized_losses") %>% + query <- tbl(con, "all_normalized_losses") %>% filter( storm_year == storm$storm_year, storm_name == storm$storm_name @@ -184,7 +166,7 @@ get_latest_aggregate_loss <- function(storm) { # returns unique lf ids for a storm get_unique_lf_ids <- function(storm) { - query <- get_tbl("all_loss_landfalls") %>% + query <- tbl(con, "all_loss_landfalls") %>% filter( storm_basin == storm$storm_basin, storm_year == storm$storm_year, @@ -215,7 +197,7 @@ get_unique_lf_ids <- function(storm) { get_normalized_cost_index <- function(storm, full_lf_id) { lf_id_parts <- split_full_lf_id(full_lf_id) - query <- get_tbl("all_yearly_normalized_losses") %>% + query <- tbl(con, "all_yearly_normalized_losses") %>% filter( storm_basin == storm$storm_basin, storm_year == storm$storm_year, @@ -234,58 +216,9 @@ get_normalized_cost_index <- function(storm, full_lf_id) { return(result) } -test_query <- function() { - result <- dbGetQuery( - con, - "WITH yearly_totals AS ( - SELECT - year, - SUM(population) as total_population, - SUM(housing_units) as total_housing_units - FROM metrics.pop_and_housing - WHERE state_fips = '12' - AND county_fips IN ('011', '021', '086', '087') - AND year BETWEEN 1926 AND 2024 - GROUP BY year -), -base_year AS ( - SELECT - total_population as base_population, - total_housing_units as base_housing - FROM yearly_totals - WHERE year = (SELECT MIN(year) FROM yearly_totals) -- Uses first year in dataset as base -) -SELECT - year, - total_population, - total_housing_units, - ROUND(total_population / base_population, 4) as population_index, - ROUND(total_housing_units / base_housing, 4) as housing_index -FROM yearly_totals -CROSS JOIN base_year -ORDER BY year;" - ) - - result <- result %>% - mutate( - year = as.Date(paste0(year, "-01-01")) - ) %>% - select( - year, - population_index, - housing_index - ) - - result_ts <- result %>% - select(-year) %>% - xts(order.by = result$year) - - return(result_ts) -} - # returns normalized mmh/mmp indexes and costs over time by storm get_all_normalized_cost_index <- function(storm) { - query <- get_tbl("all_yearly_normalized_losses") %>% + query <- tbl(con, "all_yearly_normalized_losses") %>% filter( storm_basin == storm$storm_basin, storm_year == storm$storm_year, @@ -310,7 +243,7 @@ get_all_normalized_cost_index <- function(storm) { # returns landfalls and data at landfall from HURDAT get_hurdat_landfalls <- function(storm) { - query <- get_tbl("hurdat_track") %>% + query <- tbl(con, "hurdat_track") %>% filter( storm_basin == storm$storm_basin, storm_year == storm$storm_year, @@ -342,7 +275,7 @@ get_hurdat_landfalls <- function(storm) { # returns all tracked storm conus landfalls get_all_conus_landfalls <- function() { - query <- get_tbl("all_conus_landfalls") %>% + query <- tbl(con, "all_conus_landfalls") %>% select( storm_year, storm_name, @@ -358,7 +291,7 @@ get_all_conus_landfalls <- function() { # returns all storm tracks from HURDAT get_all_hurdat_tracks <- function() { - query <- get_tbl("all_loss_storms_tracks") + query <- tbl(con, "all_loss_storms_tracks") result <- query %>% collect() @@ -367,7 +300,7 @@ get_all_hurdat_tracks <- function() { # returns storm track from HURDAT get_hurdat_track <- function(storm) { - query <- get_tbl("hurdat_track") %>% + query <- tbl(con, "hurdat_track") %>% filter( storm_basin == storm$storm_basin, storm_year == storm$storm_year, @@ -416,7 +349,7 @@ get_normalized_metric_growth <- function(storm, full_lf_id) { lf_id_parts <- split_full_lf_id(full_lf_id) if (lf_id_parts$lf_type == 'LF') { - affected_counties <- get_tbl("affected_area_landfalls", "gis") %>% + affected_counties <- tbl(con, I("gis.affected_area_landfalls")) %>% filter( storm_basin == storm$storm_basin, storm_year == storm$storm_year, @@ -426,11 +359,11 @@ get_normalized_metric_growth <- function(storm, full_lf_id) { ) %>% select(state_fips, county_fips) - query <- get_tbl("pop_housing_normalized_growth", "metrics") %>% - filter(base_year == storm$storm_year) %>% + query <- tbl(con, I("metrics.pop_housing_normalized_growth")) %>% + filter(base_year_population == storm$storm_year) %>% inner_join(affected_counties, by = c("state_fips", "county_fips")) %>% inner_join( - get_tbl("counties", "public"), + tbl(con, I("public.counties")), by = c("state_fips" = "statefp", "county_fips" = "countyfp") ) %>% mutate( @@ -471,7 +404,7 @@ get_normalized_metric_growth <- function(storm, full_lf_id) { return(result) } else { - affected_state <- get_tbl("indirect_landfalls", "gis") %>% + affected_state <- tbl(con, I("gis.indirect_landfalls")) %>% filter( storm_basin == storm$storm_basin, storm_year == storm$storm_year, @@ -483,7 +416,7 @@ get_normalized_metric_growth <- function(storm, full_lf_id) { state_fips ) - baseline_metrics <- get_tbl("yearly_state_metrics") %>% + baseline_metrics <- tbl(con, "yearly_state_metrics") %>% filter(year == storm$storm_year) %>% inner_join(affected_state, by = "state_fips") %>% select( @@ -492,7 +425,7 @@ get_normalized_metric_growth <- function(storm, full_lf_id) { baseline_housing = state_housing_units ) - normalized_metrics <- get_tbl("yearly_state_metrics") %>% + normalized_metrics <- tbl(con, "yearly_state_metrics") %>% filter( year >= storm$storm_year ) %>% @@ -515,7 +448,7 @@ get_normalized_metric_growth <- function(storm, full_lf_id) { query <- normalized_metrics %>% inner_join( - get_tbl("us_states_boundary", "gis") %>% + tbl(con, I("gis.us_states_boundary")) %>% rename(state_fips = statefp), by = "state_fips" ) %>% @@ -544,7 +477,7 @@ get_normalized_metric_growth <- function(storm, full_lf_id) { # returns all lf type landfalls get_all_lf_type_landfalls <- function() { - query <- get_tbl("lf_id_location") + query <- tbl(con, "lf_id_location") result <- query %>% collect() @@ -553,7 +486,7 @@ get_all_lf_type_landfalls <- function() { # returns all storms and factors needed to normalize a lf type landfall get_all_lf_type_factors <- function() { - query <- get_tbl("lf_landfall_gis") + query <- tbl(con, "lf_landfall_gis") result <- query %>% collect() @@ -562,7 +495,7 @@ get_all_lf_type_factors <- function() { # returns one storm and factors needed to normalize a lf type landfall get_lf_type_factors <- function(storm) { - query <- get_tbl("lf_landfall_gis") %>% + query <- tbl(con, "lf_landfall_gis") %>% filter( storm_basin == storm$storm_basin, storm_year == storm$storm_year, @@ -579,7 +512,7 @@ get_county_and_state <- function(df) { unique_state_fips <- unique(df$state_fips) unique_county_fips <- unique(df$county_fips) - counties <- get_tbl("counties", "public") %>% + counties <- tbl(con, I("public.counties")) %>% filter( statefp %in% !!unique_state_fips, countyfp %in% !!unique_county_fips @@ -592,7 +525,7 @@ get_county_and_state <- function(df) { ) %>% collect() - states <- get_tbl("states", "fips") %>% + states <- tbl(con, I("fips.states")) %>% filter(state_fips %in% !!unique_state_fips) %>% select( state_fips, @@ -614,30 +547,3 @@ get_county_and_state <- function(df) { return(result) } -cache_dir <- file.path(APP_DIR, "cache") -cache_logfile <- file.path(APP_DIR, "cachelog") - -if (!dir.exists(cache_dir)) { - dir.create(cache_dir, recursive = TRUE) -} - -query_cache <- cachem::cache_disk( - dir = cache_dir, - max_age = Inf, - evict = "lru", - logfile = cache_logfile -) - -get_latest_normalization_year <- memoise( - get_latest_normalization_year, - cache = query_cache -) -get_all_loss_storms <- memoise(get_all_loss_storms, cache = query_cache) -get_all_hurdat_ids <- memoise(get_all_hurdat_ids, cache = query_cache) -get_latest_aggregate_losses <- memoise( - get_latest_aggregate_losses, - cache = query_cache -) -get_all_conus_landfalls <- memoise(get_all_conus_landfalls, cache = query_cache) -get_all_hurdat_tracks <- memoise(get_all_hurdat_tracks, cache = query_cache) -get_all_lf_type_factors <- memoise(get_all_lf_type_factors, cache = query_cache) diff --git a/app/server.R b/app/server.R new file mode 100644 index 0000000..64ecea2 --- /dev/null +++ b/app/server.R @@ -0,0 +1,721 @@ +server <- function(input, output, session) { + storm_coverage <- get_storm_data_coverage() %>% + select(-storm_basin) %>% + { + col_names <- names(.) + mutate( + ., + data = trimws(paste( + ifelse( + as.logical(.data[[col_names[3]]]), + 'Fatality', + "" + ), + ifelse( + as.logical(.data[[col_names[4]]]), + 'Cost', + "" + ) + )) + ) %>% + select(1, 2, data) + } + + output$storm_coverage_table <- renderDT({ + datatable( + storm_coverage, + rownames = F, + escape = F, + colnames = c("Year", "Name", "Data"), + selection = "single", + options = list( + pageLength = 1000, + order = list(0, 'desc'), + searching = F, + paging = F, + info = F, + lengthChange = F + ) + ) + }) + + dt_storm_selected <- reactive({ + req(input$storm_coverage_table_rows_selected) + storm_coverage[input$storm_coverage_table_rows_selected, ] + }) + + output$dt_storm_name_year <- renderText({ + paste0( + dt_storm_selected()$storm_name, + " (", + dt_storm_selected()$storm_year, + ")" + ) + }) + + output$selected_storm_name_year <- renderText({ + if (is.null(storm_selection$storm_name)) { + "Select a storm" + } else { + paste0( + storm_selection$storm_name, + " (", + storm_selection$storm_year, + ")" + ) + } + }) + + observe({ + req( + storm_selection$storm_basin, + storm_selection$storm_year, + storm_selection$storm_name + ) + + unique_lfs <- get_unique_lf_ids(storm_selection) + + updateVirtualSelect( + session = session, + "storm_overview_cost_index_lf_select", + choices = prepare_choices(unique_lfs, full_lf_id, full_lf_id, lf_type), + 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] + ) + }) + + observeEvent(input$load_storm, { + storm_selection$storm_basin <- "AL" + storm_selection$storm_year <- dt_storm_selected()$storm_year + storm_selection$storm_name <- dt_storm_selected()$storm_name + + hurdatid <- get_hurdat_id(storm_selection) + storm_selection$hurdatid = hurdatid$hurdatid + + selected_storm <- + paste0( + dt_storm_selected()$storm_name, + " (", + dt_storm_selected()$storm_year, + ")" + ) + + nav_select("main_navbar", "Storm Explorer") + }) + + output$all_storms_map <- renderLeaflet({ + leaflet() %>% + addProviderTiles("Stadia.AlidadeSmooth") %>% + addCircleMarkers( + data = all_conus_landfalls, + lng = ~lon, + lat = ~lat, + radius = 2, + popup = ~ paste0(storm_name, " ", storm_year), + weight = 0, + color = "blue", + fillColor = "blue", + fillOpacity = 0.5 + ) %>% + addCircles( + data = all_conus_landfalls, + lng = ~lon, + lat = ~lat, + radius = ~rmw_meters, + popup = ~ paste0(storm_name, " ", storm_year), + weight = 1, + color = "blue", + fillColor = "blue", + fillOpacity = 0.05 + ) + }) + + storm_track <- reactive({ + req( + storm_selection$storm_basin, + storm_selection$storm_year, + storm_selection$storm_name + ) + result <- get_hurdat_track(storm_selection) + + # HURDAT storm status + # TD – Tropical cyclone of tropical depression intensity (< 34 knots) + # TS – Tropical cyclone of tropical storm intensity (34-63 knots) + # HU – Tropical cyclone of hurricane intensity (> 64 knots) + # EX – Extratropical cyclone (of any intensity) + # SD – Subtropical cyclone of subtropical depression intensity (< 34 knots) + # SS – Subtropical cyclone of subtropical storm intensity (> 34 knots) + # LO – A low that is neither a tropical cyclone, a subtropical cyclone, nor an extratropical cyclone (of any intensity) + # WV – Tropical Wave (of any intensity) + # DB – Disturbance (of any intensity) + + # Line Color Storm Type Status Pressure (mb) Wind (mph) Wind (knots) + # Blue Subtropical Depression SD -- <=38 <=33 + # Light Blue Subtropical Storm SS -- 39-73 34-63 + # Green Tropical Depression (TD) TD -- <=38 <=33 + # Yellow Tropical Storm (TS) TS 980+ 39-73 34-63 + # Red Hurricane (Cat 1) HU <=980 74-95 64-82 + # Pink Hurricane (Cat 2) HU 965-980 96-110 83-95 + # Magenta Major Hurricane (Cat 3) HU 945-965 111-129 96-112 + # Purple Major Hurricane (Cat 4) HU 920-945 130-156 113-136 + # White Major Hurricane (Cat 5) HU <=920 157+ 137+ + # Green dashed (- -) Wave/Low/Disturbance WV/LO/DB -- -- -- + # Black hatched (++) Extratropical Cyclone EX -- -- -- + + # Category Sustained Windspeed (knots) + # 1 64-82 + # 2 83-95 + # 3 96-112 + # 4 113-136 + # 5 137+ + + # Preprocess the track data with colors + result <- result %>% + mutate( + hurricane_category = case_when( + # Hurricane Cat 1 + storm_status == "HU" & windspeed >= 64 & windspeed <= 82 ~ 1, + + # Hurricane Cat 2 + storm_status == "HU" & windspeed >= 83 & windspeed <= 95 ~ 2, + + # Hurricane Cat 3 + storm_status == "HU" & windspeed >= 96 & windspeed <= 112 ~ 3, + + # Hurricane Cat 4 + storm_status == "HU" & windspeed >= 113 & windspeed <= 136 ~ 4, + + # Hurricane Cate 5 + storm_status == "HU" & windspeed >= 137 ~ 5, + ), + line_color = case_when( + # Tropical Depression - Green + storm_status == "TD" ~ "#2AFF00", + + # Tropical Storm - Yellow + storm_status == "TS" ~ "#FFD020", + + # Hurricane Cat 1 - Red + hurricane_category == 1 ~ "#FF4343", + + # Hurricane Cat 2 - Pink + hurricane_category == 2 ~ "#FF6FFF", + + # Hurricane Cat 3 - Magenta + hurricane_category == 3 ~ "#FF23D3", + + # Hurricane Cat 4 - Purple + hurricane_category == 4 ~ "#C916FF", + + # Hurricane Cate 5 - White + hurricane_category == 5 ~ "#FFFFFF", + + # Extratropical Cyclone + storm_status == "EX" ~ "#202020", + + # Subtropical Depression + storm_status == "SD" ~ "#0055FF", + + # Subtropical Storm + storm_status == "SS" ~ "#6CE2FF", + + # Low + storm_status == "LO" ~ "#A1A1A1", + + # Wave + storm_status == "WV" ~ "#A1A1A1", + + # Disturbance + storm_status == "DB" ~ "#A1A1A1", + + # Missing + TRUE ~ "#FF5C00" + ), + popup_category = case_when( + storm_status == "TD" ~ "TD", + storm_status == "TS" ~ "TS", + hurricane_category == 1 ~ "H1", + hurricane_category == 2 ~ "H2", + hurricane_category == 3 ~ "H3", + hurricane_category == 4 ~ "H4", + hurricane_category == 5 ~ "H5", + storm_status == "EX" ~ "EX", + storm_status == "SD" ~ "SD", + storm_status == "SS" ~ "SS", + storm_status == "LO" ~ "LO", + storm_status == "WV" ~ "WV", + storm_status == "DB" ~ "DB", + TRUE ~ "NA" + ) + ) %>% + arrange(datetime) + + return(result) + }) %>% + bindCache( + storm_selection$storm_year, + storm_selection$storm_name, + storm_selection$storm_basin + ) + + output$track_map <- renderLeaflet({ + track_data <- storm_track() + + map <- leaflet() %>% + addProviderTiles("Stadia.AlidadeSmooth") %>% + fitBounds( + lng1 = min(track_data$lon), + lng2 = max(track_data$lon), + lat1 = min(track_data$lat), + lat2 = max(track_data$lat) + ) + + map <- map %>% + leaflet::addLegend( + position = "bottomleft", + colors = c( + "#2AFF00", # TD + "#FFD020", # TS + "#FF4343", # Cat 1 + "#FF6FFF", # Cat 2 + "#FF23D3", # Cat 3 + "#C916FF", # Cat 4 + "#FFFFFF", # Cat 5 + "#202020", # EX + "#0055FF", # SD + "#6CE2FF", # SS + "#A1A1A1", # LO/WV/DB + "#FF5C00" # Missing + ), + labels = c( + "Tropical Depression (TD)", + "Tropical Storm (TS)", + "Hurricane Category 1", + "Hurricane Category 2", + "Hurricane Category 3", + "Hurricane Category 4", + "Hurricane Category 5", + "Extratropical Cyclone (EX)", + "Subtropical Depression (SD)", + "Subtropical Storm (SS)", + "Low/Wave/Disturbance (LO/WV/DB)", + "Missing Data" + ), + opacity = 1, + title = "Track Legend" + ) + + if (nrow(track_data) >= 2) { + for (i in 1:(nrow(track_data) - 1)) { + segment_data <- track_data[i:(i + 1), ] + + map <- map %>% + addPolylines( + data = segment_data, + lng = ~lon, + lat = ~lat, + weight = 2, + color = track_data$line_color[i], + opacity = 1 + ) + } + } + + map <- map %>% + addCircleMarkers( + data = track_data, + lng = ~lon, + lat = ~lat, + radius = 2, + color = ~line_color, + fillOpacity = 1, + popup = ~ paste0( + "DATE", + "
", + datetime, + "
", + "CATEGORY", + "
", + popup_category, + "
", + "WINDSPEED", + "
", + windspeed, + "kt", + "
", + "PRESSURE", + "
", + pressure, + "mb" + ) + ) + + landfall_data <- track_data %>% + filter(record_identifier == "L") + + if (nrow(landfall_data) > 0) { + map <- map %>% + addCircleMarkers( + data = landfall_data, + lng = ~lon, + lat = ~lat, + radius = 5, + weight = 0, + color = ~line_color, + fillColor = ~line_color, + fillOpacity = 1, + popup = ~ paste0( + "LANDFALL", + "
", + "DATE", + "
", + datetime, + "
", + "CATEGORY", + "
", + popup_category, + "
", + "WINDSPEED", + "
", + windspeed, + "kt", + "
", + "PRESSURE", + "
", + pressure, + "mb", + "
", + "RMW", + "
", + rmw, + "nm" + ) + ) %>% + addCircles( + data = landfall_data, + lng = ~lon, + lat = ~lat, + radius = ~rmw_meters, + weight = 2, + color = ~line_color, + fillColor = ~line_color, + fillOpacity = 0.3, + popup = ~ paste0( + "LANDFALL", + "
", + "DATE", + "
", + datetime, + "
", + "CATEGORY", + "
", + popup_category, + "
", + "WINDSPEED", + "
", + windspeed, + "kt", + "
", + "PRESSURE", + "
", + pressure, + "mb", + "
", + "RMW", + "
", + rmw, + "nm" + ) + ) + } + + return(map) + }) + + output$track_data <- renderDT({ + datatable( + storm_track() %>% + select( + formatted_datetime, + storm_status, + lon, + lat, + rmw, + pressure, + windspeed + ), + rownames = F, + colnames = c( + "Date", + "Status", + "Lon", + "Lat", + "RMW", + "Pressure", + "Windspeed" + ), + selection = "none", + options = list( + pageLength = 1000, + order = list(0, 'asc'), + searching = F, + paging = F, + info = F, + lengthChange = F, + server = T + ) + ) + }) + + storm_yearly_normalization <- reactive({ + req( + storm_selection$storm_basin, + storm_selection$storm_year, + storm_selection$storm_name + ) + + result <- get_all_normalized_cost_index(storm_selection) + + return(result) + }) %>% + bindCache( + storm_selection$storm_year, + storm_selection$storm_name, + storm_selection$storm_basin + ) + + output$cost_index_chart <- renderDygraph({ + req( + storm_yearly_normalization(), + input$storm_overview_cost_index_lf_select, + input$storm_overview_cost_index_mmh_mmp, + input$storm_overview_cost_index_scale, + input$storm_overview_cost_index_y_scale + ) + + if (input$storm_overview_cost_index_y_scale == "Log") { + is_y_log <- T + } else { + is_y_log <- F + } + + normalized_data <- storm_yearly_normalization() %>% + rename( + "MMH Index" = mmh_index, + "MMH Loss" = mmh_loss, + "MMP Index" = mmp_index, + "MMP Loss" = mmp_loss + ) + + selected_lf <- input$storm_overview_cost_index_lf_select + selected_normalization <- input$storm_overview_cost_index_mmh_mmp + selected_scale <- input$storm_overview_cost_index_scale + + method_map <- c("MMH", "MMP") + selected_methods <- method_map[method_map %in% selected_normalization] + + if (selected_scale == "Index") { + value_columns <- paste0(selected_methods, " Index") + + y_label <- "Cost Index" + } else if (selected_scale == "Loss") { + value_columns <- paste0(selected_methods, " Loss") + + y_label <- "Normalized Loss" + } + + normalization_index <- normalized_data %>% + filter( + full_lf_id %in% selected_lf + ) %>% + mutate( + normalization_year = as.Date(paste0(normalization_year, "-01-01")) + ) %>% + select( + normalization_year, + full_lf_id, + all_of(value_columns) + ) %>% + pivot_wider( + names_from = full_lf_id, + values_from = all_of(value_columns), + names_glue = "{full_lf_id} {.value}" + ) + + normalization_index_ts <- normalization_index %>% + select(-normalization_year) %>% + xts(order.by = normalization_index$normalization_year) + + dygraph(normalization_index_ts, ylab = y_label) %>% + dyOptions( + colors = paletteer_d( + "ggthemes::Classic_Purple_Gray_12", + ncol(normalization_index - 1) + ), + fillGraph = T, + fillAlpha = .2, + labelsKMB = T, + logscale = is_y_log + ) %>% + dyAxis("x", drawGrid = F) %>% + dyLegend(show = "always", width = 400, hideOnMouseOut = FALSE) %>% + dyRangeSelector() + }) %>% + bindCache( + storm_selection$storm_year, + storm_selection$storm_name, + storm_selection$storm_basin, + input$storm_overview_cost_index_lf_select, + input$storm_overview_cost_index_mmh_mmp, + input$storm_overview_cost_index_scale, + input$storm_overview_cost_index_y_scale + ) + + observe({ + req( + storm_selection$storm_basin, + storm_selection$storm_year, + storm_selection$storm_name + ) + + updateSliderInput( + session, + "growth_trend_map_slider", + min = storm_selection$storm_year, + value = storm_selection$storm_year + ) + }) + + growth_counties <- reactive({ + req( + storm_selection$storm_basin, + storm_selection$storm_year, + storm_selection$storm_name, + input$growth_trend_lf_select + ) + + selected_lf <- input$growth_trend_lf_select + + counties <- get_normalized_metric_growth(storm_selection, selected_lf) + + 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) + }) %>% + bindCache( + storm_selection$storm_year, + storm_selection$storm_name, + storm_selection$storm_basin, + input$growth_trend_lf_select + ) + + output$growth_map <- renderLeaflet({ + req( + growth_counties(), + input$growth_trend_map_slider, + input$growth_map_metric + ) + + counties_data <- growth_counties() + combined_geom <- st_union(counties_data) + growth_bbox <- st_bbox(combined_geom) + + growth_year <- input$growth_trend_map_slider + growth_county_year <- counties_data %>% + filter(year == growth_year) + + map <- leaflet() %>% + addProviderTiles("Stadia.AlidadeSmooth") %>% + fitBounds( + lng1 = growth_bbox[["xmin"]], + lng2 = growth_bbox[["xmax"]], + lat1 = growth_bbox[["ymin"]], + lat2 = growth_bbox[["ymax"]] + ) + + if (input$growth_map_metric == "Population") { + map <- map %>% + addPolygons( + data = growth_county_year, + group = "counties", + fillColor = "red", + color = "red", + fillOpacity = ~population_opacity, + weight = 1, + popup = ~name + ) + } else { + map <- map %>% + addPolygons( + data = growth_county_year, + group = "counties", + fillColor = "blue", + color = "blue", + fillOpacity = ~housing_opacity, + weight = 1, + popup = ~name + ) + } + + return(map) + }) + + observe({ + req( + growth_counties(), + input$growth_trend_map_slider, + input$growth_map_metric + ) + + growth_year <- input$growth_trend_map_slider + + growth_county_year <- growth_counties() %>% + filter( + year == growth_year + ) + + if (input$growth_map_metric == "Population") { + leafletProxy("growth_map", data = growth_county_year) %>% + clearGroup("counties") %>% + addPolygons( + group = "counties", + fillColor = "red", + color = "red", + fillOpacity = ~population_opacity, + weight = 1, + popup = ~name + ) + } else { + leafletProxy("growth_map", data = growth_county_year) %>% + clearGroup("counties") %>% + addPolygons( + group = "counties", + fillColor = "blue", + color = "blue", + fillOpacity = ~housing_opacity, + weight = 1, + popup = ~name + ) + } + }) +} diff --git a/app/ui.R b/app/ui.R new file mode 100644 index 0000000..306053a --- /dev/null +++ b/app/ui.R @@ -0,0 +1,230 @@ +library(bslib) + +ui <- page_navbar( + id = "main_navbar", + fillable = TRUE, + title = "Tropical Cyclone Database", + theme = bs_theme( + bootswatch = "sandstone" + ), + nav_panel( + "Home", + card( + "Welcome to the Tropical Cyclone Database", + 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 professionals, 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 incorporates several methodological innovations over previously used cost normalization formulas: + +

+ ' + ) + ) + ), + nav_panel( + "Storm Selector", + layout_columns( + col_widths = c(8, 4), + card( + DTOutput("storm_coverage_table") + ), + layout_columns( + col_widths = 12, + card( + height = 250, + h4(strong(textOutput("dt_storm_name_year"))), + p("Category X - Landfall: FL"), + div(), + hr(), + layout_columns( + col_widths = c(6, 6), + div(), + div(), + div(), + div() + ), + actionButton("load_storm", "Load Storm") + ), + card( + height = 750, + card_body( + class = "p-0", + leafletOutput("all_storms_map", height = "100%") + ) + ) + ) + ) + ), + nav_panel( + title = "Storm Explorer", + navset_underline( + nav_item(strong(textOutput("selected_storm_name_year"))), + nav_panel( + "Track", + layout_columns( + col_widths = 6, + card( + full_screen = TRUE, + card_body( + class = "p-0", + leafletOutput("track_map", height = "100%") + ) + ), + card( + card_body( + class = "p-0", + DTOutput("track_data", height = "100%") + ) + ) + ) + ), + nav_panel("Meterology"), + nav_panel( + "Cost Normalization", + layout_columns( + col_widths = 6, + card( + "MMH/MMP Normalization", + div( + fluidRow( + style = "height: 100%", + column( + 3, + virtualSelectInput( + "storm_overview_cost_index_lf_select", + "Landfalls", + choices = NULL, + showValueAsTags = T, + multiple = T, + autoSelectFirstOption = T + ), + radioGroupButtons( + "storm_overview_cost_index_scale", + label = "Value", + choices = c("Index", "Loss"), + status = "outline-primary rounded-0", + justified = T + ), + checkboxGroupButtons( + "storm_overview_cost_index_mmh_mmp", + label = "MMH/MMP", + choices = c("MMH", "MMP"), + selected = c("MMH", "MMP"), + status = "outline-primary rounded-0", + justified = T + ), + radioGroupButtons( + "storm_overview_cost_index_y_scale", + label = "Y-Axis Scale", + choices = c("Linear", "Log"), + status = "outline-primary rounded-0", + justified = T + ) + ), + column(9, dygraphOutput("cost_index_chart")) + ) + ) + ), + card(), + card(), + card() + ) + ), + nav_panel( + "Human Factors", + layout_columns( + col_widths = 6, + layout_columns( + col_widths = 12, + + card( + sliderInput( + "growth_trend_map_slider", + label = NULL, + min = 1926, + max = 2024, + step = 1, + animate = list( + interval = 250, + loop = F + ), + value = 1926, + sep = "", + width = "100%", + ticks = F + ) + ), + card( + leafletOutput("growth_map", height = "100%") + ), + card( + fluidRow( + column( + 6, + selectInput( + "growth_trend_lf_select", + "Landfall Select", + choices = NULL + ) + ), + column( + 6, + radioGroupButtons( + "growth_map_metric", + label = "Display Metric", + choices = c("Population", "Housing"), + selected = "Population", + status = "outline-primary rounded-0", + justified = T + ) + ) + ) + ) + ) + ) + ), + nav_panel("Perils"), + nav_panel("Fatality Map"), + nav_spacer(), + nav_menu( + title = "Export", + nav_item("Storm report") + ) + ) + ), + nav_menu( + "Data", + nav_item("What We Track"), + nav_item("Sources"), + nav_item("Export") + ), + nav_menu( + "About", + nav_item("Contact Us"), + nav_item("Our Studies"), + nav_item("MMH/MMP Methodology") + ) +)