us-popest-animation/R/02_population-animations.R

## ----setup, include=FALSE------------------------------------------------
knitr::opts_chunk$set(echo=FALSE)

## ----library-------------------------------------------------------------
library(dplyr)
library(purrr)
library(tidyr)
library(stringr)
library(readr)
library(forcats)
library(gganimate)

DATA_DIR <- "data-raw"
ANIM_OUT <- "anim"
fs::dir_create(here::here(ANIM_OUT))

pop <- readRDS(here::here("data", "pop_estimates_by_age.rds"))

# Functions ---------------------------------------------------------------

scale_abs_percent <- function(x, ...) {
  scales::percent(abs(x), ...)
}

pretty_num_abs <- function(x, decimal_digits = 0, ...) {
  grkmisc::pretty_num(abs(x), decimal_digits = decimal_digits, ...)
}

create_animation <- function(gganim, filename, base_dir = ANIM_OUT,
                             output_format = c("mp4", "gif"),
                             delete_frames = FALSE,
                             nframes = 161, fps = 25, loop = FALSE,
                             width = 2080, height = 960, res = 144) {
  grkmisc::logger(msg = glue::glue("Creating {filename} frames"))
  ga_files <-
    animate(gganim,
            width = width, height = height, res = res, fps = fps, nframes = nframes,
            renderer = file_renderer(here::here(ANIM_OUT, "frames"), filename, overwrite = TRUE))

  first_last <- first_last_new <- ga_files[c(1, length(ga_files))]
  first_last_new[1] <- sub("\\d+\\.png", "_first.png", first_last[1])
  first_last_new[2] <- sub("\\d+\\.png", "_last.png", first_last[2])
  fs::file_copy(first_last, fs::path(ANIM_OUT, fs::path_file(first_last_new)), overwrite = TRUE)

  if ("mp4" %in% output_format) {
    grkmisc::logger(msg = glue::glue("Writing MP4 {filename} animation"))
    av::av_encode_video(
      ga_files,
      here::here(ANIM_OUT, fs::path(filename, ext = "mp4")),
      framerate = fps,
      verbose = TRUE
    )
  }

  if ("gif" %in% output_format) {
    grkmisc::logger(msg = glue::glue("Writing gif {filename} animation"))
    gifski::gifski(
      ga_files,
      here::here(ANIM_OUT, fs::path(filename, ext = "gif")),
      width = width, height = height, delay = 1/fps, loop = loop
    )
  }

  if (delete_frames) unlink(ga_files)
}


# Pyramid Animation -------------------------------------------------------

age_groups <- paste(seq(0, 100, 5))
age_groups[length(age_groups)] <- paste0(age_groups[length(age_groups)], "+")


pop_age <-
  pop %>%
  bind_rows() %>%
  mutate(age_group_int = as.integer(Age) %/% 5) %>%
  group_by(age_group_int) %>%
  mutate(age_group = min(Age)) %>%
  ungroup() %>%
  select(-age_group_int) %>%
  group_by(Year, age_group) %>%
  summarize(Total = sum(Total)) %>%
  group_by(Year) %>%
  mutate(GrandTotal  = sum(Total)) %>%
  ungroup() %>%
  mutate(Total = Total/GrandTotal) %>%
  arrange(Year, age_group) %>%
  complete(Year, age_group, fill = list(Total = 0)) %>%
  # filter(Year %in% c(1930, 2000, 2018, 2030)) %>%
  mutate(
    xend = Total,
    x = -xend,
    future = Year > 2018,
    dependent = age_group < 15 | age_group > 64
  )

ga <-
  ggplot(pop_age) +
  aes(x, xend = xend, y = age_group, yend = age_group) +
  geom_segment(aes(color = future), size = 5) +
  theme_minimal(base_size = 16, base_family = "Fira Sans Condensed") +
  scale_x_continuous(labels = scale_abs_percent, expand = c(0, 0, 0, 0)) +
  scale_y_continuous(breaks = seq(0, 100, 5), labels = age_groups) +
  scale_color_manual(values = c("grey40", "#00589a"), guide = FALSE) +
  labs(x = "Percent of Population", y = NULL,
       caption = "Source: U.S. Census Bureau") +
  ggtitle("{closest_state}") +
  gganimate::transition_time(Year) +
  gganimate::transition_states(Year, 1, 1, wrap = FALSE) +
  gganimate::ease_aes("linear") +
  gganimate::enter_fade() +
  theme(
    panel.grid.major.y = element_blank(),
    panel.grid.minor.y = element_blank(),
    panel.grid.minor.x = element_blank(),
    plot.caption = element_text(color = "grey50"),
    plot.title = element_text(hjust = 0.5, size = 30)
  )

