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