mirror of
https://github.com/dylanbenzi/hurricane_normalization_app.git
synced 2026-07-30 05:08:57 +00:00
1214 lines
32 KiB
Plaintext
1214 lines
32 KiB
Plaintext
---
|
|
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()
|
|
|
|
all_storm_tracks <- get_all_hurdat_tracks()
|
|
|
|
all_conus_landfalls <- get_all_conus_landfalls()
|
|
|
|
all_storm_landfalls <- all_storm_tracks %>%
|
|
filter(record_identifier == "L")
|
|
|
|
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(
|
|
'
|
|
<h4>Welcome to the Hurricane Cost Normalization Web App</h4>
|
|
|
|
<p>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.</p>
|
|
|
|
<h6>Our Data</h6>
|
|
|
|
<p>The core datasets used in this app are based on research by Muller et al. (2025) published in <i>Bulletin of the American Meteorlogical Society</i>. This study updates and refines hurricane damage normalization methodologies to provide a more accurate picture of how historical hurricanes would impact today\'s society.</p>
|
|
|
|
<ul>
|
|
<li><b>MMP24:</b> The Muller-Mooney Population (2024) normalization with RMW weighting on affected population.</li>
|
|
|
|
<li><b>MMH24:</b> The Muller-Mooney Housing (2024) normalization with RMW weighting on affected housing units.</li>
|
|
</ul>
|
|
|
|
<h6>Methodology Innovations</h6>
|
|
|
|
<p>Our platform incorporates several methodological innovations over previously used cost normalization formulas:
|
|
|
|
<ul>
|
|
<li><b>Radius of Maximum Wind (RMW) Data:</b> Using landfalling RMWs to identify impacted coastal counties.</li>
|
|
|
|
<li><b>RMW Affected Area Weighting:</b> Determining affected population and housing unit figures based on RMW.</li>
|
|
|
|
<li><b>Expanded Storm Coverage:</b> Including over 200 storms analyzed with interactive data.</li>
|
|
|
|
<li><b>Up-to-date Data:</b> Using the latest population, housing unit, and economic data through 2024.</li>
|
|
</ul>
|
|
'
|
|
)
|
|
```
|
|
|
|
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(6,
|
|
div(
|
|
selectInput("stormBasin", "Basin", choices = "AL", width = "100%"),
|
|
selectInput("stormYear", "Year", choices = loss_storms$storm_year, width = "100%"),
|
|
selectInput("stormName", "Name", choices = NULL, width = "100%"),
|
|
actionButton("selectStorm", "Submit", class = "btn-primary rounded", width = "100%")
|
|
)
|
|
),
|
|
column(6,
|
|
HTML('
|
|
<h5>Select a Storm</h5>
|
|
|
|
We are currently tracking 201 CONUS storms with over $3.6T in losses spanning from 1900 to 2024
|
|
|
|
<hr>
|
|
|
|
Use the storm selector to the left or the table below to select a storm to analyze
|
|
')
|
|
)
|
|
)
|
|
|
|
|
|
|
|
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 = 1926,
|
|
storm_name = "GREAT MIAMI",
|
|
)
|
|
|
|
test_counties <- reactive({
|
|
req(storm_selection$is_selected)
|
|
|
|
counties <- get_normalized_metric_growth(test_storm, "LF1")
|
|
|
|
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 = -81.3, lat = 25.6, zoom = 7)
|
|
})
|
|
|
|
output$housing_growth_map <- renderLeaflet({
|
|
leaflet() %>%
|
|
addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18)) %>% setView(lng = -81.3, lat = 25.6, zoom = 7)
|
|
})
|
|
|
|
observe({
|
|
req(test_counties)
|
|
|
|
leafletProxy("pop_growth_map", data = test_counties()) %>%
|
|
clearShapes() %>%
|
|
addPolygons(
|
|
fillColor = "red",
|
|
color = "red",
|
|
fillOpacity = ~population_opacity,
|
|
weight = 2
|
|
)
|
|
|
|
leafletProxy("housing_growth_map", data = test_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 = 1926, max = 2024, step = 1, animate = T, value = 1926, sep = "", width = "100%", ticks = F)
|
|
),
|
|
leafletOutput("pop_growth_map", height = "100%"),
|
|
leafletOutput("housing_growth_map", height = "100%")
|
|
)
|
|
```
|
|
|
|
### 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")
|
|
dygraphOutput("test_dy")
|
|
)
|
|
|
|
output$test_dy <- renderDygraph({
|
|
test_ts <- test_query()
|
|
|
|
dygraph(test_ts, main = "Normalized Aggregate Growth") %>%
|
|
dySeries("population_index", label = "Population") %>%
|
|
dySeries("housing_index", label = "Housing Units") %>%
|
|
dyRangeSelector()
|
|
})
|
|
|
|
#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}
|
|
great_miami_data <- data.frame(
|
|
county_name = c("Broward County", "Collier County", "Miami-Dade County", "Monroe County"),
|
|
housing_1926 = c(3.7, 0, 25, 3.5),
|
|
housing_2024 = c(869, 250, 1100, 55),
|
|
population_1926 = c(14, 0, 103, 16),
|
|
population_2024 = c(2100, 428, 2990, 81)
|
|
)
|
|
|
|
output$great_miami_dt <- renderDT({
|
|
datatable(
|
|
great_miami_data,
|
|
rownames = F,
|
|
options = list(
|
|
order = list(0, 'asc'),
|
|
paging = F,
|
|
searching = F,
|
|
info = F,
|
|
lengthChange = F,
|
|
server = T
|
|
),
|
|
colnames = c(
|
|
"County", "1926 HU", "2024 HU", "1926 POP", "2024 POP"
|
|
),
|
|
) %>%
|
|
# Format housing columns with blue background
|
|
formatStyle(
|
|
columns = c("housing_1926", "housing_2024"),
|
|
backgroundColor = "rgba(0, 0, 255, 0.2)"
|
|
) %>%
|
|
# Format population columns with red background
|
|
formatStyle(
|
|
columns = c("population_1926", "population_2024"),
|
|
backgroundColor = "rgba(255, 0, 0, 0.2)"
|
|
) %>%
|
|
formatCurrency(
|
|
columns = c("housing_1926", "housing_2024", "population_1926", "population_2024"),
|
|
currency = "k",
|
|
digits = 0,
|
|
before = F
|
|
)
|
|
})
|
|
|
|
DTOutput("great_miami_dt")
|
|
|
|
```
|
|
|
|
Storm Fatalities {data-navmenu="Storm Details"}
|
|
===
|
|
|
|
|
|
|
|
|
|
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 = -80.3, lat = 25.6, zoom = 10) %>%
|
|
addCircles(
|
|
lng = -80.3,
|
|
lat = 25.6,
|
|
radius = 37040,
|
|
color = "blue",
|
|
weight = 2,
|
|
opacity = 0.3
|
|
) %>%
|
|
addCircleMarkers(
|
|
lng = -80.3,
|
|
lat = 25.6,
|
|
radius = 5,
|
|
weight = 0,
|
|
color = "blue",
|
|
fillColor = "blue",
|
|
fillOpacity = 0.6
|
|
)
|
|
})
|
|
|
|
leafletOutput("impact_analysis_map", height = "100%")
|
|
```
|
|
|
|
### Impact Data {.no-padding}
|
|
```{r}
|
|
|
|
```
|
|
|
|
Column {data-width=300}
|
|
---
|
|
|
|
### {}
|
|
```{r}
|
|
div(
|
|
h6("Storm Selector"),
|
|
selectInput("impact_storm_basin", label = NULL, choices = "AL", width = "100%"),
|
|
selectInput("impact_storm_year", label = NULL, choices = 1926, width = "100%"),
|
|
selectInput("impact_storm_name", label = NULL, choices = "GREAT MIAMI", 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")
|
|
)
|
|
|
|
hr()
|
|
|
|
div(
|
|
fluidRow(
|
|
column(6,
|
|
textInput("impact_lat", placeholder = "Lat", value = "25.6", label = "Latitude", width = "100%")
|
|
),
|
|
column(6,
|
|
textInput("impact_lon", placeholder = "Lon", value = "-80.3", label = "Longitude", width = "100%")
|
|
)
|
|
),
|
|
|
|
fluidRow(
|
|
column(4,
|
|
textInput("impact_rmw", placeholder = "RMW", value = "20", label = "RMW (NM)", width = "100%")
|
|
),
|
|
column(8,
|
|
sliderInput("impact_rmw_slider", label = NULL, min = 1, max = 150, value = 20, 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 = "RMW Multiplier", choices = c("1x", "2x", "3x"), status = "outline-primary rounded-0", justified = T),
|
|
|
|
fluidRow(
|
|
column(6,
|
|
textInput("impact_base_year", placeholder = "Impact Year", value = "1926", label = "Base Year", width = "100%")
|
|
),
|
|
column(6,
|
|
textInput("impact_ref_year", placeholder = "Reference Year", value = "2024", label = "Ref Year", width = "100%")
|
|
)
|
|
),
|
|
|
|
textInput("impact_base_damage", placeholder = "Storm Base Damage", label = "Base Damage", value = "76,000,000", width = "100%"),
|
|
|
|
actionButton("impact_calculate", label = "Calculate", width = "100%", class = "btn-primary rounded")
|
|
)
|
|
|
|
```
|
|
|
|
|
|
Data Export {data-navmenu="Compute"}
|
|
===
|
|
|
|
```{r}
|
|
# Dataset information
|
|
datasets_info <- data.frame(
|
|
id = c("hurricane_costs", "population_housing", "fatalities", "storm_tracks", "affected_areas", "economic_data"),
|
|
name = c("Hurricane Cost Normalization", "Population & Housing", "Storm Fatalities",
|
|
"Hurricane Best Track", "Affected Areas", "Yearly Economics"),
|
|
description = c(
|
|
"Normalized economic damage estimates for US landfalling hurricanes 1900-2023 using updated RMW methodology",
|
|
"County-level population and housing unit data used for normalization calculations",
|
|
"Direct and indirect fatalities from hurricane impacts by location and storm",
|
|
"Best track data including storm positions, intensities, and wind radii from HURDAT2",
|
|
"Geographic areas impacted by hurricane landfalls with RMW coverage percentages",
|
|
"Yearly economic data used in normalization calculations"
|
|
),
|
|
size = c("~200 storms", "3,000+ counties", "150+ storms", "2,000+ storms", "5,000+ records", "100+ years"),
|
|
last_updated = c("2024-12-01", "2024-11-15", "2024-10-30", "2024-12-15", "2024-11-30", "2025-01-01"),
|
|
tables = c("econ.normalized_landfalls, econ.storm_base_loss",
|
|
"metrics.pop_and_housing",
|
|
"fatal.storm_total_fatalities, fatal.storm_fatalities_type",
|
|
"hurdat.best_track, hurdat.hurdat_storms",
|
|
"gis.affected_area_landfalls", "econ.usa_yearly"),
|
|
stringsAsFactors = FALSE
|
|
)
|
|
|
|
# Reactive values to store selected datasets
|
|
values <- reactiveValues(selected_datasets = character(0))
|
|
```
|
|
|
|
Column {data-width=600}
|
|
-------------------------------------
|
|
|
|
### Available Datasets
|
|
|
|
```{r}
|
|
# Function to create dataset cards
|
|
create_dataset_card <- function(dataset_row) {
|
|
card_id <- paste0("card_", dataset_row$id)
|
|
|
|
div(
|
|
class = "dataset-card",
|
|
id = card_id,
|
|
style = "border: 2px solid #e3e3e3; border-radius: 8px; padding: 15px; margin: 10px 0; cursor: pointer; transition: all 0.3s ease;",
|
|
|
|
div(
|
|
style = "display: flex; justify-content: space-between; align-items: flex-start;",
|
|
|
|
# Left content
|
|
div(
|
|
style = "flex: 1;",
|
|
tags$b(dataset_row$name, style = "font-size: 16px; margin: 0 0 8px 0; color: #2c3e50; display: block;"),
|
|
p(dataset_row$description, style = "margin: 0 0 10px 0; color: #5a6c7d; font-size: 14px; line-height: 1.4;"),
|
|
|
|
# Metadata row
|
|
div(
|
|
style = "display: flex; gap: 20px; flex-wrap: wrap;",
|
|
span(icon("database"), strong("Size: "), dataset_row$size, style = "color: #7f8c8d; font-size: 12px;"),
|
|
span(icon("calendar"), strong("Updated: "), dataset_row$last_updated, style = "color: #7f8c8d; font-size: 12px;"),
|
|
span(icon("table"), strong("Tables: "), dataset_row$tables, style = "color: #7f8c8d; font-size: 11px;")
|
|
)
|
|
),
|
|
|
|
# Selection checkbox
|
|
div(
|
|
style = "margin-left: 15px;",
|
|
checkboxInput(
|
|
inputId = paste0("select_", dataset_row$id),
|
|
label = NULL,
|
|
value = FALSE,
|
|
width = "20px"
|
|
)
|
|
)
|
|
)
|
|
)
|
|
}
|
|
|
|
# Add CSS for card interactions
|
|
#tags$head(tags$style(HTML("
|
|
# .dataset-card:hover {
|
|
# border-color: #3498db !important;
|
|
# box-shadow: 0 4px 8px rgba(52, 152, 219, 0.3) !important;
|
|
# }
|
|
# .dataset-card.selected {
|
|
# border-color: #27ae60 !important;
|
|
# background-color: #f8fff9 !important;
|
|
# box-shadow: 0 4px 8px rgba(39, 174, 96, 0.3) !important;
|
|
# }
|
|
# .export-box {
|
|
# border: 2px solid #34495e;
|
|
# border-radius: 8px;
|
|
# padding: 20px;
|
|
# background-color: #f8f9fa;
|
|
# margin-bottom: 20px;
|
|
# }
|
|
# .selected-item {
|
|
# background-color: #e8f5e8;
|
|
# border: 1px solid #27ae60;
|
|
# border-radius: 4px;
|
|
# padding: 8px 12px;
|
|
# margin: 4px;
|
|
# display: inline-block;
|
|
# }
|
|
# .info-box {
|
|
# border: 2px solid #95a5a6;
|
|
# border-radius: 8px;
|
|
# padding: 20px;
|
|
# background-color: #ecf0f1;
|
|
# }
|
|
#")))
|
|
|
|
# Update selected datasets based on checkboxes
|
|
observe({
|
|
selected <- character(0)
|
|
for(i in 1:nrow(datasets_info)) {
|
|
dataset_id <- datasets_info[i, "id"]
|
|
if(isTruthy(input[[paste0("select_", dataset_id)]])) {
|
|
selected <- c(selected, dataset_id)
|
|
}
|
|
}
|
|
values$selected_datasets <- selected
|
|
})
|
|
|
|
# Add JavaScript for card click interaction
|
|
tags$script(HTML("
|
|
$(document).on('click', '.dataset-card', function() {
|
|
var checkbox = $(this).find('input[type=\"checkbox\"]');
|
|
checkbox.prop('checked', !checkbox.prop('checked')).trigger('change');
|
|
|
|
if(checkbox.prop('checked')) {
|
|
$(this).addClass('selected');
|
|
} else {
|
|
$(this).removeClass('selected');
|
|
}
|
|
});
|
|
"))
|
|
|
|
# Instructions
|
|
div(
|
|
style = "margin-bottom: 20px; padding: 15px; background-color: #f0f8ff; border-radius: 0; border-left: 4px solid #3498db;",
|
|
p(strong("Instructions:"), "Select datasets from the cards below by clicking on them. Your selected datasets will appear in the export panel on the right.",
|
|
style = "margin: 0; color: #2c3e50;")
|
|
)
|
|
|
|
# Render dataset cards
|
|
output$dataset_cards <- renderUI({
|
|
cards <- lapply(1:nrow(datasets_info), function(i) {
|
|
create_dataset_card(datasets_info[i, ])
|
|
})
|
|
do.call(tagList, cards)
|
|
})
|
|
|
|
uiOutput("dataset_cards")
|
|
```
|
|
|
|
Column {data-width=400}
|
|
-------------------------------------
|
|
|
|
### Data Export {data-height=600}
|
|
|
|
```{r}
|
|
div(
|
|
class = "export-box",
|
|
|
|
tags$b("Export Selected Data", style = "font-size: 18px; margin-top: 0; color: #2c3e50; display: block; margin-bottom: 15px;"),
|
|
|
|
# Selected datasets display
|
|
tags$b("Selected Datasets:", style = "font-size: 14px; margin-bottom: 10px; color: #34495e; display: block;"),
|
|
div(
|
|
id = "selected-datasets-display",
|
|
style = "min-height: 60px; margin-bottom: 20px; padding: 10px; background-color: white; border-radius: 4px; border: 1px solid #ddd;",
|
|
uiOutput("selected_datasets_display")
|
|
),
|
|
|
|
# Format selection
|
|
tags$b("Export Format:", style = "font-size: 14px; margin-bottom: 10px; color: #34495e; display: block;"),
|
|
radioButtons(
|
|
"export_format",
|
|
label = NULL,
|
|
choices = list(
|
|
"CSV (Comma Separated)" = "csv",
|
|
"JSON" = "json"
|
|
),
|
|
selected = "csv",
|
|
inline = FALSE
|
|
),
|
|
|
|
# Export options
|
|
checkboxInput(
|
|
"include_documentation",
|
|
"Include documentation",
|
|
value = TRUE
|
|
),
|
|
|
|
# Export button
|
|
br(),
|
|
downloadButton(
|
|
"download_data",
|
|
"Export Selected Data",
|
|
class = "btn-primary",
|
|
style = ""
|
|
)
|
|
)
|
|
|
|
# Display selected datasets
|
|
output$selected_datasets_display <- renderUI({
|
|
if(length(values$selected_datasets) == 0) {
|
|
p("No datasets selected", style = "color: #95a5a6; font-style: italic; margin: 20px 0;")
|
|
} else {
|
|
selected_names <- datasets_info$name[datasets_info$id %in% values$selected_datasets]
|
|
lapply(selected_names, function(name) {
|
|
span(
|
|
class = "selected-item",
|
|
icon("check-circle"), " ", name
|
|
)
|
|
})
|
|
}
|
|
})
|
|
```
|
|
|
|
### Contact {data-height=400}
|
|
|
|
```{r}
|
|
div(
|
|
class = "info-box",
|
|
tags$b("Need More Data?", style = "font-size: 16px; margin-top: 0; color: #2c3e50; display: block; margin-bottom: 10px;"),
|
|
p("Additional datasets, custom queries, and research collaborations are available through our team.",
|
|
style = "margin-bottom: 15px; color: #5a6c7d; font-size: 14px;"),
|
|
|
|
p(icon("envelope"), strong(" Email:"), " [CONTACT US EMAIL]", style = "margin: 5px 0; color: #34495e; font-size: 14px;")
|
|
)
|
|
```
|
|
|
|
Tracked Storms {data-navmenu="All Storms"}
|
|
===
|
|
|
|
Column {data-width=650}
|
|
---
|
|
|
|
### {}
|
|
```{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")
|
|
|
|
|
|
```
|
|
|
|
Column {data-width=350}
|
|
---
|
|
|
|
### {.no-padding}
|
|
```{r}
|
|
output$all_storms_map <- renderLeaflet({
|
|
leaflet() %>%
|
|
addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18)) %>%
|
|
# %>% setView(lng = -89.8, lat = 29.6, zoom = 8)
|
|
#addPolylines(
|
|
#data = all_storm_tracks,
|
|
#lng = ~lon,
|
|
#lat = ~lat,
|
|
#weight = .5,
|
|
#color = "blue"
|
|
#) %>%
|
|
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
|
|
)
|
|
})
|
|
|
|
leafletOutput("all_storms_map", height = "100%")
|
|
```
|
|
|
|
Fatalities {data-navmenu="All Storms"}
|
|
===
|
|
|
|
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}
|
|
```
|
|
|
|
About
|
|
===
|