Introduction

This document explores a handful of characteristics of Buncombe County, NC which could be relevant to planning efforts in the area. It includes an exploration of 2022 American Community Survey (ACS) estimates at the block group level, some basic summary statistics of automobile accidents over the past decade, and federal grants from the US Department of Transportation.


knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(warning = FALSE)

buncombe16_clean <- readRDS('buncombe16_clean.rds')
buncombe22_clean <- read_rds('buncombe22_clean.rds')
acs_long <- readRDS('acs_long.rds')

Buncombe County, NC American Community Survey


Measuring Change from 2016 to 2022

The following table and plot analyze change from 2016 ACS estimates to 2022. The figures listed represent estimated averages for all Census blocks in Buncombe County in their respective years. Notably, Buncombe County witnessed a population increase of 19,337 or about 7.7%, and an increase in average median household income of about 13% after adjusting for inflation. The county had about 12% total more housing units in 2022 than 2016, yet the vacancy rate appears to have considerably increased from 11.98% to 20.66%. Additionally, the unemployment and poverty rate both decreased while the population under 18 stayed the same while the elderly population (over 65) increased somewhat.


knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(warning = FALSE)

acs_table <- kable(acs_long, format = 'markdown')
acs_table <- kable(acs_long, format = 'markdown', caption = "Comparison of ACS Variables from 2016 to 2022") %>%
  kable_styling(bootstrap_options = c('striped', 'hover'), full_width = F) %>%
  scroll_box(width = '100%', height = '500px')

acs_table
Comparison of ACS Variables from 2016 to 2022
Variable 2016 2022
TotalPopulation 250112 269449
AvgMedianHHIncome 48218.34 70803.58
AvgMeanAge 42.08 43.93
TotalHousingUnits 115984 130081
AvgOwnerOccupancyRate 56.46 52.68
AvgRenterOccupancyRate 31.56 26.66
AvgVacancyRate 11.98 20.66
AvgElderlyPop 17.84 21.40
AvgMinorPop 18.80 18.30
AvgNewResidents 4.57 4.94
AvgPovertyRate 5.99 4.76
AvgUnemploymentRate 6.36 3.47
AvgCommuteLessThan30Min 68.46 64.09
AvgCommuteMoreThan45Min 2.39 2.32
AvgDroveAlonetoWork 73.12 70.27
AvgCarpooledtoWork 7.53 6.55
AvgWhite 88.25 85.22
AvgBlack 6.84 5.88
AvgAsian 1.25 1.24
AvgHispanic 6.06 6.41
AvgNativAmer 0.32 0.21 


knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(warning = FALSE)

acs_long <- acs_long %>%
  pivot_longer(
    cols = c(`2016`, `2022`),
    names_to = 'Year',
    values_to = 'Value')

acs_plot <- ggplot(acs_long[9:42, ], aes(x = Variable, y = as.numeric(Value), 
                                         fill = Year)) +
  geom_bar(stat = 'identity', position = position_dodge(width = 0.7)) +
  theme_minimal() +
  labs(title = 'Comparison of 2016 & 2022 ACS Variables',
       x = '', y = '', fill = 'Year') +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = 'bottom', 
        title = element_text(family = 'Artifakt Element'),
        legend.text = element_text(family = 'Artifakt Element')) 

acs_plot


Where are the vacant units?

Given the apparantly dramatic uptick in vacancy rates, closer examination of the Census blocks reveals many are clustered in the neighborhoods of Montreat, Black Mountain, Weaverville, and Royal Pines.

# Mapping Vacant Units

# 2016
vacancy16 <- buncombe16_clean %>%
  ggplot() +
  geom_sf(aes(fill = PctVacant)) +
  scale_fill_met_c(name = 'OKeeffe2') +  
  labs(title = '2016', fill = 'Vacancy Rate (%)') +
  theme_void() +
  theme(legend.position = 'none', 
        plot.title = element_text(hjust = 0.5, family = 'Artifakt Element'),
        legend.title = element_text(family = 'Artifakt Element'))
        
