A brief weblog put up in the present day which is simply all about producing this animation, which I used for a piece presentation yesterday:
It’s tremendous simple and it’s price placing on the market how one can do it, if solely to encourage individuals to suppose extra about demography within the Pacific. And animated inhabitants pyramids are cool.
Concerning the substance, it’s a well-recognized sample for these within the area. The populations begin at small, quick rising and heavy in younger individuals; and over time change into extra evenly unfold over age teams and certainly in some instances positively aged. There are a couple of fascinating quirks such because the very excessive variety of males in Guam early within the interval, reflecting the predominance of the US navy within the inhabitants numbers at the moment. Some smaller nations with learn outwards immigration choices, like Niue, have been shrinking proper from the very starting of the interval.
It’s a easy three step course of. First, we obtain the information from the Pacific Information Hub “PDH.stat”, and do some formatting and reshaping to make it simple to attract the chart with the best nation names and inhabitants totals within the aspect labels:
library(tidyverse)
library(rsdmx)
library(scales)
library(janitor)
library(ISOcodes)
library(glue)
require(spcstyle)
#============Animated inhabitants pyramids=====================
if(!exists("proj_raw"))>
as_tibble()
#' Format a quantity as hundreds of thousands or 1000's
format_num <- operate(x){
y <- dplyr::case_when(
# had to make use of spherical explicitly due to one thing humorous taking place later with pops' creation:
x > 1e6 ~ paste0(format(spherical(x / 1e6, digits = 1), nsmall = 1, scientific = FALSE), "m"),
x > 1e3 ~ paste0(format(spherical(x / 1e3, digits = 1), nsmall = 1, scientific = FALSE), "okay"),
TRUE ~ as.character(spherical(x))
)
return(str_squish(y))
}
# take a look at that operate works as anticipated
stopifnot(format_num(1234567.1234) == "1.2m")
stopifnot(format_num(1234.1234) == "1.2k")
stopifnot(format_num(12) == "12")
# create a pops information body, full with nation names that embrace
# the inhabitants in that yr
pops <- proj_raw |>
# remove the totals we solely need male, feminine, and explicit age teams:
filter(intercourse != "_T" & age != "_T") |>
# remove the subregional groupings - we solely need nations / territories
filter(!geo_pict %in% c("_T", "_TXPNG", "MELXPNG", "MEL", "POL", "MIC")) |>
# select the best indicator
filter(indicator == "MIDYEARPOPEST") |>
# fiddle a bit with the age classes to ensure we've got them accurately
# so as:
mutate(age = gsub("^Y", "", age)) |>
separate(age, into = c("from", "to"), sep = "T", take away = FALSE) |>
mutate(age = gsub("T", "-", age),
age = gsub("-999", "+", age, fastened = TRUE),
intercourse = case_when(
intercourse == "M" ~ "Male",
intercourse == "F" ~ "Feminine"
)) |>
mutate(age = issue(age),
intercourse = fct_relevel(intercourse, "Male"))|>
# be a part of the geo_pict nation codes to the total nation names:
left_join(ISO_3166_1, by = c("geo_pict" = "Alpha_2")) |>
# calculate whole inhabitants in any given yr, for displaying in aspect label:
group_by(geo_pict, obs_time) |>
mutate(total_pop = sum(obs_value)) |>
# inhabitants in 2024 which we'll use for ordering the aspects within the chart
# (we wish the ordering to be steady over time):
group_by(geo_pict) |>
mutate(total_pop_2024 = sum(obs_value[obs_time == 2024])) |>
ungroup() |>
# Fiddle a bit with the nation names so that they match properly
mutate(short_name = gsub("Federated States of", "Fed Sts", Identify),
short_name = gsub("Mariana Islands", "Marianas", short_name)) |>
mutate(pict = glue("{short_name}: {format_num(total_pop)}")) |>
mutate(pict = fct_reorder(pict, total_pop_2024))Second, we draw 101 plots, one for every year, and save them as photos in a short lived folder. I like to do that explicitly (saving every body of the animation in a loop) as I discover it usually simpler to troubleshoot this fashion:
#-----------------------Draw plot--------------------
# see https://weblog.datawrapper.de/gendercolor/
pal <- c("#D4855A", "#C5CB81")
names(pal) <- c("Feminine", "Male")
# Reverse order so Male seems on left in legend:
pal <- pal[2:1]
ff <- "Calibri"
dir.create("tmp_pyramids", showWarnings = FALSE)
for(y in 1950:2050){
p1 <- ggplot(filter(pops, obs_time == y), aes(y = age, fill = intercourse)) +
facet_wrap(~pict, scales = "free_x", ncol = 7) +
geom_col(information = filter(pops, intercourse == "Male" & obs_time == y),
aes(x = -obs_value)) +
geom_col(information = filter(pops, intercourse == "Feminine" & obs_time == y),
aes(x = obs_value)) +
scale_fill_manual(values = pal) +
scale_x_continuous(label = comma) +
theme_void(base_family = ff) +
theme(axis.textual content.y = element_text(hjust = 1, measurement = 6),
axis.title.x = element_text(),
legend.place = "high",
plot.caption = element_text(hjust = 0.5, color = "grey20"),
panel.background = element_rect(fill = "grey95", color = NA),
plot.margin = unit(c(3,3,3,3), "mm")) +
labs(title = glue("Inhabitants estimates and projections in {y}"),
subtitle = "Pacific Island Nation and Territory members of the Pacific Group",
x = "Variety of individuals",
fill = "",
caption = "Supply: UN Inhabitants Projections within the Pacific Information Hub")
sc <- 5
png(glue("tmp_pyramids/{y}.png"),
width = 7000 / sc, peak = 4000 / sc, res = 600 / sc, kind = "cairo-png")
print(p1)
dev.off()
}Lastly, we use ImageMagick to transform these 101 PNG photos right into a single GIF. This can be a single line of code on the command line; if we need to do it with out leaving R it’s simple sufficient:
# subsequent step requires imagemagick to be put in. Takes about 30 seconds.
wd <- setwd("tmp_pyramids")
system('magick -loop -50 -delay 10 *.png "0291-pac_pyramids.gif"')
setwd(wd) # return to authentic working listingAnd that’s it!
The supply for these inhabitants projections (at the least proper now) is the UN Inhabitants Prospects. It might be simple to adapt this code to work with every other mixture of nations, in fact. I’ve simply used the model in PDH.stat as a result of I needed to spotlight that for work, and it made it simpler for me to get simply the nations and age teams I wanted for a presentation that was put collectively in a little bit of a rush.
