dylan/hurricane_normalization_app
1
0
Fork 0
mirror of https://github.com/dylanbenzi/hurricane_normalization_app.git synced 2026-07-30 05:08:57 +00:00
Code Issues Packages Projects Releases Wiki Activity

modify user flow prior to major redesign

Browse Source
This commit is contained in:
dylan
2026-04-04 14:04:41 -04:00
parent 1970983caf
commit 81a67982b1
2 changed files with 233 additions and 626 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/dashboard.Rmd
+225 -626
View File
@@ -1,5 +1,5 @@
---
title: "Hurricane Normalization App"
title: "Tropical Cyclone Database"
runtime: shiny
output:
flexdashboard::flex_dashboard:
@@ -214,11 +214,6 @@ output$normalized_storms_table <- renderDT({
DTOutput("normalized_storms_table")
```
Storm Overview {data-navmenu="Storm Details"}
====================================
```{r}
# Storm Overview - Setup
@@ -243,9 +238,115 @@ observe({
})
```
Col {data-width=500}
------------------------------------
Storm Selector
====================================
Col {data-width=600}
----------------------------------------------
### {.no-padding}
```{r}
# Tracking - Storms Table
observeEvent(input$normalized_storms_full_table_rows_selected, {
showNotification(latest_normalized_losses[input$normalized_storms_full_table_rows_selected, ]$storm_name, type = "message")
})
output$storm_coverage_table <- renderDT({
raw <- get_storm_data_coverage() %>% select(-storm_basin)
col_names <- names(raw)
df <- raw %>%
mutate(
data = trimws(paste(
ifelse(as.logical(.data[[col_names[3]]]), '<span class="badge badge-info">Fatality</span>', ""),
ifelse(as.logical(.data[[col_names[4]]]), '<span class="badge badge-success">Cost</span>', "")
))
) %>%
select(1, 2, data)
datatable(
df,
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 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 = "single",
options = list(
pageLength = 20,
order = list(0, 'asc'),
server = T
)
) %>%
formatCurrency(c("mmh", "mmp"), "$", digits = 0)
})
DTOutput("storm_coverage_table")
```
Col {data-width=400}
----------------------------------------------
### {data-height=200 .no-padding}
```{r}
```
### {data-height=800 .no-padding}
```{r}
# Tracking - Storms Map
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
)
})
leafletOutput("all_storms_map", height = "100%")
```
Storm Track {data-navmenu="Meteorology"}
====================================
Col {data-width=500}
----------------------------------------------
### Track Map {.no-padding}
```{r}
# Overview - Track Map
@@ -548,10 +649,59 @@ output$track_map <- renderLeaflet({
leafletOutput("track_map", height = "100%")
```
Col {data-width=500 .tabset}
------------------------------------
### Normalization and Landfalls {}
Col {data-width=500}
----------------------------------------------
### Track Data {.no-padding}
```{r}
# Overview - Track Data
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
)
)
})
DTOutput("track_data")
```
Meteorology {data-navmenu="Meteorology"}
====================================
Normalizations {data-navmenu="Costs"}
====================================
Col {data-width=500}
----------------------------------------------
### MMH/MMP Normalization {data-height=500}
```{r}
# Overview - Normalization and Landfalls
@@ -651,129 +801,58 @@ output$cost_index_chart <- renderDygraph({
input$storm_overview_cost_index_y_scale
)
hurdat_landfalls <- reactive({
req(storm_selection$storm_basin, storm_selection$storm_year, storm_selection$storm_name)
get_hurdat_landfalls(storm_selection)
}) %>%
bindCache(storm_selection$storm_year, storm_selection$storm_name, storm_selection$storm_basin)
output$landfalls_table <- renderDT({
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")
})
fillCol(
flex = c(0.5, 0.5),
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
)
div(
fluidRow(
style = "height: 100%",
column(
3,
virtualSelectInput(
"storm_overview_cost_index_lf_select",
"Landfalls",
choices = NULL,
showValueAsTags = T,
multiple = T,
autoSelectFirstOption = T
),
column(9, dygraphOutput("cost_index_chart"))
)
),
div(
DTOutput("landfalls_table")
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"))
)
)
```
### Track Data {.no-padding}
```{r}
# Overview - Track Data
### Other1 {data-height=500}
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
)
)
})
Col {data-width=500}
----------------------------------------------
### Other2 {data-height=500}
DTOutput("track_data")
```
### Other3 {data-height=500}
Growth Trends {data-navmenu="Storm Details"}
================================
Growth Factors {data-navmenu="Costs"}
====================================
Column {data-width=550}
-------------------------------
@@ -1068,446 +1147,29 @@ output$county_growth_dt <- renderDT({
DTOutput("county_growth_dt")
```
Normalization Calculator {data-navmenu="Compute"}
===
```{r}
# Calculator - Setup Code
calculator_storm_selection <- reactiveValues(
storm_year = NULL,
storm_name = NULL,
storm_basin = NULL,
full_lf_id = NULL,
)
observeEvent(input$impact_populate_storm, {
calculator_storm_selection$storm_basin = input$impact_storm_basin
calculator_storm_selection$storm_year = input$impact_storm_year
calculator_storm_selection$storm_name = input$impact_storm_name
calculator_storm_selection$full_lf_id = input$impact_storm_full_lf_id
calculator_storm_details <- get_lf_type_factors(calculator_storm_selection)
updateTextInput(
session,
"impact_lat",
value = calculator_storm_details$lat
)
updateTextInput(
session,
"impact_lon",
value = calculator_storm_details$lon
)
updateTextInput(
session,
"impact_rmw",
value = calculator_storm_details$rmw
)
updateSliderInput(
session,
"impact_rmw_slider",
value = calculator_storm_details$rmw
)
updateTextInput(
session,
"impact_base_year",
value = calculator_storm_details$storm_year
)
updateTextInput(
session,
"impact_ref_year",
value = "2024"
)
updateTextInput(
session,
"impact_base_damage",
value = calculator_storm_details$mwr
)
})
```
Column {data-width=700}
---
### Impact Map {.no-padding}
```{r}
# Calculator - Impact Map
output$impact_analysis_map <- renderLeaflet({
leaflet() %>%
addProviderTiles("Stadia.AlidadeSmooth") #%>%
#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%")
```
Column {data-width=300}
---
### {}
```{r}
# Calculator - Input
# TODO: add data population and compute
observeEvent(input$impact_storm_year, {
stormsByChosenYear <- all_lf_type_storms[all_lf_type_storms$storm_year == input$impact_storm_year, ]
stormsByYear <- all_lf_type_storms %>% filter(storm_year == input$impact_storm_year)
updateSelectInput(
session,
"impact_storm_name",
choices = stormsByYear$storm_name,
selected = NULL
)
})
observeEvent(input$impact_storm_name, {
uniqueLfs <- all_lf_type_storms %>%
filter(
storm_basin == input$impact_storm_basin,
storm_year == input$impact_storm_year,
storm_name == input$impact_storm_name
)
updateSelectInput(
session,
"impact_storm_full_lf_id",
choices = uniqueLfs$full_lf_id
)
})
observe({
req(
input$impact_lat,
input$impact_lon
)
new_lat <- as.numeric(input$impact_lat)
new_lon <- as.numeric(input$impact_lon)
if(new_lat >= -90 & new_lat <= 90 & new_lon >= -180 & new_lon <= 180) {
rmw_meters <- input$impact_rmw_slider * 1852
leafletProxy("impact_analysis_map") %>%
setView(lat = new_lat, lng = new_lon, zoom = 9) %>%
clearShapes() %>%
clearMarkers() %>%
addCircleMarkers(
lng = new_lon,
lat = new_lat,
radius = 2,
weight = 0,
color = "blue",
fillColor = "blue",
fillOpacity = 0.5
) %>%
addCircles(
lng = new_lon,
lat = new_lat,
radius = rmw_meters,
weight = 1,
color = "blue",
fillColor = "blue",
fillOpacity = 0.05
)
}
})
observe({
req(input$impact_rmw)
if(as.numeric(input$impact_rmw) > 0) {
updateSliderInput(
session,
"impact_rmw_slider",
value = input$impact_rmw
)
}
})
observe({
req(input$impact_rmw_slider)
updateTextInput(
session,
"impact_rmw",
value = input$impact_rmw_slider
)
})
observe({
req(input$impact_rmw, input$impact_rmw_slider)
rmw_meters <- input$impact_rmw_slider * 1852
new_lon = input$impact_storm_lon
new_lat = input$impact_storm_lat
req(new_lon, new_lat)
if(new_lat >= -90 & new_lat <= 90 & new_lon >= -180 & new_lon <= 180) {
leafletProxy("impact_analysis_map") %>%
clearShapes() %>%
clearMarkers() %>%
addCircleMarkers(
lng = new_lon,
lat = new_lat,
radius = 2,
weight = 0,
color = "blue",
fillColor = "blue",
fillOpacity = 0.5
) %>%
addCircles(
lng = new_lon,
lat = new_lat,
radius = rmw_meters,
weight = 1,
color = "blue",
fillColor = "blue",
fillOpacity = 0.05
)
}
})
div(
h6("Storm Selector"),
fluidRow(
column(
6,
selectInput(
"impact_storm_basin",
label = NULL,
choices = "AL",
width = "100%"
),
),
column(
6,
selectInput(
"impact_storm_year",
label = NULL,
choices = all_lf_type_storms$storm_year,
width = "100%"
),
)
),
fluidRow(
column(
6,
selectInput(
"impact_storm_name",
label = NULL,
choices = NULL,
width = "100%"
),
),
column(
6,
selectInput(
"impact_storm_full_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%"
)
)
),
radioGroupButtons(
"impact_rmw_multiplier",
label = "RMW Multiplier",
choices = c("1x", "2x", "3x"),
selected = "2x",
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"
)
)
```
Download Report {data-navmenu="Compute"}
===
Column {data-width=400}
---
### Report Options {}
```{r}
downloadButton("report", "Generate Report")
output$report <- downloadHandler(
filename = function() {
paste0(
storm_selection$hurdatid,
"_",
storm_selection$storm_name,
"_",
storm_selection$storm_year,
".pdf"
)
},
content = function(file) {
params <- list(
storm_basin = storm_selection$storm_basin,
storm_year = storm_selection$storm_year,
storm_name = storm_selection$storm_name,
hurdat_id = storm_selection$hurdatid
)
id <- showNotification(
"Rendering report...",
duration = NULL,
closeButton = FALSE
)
on.exit(removeNotification(id), add = TRUE)
temp_pdf <- file.path(APP_DIR, "storm_report.pdf")
quarto::quarto_render(
input = file.path(APP_DIR, "storm_report.qmd"),
execute_params = params,
output_format = "pdf"
)
file.copy(temp_pdf, file)
}
)
```
Column {data-width=600}
---
Fatality Map {data-navmenu="Fatalities"}
====================================
### {.no-padding}
```{r}
output$fatality_map <- renderLeaflet({
leaflet() %>%
addProviderTiles("Stadia.AlidadeSmooth")
})
leafletOutput("fatality_map", height = "100%")
```
Data Export {data-navmenu="Compute"}
===
Peril Breakdown {data-navmenu="Fatalities"}
====================================
What We Track {data-navmenu="Data"}
====================================
Export {data-navmenu="Data"}
====================================
```{r}
# Export - Mock Data
@@ -1792,71 +1454,8 @@ div(
)
```
Tracked Storms {data-navmenu="All Storms"}
===
Our Methodology {data-navmenu="About"}
====================================
Column {data-width=650}
---
### {}
```{r}
# Tracking - Storms Table
#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'),
server = T
)
) %>%
formatCurrency(c("mmh", "mmp"), "$", digits = 0)
})
DTOutput("normalized_storms_full_table")
```
Column {data-width=350}
---
### {.no-padding}
```{r}
# Tracking - Storms Map
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
)
})
leafletOutput("all_storms_map", height = "100%")
```
About
===
Contact {data-navmenu="About"}
====================================
app/queries.R
+8
View File
@@ -100,6 +100,14 @@ get_latest_normalization_year <- function() {
return(result)
}
get_storm_data_coverage <- function() {
query <- get_tbl("storm_data_coverage")
result <- query %>% collect()
return(result)
}
get_yearly_usa_pop_hu <- function(yr) {
query <- get_tbl("usa_pop_hu", "metrics") %>%
filter(year == yr)