# Create the second plot for 2022
vacancy22 <- buncombe22_clean %>%
  ggplot() +
  geom_sf(aes(fill = PctVacant)) +
  scale_fill_met_c(name = 'OKeeffe2') +  
  labs(title = '2022', fill = 'Vacancy Rate (%)') +
  theme_void() +
  theme(legend.position = 'none', 
        plot.title = element_text(hjust = 0.5, family = 'Artifakt Element'),
        legend.title = element_text(family = 'Artifakt Element'))

vacancy_combined <- ggarrange(vacancy16, vacancy22, nrow = 1,
                              common.legend = TRUE, legend = 'bottom')

vacancy_combined <- annotate_figure(vacancy_combined, top = text_grob('Buncombe County Vacancy Rates',
                                                                      just = 'centre', size = 16, 
                                                                      family = 'Artifakt Element', face = 'bold'))
vacancy_combined


Buncombe County had an average vacancy rate of 11.98% in 2016 and 20.66% in 2022. In 2016, there were 70, 45%, Census block groups where the vacancy rate was above the average and 77, 46%, in 2022.

Exploring 2022 ACS Data

The interactive map below features 2022 5-year ACS estimates for Buncombe County acquired through the US Census Bureau’s public API. By navigating the map, users can examine each block group’s characteristics including selected demographics, commute variables, and unemployment rates among others. Note that “New Residents” are those who lived in a different Metropolitan Statistical Area than Asheville within the past year.


knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(warning = FALSE)

# interactive map
pal <- RColorBrewer::brewer.pal(n = 12, name = 'YlGnBu')
tmap_mode('view')
map <- tm_shape(buncombe22_clean) +
  tm_basemap('OpenStreetMap') +
  tm_polygons("TotPopE", 
              title = "Total Population", 
              palette = pal, 
              style = 'quantile', n = 8,
              alpha = 0.25,
              border.col = "black",
              id = 'NAME',
              popup.vars = c('Total Population' = 'TotPopE',
                             'Median Household Income' = 'MedHHIncomeE',
                             'Median Structure Year' = 'MedianStructureYearE',
                             'Total Housing Units' = 'TotHousingUnitsE',
                             'Percent Vacant Housing' = 'PctVacant',
                             'Percent Owner Occupied' = 'PctOwnerOcc',
                             'Percent Renter Occupied' = 'PctRenterOcc',
                             'Percent White' = 'PctWhite',
                             'Percent Black' = 'PctBlack',
                             'Percent Hispanic' = 'PctHispanic',
                             'Percent Asian' = 'PctAsian',
                             'Percent Native American' = 'PctIndian',
                             'Percent Elderly' = 'PctElderly',
                             'Percent Minors' = 'PctMinors',
                             'Percent New Residents' = 'PctMigrants',
                             'Percent Less Than 30 Minute Commute' = 'PctLessThan30MinCommute',
                             'Percent More Than 45 Minute Commute' = 'PctMoreThan45MinCommute',
                             'Percent Drove Alone to Work' = 'PctDroveAlone',
                             'Percent Carpooled to Work' = 'PctCarpooled',
                             'Percent Unemployed' = 'PctUnemployed',
                             'Percent Poverty' = 'PctPov')) 
map



10 Years of Car Crashes

The following plots and map were created by acquiring a shapefile containing crash data from the North Carolina Department of Transportation ArcGIS Online Profile. Further analysis of this dataset could include correlations between various conditions such as alcohol, weather, or speed; performing a spatial join with NCDOT’s Annual Average Daily Traffic volume maps to assess where the highest incidents per capita (or vehicle, in this case) occur.

knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(warning = FALSE)

# load crash data and filter to buncombe
crash_shp <- read_rds('crash_shp.rds')

# crash summary stats
# wrangle time data first...
crash_shp <- crash_shp %>%
  mutate(Date = str_remove(Date, "\\."),
         Date = mdy(Date))