create_animation(ga, "pop-anim", fps = 25, loop = FALSE)

# Pyramid Static Images ---------------------------------------------------

gg_first_underlay <-
  pop_age %>%
  filter(Year %in% c(min(Year), max(Year))) %>%
  ggplot() +
  aes(x, xend = xend, y = age_group, yend = age_group) +
  geom_segment(aes(color = future), size = 5) +
  theme_minimal(base_size = 16, base_family = "Fira Sans Condensed") +
  scale_x_continuous(labels = scale_abs_percent, expand = c(0, 0, 0, 0)) +
  scale_y_continuous(breaks = seq(0, 100, 5), labels = age_groups) +
  scale_color_manual(values = c("grey90", "#00589a"), guide = FALSE) +
  # scale_alpha_discrete(range = c(0.75, 1)) +
  labs(x = "Percent of Population", y = NULL,
       caption = "Source: U.S. Census Bureau") +
  ggtitle(max(pop_age$Year)) +
  theme(
    panel.grid.major.y = element_blank(),
    panel.grid.minor.y = element_blank(),
    panel.grid.minor.x = element_blank(),
    plot.caption = element_text(color = "grey50"),
    plot.title = element_text(hjust = 0.5, size = 30)
  )

ggsave(
  fs::path(ANIM_OUT, "pop-anim_first-last", ext = "png"),
  gg_first_underlay,
  width = 28.89/2, height = 13.33/2, dpi = 144, device = "png", scale = 1
)

gg_dependency_ratio <-
  pop_age %>%
  filter(Year %in% c(max(Year))) %>%
  ggplot() +
  aes(x, xend = xend, y = age_group, yend = age_group) +
  geom_segment(aes(color = dependent), size = 5) +
  theme_minimal(base_size = 16, base_family = "Fira Sans Condensed") +
  scale_x_continuous(labels = scale_abs_percent, expand = c(0, 0, 0, 0),
                     limits = c(min(pop_age$x), max(pop_age$xend))) +
  scale_y_continuous(breaks = seq(0, 100, 5), labels = age_groups) +
  scale_color_manual(values = c("#bec3c3", "#00589a"), guide = FALSE) +
  labs(x = "Percent of Population", y = NULL,
       caption = "Source: U.S. Census Bureau") +
  ggtitle(max(pop_age$Year)) +
  theme(
    panel.grid.major.y = element_blank(),
    panel.grid.minor.y = element_blank(),
    panel.grid.minor.x = element_blank(),
    plot.caption = element_text(color = "grey50"),
    plot.title = element_text(hjust = 0.5, size = 30)
  )

ggsave(
  fs::path(ANIM_OUT, "pop-anim_dependency-ratio", ext = "png"),
  gg_dependency_ratio,
  width = 28.89/2, height = 13.33/2, dpi = 144, device = "png", scale = 1
)


# Pyramid Absolute Animation -------------------------------------------------------

age_groups <- paste(seq(0, 100, 5))
age_groups[length(age_groups)] <- paste0(age_groups[length(age_groups)], "+")


pop_age_abs <-
  pop %>%
  bind_rows() %>%
  mutate(age_group_int = as.integer(Age) %/% 5) %>%
  group_by(age_group_int) %>%
  mutate(age_group = min(Age)) %>%
  ungroup() %>%
  select(-age_group_int) %>%
  group_by(Year, age_group) %>%
  summarize(Total = sum(Total)) %>%
  # group_by(Year) %>%
  # mutate(GrandTotal  = sum(Total)) %>%
  ungroup() %>%
  # mutate(Total = Total/GrandTotal) %>%
  arrange(Year, age_group) %>%
  complete(Year, age_group, fill = list(Total = 0)) %>%
  # filter(Year %in% c(1930, 2000, 2018, 2030)) %>%
  mutate(
    xend = Total,
    x = -xend,
    future = Year > 2018,
    dependent = age_group < 15 | age_group > 64
  )

