The analysis done by The Post for the story The Ring in Ashes can be reproduced using FEMA’s Hazard Mitigation Assistance Projects open data and joined with with FEMA’s Disaster Declarations Summaries data to determine which designated disasters occurred between three time periods

library(tidyverse)
library(tidycensus)
library(lubridate)
library(DT)
library(knitr)
library(viridis)
library(scales)

knitr::opts_chunk$set(warning = FALSE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(fig.width = 8)
knitr::opts_chunk$set(fig.height = 3)

# load up cleaned up data
mega_df <- readRDS("../../data/clean/mega_df_pt2.RDS") %>%
  mutate(declaration_year=year(declarationDate)) %>% 
  filter(programArea=="HMGP")

Of the $11 billion FEMA has allocated for this program over the past decade, only $1.6 billion has been spent.

# 1. What percent of money is unspent
share1 <- mega_df %>%
   #filter(programFy>2010) %>%
   mutate(year_declared=year(declarationDate)) %>%
   filter(year_declared>2010) %>% 
   filter(programArea=="HMGP") %>%
   group_by(status) %>%
   summarize(amount=sum(projectAmount, na.rm=T)) %>%
   mutate(percent_money=round(amount/sum(amount, na.rm=T)*100,1))

kable(share1, format.args = list(big.mark = ","))
status amount percent_money
Approved 9,393,000,822 85.5
Closed 1,597,847,125 14.5

How long counties wait on average to complete their FEMA-funded resilience projects.

Projects that closed in 2020 took an average of 7 years to get funded and completed, one year longer than it took a decade ago.

This is counting from a declared disaster dates to dates projects closed by year of closure.

mega_df %>%
  mutate(year_closed=year(dateClosed)) %>% 
  mutate(disaster_closed_interval=interval(declarationDate, dateClosed)) %>% 
  mutate(months_disaster_closed=disaster_closed_interval %/% months(1)) %>% 
  mutate(months_disaster_closed=case_when(
    months_disaster_closed < 0 ~ 0,
    TRUE ~ months_disaster_closed
  )) %>% 
  filter(year_closed>2010 & year_closed < 2021) %>% 
  group_by(year_closed) %>%
  #filter(initially_approved_year>2010) %>% 
  summarize(total=n(),
            months_disaster_closed=round(mean(months_disaster_closed, na.rm=T),1)) %>% 
  mutate(years=months_disaster_closed/12) %>% 
  filter(year_closed>2010) %>% 
  ggplot(aes(x=year_closed, y=years)) +
  
  geom_bar(position="stack", stat="identity") +
  #facet_wrap(~still_open) +
  scale_y_continuous(labels = scales::comma) +
  labs(title="Years it took for projects to close",
       subtitle="By project close year",
       caption="Data: FEMA",
       y="Years",
       x="") +
  theme_minimal()

It takes nearly two years for projects in rural counties to get approved.

# import county census data (poverty, urban, race)
county_data <- read_csv("../../data/clean/county_combined.csv") %>% 
  mutate(pov_quantile= ntile(pctpov, 4))  %>% 
  mutate(pop_quantile=ntile(poverty_population, 4))

# import county names
county_names <- read_csv("../../data/clean/county_names.csv")

county_data <- county_data %>% left_join(county_names)

mega_df %>%
     mutate(fipsStateCode=case_when(
         nchar(stateNumberCode)==1 ~ paste0("0", stateNumberCode),
         TRUE ~ as.character(stateNumberCode)
     )) %>%
     mutate(fipsCountyCode=case_when(
         nchar(countyCode)==1 ~ paste0("00", countyCode),
         nchar(countyCode)==2 ~ paste0("0", countyCode),
         is.na(countyCode) ~ "000",
         TRUE ~ as.character(countyCode)
     )) %>%
     mutate(GEOID=paste0(fipsStateCode, fipsCountyCode)) %>%
     left_join(county_data, by="GEOID") %>% 
     mutate(ur=case_when(
         (urban_rural > 0 & urban_rural <= 2) ~ "1. Urban",
         (urban_rural > 2 & urban_rural <= 4) ~ "2. Suburban",
         (urban_rural > 4 & urban_rural <= 6) ~ "3. Rural",
         TRUE ~ "4. Unclassified"
     )) %>%
     mutate(initially_approved_year=year(approval_date)) %>%
     mutate(initially_declared_approved_interval=interval(declarationDate, approval_date)) %>% 
     mutate(months_declared_approved=initially_declared_approved_interval %/% months(1)) %>% 
     filter(initially_approved_year>2010) %>% 
     group_by(ur) %>%
     summarize(total=n(),
               costs=sum(projectAmount, na.rm=T),
               months_declared_approved=round(mean(months_declared_approved, na.rm=T),1)) %>% 
  filter(ur=="3. Rural") %>% 
  kable()
ur total costs months_declared_approved
3. Rural 3766 2116359580 22.4

How long it takes counties to close out projects by poverty percentile.

# poor communities
mega_df %>%
     mutate(fipsStateCode=case_when(
         nchar(stateNumberCode)==1 ~ paste0("0", stateNumberCode),
         TRUE ~ as.character(stateNumberCode)
     )) %>%
     mutate(fipsCountyCode=case_when(
         nchar(countyCode)==1 ~ paste0("00", countyCode),
         nchar(countyCode)==2 ~ paste0("0", countyCode),
         is.na(countyCode) ~ "000",
         TRUE ~ as.character(countyCode)
     )) %>%
     mutate(GEOID=paste0(fipsStateCode, fipsCountyCode)) %>%
    mutate(year_closed=year(dateClosed)) %>% 
    #mutate(disaster_closed_interval=interval(declarationDate, approval_date)) %>% 
    mutate(disaster_closed_interval=interval(declarationDate, dateClosed)) %>% 
    mutate(months_disaster_closed=disaster_closed_interval %/% months(1)) %>% 
    left_join(county_data, by="GEOID") %>%
    #filter(year(approval_date)>2010) %>%    
    filter(year_closed>2010) %>% 
     group_by(pov_quantile) %>%
     summarize(total=n(),
               costs=sum(projectAmount, na.rm=T),
               months_declared_closed=round(mean(months_disaster_closed, na.rm=T),1))  %>% 
  filter(!is.na(pov_quantile)) %>% 
  kable()
pov_quantile total costs months_declared_closed
1 2294 1200396874 65.2
2 1999 1354363394 70.9
3 2476 1953018115 79.5
4 1715 737964092 73.0

How long it takes to close out projects in counties where majority of the population is either white or non-white.

# white or non-white
mega_df %>%
     mutate(fipsStateCode=case_when(
         nchar(stateNumberCode)==1 ~ paste0("0", stateNumberCode),
         TRUE ~ as.character(stateNumberCode)
     )) %>%
     mutate(fipsCountyCode=case_when(
         nchar(countyCode)==1 ~ paste0("00", countyCode),
         nchar(countyCode)==2 ~ paste0("0", countyCode),
         is.na(countyCode) ~ "000",
         TRUE ~ as.character(countyCode)
     )) %>%
    mutate(GEOID=paste0(fipsStateCode, fipsCountyCode)) %>%
    mutate(year_closed=year(dateClosed)) %>% 
    mutate(disaster_closed_interval=interval(declarationDate, approval_date)) %>% 
    #mutate(disaster_closed_interval=interval(declarationDate, dateClosed)) %>% 
    mutate(months_disaster_closed=disaster_closed_interval %/% months(1)) %>% 
    select(-majority) %>% 
    left_join(county_data, by="GEOID") %>%
    filter(year(approval_date)>2010) %>% 
#    filter(year_closed>2010) %>% 
    group_by(majority) %>%
    summarize(total=n(),
               costs=sum(projectAmount, na.rm=T),
               months_declared_closed=round(mean(months_disaster_closed, na.rm=T),1)) %>% 
  filter(!is.na(majority)) %>% 
  kable()
majority total costs months_declared_closed
Non-White 1580 4504105055 27.5
White 7835 6834382034 24.2

Counties with at least one project that took longer than 10 years to close out where majority of the population is either white or non-white.

tenplus <- mega_df %>%
     mutate(fipsStateCode=case_when(
         nchar(stateNumberCode)==1 ~ paste0("0", stateNumberCode),
         TRUE ~ as.character(stateNumberCode)
     )) %>%
     mutate(fipsCountyCode=case_when(
         nchar(countyCode)==1 ~ paste0("00", countyCode),
         nchar(countyCode)==2 ~ paste0("0", countyCode),
         is.na(countyCode) ~ "000",
         TRUE ~ as.character(countyCode)
     )) %>%
    mutate(GEOID=paste0(fipsStateCode, fipsCountyCode)) %>%
    mutate(year_closed=year(dateClosed)) %>% 
    #mutate(disaster_closed_interval=interval(declarationDate, dateClosed)) %>% 
    mutate(disaster_closed_interval=interval(declarationDate, approval_date)) %>% 
    mutate(months_disaster_closed=disaster_closed_interval %/% months(1)) %>% 
    select(-majority) %>% 
    left_join(county_data, by="GEOID") %>%
    filter(months_disaster_closed>120) %>% 
  mutate(year_approved=year(approval_date)) %>% 
  filter(year_approved>2010)
  #filter(year_closed>2010)

# Counties with at least one project that took longer than 10 years to close out
tenplus %>% 
    count(GEOID) %>% 
    mutate(project=1) %>% 
    right_join(county_data, by="GEOID") %>% 
    group_by(majority) %>%
    summarize(total=n(),
              counties=sum(project, na.rm=T)) %>% 
  ungroup() %>% 
  mutate(percent_of_counties=round(counties/total*100,1)) %>% 
  kable()
majority total counties percent_of_counties
Non-White 462 5 1.1
White 2758 11 0.4

Counties with projects that took longer than 10 years to close out in counties by poverty quantiles.

tenplus <- mega_df %>%
     mutate(fipsStateCode=case_when(
         nchar(stateNumberCode)==1 ~ paste0("0", stateNumberCode),
         TRUE ~ as.character(stateNumberCode)
     )) %>%
     mutate(fipsCountyCode=case_when(
         nchar(countyCode)==1 ~ paste0("00", countyCode),
         nchar(countyCode)==2 ~ paste0("0", countyCode),
         is.na(countyCode) ~ "000",
         TRUE ~ as.character(countyCode)
     )) %>%
    mutate(GEOID=paste0(fipsStateCode, fipsCountyCode)) %>%
    mutate(year_closed=year(dateClosed)) %>% 
    mutate(disaster_closed_interval=interval(declarationDate, dateClosed)) %>% 
    mutate(months_disaster_closed=disaster_closed_interval %/% months(1)) %>% 
    select(-majority) %>% 
    left_join(county_data, by="GEOID") %>%
    filter(months_disaster_closed>120) %>% 
    filter(year_closed>2010)

tenplus %>% 
    mutate(project=1) %>% 
    group_by(GEOID) %>% 
    summarize(projects=sum(project, na.rm=T)) %>%   
    right_join(county_data, by="GEOID") %>% 
    group_by(pov_quantile) %>%
    summarize(total=n(),
              counties=sum(projects, na.rm=T)) %>% 
  filter(!is.na(pov_quantile)) %>% 
  kable()
pov_quantile total counties
1 805 73
2 805 136
3 805 349
4 805 158

Average number of disasters affecting counties while waiting for relevant hazard mitigation projects.

project_types <- read_csv("../../data/raw/project_types.csv")

mega_df <- mega_df %>%
  left_join(project_types)

mega_df <- mega_df %>%
  mutate(incident_count=str_count(disaster_wide_type, incidentType)) 

mega_df %>%
  filter(subappType!="Management Costs") %>%
  filter(subappType!="Planning") %>%
  filter(programFy>2010) %>%
  group_by(incidentType) %>%
  summarize(average_disaster_count=round(mean(incident_count, na.rm=T),1)) %>%
  arrange(-average_disaster_count) %>% 
  head(3) %>% 
  kable()
incidentType average_disaster_count
Typhoon 3.2
Fire 2.9
Hurricane 2.2 
#Hurricane
hurricanes <- 
     mega_df %>%
     filter(subappType!="Management Costs") %>%
     filter(subappType!="Planning") %>%
     filter(programFy>2010) %>% filter(incidentType=="Hurricane")

stc <- mega_df %>% 
  filter(year(approval_date)>2010) %>% 
  filter(county=="St. Charles")
#Fire

#Severe Ice Storm
ice <- 
     mega_df %>%
     filter(subappType!="Management Costs") %>%
     filter(subappType!="Planning") %>%
     filter(programFy>2010) %>% filter(incidentType=="Severe Ice Storm")
# too many are still open

#Flood
Flood <- 
     mega_df %>%
     filter(subappType!="Management Costs") %>%
     filter(subappType!="Planning") %>%
     filter(programFy>2010) %>% filter(incidentType=="Flood")


#Tornado
tornados <- 
     mega_df %>%
     filter(subappType!="Management Costs") %>%
     filter(subappType!="Planning") %>%
     filter(programFy>2010) %>% filter(incidentType=="Tornado")

typh<- 
     mega_df %>%
     filter(subappType!="Management Costs") %>%
     filter(subappType!="Planning") %>%
     filter(programFy>2010) %>% filter(incidentType=="Typhoon")

Disasters compared to projects by county type.

disasters <- read_csv("../../data/raw/DisasterDeclarationsSummaries090321.csv") %>% 
  mutate(GEOID=paste0(fipsStateCode, fipsCountyCode)) 

# import county census data (poverty, urban, race)
county_data <- read_csv("../../data/clean/county_combined.csv") %>% 
  mutate(pov_quantile= ntile(pctpov, 4))  %>% 
  mutate(pop_quantile= ntile(poverty_population,4))
# import county names (whoops)
county_names <- read_csv("../../data/clean/county_names.csv")

county_data <- county_data %>% left_join(county_names)


county_disaster_list <- disasters %>% 
  ungroup() %>% 
  select(-placeCode, -designatedArea, -hash, -id) %>% 
  unique() %>% 
  mutate(declaration_year=year(declarationDate)) %>% 
  filter(declaration_year>2010)

write_csv(county_disaster_list, "../../data/clean/county_disaster_list_dupe.csv", na="")

county_disaster_list <- read_csv("../../data/clean/county_disaster_list_dupe.csv") %>% 
  unique()

county_disaster_count <- county_disaster_list %>% 
  count(GEOID, name="disasters") %>% 
  full_join(county_data) %>% 
  mutate(ur=case_when(
    (urban_rural > 0 & urban_rural <= 2) ~ "1. Urban",
    (urban_rural > 2 & urban_rural <= 4) ~ "2. Suburban",
    (urban_rural > 4 & urban_rural <= 6) ~ "3. Rural",
    TRUE ~ "4. Unclassified"
  )) %>% 
  filter(!is.na(NAME))

county_projects_count <- mega_df %>% 
  filter(programArea=="HMGP") %>%
  filter(year(declarationDate)>2010) %>% 
#  filter(is.na(dateClosed) | year(dateClosed)>2010) %>% 
  mutate(fipsStateCode=case_when(
    nchar(stateNumberCode)==1 ~ paste0("0", stateNumberCode),
    TRUE ~ as.character(stateNumberCode)
  )) %>%
  mutate(fipsCountyCode=case_when(
    nchar(countyCode)==1 ~ paste0("00", countyCode),
    nchar(countyCode)==2 ~ paste0("0", countyCode),
    is.na(countyCode) ~ "000",
    TRUE ~ as.character(countyCode)
  )) %>%
  mutate(GEOID=paste0(fipsStateCode, fipsCountyCode)) %>% 
  count(GEOID, name="projects")

county_projects_disasters <- full_join(county_disaster_count, county_projects_count) %>% 
  filter(!is.na(NAME))

ggplot(county_projects_disasters, aes(x=disasters, y=projects, color=ur)) +
  geom_point()+
  #geom_smooth(method='lm', formula= y~x, se=FALSE) +
  geom_abline(intercept=0, slope=1) +
  geom_smooth(method=lm) +
  labs(title="Number of projects versus disasters by county type") +
  theme_minimal()

Urban counties are twice as likely on average to receive funding after a disaster than rural areas.

county_projects_disasters %>% 
  mutate(projects2=case_when(
    is.na(projects) ~ 0,
    TRUE ~ as.numeric(projects)
  ),
  disasters2=case_when(
    is.na(disasters) ~ 0,
    TRUE ~ as.numeric(disasters)
  )) %>% 
  mutate(ratio=projects2/disasters2) %>% 
  group_by(ur) %>% 
  summarize(average_ratio = mean(ratio, na.rm=T)) %>% 
  kable()
ur average_ratio
1. Urban 0.5252977
2. Suburban 0.4593427
3. Rural 0.2310508
4. Unclassified 0.0703265

Half of all rural counties in the U.S. experienced a disaster over the past 10 years, yet didn’t have a single mitigation project.

disasters_counties <- read_csv("../../data/raw/DisasterDeclarationsSummaries090321.csv") %>% 
  mutate(GEOID=paste0(fipsStateCode, fipsCountyCode)) %>% 
  filter(incidentType=="Biological") %>% 
  filter(year(declarationDate)>2010) %>% 
  select(GEOID) %>% 
  unique()


counties_only <- mega_df %>% 
  filter(year(declarationDate)>2010) %>% 
  select(GEOID) %>% 
  unique() %>% 
  left_join(county_data, by="GEOID") %>% 
  mutate(ur=case_when(
      (urban_rural > 0 & urban_rural <= 2) ~ "1. Urban",
      (urban_rural > 2 & urban_rural <= 4) ~ "2. Suburban",
      (urban_rural > 4 & urban_rural <= 6) ~ "3. Rural",
      TRUE ~ "4. Unclassified"
    )) %>%
    count(ur, name="counties_with_projects")

no_mitigation <- readRDS("../../data/clean/no_mitigation.RDS")
county_data_none <- county_data %>%
  mutate(pov_quantile= ntile(pctpov, 4)) %>%
  filter(GEOID %in% no_mitigation)

total_ur <- county_data %>% 
  count(urban_rural, name="total_counties")
# 
# county_data_none %>%
#   count(urban_rural) %>% 
#   left_join(total_ur) %>% 
#   mutate(percent=round(n/total_counties*100,1)) %>% 
#   rename(counties_with_no_projects=n,
#          counties=total_counties) %>% 
#   filter(!is.na(urban_rural)) %>% 
#   kable()

county_data_none <- county_data %>%
  mutate(pov_quantile= ntile(pctpov, 4)) %>%
  filter(GEOID %in% no_mitigation)

total_ur <- county_data %>% 
  count(urban_rural, name="total_counties")

county_data_none %>%
  count(urban_rural) %>% 
  left_join(total_ur) %>% 
mutate(ur=case_when(
    (urban_rural > 0 & urban_rural <= 2) ~ "1. Urban",
    (urban_rural > 2 & urban_rural <= 4) ~ "2. Suburban",
    (urban_rural > 4 & urban_rural <= 6) ~ "3. Rural",
    TRUE ~ "4. Unclassified"
  )) %>%
  group_by(ur) %>% 
  summarize(total_counties=sum(total_counties),
            n=sum(n)) %>% 
  left_join(counties_only) %>% 
  filter(ur!="4. Unclassified") %>% 
  mutate(percent=round(n/total_counties*100,1)) %>% 
  rename(type=ur,
         `total counties`=total_counties,
         `qualified counties with no projects`=n,
         `counties with projects`=counties_with_projects,
         `percent counties with no projects`=percent) %>% 
  kable()
type total counties qualified counties with no projects counties with projects percent counties with no projects
1. Urban 436 155 281 35.6
2. Suburban 730 228 502 31.2
3. Rural 1976 908 1067 46.0

Southern states wait longer.

states <- read_csv("../../data/raw/states.csv")

mega_df %>%
  mutate(fipsStateCode=case_when(
    nchar(stateNumberCode)==1 ~ paste0("0", stateNumberCode),
    TRUE ~ as.character(stateNumberCode)
  )) %>%
  mutate(fipsCountyCode=case_when(
    nchar(countyCode)==1 ~ paste0("00", countyCode),
    nchar(countyCode)==2 ~ paste0("0", countyCode),
    is.na(countyCode) ~ "000",
    TRUE ~ as.character(countyCode)
  )) %>%
  mutate(GEOID=paste0(fipsStateCode, fipsCountyCode)) %>%
  mutate(year_closed=year(dateClosed)) %>% 
  mutate(disaster_closed_interval=interval(declarationDate, dateClosed)) %>% 
  mutate(months_disaster_closed=disaster_closed_interval %/% months(1)) %>% 
  filter(year(dateClosed)>2010) %>% 
  left_join(states, by=c("fipsStateCode"="st_fips")) %>% 
  group_by(region.y) %>% 
  summarize(total=n(),
            costs=sum(projectAmount, na.rm=T),
            months_declared_closed=round(mean(months_disaster_closed, na.rm=T),1)) %>% 
  arrange(-months_declared_closed) %>% 
  filter(!is.na(region.y)) %>% 
  kable()
region.y total costs months_declared_closed
South 4529 2986186893 80.9
Northeast 1431 902396328 74.4
West 888 520122488 73.3
Midwest 2415 1438674982 58.1

Specifically West South Central, which consists of Arkansas, Louisiana, Oklahoma, and Texas.

mega_df %>%
  mutate(fipsStateCode=case_when(
    nchar(stateNumberCode)==1 ~ paste0("0", stateNumberCode),
    TRUE ~ as.character(stateNumberCode)
  )) %>%
  mutate(fipsCountyCode=case_when(
    nchar(countyCode)==1 ~ paste0("00", countyCode),
    nchar(countyCode)==2 ~ paste0("0", countyCode),
    is.na(countyCode) ~ "000",
    TRUE ~ as.character(countyCode)
  )) %>%
  mutate(GEOID=paste0(fipsStateCode, fipsCountyCode)) %>%
  mutate(year_closed=year(dateClosed)) %>% 
  mutate(disaster_closed_interval=interval(declarationDate, dateClosed)) %>% 
  mutate(months_disaster_closed=disaster_closed_interval %/% months(1)) %>% 
  filter(year(dateClosed)>2010) %>% 
  left_join(states, by=c("fipsStateCode"="st_fips")) %>% 
  group_by(division) %>% 
  summarize(total=n(),
            costs=sum(projectAmount, na.rm=T),
            months_declared_closed=round(mean(months_disaster_closed, na.rm=T),1)) %>% 
  arrange(-months_declared_closed) %>% 
  filter(!is.na(division)) %>% 
  kable()
division total costs months_declared_closed
West South Central 1643 1370051448 97.8
Middle Atlantic 865 783599758 77.6
Pacific 546 375097146 76.0
East North Central 470 249205028 75.8
East South Central 1506 629269697 74.4
New England 566 118796570 69.6
Mountain 342 145025342 69.1
South Atlantic 1380 986865747 68.0
West North Central 1945 1189469954 53.8