Finalize animation and static frames

R/02_population-animations.R

@@ -16,20 +16,68 @@ fs::dir_create(here::here(ANIM_OUT))
 
 pop <- readRDS(here::here("data", "pop_estimates_by_age.rds"))
 
-## ------------------------------------------------------------------------
-ga <-
+# 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 = paste(min(Age), max(Age), sep = " - "),
-    age_group = paste(min(Age)),
-    age_group = ifelse(Age >= 100, "100+", age_group)
-  ) %>%
+  mutate(age_group = min(Age)) %>%
   ungroup() %>%
-  arrange(age_group_int, Year) %>%
-  mutate(age_group = fct_inorder(age_group)) %>%
   select(-age_group_int) %>%
   group_by(Year, age_group) %>%
   summarize(Total = sum(Total)) %>%
@@ -38,65 +86,227 @@ ga <-
   ungroup() %>%
   mutate(Total = Total/GrandTotal) %>%
   arrange(Year, age_group) %>%
-  # complete(Year, age_group, fill = list(Total = 0)) %>%
-  # filter(Year > 2000) %>%
-  {
-    ggplot(.) +
-      # aes(age_group, Total) +
-      # geom_vline(xintercept = c(1980, 1990), color = "grey50") +
-      # geom_line(aes(group = age_group)) +
-      # geom_point(size = 0.2) +
-      # geom_col(fill = "grey40") +
-      # facet_wrap(~ Year) +
-      # coord_flip() +
-      # scale_y_continuous(labels = function(x) {grkmisc::pretty_num(x, decimal_digits = 0)}) +
-      geom_segment(aes(yend = age_group, y = age_group, xend = Total), x = 0, size = 5) +
-      geom_segment(aes(yend = age_group, y = age_group, xend = Total),
-                   x = 0,
-                   size = 5,
-                   color = "grey40",
-                   alpha = 0.25,
-                   data = filter(., Year == min(Year)) %>% select(-Year)
-      ) +
-      # annotate("text", label = "{closest_state}", x = max(.$Total) * 0.8, y = 20, size = 12) +
-      theme_minimal(base_size = 16, base_family = "Fira Sans Condensed") +
-      theme(panel.grid.major.y = element_blank()) +
-      scale_x_continuous(labels = scales::percent, expand = c(0, 0, 0.05, 0)) +
-      # labs(x = "Percent of Population", y = NULL) +
-      theme(axis.title.x = element_text(hjust = 0.5, size = 30)) +
-      labs(x = "{closest_state}", y = NULL) +
-      gganimate::transition_time(Year) +
-      gganimate::transition_states(Year, 1, 0, wrap = FALSE) +
-      gganimate::ease_aes("linear") +
-      gganimate::enter_fade()
-  }
+  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
+  )
 
-grkmisc::logger(msg = "Creating pop bar frames")
-ga_files <-
-  animate(ga,
-        width = 2080, height = 960, res = 144, fps = 25, nframes = 161,
-        renderer = file_renderer(here::here(ANIM_OUT, "frames"), "pop-anim", 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)
-
-grkmisc::logger(msg = "Writing MP4 population bar animation")
-av::av_encode_video(
-  ga_files,
-  here::here(ANIM_OUT, "pop-anim.mp4"),
-  verbose = TRUE
+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
 )
 
-grkmisc::logger(msg = "Writing gif population bar animation")
-gifski::gifski(
-  ga_files,
-  here::here(ANIM_OUT, "pop-anim.gif"),
-  width = 2080, height = 960, delay = 1/18, loop = FALSE
+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
 )
 
-unlink(ga_files)
+
+
+# Elder Dependency Animation ----------------------------------------------
 
 pop %>%
   bind_rows() %>%
@@ -144,37 +354,36 @@ ga_elder_dep <-
   aes(Year, dependency_elder) +
   geom_point(color = "#00589a") +
   geom_point(data = filter(elder_dependency, Year == 2018), size = 4, color = "#eb1455") +
-  labs(y = "Dependency Ratio", x = NULL) +
+  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()
 
-grkmisc::logger(msg = "Creating elder dep frames")
-ga_elder_dep_files <-
-  animate(ga_elder_dep,
-        width = 2080, height = 960, res = 144, fps = 25, nframes = 161,
-        renderer = file_renderer(here::here(ANIM_OUT, "frames"), "pop-dependency", overwrite = TRUE))
-
-first_last <- first_last_new <- ga_elder_dep_files[c(1, length(ga_elder_dep_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)
-
-grkmisc::logger(msg = "Writing mp4 elder dependency animation")
-av::av_encode_video(
-  ga_elder_dep_files,
-  output = here::here(ANIM_OUT, "pop-dependency.mp4"),
-  verbose = TRUE
-)
+create_animation(ga_elder_dep, "pop-dependency", delete_frames = TRUE, fps = 30, loop = FALSE)
 
-grkmisc::logger(msg = "Writing gif elder dependency animation")
-gifski::gifski(
-  ga_elder_dep_files,
-  here::here(ANIM_OUT, "pop-dependency.gif"),
-  width = 2080, height = 960, delay = 1/25, loop = FALSE
-)
-unlink(ga_elder_dep_files)
+
+# All Dependency Animation ------------------------------------------------
 
 elder_dep_together <-
   elder_dependency %>%
@@ -188,37 +397,14 @@ ga_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) +
+  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()
 
-grkmisc::logger(msg = "Creating all dependency frames")
-ga_dep_together_files <-
-  animate(ga_dep_together,
-        width = 2080, height = 960, res = 144, fps = 25, nframes = 161,
-        renderer = file_renderer(here::here(ANIM_OUT, "frames"), "pop-dependency-both", overwrite = TRUE))
-
-first_last <- first_last_new <- ga_dep_together_files[c(1, length(ga_dep_together_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)
-
-grkmisc::logger(msg = "Writing mp4 all dependency animation")
-av::av_encode_video(
-  ga_dep_together_files,
-  output = here::here(ANIM_OUT, "pop-dependency-both.mp4"),
-  verbose = TRUE
-)
-
-grkmisc::logger(msg = "Writing gif all dependency animation")
-gifski::gifski(
-  ga_dep_together_files,
-  here::here(ANIM_OUT, "pop-dependency-both.gif"),
-  width = 2080, height = 960, delay = 1/25, loop = FALSE
-)
-
-unlink(ga_dep_together_files)
+create_animation(ga_dep_together, "pop-dependency-both", delete_frames = TRUE, fps = 30, loop = FALSE)