ga_abs <-
  ggplot(pop_age_abs) +
  aes(x, xend = xend, y = age_group, yend = age_group) +
  geom_segment(aes(color = future), size = 5) +
  theme_minimal(base_size = 16, base_family = "Fira Sans Condensed") +
  scale_x_continuous(labels = pretty_num_abs, expand = c(0, 0, 0, 0)) +
  scale_y_continuous(breaks = seq(0, 100, 5), labels = age_groups) +
  scale_color_manual(values = c("grey40", "#00589a"), guide = FALSE) +
  labs(x = "Total Age Group Population", y = NULL,
       caption = "Source: U.S. Census Bureau") +
  ggtitle("{closest_state}") +
  gganimate::transition_time(Year) +
  gganimate::transition_states(Year, 1, 1, wrap = FALSE) +
  gganimate::ease_aes("linear") +
  gganimate::enter_fade() +
  theme(
    panel.grid.major.y = element_blank(),
    panel.grid.minor.y = element_blank(),
    panel.grid.minor.x = element_blank(),
    plot.caption = element_text(color = "grey50"),
    plot.title = element_text(hjust = 0.5, size = 30)
  )

create_animation(ga_abs, "pop-anim-abs", fps = 25, nframes = 321, loop = FALSE)


# Pyramid Abs Static Images ---------------------------------------------------

gg_first_underlay <-
  pop_age_abs %>%
  filter(Year %in% c(min(Year), max(Year))) %>%
  ggplot() +
  aes(x, xend = xend, y = age_group, yend = age_group) +
  geom_segment(
    data = filter(pop_age_abs, Year == max(Year)),
    color = "#00589a",
    size = 5,
  ) +
  geom_segment(
    data = filter(pop_age_abs, Year == min(Year)),
    color = "#bec3c3",
    size = 5,
  ) +
  annotate("text", x = 0, y = 0, label = "1900", vjust = 0,
           family = "Fira Sans Condensed", size = 12) +
  theme_minimal(base_size = 16, base_family = "Fira Sans Condensed") +
  scale_x_continuous(labels = pretty_num_abs, expand = c(0, 0, 0, 0)) +
  scale_y_continuous(breaks = seq(0, 100, 5), labels = age_groups) +
  # scale_color_manual(values = c("grey90", "#00589a"), guide = FALSE) +
  # scale_alpha_discrete(range = c(0.75, 1)) +
  labs(x = "Total Age Group Population", y = NULL,
       caption = "Source: U.S. Census Bureau") +
  ggtitle(max(pop_age$Year)) +
  theme(
    panel.grid.major.y = element_blank(),
    panel.grid.minor.y = element_blank(),
    panel.grid.minor.x = element_blank(),
    plot.caption = element_text(color = "grey50"),
    plot.title = element_text(hjust = 0.5, size = 30)
  )

ggsave(
  fs::path(ANIM_OUT, "pop-anim-abs_first-last", ext = "png"),
  gg_first_underlay,
  width = 28.89/2, height = 13.33/2, dpi = 144, device = "png", scale = 1
)

gg_dependency_ratio <-
  pop_age_abs %>%
  filter(Year %in% c(max(Year))) %>%
  ggplot() +
  aes(x, xend = xend, y = age_group, yend = age_group) +
  geom_segment(aes(color = dependent), size = 5) +
  theme_minimal(base_size = 16, base_family = "Fira Sans Condensed") +
  scale_x_continuous(labels = pretty_num_abs, expand = c(0, 0, 0, 0),
                     limits = c(min(pop_age_abs$x), max(pop_age_abs$xend))) +
  scale_y_continuous(breaks = seq(0, 100, 5), labels = age_groups) +
  scale_color_manual(values = c("#bec3c3", "#00589a"), guide = FALSE) +
  labs(x = "Total Age Group Population", y = NULL,
       caption = "Source: U.S. Census Bureau") +
  ggtitle(max(pop_age$Year)) +
  theme(
    panel.grid.major.y = element_blank(),
    panel.grid.minor.y = element_blank(),
    panel.grid.minor.x = element_blank(),
    plot.caption = element_text(color = "grey50"),
    plot.title = element_text(hjust = 0.5, size = 30)
  )

ggsave(
  fs::path(ANIM_OUT, "pop-anim-abs_dependency-ratio", ext = "png"),
  gg_dependency_ratio,
  width = 28.89/2, height = 13.33/2, dpi = 144, device = "png", scale = 1
)



