add better markers and path to storm track map

This commit is contained in:
2025-06-05 22:21:51 -04:00
parent 858868c828
commit a0445a3361
+73 -38
View File
@@ -163,13 +163,7 @@ katrinaLfTwoCountyMetrics <- metrics.pop_and_housing %>%
###### REACTIVE VALUES ###### REACTIVE VALUES
storm_selection <- reactiveValues(
storm_year = NULL,
storm_name = NULL,
storm_basin = NULL,
lf_id = NULL,
is_selected = FALSE
)
###### ######
@@ -209,7 +203,7 @@ loss_storms <- econ.storm_base_loss %>%
mutate(hurdatId = paste0(storm_basin, storm_number, storm_year)), mutate(hurdatId = paste0(storm_basin, storm_number, storm_year)),
by = c("storm_basin", "storm_year", "storm_name")) %>% by = c("storm_basin", "storm_year", "storm_name")) %>%
select( select(
hurdatId, storm_name, storm_year hurdatId, storm_basin, storm_name, storm_year
) %>% ) %>%
collect() collect()
@@ -262,6 +256,15 @@ normalized_losses_2024 <- econ.normalized_landfalls %>%
) %>% ) %>%
filter(!is.na(mmh) & !is.na(mmp)) %>% filter(!is.na(mmh) & !is.na(mmp)) %>%
collect() collect()
storm_selection <- reactiveValues(
storm_year = NULL,
storm_name = NULL,
storm_basin = NULL,
lf_id = NULL,
is_selected = FALSE,
is_table_selection = FALSE,
)
``` ```
```{r} ```{r}
@@ -397,7 +400,7 @@ Col {data-width=500}
```{r} ```{r}
fluidRow( fluidRow(
column(6, column(6,
h5("Select Storm Name and Year"), selectInput("stormBasin", "Select Basin", choices = "AL"),
selectInput("stormYear", "Select Year", choices = loss_storms$storm_year), selectInput("stormYear", "Select Year", choices = loss_storms$storm_year),
selectInput("stormName", "Select Storm", choices = NULL), selectInput("stormName", "Select Storm", choices = NULL),
actionButton("selectStorm", "Submit", class = "btn-primary") actionButton("selectStorm", "Submit", class = "btn-primary")
@@ -409,47 +412,36 @@ fluidRow(
) )
) )
output$storm_selector_table <- renderDT({
datatable(
loss_storms,
rownames = F,
options = list(
pageLength = 1000,
order = list(2, 'desc'),
searching = F,
paging = F,
info = F,
lengthChange = F,
server = T
)
)
})
observeEvent(input$stormYear, { observeEvent(input$stormYear, {
stormsByChosenYear <- loss_storms[loss_storms$storm_year == input$stormYear, ] stormsByChosenYear <- loss_storms[loss_storms$storm_year == input$stormYear, ]
stormsByYear <- loss_storms %>% filter(storm_year == input$stormYear)
updateSelectInput(session, "stormName", updateSelectInput(session, "stormName",
choices = stormsByChosenYear$storm_name, choices = stormsByYear$storm_name,
selected = NULL) selected = NULL
)
}) })
observeEvent(input$selectStorm, { observeEvent(input$selectStorm, {
storm_selection$storm_basin <- input$stormBasin
storm_selection$storm_year <- input$stormYear storm_selection$storm_year <- input$stormYear
storm_selection$storm_name <- input$stormName storm_selection$storm_name <- input$stormName
storm_selection$storm_basin <- "AL"
storm_selection$is_selected <- TRUE storm_selection$is_selected <- TRUE
showNotification("Storm selection updated!", type = "message") showNotification("Storm selection updated!", type = "message")
}) })
``` ```
### All Storms {data-height=500 .no-padding} ### All Storms {data-height=500 .no-padding}
```{r} ```{r}
output$allStorms <- renderDT({ output$normalized_storms_table <- renderDT({
datatable( datatable(
normalized_losses_2024 %>% select(Storm = storm_name, Year = storm_year, MMH24 = mmh, MMP24 = mmp), normalized_losses_2024 %>% select(Storm = storm_name, Year = storm_year, MMH24 = mmh, MMP24 = mmp),
rownames = F, rownames = F,
selection = "single",
options = list( options = list(
pageLength = 1000, pageLength = 1000,
order = list(2, 'desc'), order = list(2, 'desc'),
@@ -463,7 +455,7 @@ output$allStorms <- renderDT({
formatCurrency(c("MMH24", "MMP24"), "$", digits = 0) formatCurrency(c("MMH24", "MMP24"), "$", digits = 0)
}) })
DTOutput("allStorms") DTOutput("normalized_storms_table")
``` ```
@@ -666,8 +658,6 @@ Col {data-width=500}
### Fatalities {data-height=200} ### Fatalities {data-height=200}
```{r} ```{r}
# TODO: fatalities dashboard
fluidRow( fluidRow(
column(6, column(6,
HTML(' HTML('
@@ -734,20 +724,65 @@ DTOutput("landfalls_table")
### Storm Track {data-height=500 .no-padding} ### Storm Track {data-height=500 .no-padding}
```{r} ```{r}
storm_track <- reactive({
req(storm_selection$is_selected)
result <- hurdat.best_track %>%
filter(
storm_basin == storm_selection$storm_basin,
storm_year == storm_selection$storm_year,
storm_name == storm_selection$storm_name
) %>%
mutate(
lon = sql("ST_X(ST_Transform(location::geometry, 4326))"),
lat = sql("ST_Y(ST_Transform(location::geometry, 4326))"),
rmw_meters = (rmw * 1852)
) %>%
select(
datetime,
lon,
lat,
rmw,
record_identifier,
rmw_meters
) %>%
collect()
cat(str(result))
return(result)
})
output$trackMap <- renderLeaflet({ output$trackMap <- renderLeaflet({
leaflet() %>% leaflet() %>%
addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18)) %>% addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18)) %>%
setView(lng = -80, lat = 32, zoom = 4) %>% setView(lng = -80, lat = 32, zoom = 4) %>%
addPolylines(
data = storm_track(),
lng = ~lon,
lat = ~lat,
weight = 4,
color = "blue"
) %>%
addCircleMarkers( addCircleMarkers(
#data = katrinaTrack, data = storm_track() %>% filter(record_identifier == "L"),
#lng = ~Longitude,
#lat = ~Latitude,
data = selected.best_track(),
lng = ~lon, lng = ~lon,
lat = ~lat, lat = ~lat,
radius = 5, radius = 5,
color = ~ifelse(record_identifier == "L", "red", "blue"), weight = 0,
fillColor = ~ifelse(record_identifier == "L", "red", "blue") 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
) )
}) })