crash_shp <- crash_shp %>%
  mutate(Year = year(Date),
         Month = month(Date))

crash_shp <- crash_shp %>%
  mutate(Hour = hour(hm(Time)),  
         Minute = minute(hm(Time))) 

crash_severity_data <- st_drop_geometry(crash_shp) %>%
  filter(Crash_Seve %in% c('K', 'A')) %>%
  group_by(Month, Crash_Seve) %>%
  summarise(Count = n(), .groups = 'drop')
knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(warning = FALSE)

# monthly distribution of fatal/serious injuries plot
p1 <- crash_severity_data %>%
  ggplot(aes(x = factor(Month, levels = 1:12), y = Count,
             fill = Crash_Seve)) +
  geom_bar(stat = 'identity', position = 'dodge') +
  scale_fill_viridis_d(begin = 0.3, end = 0.8, direction = 1, name = 'Severity',
                       labels = c('K' = 'Fatal', 'A' = 'Serious')) +
  labs(x = '', y = 'Number of Crashes',
       title = 'Distribution of Fatal and Serious Injuries by Month',
       subtitle = 'Buncombe County, NC | 2014 - 2023') +
  theme_minimal(base_family = 'Artifakt Element') +
  theme(legend.position = 'bottom') +
  scale_x_discrete(labels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"))

p1


fatal_ratio <- crash_severity_data %>%
  group_by(Month) %>%
  summarise(TotalFatal = sum(Count[Crash_Seve == 'K']),
            TotalCrashes = sum(Count),
            FatalRatio = TotalFatal / TotalCrashes) %>%
  arrange(desc(FatalRatio)) 

fatal_ratio <- fatal_ratio %>%
  mutate(MonthName = factor(Month, levels = 1:12,
                            labels = month.name),
         FatalRatio = round(FatalRatio*100, 2))

fatal_ratio <- fatal_ratio[c(5, 3, 2, 4)]

fatal_ratio <- fatal_ratio %>%
  rename(`Total Fatal` = TotalFatal,
         `Total Crashes` = TotalCrashes,
         `Fatality Ratio` = FatalRatio,
         Month = MonthName)

# Create a kable 
kable_fatal_ratio <- kable(fatal_ratio, format = 'markdown', 
                           col.names = c('Month Name', 'Total Crashes', 'Total Fatal', 'Fatality Ratio'),
                           caption = 'Most Fatal Months (Greatest to Least)')

kable_fatal_ratio
Most Fatal Months (Greatest to Least)
Month Name Total Crashes Total Fatal Fatality Ratio
January 65 31 47.69
March 59 28 47.46
September 75 32 42.67
November 60 25 41.67
December 64 24 37.50
February 70 26 37.14
June 76 28 36.84
July 63 23 36.51
October 86 30 34.88
April 63 21 33.33
August 68 22 32.35
May 67 17 25.37 


knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(warning = FALSE)

# crash severity by accident type
crash_sev_bytype <- st_drop_geometry(crash_shp) %>%
  group_by(Crash_Seve, Crash_Type) %>%
  summarise(Count = n(), .groups = 'drop')


p2 <- crash_sev_bytype %>%
  ggplot(aes(x = Crash_Type, y = Count, fill = Crash_Seve)) +
  geom_bar(stat = 'identity', position = 'dodge') +
  scale_fill_viridis_d(name = 'Severity', labels = c('K' = 'Fatal', 'A' = 'Serious'),
                       option = 'cividis') +
  labs(x = '', y = 'Number of Crashes',
       title = 'Crash Severity by Type') + 
  theme_minimal(base_family = 'Artifakt Element') + coord_flip()

p2


knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(warning = FALSE)

crash_shp <- crash_shp %>%
  mutate(Fatal = ifelse(Crash_Seve == 'K', 'Fatal', 'Non-fatal'))
tmap_mode('view')

# Create heatmap
heat_map <- tm_shape(crash_shp) +
  tm_basemap('OpenStreetMap') +
  tm_dots(col = "Fatal", palette = c("red", "grey"), size = 0.1, 
          style = "fixed", alpha = 0.5, 
          title = "Crash Severity",
          id = 'On_Road',
          popup.vars = c('Date' = 'Date',
                         'Time' = 'Time',
                         'Crash Severity' = 'Fatal',
                         'Crash Type' = 'Crash_Type',
                         'Number of Vehicles' = 'Num_Vehicl',
                         'Weather' = 'Weather',
                         'Alcohol Related' = 'Alcohol_Re',
                         'Speed Related' = 'Speed_Rela',
                         'Unbelted Driver' = 'Unbelted_D',
                         'Heavy Truck' = 'Heavy_Truc')) +
  tm_layout(main.title = 'Buncombe County, NC Auto Accidents\n2014-2023',
           main.title.position = "center",
           main.title.size = 1.5,  
           frame = FALSE) 

heat_map


Tracking Federal Grants

To get a sense of many federal transportation dollars are reaching Buncombe County, I searched usaspending.gov for all grants where the Department of Transportation was the prime award funding agency and Buncombe County was listed as the subawardee. I repeated this process for the Land of Sky Regional Council (LOSRC). Between 2011 and 2022, Buncombe County was listed as a subawardee on 28 DOT funded grants while LOSRC was listed as a subawardee on 34. LOSRC primarily received funding through 20.505, Highway Planning and Construction Program.

knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(warning = FALSE)

buncombe_sub <- readRDS('buncombe_sub.rds')
losrc_sub <- readRDS('losrc_sub.rds')

# wrangle buncombe co. subaward data
buncombe_sub <- buncombe_sub %>%
  filter(prime_award_awarding_agency_name == 'Department of Transportation (DOT)')

buncombe_sub <- buncombe_sub %>%
  separate(col = prime_award_cfda_numbers_and_titles,
           into = c('CFDA', 'Description'),
           sep = ':\\s*',
           extra = 'merge')

buncombe_summary <- buncombe_sub %>%
  group_by(CFDA) %>%
  summarise(Count = n(),
            TotalSubaward = sum(subaward_amount))
knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(message = FALSE)
knitr::opts_chunk$set(warning = FALSE)

# create dataframe legend
legend <- data.frame(
  CFDA = c('20.703', '20.601', '20.526', '20.516', '20.509', '20.505'),
  Description = c('Interagency Hazardous Materials Public Sector Training and Planning Grants',
                  'Alcohol Impaired Driving Countermeasures Incentive Grants',
                  'Buses and Bus Facilities Formula, Competitive, and Low or No Emissions Program',
                  'Job Access and Reverse Commute Program',
                  'Formula Grants for Rural Areas and Tribal Transit Program',
                  'Metropolitan Transportation Planning and State and Non-Metropolitan Planning and Research'))

kable_output <- kable(legend, format = 'markdown', caption = 'List of CFDA Programs')
kable_output
List of CFDA Programs
CFDA Description
20.703 Interagency Hazardous Materials Public Sector Training and Planning Grants
20.601 Alcohol Impaired Driving Countermeasures Incentive Grants
20.526 Buses and Bus Facilities Formula, Competitive, and Low or No Emissions Program
20.516 Job Access and Reverse Commute Program
20.509 Formula Grants for Rural Areas and Tribal Transit Program
20.505 Metropolitan Transportation Planning and State and Non-Metropolitan Planning and Research 
p3 <- buncombe_summary %>%
  ggplot(aes(x = CFDA, y = TotalSubaward, fill = CFDA)) +  
  geom_col() +
  scale_fill_viridis_d() +  
  labs(x = '', y = 'Total Subaward',  
       title = 'Buncombe County DOT Grant Funding',
       subtitle = '2011-2022') +
  theme_minimal(base_family = 'Artifakt Element') +
  scale_y_continuous(labels = scales::dollar_format(prefix = '$', suffix = '')) +  
  theme(legend.position = 'none') +
  coord_flip()  

p3