Create an interactive map that shows median age with click-to-access popup graphs for barcharts showing age distribution

interactive_map_with_barchart_age_distribution.R

# dependencies
library(tidycensus)
library(leaflet)
library(magrittr)
library(dplyr)
library(tidyr)
library(stringr)
library(ggplot2)
library(leafpop)
library(mapview)

# specify variables
age_variables <- paste0("B01001_0", stringr::str_pad(1:49, 2, side='left', pad=0))

# pull population data 
popsizes <- tidycensus::get_acs(
  geography = 'tract',
  year = 2019,
  state = 'MA',
  county = 'Middlesex',
  variables = age_variables,
  geometry = TRUE
)

# clean variables
variables <- tidycensus::load_variables(
  year = 2019,
  dataset = 'acs5')
 
# get specific variable definitions
variables %<>% filter(name %in% age_variables)

# parse estimate labels
variables %<>% separate(label, into = c('estimate_label', 'total_label', 'sex_gender', 'age_group'), sep = '!!')
variables %<>% select(-estimate_label, -total_label, -concept)
variables$sex_gender %<>% str_remove_all(":")

# join in the variable labels
popsizes %<>% left_join(variables, by = c('variable' = 'name'))

# pull out geometry data
geometry_sf <- popsizes %>% select(GEOID) %>% unique() 
popsizes %<>% sf::st_drop_geometry()

# aggregate sex/gender
popsizes %<>% group_by(GEOID, NAME, age_group) %>% 
  summarize(
    estimate = sum(estimate),
    moe = moe_sum(estimate, moe))

# assign 10-year age bands
popsizes %<>% mutate(
  age_group_10yr = case_when(
    age_group == 'Under 5 years' ~ '0-4',
    age_group %in% c('5 to 9 years', '10 to 14 years') ~ '5-14',
    age_group %in% c('15 to 17 years', '18 and 19 years', '20 years', '21 years', '22 to 24 years') ~ '15-24',
    age_group %in% c('25 to 29 years', '30 to 34 years') ~ '25-34',
    age_group %in% c('35 to 39 years', '40 to 44 years') ~ '35-44',
    age_group %in% c('45 to 49 years', '50 to 54 years') ~ '45-54',
    age_group %in% c('55 to 59 years', '60 and 61 years', '62 to 64 years') ~ '55-64',
    age_group %in% c('65 and 66 years', '67 to 69 years', '70 to 74 years') ~ '65-74',
    age_group %in% c('75 to 79 years', '80 to 84 years') ~ '75-84',
    age_group == '85 years and over' ~ '85+'
    ))

# sum up age groups within 10-year age bands
popsizes %<>% group_by(GEOID, NAME, age_group_10yr) %>% 
  summarize(estimate = sum(estimate))

# separately, get the median age
median_age <- tidycensus::get_acs(
  geography = 'tract',
  state = 'MA',
  county = 'Middlesex',
  variables = 'B01002_001',
  geometry = TRUE
  )

# make the 10-year age bands an ordered factor
popsizes$age_group_10yr %<>% factor(
  levels = c(
    '0-4', '5-14', '15-24', '25-34', '35-44', '45-54', '55-64', '65-74', '75-84', '85+'))

# nest the population sizes so we can make a plot for each GEOID/census tract
popsizes_nested <- popsizes %>% ungroup() %>% nest_by(GEOID) 

# create barchart for population distribution
popsizes_nested %<>% mutate(
  plot = list(ggplot(data %>% filter(! is.na(age_group_10yr)), aes(x = age_group_10yr, y = estimate)) + 
    geom_col() + 
    xlab("Age Group") + 
    ggtitle("Age Distribution - ", GEOID)))

# make sure the plots and median age data frames are ordered exactly the same 
popsizes_nested %<>% arrange(GEOID)
median_age %<>% arrange(GEOID)
stopifnot(identical(popsizes_nested$GEOID, median_age$GEOID))

# mapview options
mapviewOptions(fgb=FALSE) # for some reason, the plot doesn't render properly without this

# map the median age of each census tract with popup graphs showing the age distribution 
m1 <- mapview(median_age, zcol = 'estimate', popup = popupGraph(popsizes_nested$plot))
m1

# this version shows the data from the median_age dataframe 
m2 <- mapview(median_age, zcol = 'estimate', popup = popupTable(median_age))
m2 

# save the interactive map
mapshot(m1, "map.html")

Example shown: