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

update db calls

Browse Source
This commit is contained in:
dylan
2025-06-10 12:51:06 -04:00
parent 31b92a0254
commit 2e5bf0eebb
5 changed files with 394 additions and 708 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dashboard.Rmd
+130 -647
View File
@@ -37,6 +37,8 @@ library(sf)
library(shinyBS) library(shinyBS)
library(xts) library(xts)
library(tigris) library(tigris)
library(caret)
library(scales)
linuxdir <- "/home/dylan/Personal/Projects/Hurricane Normalization/" linuxdir <- "/home/dylan/Personal/Projects/Hurricane Normalization/"
macdir <- "~/Desktop/Personal/Projects/Hurricane Normalization/" macdir <- "~/Desktop/Personal/Projects/Hurricane Normalization/"
@@ -57,120 +59,7 @@ con <- dbConnect(
password = config$db_password password = config$db_password
) )
selected_storm_name <- "KATRINA" # lazy load DB tables
selected_storm_year <- 2005
selected_storm_basin <- "AL"
selected_lf_type = "LF"
selected_lf_id = "2"
xlallLandfallsNormalized <- read.csv(paste0(baseDir, "R/dataScripts/restructured/normalization/all-landfalls-normalized.csv"), header = T) %>%
select(-X)
normalized2024 <- read.csv(paste0(baseDir, "R/dataScripts/restructured/normalization/2024-normalized.csv"), header = T) %>%
select(-X, -hurdatId, -MMH23, -MMP23) %>%
filter(MMH24 > 0) %>%
mutate(
lf_date = trimws(lf_date)
)
normalized2024 <- normalized2024 %>%
mutate(
lf_date = mdy(lf_date)
) %>%
rename(
Storm = storm_name,
Landfall = lf_date
)
pop <- read.csv(paste0(baseDir, "Data/population_with_projections.csv"), stringsAsFactors = F) %>%
pivot_longer(
cols = starts_with("X"),
names_to = "year",
values_to = "pop",
) %>%
rename(population = pop) %>%
mutate(
year = parse_number(year),
FIPS = ifelse(nchar(FIPS) == 4, paste0("0", FIPS), FIPS),
state_fips = substr(FIPS, 1, 2),
county_fips = substr(FIPS, 3, 5)
) %>%
select(!full_county_and_state:County & !county_state & !FIPS)
housing <- read.csv(paste0(baseDir, "Data/housing_units.csv"), stringsAsFactors = F) %>%
pivot_longer(
cols = starts_with("X"),
names_to = "year",
values_to = "housing"
) %>%
mutate(
year = parse_number(year),
FIPS = ifelse(nchar(FIPS) == 4, paste0("0", FIPS), FIPS),
state_fips = substr(FIPS, 1, 2),
county_fips = substr(FIPS, 3, 5)
) %>%
rename(housing_units = housing) %>%
select(!County.Full:County & !County.State & !FIPS)
metrics.pop_and_housing <- pop %>%
left_join(housing, by = c("state_fips", "county_fips", "year"))
weightedCounties <- read.csv(paste0(baseDir, "R/dataScripts/weighted-counties.csv"), header = T) %>%
mutate(
weight = (PERCENTAGE/100),
FIPS = ifelse(nchar(FIPS) == 4, paste0("0", FIPS), FIPS),
state_fips = substr(FIPS, 1, 2),
county_fips = substr(FIPS, 3, 5)
) %>%
select(
state_fips,
county_fips,
hurdatId = HURDAT_Cod,
storm_name = Name_1,
lfId = LF_ID_Mull,
lf_date = LF_Date,
year = Year,
rmw = RMW,
lat = Lat,
lon = Long,
rmw_2x = RMW_x2,
area = AREA,
weight
)
katrinaAffectedCounties <- weightedCounties %>%
filter(hurdatId == "AL122005" & lfId == "LF2") %>%
mutate(
fips = paste0(state_fips, county_fips)
)
katrinaLfTwoCountyMetrics <- metrics.pop_and_housing %>%
filter(year >= 2005) %>%
pivot_longer(
cols = c("population", "housing_units"),
names_to = "metric",
values_to = "value"
) %>%
pivot_wider(
names_from = year,
values_from = value,
) %>%
mutate(
fips = paste0(state_fips, county_fips)
) %>%
filter(fips %in% katrinaAffectedCounties$fips) %>%
select(fips, !state_fips & !county_fips)
###### REACTIVE VALUES
######
# LAZY LOAD DB TABLES
econ.normalized_landfalls <- tbl(con, I("econ.normalized_landfalls")) econ.normalized_landfalls <- tbl(con, I("econ.normalized_landfalls"))
econ.storm_base_loss <- tbl(con, I("econ.storm_base_loss")) econ.storm_base_loss <- tbl(con, I("econ.storm_base_loss"))
econ.usa_yearly <- tbl(con, I("econ.usa_yearly")) econ.usa_yearly <- tbl(con, I("econ.usa_yearly"))
@@ -187,79 +76,14 @@ hurdat.best_track <- tbl(con, I("hurdat.best_track"))
hurdat.hurdat_storms <- tbl(con, I("hurdat.hurdat_storms")) hurdat.hurdat_storms <- tbl(con, I("hurdat.hurdat_storms"))
metrics.geo_attributes <- tbl(con, I("metrics.geo_attributes")) metrics.geo_attributes <- tbl(con, I("metrics.geo_attributes"))
#metrics.pop_and_housing <- tbl(con, I("metrics.pop_and_housing")) metrics.pop_and_housing <- tbl(con, I("metrics.pop_and_housing"))
public.counties <- tbl(con, I("public.counties")) public.counties <- tbl(con, I("public.counties"))
### COMMONLY USED DATA # pull static data
#loss_storms <- econ.storm_base_loss %>%
# select(
# storm_basin, storm_year, storm_name
# ) %>%
# distinct(
# storm_basin, storm_year, storm_name
# ) %>%
# left_join(
# hurdat.hurdat_storms %>%
# mutate(hurdatId = paste0(storm_basin, storm_number, storm_year)),
# by = c("storm_basin", "storm_year", "storm_name")) %>%
# select(
# hurdatId, storm_basin, storm_name, storm_year
# ) %>%
# collect()
loss_storms <- get_all_loss_storms() loss_storms <- get_all_loss_storms()
base_losses_by_lf <- econ.storm_base_loss %>% latest_normalized_losses <- get_latest_aggregate_losses()
filter(!is.na(base_loss)) %>%
mutate(
ncei_priority = case_when(
str_like(base_loss_source, "%ncei%") ~ 1,
str_like(base_loss_source, "%ncei%") ~ 2,
TRUE ~ 3
)
) %>%
group_by(storm_basin, storm_year, storm_name, lf_type, lf_id) %>%
slice_min(ncei_priority, n = 1, with_ties = F) %>%
ungroup() %>%
collect()
total_base_losses <- base_losses_by_lf %>%
group_by(storm_basin, storm_year, storm_name) %>%
summarize(
total_base_loss = sum(base_loss),
.groups = "drop"
) %>%
collect()
normalized_losses_2024 <- econ.normalized_landfalls %>%
filter(normalization_year == 2024) %>%
left_join(econ.storm_base_loss %>%
filter(!is.na(base_loss)) %>%
mutate(
ncei_priority = case_when(
str_like(base_loss_source, "%ncei%") ~ 1,
str_like(base_loss_source, "%ncei%") ~ 2,
TRUE ~ 3
)
) %>%
group_by(storm_basin, storm_year, storm_name, lf_type, lf_id) %>%
slice_min(ncei_priority, n = 1, with_ties = F) %>%
ungroup(),
by = c("storm_basin", "storm_year", "storm_name", "lf_type", "lf_id")) %>%
mutate(
mmh_lf = (base_loss * gdp_deflator * rwhu * affected_housing),
mmp_lf = (base_loss * gdp_deflator * rwpc * affected_population)
) %>%
group_by(storm_basin, storm_year, storm_name) %>%
summarize(
mmh = sum(mmh_lf, na.rm = T),
mmp = sum(mmp_lf, na.rm = T),
.groups = "drop"
) %>%
filter(!is.na(mmh) & !is.na(mmp)) %>%
collect()
storm_selection <- reactiveValues( storm_selection <- reactiveValues(
storm_year = NULL, storm_year = NULL,
@@ -269,6 +93,10 @@ storm_selection <- reactiveValues(
is_selected = FALSE, is_selected = FALSE,
is_table_selection = FALSE, is_table_selection = FALSE,
) )
onStop(function() {
dbDisconnect(con)
})
``` ```
Home Home
@@ -370,20 +198,24 @@ Col {data-width=500}
### Storm Selector {data-height=500} ### Storm Selector {data-height=500}
```{r} ```{r}
#h5("Select a storm: ")
#h6("Use either the select inputs or the data table below")
fluidRow( fluidRow(
column(6, column(4,
selectInput("stormBasin", "Select Basin", choices = "AL"), selectInput("stormBasin", "Select Basin", choices = "AL")
selectInput("stormYear", "Select Year", choices = loss_storms$storm_year),
selectInput("stormName", "Select Storm", choices = NULL),
actionButton("selectStorm", "Submit", class = "btn-primary")
), ),
column(6, column(4,
#TODO: ADD TABLE selectInput("stormYear", "Select Year", choices = loss_storms$storm_year)
),
#DTOutput("storm_selector_table") column(4,
selectInput("stormName", "Select Storm", choices = NULL)
) )
) )
actionButton("selectStorm", "Submit", class = "btn-primary")
observeEvent(input$stormYear, { observeEvent(input$stormYear, {
stormsByChosenYear <- loss_storms[loss_storms$storm_year == input$stormYear, ] stormsByChosenYear <- loss_storms[loss_storms$storm_year == input$stormYear, ]
@@ -411,8 +243,9 @@ observeEvent(input$selectStorm, {
```{r} ```{r}
output$normalized_storms_table <- renderDT({ output$normalized_storms_table <- renderDT({
datatable( datatable(
normalized_losses_2024 %>% select(Storm = storm_name, Year = storm_year, MMH24 = mmh, MMP24 = mmp), latest_normalized_losses,
rownames = F, rownames = F,
colnames = c("Storm", "Year", "MMH24", "MMP24"),
selection = "single", selection = "single",
options = list( options = list(
pageLength = 1000, pageLength = 1000,
@@ -424,7 +257,7 @@ output$normalized_storms_table <- renderDT({
server = T server = T
) )
) %>% ) %>%
formatCurrency(c("MMH24", "MMP24"), "$", digits = 0) formatCurrency(c("mmh", "mmp"), "$", digits = 0)
}) })
DTOutput("normalized_storms_table") DTOutput("normalized_storms_table")
@@ -451,7 +284,25 @@ growth_trends <- reactiveValues(
full_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} Col {data-width=500}
@@ -467,156 +318,27 @@ HTML('
### Normalization Cost Index {data-height=800} ### Normalization Cost Index {data-height=800}
```{r} ```{r}
storm_unique_landfalls <- reactive({
req(storm_selection$is_selected)
result <- econ.storm_base_loss %>%
filter(
storm_basin == storm_selection$storm_basin,
storm_year == storm_selection$storm_year,
storm_name == storm_selection$storm_name
) %>%
mutate(
full_lf_id = paste0(lf_type, lf_id)
) %>%
distinct(
full_lf_id,
.keep_all = T
) %>%
arrange(
full_lf_id
) %>%
select(
storm_basin, storm_year, storm_name, lf_type, lf_id, full_lf_id
) %>%
collect()
return(result)
})
storm_normalized_landfall <- reactive({
req(storm_overview_reactive$full_lf_id)
result <- econ.normalized_landfalls %>%
filter(
storm_basin == storm_selection$storm_basin,
storm_year == storm_selection$storm_year,
storm_name == storm_selection$storm_name,
lf_type == storm_overview_reactive$lf_type,
lf_id == storm_overview_reactive$lf_id
) %>%
left_join(econ.storm_base_loss %>%
filter(!is.na(base_loss)) %>%
mutate(
ncei_priority = case_when(
str_like(base_loss_source, "%ncei%") ~ 1,
str_like(base_loss_source, "%ncei%") ~ 2,
TRUE ~ 3
)
) %>%
group_by(storm_basin, storm_year, storm_name, lf_type, lf_id) %>%
slice_min(ncei_priority, n = 1, with_ties = F) %>%
ungroup(),
by = c("storm_basin", "storm_year", "storm_name", "lf_type", "lf_id")) %>%
mutate(
mmh_index = (gdp_deflator * rwhu * affected_housing),
mmp_index = (gdp_deflator * rwpc * affected_population),
mmh = (base_loss * mmh_index),
mmp = (base_loss * mmp_index)
) %>%
select(
-base_loss_source, -base_loss, -base_loss_citation, -doi, -notes, -ncei_priority
) %>%
collect()
cat(str(result))
return(result)
})
storm_cost_index_base_index_ts <- reactive({ output$cost_index_chart <- renderDygraph({
req(storm_normalized_landfall()) req(storm_selection$is_selected, input$storm_overview_cost_index_lf)
cost_index <- storm_normalized_landfall() %>% cost_index <- get_normalized_cost_index(storm_selection, input$storm_overview_cost_index_lf) %>%
select(
normalization_year, mmh_index, mmp_index
) %>%
mutate(normalization_year = as.Date(paste0(normalization_year, "-01-01"))) mutate(normalization_year = as.Date(paste0(normalization_year, "-01-01")))
cost_index_ts <- cost_index %>% cost_index_ts <- cost_index %>%
select(-normalization_year) %>% select(-normalization_year) %>%
xts(order.by = cost_index$normalization_year) xts(order.by = cost_index$normalization_year)
cat(str(cost_index_ts)) dygraph(cost_index_ts, main = "Cost Index") %>%
dySeries("mmh", label = "MMH24") %>%
result <- cost_index_ts dySeries("mmp", label = "MMP24") %>%
dyRangeSelector(height = 30)
return(result)
}) })
storm_cost_index_normalized_costs_ts <- reactive({ #observeEvent(input$storm_overview_select_base, {
req(storm_normalized_landfall())
cost_index <- storm_normalized_landfall() %>%
select(
normalization_year, mmh, mmp
) %>%
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)
cat(str(cost_index_ts))
result <- cost_index_ts
return(result)
})
observe({
req(storm_unique_landfalls())
storm_overview_reactive$lf_type = storm_unique_landfalls()$lf_type[1]
storm_overview_reactive$lf_id = storm_unique_landfalls()$lf_id[1]
storm_overview_reactive$full_lf_id = storm_unique_landfalls()$full_lf_id[1]
growth_trends$lf_type = storm_unique_landfalls()$lf_type[1]
growth_trends$lf_id = storm_unique_landfalls()$lf_id[1]
growth_trends$full_lf_id = storm_unique_landfalls()$full_lf_id[1]
})
observe({
req(storm_overview_reactive$full_lf_id)
updateSelectInput(
session,
"storm_overview_cost_index_lf",
choices = storm_unique_landfalls()$full_lf_id,
selected = storm_overview_reactive$full_lf_id
)
})
observeEvent(input$storm_overview_select_base, {
# TODO: add button to select normalized costs # TODO: add button to select normalized costs
}) #})
output$costIndex <- renderDygraph({
req(storm_normalized_landfall())
if(storm_overview_reactive$use_normalized_costs == F) {
dygraph(storm_cost_index_base_index_ts(), main = paste(storm_selection$storm_name, storm_selection$storm_year, "Cost Index")) %>%
dySeries("mmh_index", label = "MMH Index") %>%
dySeries("mmp_index", label = "MMP Index") %>%
dyRangeSelector(height = 30)
}else{
dygraph(storm_cost_index_normalized_costs_ts(), main = paste(storm_selection$storm_name, storm_selection$storm_year, "Cost Index")) %>%
dySeries("mmh", label = "MMH") %>%
dySeries("mmp", label = "MMP") %>%
dyRangeSelector(height = 30)
}
})
fillCol( fillCol(
flex = c(.2, .8), flex = c(.2, .8),
@@ -632,7 +354,7 @@ fillCol(
#checkboxInput("mmpSelect", "Display MMP", value = T) #checkboxInput("mmpSelect", "Display MMP", value = T)
) )
), ),
dygraphOutput("costIndex") dygraphOutput("cost_index_chart")
) )
``` ```
@@ -656,39 +378,15 @@ fluidRow(
### Landfalls {data-height=300 .no-padding} ### Landfalls {data-height=300 .no-padding}
```{r} ```{r}
storm_landfalls <- reactive({ output$landfalls_table <- renderDT({
req(storm_selection$is_selected) req(storm_selection$is_selected)
result <- hurdat.best_track %>% hurdat_landfalls <- get_hurdat_landfalls(storm_selection)
filter(
storm_basin == storm_selection$storm_basin,
storm_year == storm_selection$storm_year,
storm_name == storm_selection$storm_name,
record_identifier == "L"
) %>%
mutate(
lon = sql("ST_X(ST_Transform(location::geometry, 4326))"),
lat = sql("ST_Y(ST_Transform(location::geometry, 4326))")
) %>%
select(
Date = datetime,
Longitude = lon,
Latitude = lat,
RMW = rmw,
Pressure = pressure,
Windspeed = windspeed
) %>%
collect()
cat(str(result))
return(result)
})
output$landfalls_table <- renderDT({
datatable( datatable(
storm_landfalls(), hurdat_landfalls,
rownames = F, rownames = F,
colnames = c("Date", "Longitude", "Latitude", "RMW", "Pressure", "Windspeed"),
options = list( options = list(
order = list(0, 'asc'), order = list(0, 'asc'),
paging = F, paging = F,
@@ -698,57 +396,29 @@ output$landfalls_table <- renderDT({
server = T server = T
) )
) %>% ) %>%
formatDate(columns = "Date", method = "toUTCString") formatDate(columns = "datetime", method = "toUTCString")
}) })
DTOutput("landfalls_table") DTOutput("landfalls_table")
``` ```
### Storm Track {data-height=500 .no-padding} ### Storm Track {data-height=500 .no-padding}
```{r} ```{r}
storm_track <- reactive({ output$track_map <- renderLeaflet({
req(storm_selection$is_selected) storm_track <- get_hurdat_track(storm_selection)
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({
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( addPolylines(
data = storm_track(), data = storm_track,
lng = ~lon, lng = ~lon,
lat = ~lat, lat = ~lat,
weight = 4, weight = 4,
color = "blue" color = "blue"
) %>% ) %>%
addCircleMarkers( addCircleMarkers(
data = storm_track() %>% filter(record_identifier == "L"), data = storm_track %>% filter(record_identifier == "L"),
lng = ~lon, lng = ~lon,
lat = ~lat, lat = ~lat,
radius = 5, radius = 5,
@@ -758,7 +428,7 @@ output$trackMap <- renderLeaflet({
fillOpacity = 0.8 fillOpacity = 0.8
) %>% ) %>%
addCircles( addCircles(
data = storm_track() %>% filter(record_identifier == "L"), data = storm_track %>% filter(record_identifier == "L"),
lng = ~lon, lng = ~lon,
lat = ~lat, lat = ~lat,
radius = ~rmw_meters, radius = ~rmw_meters,
@@ -769,7 +439,7 @@ output$trackMap <- renderLeaflet({
) )
}) })
leafletOutput("trackMap", height="100%") leafletOutput("track_map", height="100%")
``` ```
Growth Trends {data-navmenu="Storm Details"} Growth Trends {data-navmenu="Storm Details"}
@@ -780,230 +450,76 @@ Column {data-width=550}
### Map Year {data-height=100} ### Map Year {data-height=100}
```{r} ```{r}
sliderInput("growth_trend_map_slider", label = NULL, min = 1900, max = 2024, step = 1, animate = T, value = 2005, sep = "", width = "100%", ticks = F) observe({
req(storm_selection$is_selected)
updateSliderInput(session,
"growth_trend_map_slider",
min = storm_selection$storm_year,
value = storm_selection$storm_year)
})
sliderInput("growth_trend_map_slider", label = NULL, min = 1700, max = 2024, step = 1, animate = T, value = 1700, sep = "", width = "100%", ticks = F)
``` ```
### {data-height=900 .no-padding} ### {data-height=900 .no-padding}
```{r} ```{r}
growth_metrics_lf_fips <- reactive({ #storm_metrics_growth_geom <- reactive({
req(growth_trends$full_lf_id) # req(storm_selection$is_selected)
#
result <- gis.affected_area_landfalls %>% # counties <- get_normalized_metric_growth(storm_selection, input$growth_trend_lf_select)
filter( #
storm_basin == storm_selection$storm_basin, # result <- counties %>%
storm_year == storm_selection$storm_year, # st_as_sf(wkt = "geom_wkt")
storm_name == storm_selection$storm_name, # #%>%
lf_type == growth_trends$lf_type, # # mutate(
lf_id == growth_trends$lf_id # # 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))
mutate( # # ) %>%
fips = paste0(state_fips, county_fips) #
) %>% #
select( # cat(str(result))
fips #
) %>% # return(result)
collect() #})
return(result)
})
normalized_growth_metrics_lf <- reactive({ #observe({
req(growth_metrics_lf_fips()) # req(storm_selection$is_selected, input$growth_trend_map_slider)
#
affected_fips <- growth_metrics_lf_fips()$fips # county_data <- storm_metrics_growth_geom() %>%
# filter(year == input$growth_trend_map_slider)
affected_counties <- metrics.pop_and_housing %>% #
mutate( # cat(str(county_data))
fips = paste0(state_fips, county_fips) #
) %>% # leafletProxy("pop_growth_map", session) %>%
filter( # clearShapes() %>%
fips %in% affected_fips, # addPolygons(
year >= storm_selection$storm_year # data = county_data,
) %>% # fillColor = "red",
group_by( # fillOpacity = 1
fips # )
) %>% #})
arrange(
year
) %>%
mutate(
base_population = first(population),
base_housing_units = first(housing_units),
) %>%
ungroup() %>%
collect()
affected_counties_geom <- public.counties %>% output$pop_growth_map <- renderLeaflet({
mutate(
fips = paste0(statefp, countyfp),
geom_wkt = sql("ST_AsText(ST_Transform(geom, 4326))")
) %>%
filter(
fips %in% affected_fips,
) %>%
collect()
result <- affected_counties %>%
left_join(
affected_counties_geom,
by = "fips"
) %>%
st_as_sf(wkt = "geom_wkt")
return(result)
})
growth_trend_map_year <- reactive({
req(input$growth_trend_map_slider)
result <- normalized_growth_metrics_lf() %>%
filter(
year == input$growth_trend_map_slider
)
return(result)
})
aggregate_growth_metrics_lf <- reactive({
req(growth_metrics_lf_fips())
result <- metrics.pop_and_housing %>%
mutate(
fips = paste0(state_fips, county_fips)
) %>%
filter(
fips %in% growth_metrics_lf_fips()$fips,
year >= storm_selection$storm_year
) %>%
group_by(
year
) %>%
summarize(
aggregate_population = sum(population, na.rm = T),
aggregate_housing_units = sum(housing_units, na.rm = T),
.groups = "drop"
) %>%
collect()
return(result)
})
aggregate_normalized_growth_metrics_lf <- reactive ({
req(aggregate_growth_metrics_lf())
result <- aggregate_growth_metrics_lf() %>%
arrange(
year
) %>%
mutate(
base_population = first(aggregate_population),
base_housing_units = first(aggregate_housing_units),
normalized_population = (aggregate_population / base_population),
normalized_housing_units = (aggregate_housing_units / base_housing_units),
year = as.Date(paste0(year, "-01-01"))
) %>%
select(
year, normalized_population, normalized_housing_units
)
return(result)
})
aggregate_normalized_growth_metrics_lf_ts <- reactive({
req(aggregate_normalized_growth_metrics_lf())
result <- aggregate_normalized_growth_metrics_lf() %>%
select(-year) %>%
xts(order.by = aggregate_normalized_growth_metrics_lf()$year)
return(result)
})
normalized_growth_metrics_lf_ts <- reactive({
req(normalized_growth_metrics_lf())
result <- normalized_growth_metrics_lf() %>%
select(-year) %>%
xts(order.by = normalized_growth_metrics_lf()$year)
return(result)
})
normalized_counties_sf <- reactive({
req(storm_selection$is_selected)
affected_counties <- gis.affected_area_landfalls
})
dbStormCounties <- reactive({
req(storm_selection$is_selected)
sel_storm_basin <- storm_selection$storm_basin
sel_storm_year <- storm_selection$storm_year
sel_storm_name <- storm_selection$storm_name
sel_lfid <- growth_trends$lf_id
affectedCounties <- gis.affected_area_landfalls %>%
mutate(
fips = paste0(state_fips, county_fips),
lfid = paste0(lf_type, lf_id)
) %>%
filter(
storm_basin == sel_storm_basin,
storm_year == sel_storm_year,
storm_name == sel_storm_name,
lfid == sel_lfid
) %>%
left_join(
public.counties %>%
mutate(geom_wkt = sql("ST_AsText(ST_Transform(geom, 4326))")) %>%
rename(state_fips = statefp, county_fips = countyfp),
by = c("state_fips", "county_fips")
) %>%
collect()
affectedCounties_sf <- affectedCounties %>%
st_as_sf(wkt = "geom_wkt")
cat(str(affectedCounties_sf))
return(affectedCounties_sf)
})
output$popMapPoly <- renderLeaflet({
leaflet() %>% leaflet() %>%
addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18)) %>% addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18))
setView(lng = -89.8, lat = 29.6, zoom = 8) %>% # %>% setView(lng = -89.8, lat = 29.6, zoom = 8)
addPolygons(
data = growth_trend_map_year(),
fillColor = "red",
fillOpacity = 0.3,
color = "black",
weight = 2
)
}) })
output$housingMapPoly <- renderLeaflet({ output$housing_growth_map <- renderLeaflet({
leaflet() %>% leaflet() %>%
addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18)) %>% addProviderTiles("CartoDB.Positron", option = providerTileOptions(minZoom = 2, maxZoom = 18))
setView(lng = -89.8, lat = 29.6, zoom = 8) #%>% # %>% setView(lng = -89.8, lat = 29.6, zoom = 8)
#addPolygons(
# data = dbStormCounties(),
# fillColor = "blue",
# fillOpacity = 0.3,
# color = "black",
# weight = 2
#)
}) })
fillCol( fillCol(
flex = c(1, 1), flex = c(1, 1),
leafletOutput("popMapPoly"), leafletOutput("pop_growth_map"),
leafletOutput("housingMapPoly") leafletOutput("housing_growth_map")
) )
``` ```
Column {data-width=450} Column {data-width=450}
@@ -1011,23 +527,6 @@ Column {data-width=450}
### Landfall Selection {data-height=550} ### Landfall Selection {data-height=550}
```{r} ```{r}
observe({
req(growth_trends$full_lf_id)
updateSelectInput(
session,
"growth_trend_lf_select",
choices = storm_unique_landfalls()$full_lf_id,
selected = growth_trends$full_lf_id
)
})
observeEvent(input$growth_trend_lf_select, {
growth_trends$full_lf_id = input$growth_trend_lf_select
})
fillCol( fillCol(
flex = c(.2, .8), flex = c(.2, .8),
fluidRow( fluidRow(
@@ -1039,15 +538,15 @@ fillCol(
#checkboxInput("storm_overview_select_base", "Include Normalized Losses", value = F) #checkboxInput("storm_overview_select_base", "Include Normalized Losses", value = F)
) )
), ),
dygraphOutput("popHu") #dygraphOutput("popHu")
) )
output$popHu <- renderDygraph({ #output$popHu <- renderDygraph({
dygraph(aggregate_normalized_growth_metrics_lf_ts(), main = "Normalized Aggregate Growth") %>% # dygraph(aggregate_normalized_growth_metrics_lf_ts(), main = "Normalized Aggregate Growth") %>%
dySeries("normalized_population", label = "Population") %>% # dySeries("normalized_population", label = "Population") %>%
dySeries("normalized_housing_units", label = "Housing Units") %>% # dySeries("normalized_housing_units", label = "Housing Units") %>%
dyRangeSelector() # dyRangeSelector()
}) #3})
``` ```
@@ -1055,27 +554,11 @@ output$popHu <- renderDygraph({
```{r} ```{r}
output$katrinaCounties <- renderDT({
datatable(
katrinaLfTwoCountyMetrics,
rownames = F,
#extensions = "RowGroup",
options = list(
pageLength = 1000,
#rowGroup = list(dataSrc = 1),
paging = F,
searching = F,
info = F,
lengthChange = F,
server = T
)
)
})
#DTOutput("katrinaCounties")
``` ```
Storm Fatalities {data-navmenu="Storm Details"}
===
Fatalities {data-navmenu="Fatalities"} Fatalities {data-navmenu="Fatalities"}
hurricane_app/server.R
-28
View File
@@ -1,28 +0,0 @@
#
# This is the server logic of a Shiny web application. You can run the
# application by clicking 'Run App' above.
#
# Find out more about building applications with Shiny here:
#
# https://shiny.posit.co/
#
library(shiny)
# Define server logic required to draw a histogram
function(input, output, session) {
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white',
xlab = 'Waiting time to next eruption (in mins)',
main = 'Histogram of waiting times')
})
}
hurricane_app/ui.R
-33
View File
@@ -1,33 +0,0 @@
#
# This is the user-interface definition of a Shiny web application. You can
# run the application by clicking 'Run App' above.
#
# Find out more about building applications with Shiny here:
#
# https://shiny.posit.co/
#
library(shiny)
# Define UI for application that draws a histogram
fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot")
)
)
)
queries.R
+264
View File
@@ -3,6 +3,7 @@
library(tidyverse) library(tidyverse)
library(dplyr) library(dplyr)
library(DBI) library(DBI)
#library(sf)
linuxdir <- "/home/dylan/Personal/Projects/Hurricane Normalization/" linuxdir <- "/home/dylan/Personal/Projects/Hurricane Normalization/"
macdir <- "~/Desktop/Personal/Projects/Hurricane Normalization/" macdir <- "~/Desktop/Personal/Projects/Hurricane Normalization/"
@@ -43,6 +44,18 @@ metrics.pop_and_housing <- tbl(con, I("metrics.pop_and_housing"))
public.counties <- tbl(con, I("public.counties")) public.counties <- tbl(con, I("public.counties"))
# helper functions
# splits full_lf_id into lf_type and lf_id
split_full_lf_id <- function(full_lf_id) {
lf_type = gsub('[0-9]+', '', full_lf_id)
lf_id = gsub('[^0-9]', '', full_lf_id)
return(list(lf_type = lf_type, lf_id = lf_id))
}
# DB getters
# returns a list of loss storms we have data on # returns a list of loss storms we have data on
get_all_loss_storms <- function() { get_all_loss_storms <- function() {
query <- econ.storm_base_loss %>% query <- econ.storm_base_loss %>%
@@ -65,14 +78,265 @@ get_all_loss_storms <- function() {
return(result) return(result)
} }
# returns a list of latest normalized losses
get_latest_aggregate_losses <- function() {
latest_loss_year <- econ.normalized_landfalls %>%
select(normalization_year) %>%
arrange(desc(normalization_year)) %>%
head(1) %>%
collect() %>%
pull(normalization_year)
query <- econ.normalized_landfalls %>%
filter(normalization_year == latest_loss_year) %>%
left_join(econ.storm_base_loss %>%
filter(!is.na(base_loss)) %>%
mutate(
ncei_priority = case_when(
str_like(base_loss_source, "%ncei%") ~ 1,
str_like(base_loss_source, "%ncei%") ~ 2,
TRUE ~ 3
)
) %>%
group_by(storm_basin, storm_year, storm_name, lf_type, lf_id) %>%
slice_min(ncei_priority, n = 1, with_ties = F) %>%
ungroup(),
by = c("storm_basin", "storm_year", "storm_name", "lf_type", "lf_id")) %>%
mutate(
mmh_lf = (base_loss * gdp_deflator * rwhu * affected_housing),
mmp_lf = (base_loss * gdp_deflator * rwpc * affected_population)
) %>%
group_by(storm_basin, storm_year, storm_name) %>%
summarize(
mmh = sum(mmh_lf, na.rm = T),
mmp = sum(mmp_lf, na.rm = T),
.groups = "drop"
) %>%
filter(!is.na(mmh) & !is.na(mmp)) %>%
select(
storm_name,
storm_year,
mmh,
mmp
)
result <- query %>% collect()
return(result)
}
# returns unique lf ids for a storm
get_unique_lf_ids <- function(storm) {
query <- econ.storm_base_loss %>%
filter(
storm_basin == storm$storm_basin,
storm_year == storm$storm_year,
storm_name == storm$storm_name
) %>%
mutate(
full_lf_id = paste0(lf_type, lf_id)
) %>%
distinct(
full_lf_id,
.keep_all = T
) %>%
arrange(
full_lf_id
) %>%
select(
storm_basin, storm_year, storm_name, lf_type, lf_id, full_lf_id
)
result <- query %>% collect()
return(result)
}
# returns normalized mmh/mmp indexes and costs over time by landfall
get_normalized_cost_index <- function(storm, full_lf_id) {
lf_id_parts <- split_full_lf_id(full_lf_id)
query <- econ.normalized_landfalls %>%
filter(
storm_basin == storm$storm_basin,
storm_year == storm$storm_year,
storm_name == storm$storm_name,
lf_type == lf_id_parts$lf_type,
lf_id == lf_id_parts$lf_id
) %>%
left_join(econ.storm_base_loss %>%
filter(!is.na(base_loss)) %>%
mutate(
ncei_priority = case_when(
str_like(base_loss_source, "%ncei%") ~ 1,
str_like(base_loss_source, "%mwr%") ~ 2,
TRUE ~ 3
)
) %>%
group_by(storm_basin, storm_year, storm_name, lf_type, lf_id) %>%
slice_min(ncei_priority, n = 1, with_ties = F) %>%
ungroup(),
by = c("storm_basin", "storm_year", "storm_name", "lf_type", "lf_id")) %>%
mutate(
mmh_index = (gdp_deflator * rwhu * affected_housing),
mmp_index = (gdp_deflator * rwpc * affected_population),
mmh = (base_loss * mmh_index),
mmp = (base_loss * mmp_index)
) %>%
select(
normalization_year, mmh, mmp
)
result <- query %>% collect()
return(result)
}
# returns landfalls and data at landfall from HURDAT
get_hurdat_landfalls <- function(storm) {
query <- hurdat.best_track %>%
filter(
storm_basin == storm$storm_basin,
storm_year == storm$storm_year,
storm_name == storm$storm_name,
record_identifier == "L"
) %>%
mutate(
lon = sql("ST_X(ST_Transform(location::geometry, 4326))"),
lat = sql("ST_Y(ST_Transform(location::geometry, 4326))")
) %>%
select(
datetime,
lon,
lat,
rmw,
pressure,
windspeed
)
result <- query %>% collect()
return(result)
}
# returns storm track from HURDAT
get_hurdat_track <- function(storm) {
query <- hurdat.best_track %>%
filter(
storm_basin == storm$storm_basin,
storm_year == storm$storm_year,
storm_name == storm$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) # convert nautical miles to meters
) %>%
select(
datetime,
lon,
lat,
rmw,
record_identifier,
rmw_meters
)
result <- query %>% collect()
return(result)
}
# returns normalized population and housing growth by county with geometry
#get_normalized_metric_growth <- function(storm, full_lf_id) {
# lf_id_parts <- split_full_lf_id(full_lf_id)
#
# affected_counties <- gis.affected_area_landfalls %>%
# filter(
# storm_basin == storm$storm_basin,
# storm_year == storm$storm_year,
# storm_name == storm$storm_name,
# lf_type == lf_id_parts$lf_type,
# lf_id == lf_id_parts$lf_id
# ) %>%
# select(state_fips, county_fips)
#
# baseline_metrics <- metrics.pop_and_housing %>%
# filter(
# year == storm$storm_year
# ) %>%
# inner_join(affected_counties, by = c("state_fips", "county_fips")) %>%
# select(
# state_fips,
# county_fips,
# baseline_population = population,
# baseline_housing = housing_units
# )
#
# normalized_metrics <- metrics.pop_and_housing %>%
# filter(
# year >= storm$storm_year
# ) %>%
# inner_join(affected_counties, by = c("state_fips", "county_fips")) %>%
# inner_join(baseline_metrics, by = c("state_fips", "county_fips")) %>%
# mutate(
# normalized_population = as.numeric(population) / as.numeric(baseline_population),
# normalized_housing = as.numeric(housing_units) / as.numeric(baseline_housing)
# ) %>%
# select(
# state_fips,
# county_fips,
# year,
# population,
# housing_units,
# normalized_population,
# normalized_housing
# )
#
# query <- normalized_metrics %>%
# inner_join(
# public.counties,
# by = c("state_fips" = "statefp", "county_fips" = "countyfp")
# ) %>%
# mutate(
# geom_wkt = sql("ST_AsText(ST_Transform(geom, 4326))")
# ) %>%
# select(
# state_fips,
# county_fips,
# year,
# population,
# housing_units,
# normalized_population,
# normalized_housing,
# geom_wkt
# ) %>%
# arrange(state_fips, county_fips, year)
#
# result <- query %>% collect()
#
# return(result)
#}
# test functions
#storm <- list(storm_basin = "AL", storm_name = "KATRINA", storm_year = 2005)
#full_lf_id <- "LF1"
#a <- get_all_loss_storms()
#b <- get_latest_aggregate_losses()
#c <- get_unique_lf_ids(storm)
#d <- get_normalized_cost_index(storm, full_lf_id)
#e <- get_hurdat_landfalls(storm)
#f <- get_hurdat_track(storm)
#g <- get_normalized_metric_growth(storm, full_lf_id)
#g_2 <- g %>%
# st_as_sf(wkt = "geom_wkt")
utils.R
View File