# Elder Dependency Animation ----------------------------------------------

pop %>%
  bind_rows() %>%
  mutate(age_group_int = as.integer(Age) %/% 5) %>%
  select(1:3, age_group_int) %>%
  filter(age_group_int > 5) %>%
  mutate(
    old = age_group_int >= 13,
    old = c("Adult", "Older Adult")[old + 1]
  ) %>%
  group_by(Year, old) %>%
  summarize(n = sum(Total)) %>%
  spread(old, n) %>%
  {
    ggplot(.) +
      aes(x = Year) +
      geom_segment(aes(xend = Year, y = Adult, yend = `Older Adult`)) +
      geom_point(aes(y = Adult), color = grkmisc::moffitt_colors$blue) +
      geom_point(aes(y = `Older Adult`), color = grkmisc::moffitt_colors$orange, size = 2)
  } %>%
  invisible()

elder_dependency <-
  pop %>%
  bind_rows() %>%
  mutate(age_group_int = as.integer(Age) %/% 5) %>%
  select(1:3, age_group_int) %>%
  mutate(
    old = case_when(
      age_group_int < 3 ~ "Children",
      age_group_int >= 13 ~ "Older Adult",
      TRUE ~ "Adult"
    )
  ) %>%
  group_by(Year, old) %>%
  summarize(n = sum(Total)) %>%
  spread(old, n) %>%
  mutate(
    dependency_elder = `Older Adult` / Adult,
    dependency_all = (`Older Adult` + Children) / Adult
  )

ga_elder_dep <-
  ggplot(elder_dependency) +
  aes(Year, dependency_elder) +
  geom_point(color = "#00589a") +
  geom_point(data = filter(elder_dependency, Year == 2018), size = 4, color = "#eb1455") +
  geom_text(
    data = filter(elder_dependency, Year == 1900),
    aes(label = round(dependency_elder * 100, 1)),
    color = "#00589a",
    size = 6, hjust = 1.25, vjust = 0.4, family = "Fira Sans Condensed"
  ) +
  geom_text(
    data = filter(elder_dependency, Year == 2018),
    aes(label = round(dependency_elder * 100, 1)),
    color = "#eb1455",
    size = 6, hjust = 1.5, vjust = 0.4, family = "Fira Sans Condensed"
  ) +
  geom_text(
    data = filter(elder_dependency, Year == 2060),
    aes(label = round(dependency_elder * 100, 1)),
    color = "#00589a",
    size = 6, hjust = -0.25, vjust = 0.4, family = "Fira Sans Condensed"
  ) +
  labs(y = "Dependency Ratio", x = NULL,
       caption = "Source: U.S. Census Bureau") +
  theme_minimal(base_size = 24, base_family = "Fira Sans Condensed") +
  theme(plot.caption = element_text(color = "grey50", size = 14)) +
  scale_y_continuous(labels = scales::percent) +
  gganimate::transition_states(Year, 1, 0, FALSE) +
  gganimate::shadow_mark()

create_animation(ga_elder_dep, "pop-dependency", delete_frames = TRUE, fps = 30, loop = FALSE)


# All Dependency Animation ------------------------------------------------

elder_dep_together <-
  elder_dependency %>%
  ungroup() %>%
  gather(timeseries, ratio, starts_with("depend")) %>%
  select(-Adult:-`Older Adult`) %>%
  mutate(timeseries = ifelse(timeseries == "dependency_elder", 0, 1))

ga_dep_together <-
  ggplot(elder_dep_together) +
  aes(Year, ratio, group = Year) +
  geom_point(aes(color = paste(timeseries)), show.legend = FALSE) +
  scale_color_manual(values = c("#00589a", "#82c878")) +
  labs(y = "Dependency Ratio", x = NULL,
       caption = "Source: U.S. Census Bureau") +
  theme_minimal(base_size = 24, base_family = "Fira Sans Condensed") +
  theme(plot.caption = element_text(color = "grey50", size = 14)) +
  scale_y_continuous(labels = scales::percent) +
  gganimate::transition_states(timeseries, 1, 0, FALSE) +
  gganimate::view_follow(fixed_x = TRUE) +
  gganimate::ease_aes("sine-in-out")+
  gganimate::shadow_mark()

create_animation(ga_dep_together, "pop-dependency-both", delete_frames = TRUE, fps = 30, loop = FALSE)