diff --git a/_projects/2025/100571079/100571079.Rmd b/_projects/2025/100571079/100571079.Rmd new file mode 100644 index 00000000..4dcf0ca2 --- /dev/null +++ b/_projects/2025/100571079/100571079.Rmd @@ -0,0 +1,645 @@ +--- +title: "Fertility Rates 2024 World Map" +description: | + Replication based on UN Population Division data. +categories: "2025" +author: José Manuel Eyzaguirre-Venegas +date: "`r Sys.Date()`" +output: + distill::distill_article: + self_contained: false + toc: true +preview: fertility_infographic.png +--- + +## Introduction + +The total fertility rate is a demographic indicator. This metric is crucial for understanding population dynamics and planning for future societal needs. + +For this project, I selected an infographic by Iswardi Ishak that visualizes global fertility rates using a choropleth map combined with ranking charts. The visualization tries to communicate the contrast between high-fertility regions (primarily in Sub-Saharan Africa) and low-fertility regions (East Asia and Europe). + +## Original Chart + +The following infographic was created by Iswardi Ishak using UN Population Division data for 2024. + + +{.external width="100%"} + + + +## Replication + +### Loading Libraries + +We begin by loading the necessary packages for data manipulation, spatial analysis, and visualization. + +```{r load-libraries, message=FALSE, warning=FALSE} +library(sf) +library(rnaturalearth) +library(rnaturalearthdata) +library(ggplot2) +library(tidyverse) +library(cowplot) +library(stringr) +library(showtext) +library(sysfonts) +library(ggchicklet) +library(ggtext) +``` + +### Data Preparation + +We use the "rnaturalearth" package to obtain world geometries and join them with the United Nations Population Division fertility rate data. Some ISO codes need manual correction for countries like Kosovo, France, and Norway. + +```{r data-manipulation, message=FALSE, warning=FALSE} +world <- ne_countries(scale = "medium", returnclass = "sf") + +geo_world <- world |> + select(geounit, iso3 = iso_a3) |> + mutate( + iso3 = case_when( + geounit == "Kosovo" ~ "XKX", + geounit == "France" ~ "FRA", + geounit == "Norway" ~ "NOR", + TRUE ~ iso3 + ) + ) + +fertility_rate <- read_csv("data/un_fertility_rates.csv.gz") + +fertility_rate_2024 <- fertility_rate |> + filter(Time == 2024) |> + select(Location, iso3 = Iso3, Value) + +db <- geo_world |> + left_join(fertility_rate_2024, by = "iso3") |> + select(country = geounit, iso3, value = Value, geometry) |> + filter(iso3 != "ATA") |> + mutate(value = round(value, 2)) +``` + +We define the countries that have labels displayed on the map by their ISO3 name code. + +```{r iso-codes} +iso_map_plot <- c( + "AFG", "DZA", "AGO", "ARG", "AUS", "BOL", "BWA", "BRA", "CAN", "CAF", + "TCD", "CHL", "CHN", "COL", "CUB", "COD", "DNK", "ECU", "EGY", "FIN", + "FRA", "DEU", "IND", "IDN", "IRN", "IRL", "JPN", "KAZ", "KEN", "LBY", + "MDG", "MYS", "MLI", "MRT", "MEX", "MNG", "MAR", "MOZ", "MMR", "NAM", + "NZL", "NER", "NGA", "NOR", "PAK", "PNG", "PRY", "PER", "PHL", "PRT", + "RUS", "SAU", "SGP", "SOM", "ZAF", "KOR", "ESP", "LKA", "SDN", "SWE", + "TWN", "TZA", "THA", "UKR", "GBR", "USA", "URY", "VEN", "VNM", "YEM", + "ZWE" +) + +db <- db |> + mutate( + show_label = iso3 %in% iso_map_plot, + .after = value + ) |> + mutate( + country = case_when( + country == "United States of America" ~ "USA", + country == "Democratic Republic of the Congo" ~ "DR Congo", + country == "Central African Republic" ~ "C.A.R", + country == "United Kingdom" ~ "UK", + TRUE ~ country + ) + ) +``` + +### Manual Label Positioning System + +One of the key challenges in replicating this visualization was positioning labels for each country. Rather than relying on automatic centroid placement, I created a manual positioning system that allows fine-tuned control over each label's location, size, color, and offset from the coordinate point. + +```{r manual-positions} +manual_positions <- tibble::tribble( + ~iso3, ~lon, ~lat, ~label_size, ~label_color, ~value_color, ~label_offset, + + # Americas + "MEX", -110, 16, 7, "black", "black", 200000, + "USA", -100, 40, 7, "black", "black", 200000, + "CAN", -110, 60, 7, "black", "black", 200000, + "CUB", -68, 26, 7, "black", "black", 200000, + "COL", -88, 5, 7, "black", "black", 200000, + "VEN", -53, 12, 7, "black", "black", 200000, + "ECU", -87, -5, 7, "black", "black", 200000, + "PER", -82, -14, 7, "black", "black", 200000, + "BRA", -53, -10, 7, "black", "black", 200000, + "BOL", -81, -22, 7, "black", "black", 200000, + "PRY", -40, -27, 7, "black", "black", 200000, + "CHL", -80, -35, 7, "black", "black", 200000, + "ARG", -50, -42, 7, "black", "black", 200000, + "URY", -44, -34, 7, "black", "black", 200000, + + # Europe + "IRL", -30, 58, 7, "black", "black", 200000, + "GBR", -17, 58, 7, "black", "black", 200000, + "PRT", -28, 40, 7, "black", "black", 200000, + "ESP", -16, 40, 7, "black", "black", 200000, + "FRA", -12, 48, 7, "black", "black", 200000, + "DEU", -6, 66, 6, "black", "black", 175000, + "DNK", -4, 74, 6, "black", "black", 175000, + "NOR", 3, 83, 6, "black", "black", 175000, + "SWE", 34, 77, 6, "black", "black", 175000, + "FIN", 40, 61, 5, "black", "black", 150000, + "UKR", 42, 55, 5, "black", "black", 150000, + "RUS", 100, 62, 7, "black", "black", 200000, + + # Africa + "MAR", -20, 32, 7, "black", "black", 200000, + "DZA", 3, 28, 6, "black", "black", 175000, + "LBY", 18, 27, 5, "black", "black", 150000, + "EGY", 30, 27, 4, "black", "black", 125000, + "MRT", -24, 22, 7, "black", "black", 200000, + "MLI", -22, 10, 7, "black", "black", 200000, + "NER", -11, 1, 7, "black", "black", 200000, + "TCD", 19, 14, 5, "#FFFDF5", "#FFFDF5", 150000, + "SDN", 30, 16, 5, "black", "black", 150000, + "NGA", 1, -1, 7, "black", "black", 200000, + "CAF", 20, 6, 4, "#FFFDF5", "#FFFDF5", 125000, + "COD", 24, -3, 4, "#FFFDF5", "#FFFDF5", 150000, + "AGO", 5, -12, 7, "black", "black", 200000, + "TZA", 57, -8, 6, "black", "black", 175000, + "KEN", 51, 0, 6, "black", "black", 175000, + "SOM", 58, 6, 6, "black", "black", 175000, + "NAM", 6, -22, 7, "black", "black", 200000, + "BWA", 8, -30, 7, "black", "black", 200000, + "ZWE", 40, -30, 6, "black", "black", 175000, + "MOZ", 60, -15, 6, "black", "black", 175000, + "ZAF", 29, -38, 7, "black", "black", 200000, + "MDG", 58, -26, 6, "black", "black", 175000, + + # Asia and Middle East + "SAU", 44, 24, 5, "black", "black", 150000, + "YEM", 56, 14, 5, "black", "black", 150000, + "IRN", 54, 33, 5, "black", "black", 150000, + "AFG", 66, 34, 4, "black", "black", 125000, + "PAK", 66, 18, 5, "black", "black", 150000, + "IND", 79, 22, 6, "black", "black", 175000, + "LKA", 74, 2, 7, "black", "black", 200000, + "KAZ", 67, 48, 5, "black", "black", 150000, + "MNG", 104, 46, 5, "black", "black", 150000, + "CHN", 104, 35, 7, "black", "black", 200000, + "MMR", 105, 27, 5, "black", "black", 150000, + "THA", 89, 8, 6, "black", "black", 175000, + "VNM", 114, 14, 5, "black", "black", 150000, + "MYS", 90, -3, 7, "black", "black", 200000, + "SGP", 94, -12, 7, "black", "black", 200000, + "IDN", 112, -14, 7, "black", "black", 200000, + "PHL", 135, 12, 7, "black", "black", 200000, + "TWN", 135, 22, 7, "black", "black", 200000, + "KOR", 146, 30, 7, "black", "black", 200000, + "JPN", 155, 40, 7, "black", "black", 200000, + + # Oceania + "AUS", 134, -25, 7, "black", "black", 200000, + "PNG", 142, 4, 7, "black", "black", 200000, + "NZL", 155, -50, 7, "black", "black", 200000 +) +``` + +The coordinates are then transformed from WGS84 (longitude/latitude) to the Robinson projection, which is the same projection used for the map. + +```{r robinson-transform} +manual_positions_sf <- manual_positions |> + st_as_sf(coords = c("lon", "lat"), crs = 4326) |> + st_transform(crs = "+proj=robin") |> + mutate( + lon_robin = st_coordinates(geometry)[,1], + lat_robin = st_coordinates(geometry)[,2] + ) |> + st_drop_geometry() + +final_db <- db |> + left_join(manual_positions_sf, by = "iso3") +``` + +### Visual Settings + +The color palette replicates the original's gradient from light yellow to dark red. I used Google Fonts (Archivo and Archivo Black) to match the typographic style. + +```{r color-settings} +color_palette <- c("#FCDCA7","#FCD0BA","#F9C8C2","#E58390","#CF4146","#C72729") + +background_colour <- "#FEF0EF" +background_color <- "#FEF0EF" + +font_add_google(name = "Archivo Black", family = "archivoblack") +font_add_google(name = "Archivo", family = "archivo") +showtext_auto() + +font_regular <- "archivo" +font_bold <- "archivoblack" +``` + +### Building the Map + +The map uses "geom_sf" for the choropleth base, with "geom_text" for country names and "geom_label" for the fertility rate values. The "scale_size_identity()" and "scale_color_identity()" functions allow us to use the exact values specified in our manual positions table. + +```{r map-plot, fig.width=10, fig.height=8} +labels_data <- final_db |> filter(show_label == TRUE) + +map_plot <- ggplot(final_db) + + geom_sf(aes(fill = value), color = "black", size = 0.25) + + + geom_text( + data = labels_data, + aes(x = lon_robin, y = lat_robin + label_offset, label = country, + size = label_size, color = label_color), + fontface = "italic", + family = font_regular + ) + + + geom_label( + data = labels_data, + aes(x = lon_robin, y = lat_robin - label_offset, label = value, + size = label_size, color = value_color), + fontface = "bold", + family = font_bold, + fill = NA, + label.size = 0.15, + label.padding = unit(c(0.1, 0.15, 0.1, 0.15), "lines") + ) + + + scale_size_identity() + + scale_color_identity() + + scale_fill_gradientn( + colours = color_palette, + na.value = "grey90" + ) + + + theme_minimal() + + theme( + plot.background = element_rect(fill = background_colour, color = NA), + axis.text = element_blank(), + axis.title = element_blank(), + panel.grid = element_blank(), + legend.position = "none" + ) + + coord_sf(crs = "+proj=robin") +``` + +### Bar Plots + +The original includes two gradient bars that serve as both legend and section dividers. These are created using "geom_tile" to simulate a color gradient. + +```{r bar-plots} +text_size <- 14.5 +text_size2 <- 12.5 + +bar_plot <- ggplot() + + geom_tile( + data = data.frame( + x = seq(0, 1, length.out = 100), + y = 0.5, + fill = seq(0, 1, length.out = 100) + ), + aes(x = x, y = y, fill = fill), + height = 1, + width = 0.0101 + ) + + scale_fill_gradientn(colours = color_palette) + + + annotate("text", x = 0.02, y = 0.5, label = "Lowest", + family = font_bold, fontface = "bold", color = "black", hjust = 0, size = text_size) + + annotate("text", x = 0.12, y = 0.5, label = "0.73 South Korea", + family = font_regular, color = "black", hjust = 0, size = text_size) + + annotate("text", x = 0.865, y = 0.5, label = "Highest", + family = font_bold, fontface = "bold", color = "white", hjust = 1, size = text_size) + + annotate("text", x = 0.98, y = 0.5, label = "6.03 Chad", + family = font_regular, color = "white", hjust = 1, size = text_size) + + + scale_x_continuous(expand = c(0, 0)) + + scale_y_continuous(expand = c(0, 0)) + + theme_void() + + theme(legend.position = "none", plot.margin = margin(0, 0, 0, 0, "pt")) + +bar_plot2 <- ggplot() + + geom_tile( + data = data.frame( + x = seq(0, 1, length.out = 100), + y = 0.5, + fill = seq(0, 1, length.out = 100) + ), + aes(x = x, y = y, fill = fill), + height = 1, + width = 0.0101 + ) + + scale_fill_gradientn(colours = color_palette) + + + annotate("text", x = 0.02, y = 0.5, label = "Top 10 Highest Total Fertility Rate (2024)", + family = font_bold, color = "black", hjust = 0, size = text_size2) + + annotate("text", x = 0.98, y = 0.5, label = "Top 10 Lowest Total Fertility Rate (2024)", + family = font_bold, color = "white", hjust = 1, size = text_size2) + + + scale_x_continuous(expand = c(0, 0)) + + scale_y_continuous(expand = c(0, 0)) + + theme_void() + + theme(legend.position = "none", plot.margin = margin(0, 0, 0, 0, "pt")) +``` + +### Ranking Charts + +The Top 10 highest and lowest fertility rate countries are displayed using bar charts with "ggchicklet" for slightly rounded corners. + +```{r ranking-plots} +ranking_label_size <- 9 +ranking_axis_x_size <- 32 +ranking_axis_y_size <- 22 + +data_high <- data.frame( + Country = c("Chad", "Somalia", "D.R Congo", "C.A.R", "Niger", + "Mali", "Angola", "Burundi", "Afghanistan", "Mozambique"), + Value = c(6.03, 6.01, 5.98, 5.95, 5.94, 5.51, 5.05, 4.79, 4.76, 4.69) +) +data_high$Country <- factor(data_high$Country, levels = data_high$Country) + +data_low <- data.frame( + Country = c("S. Korea", "Taiwan", "Singapore", "Ukraine", "China", + "Andorra", "Malta", "Chile", "San Marino", "Thailand"), + Value = c(0.73, 0.86, 0.95, 0.99, 1.01, 1.09, 1.11, 1.14, 1.16, 1.20) +) +data_low$Country <- factor(data_low$Country, levels = data_low$Country) + +col_high_bar <- "#CE4143" +col_low_bar <- "#FDDDA8" + +p_high <- ggplot(data_high, aes(x = Country, y = Value)) + + geom_chicklet(fill = col_high_bar, width = 0.85, radius = grid::unit(2, "pt"), color = NA) + + geom_text(aes(label = sprintf("%.2f", Value)), vjust = -0.5, size = ranking_label_size, fontface = "bold") + + scale_y_continuous(limits = c(0, 7), expand = c(0, 0), breaks = seq(0, 7, 1)) + + theme_minimal(base_family = "sans") + + theme( + plot.background = element_blank(), + panel.background = element_blank(), + axis.title = element_blank(), + axis.text.x = element_text(color = "black", size = ranking_axis_x_size, face = "bold", angle = 45, hjust = 1), + axis.text.y = element_text(color = "black", size = ranking_axis_y_size, face = "bold"), + panel.grid.major.x = element_blank(), + panel.grid.minor = element_blank(), + panel.grid.major.y = element_line(color = "gray85", linewidth = 0.3) + ) + +p_low <- ggplot(data_low, aes(x = Country, y = Value)) + + geom_chicklet(fill = col_low_bar, width = 0.85, radius = grid::unit(2, "pt"), color = NA) + + geom_text(aes(label = sprintf("%.2f", Value)), vjust = -0.5, size = ranking_label_size, fontface = "bold") + + scale_y_continuous(limits = c(0, 1.4), expand = c(0, 0), breaks = seq(0, 1.2, 0.2)) + + theme_minimal(base_family = "sans") + + theme( + plot.background = element_blank(), + panel.background = element_blank(), + axis.title = element_blank(), + axis.text.x = element_text(color = "black", size = ranking_axis_x_size, face = "bold", angle = 45, hjust = 1), + axis.text.y = element_text(color = "black", size = ranking_axis_y_size, face = "bold"), + panel.grid.major.x = element_blank(), + panel.grid.minor = element_blank(), + panel.grid.major.y = element_line(color = "gray85", linewidth = 0.3) + ) + +ranking_grid <- plot_grid(p_high, NULL, p_low, ncol = 3, align = "h", axis = "tb", rel_widths = c(1, 0.0, 1)) + +ranking_plot <- ggdraw(ranking_grid) + + theme(plot.background = element_rect(fill = background_colour, color = NA)) +``` + +### Header + +The header includes the main title, subtitle, and a descriptive text explaining the metric. + +```{r header-plot} +font_add_google("Oswald", family = "title_bold_font") +font_add_google("Lora", family = "title_regular_font") +showtext_auto() + +title_bold_font <- "title_bold_font" +title_regular_font <- "title_regular_font" + +title_size <- 140 +subtitle_size <- 55 +desc_size <- 16 + +text_title <- "TOTAL FERTILITY RATES" +text_subtitle <- "BY COUNTRY" +text_desc <- "The total fertility rate is defined as the average number of children that would be born alive to a woman during her lifetime if she were to pass through her childbearing years conforming to the age-specific fertility rates of a given year. (UN)" +text_desc_wrapped <- str_wrap(text_desc, width = 105) + +header_plot <- ggdraw() + + theme(plot.background = element_rect(fill = "#FEF0EF", color = NA)) + + draw_label(text_title, x = 0.5, y = 0.75, hjust = 0.5, size = title_size, + fontface = "bold", fontfamily = title_bold_font, color = "black") + + draw_label(text_subtitle, x = 0.40, y = 0.35, hjust = 1, size = subtitle_size, + fontface = "bold", fontfamily = title_bold_font, color = "black") + + draw_label(text_desc_wrapped, x = 0.41, y = 0.35, hjust = 0, size = desc_size, + fontface = "plain", fontfamily = title_regular_font, color = "black", lineheight = 0.65) +``` + +### Final Assembly + +Using cowplot's "ggdraw()" and "draw_plot()" functions, we assemble all components into the final infographic. + +```{r final-assembly, fig.width=8, fig.height=11} +final_plot <- ggdraw() + + theme(plot.background = element_rect(fill = background_colour, color = NA)) + + draw_plot(header_plot, x = 0, y = 0.85, width = 1, height = 0.15) + + draw_plot(bar_plot, x = 0, y = 0.82, width = 1, height = 0.045) + + draw_plot(map_plot, x = 0, y = 0.26, width = 0.88, height = 0.58, scale = 1.68) + + draw_plot(bar_plot2, x = 0, y = 0.25, width = 1, height = 0.045) + + draw_plot(ranking_plot, x = 0, y = 0, width = 1, height = 0.36, hjust = 0.01, vjust = 0.35) +``` + +### Exporting the Replication + +```{r save-replication} +ggsave("fertility_infographic.png", final_plot, width = 8, height = 11, dpi = 300) +``` + +```{r show-replication, echo=FALSE} +knitr::include_graphics("fertility_infographic.png") +``` + +### Limitations and weaknesses of the plot + +The plot has clean typography and a balanced layout that make the infographic visually appealing. However, with 70+ labels on the map, some regions become difficult to read. In terms of color scale, the linear gradient may not effectively show variations in the lower range of fertility rates. Regarding storytelling, the visualization doesn't focus on any particular narrative or trend, and the excess of information can be overwhelming, making it harder to communicate a clear message. + + +## Improvement: The Shrinking Nations + +For the improvement, I chose to focus on storytelling. The visualization may look simpler, but simplicity can open a window to tell a more focused story that communicates a clear idea more effectively. In this case, I decided to use the same dataset, but addressing only countries below the replacement level. This threshold is critical because populations with fertility rates below this level will eventually decline without immigration. Instead of showing all fertility rates, we highlight only countries facing potential population decline. A logarithmic color scale was applied to bring better contrast among low-fertility countries. Only the Top 5 lowest countries are labeled, reducing visual clutter. 2025 projections from the same UN dataset were used for an up-to-date result. + +### Data Preparation + +We filter the data to show only countries below the replacement level, setting others to NA (which will appear in grey). + +```{r improvement-data, message=FALSE, warning=FALSE} +fertility_rate_2025 <- fertility_rate |> + filter(Time == 2025) |> + select(Location, iso3 = Iso3, Value) + +db2 <- geo_world |> + left_join(fertility_rate_2025, by = "iso3") |> + select(country = geounit, iso3, value = Value, geometry) |> + filter(iso3 != "ATA") |> + mutate(value = round(value, 2)) + +improvement_db <- db2 |> + mutate(value_display = if_else(value < 2.1, value, NA)) +``` + +### Visual Settings for Improvement + +```{r improvement-settings} +font_add_google("Oswald", family = "title_bold_font") +font_add_google("Lora", family = "title_regular_font") +showtext_auto() + +title_bold_font <- "title_bold_font" +title_regular_font <- "title_regular_font" + +background_colour <- "#FAFAFA" +``` + +### Top 5 Ranking Annotation + +We create a small ranking chart to be embedded directly on the map, showing the 5 countries with the lowest fertility rates. + +```{r ranking-annotation} +top5_low <- data.frame( + rank = 1:5, + country = c("S. Korea", "Taiwan", "Singapore", "Ukraine", "China"), + value = c(0.73, 0.86, 0.95, 0.99, 1.01) +) + +ranking_top5 <- ggplot(top5_low, aes(y = reorder(country, -rank))) + + geom_tile(aes(x = 0, fill = value), width = 0.3, height = 0.8) + + geom_text(aes(x = 0.3, label = country), hjust = 0, size = 8, family = title_regular_font) + + geom_text(aes(x = 1.5, label = sprintf("%.2f", value)), hjust = 1, size = 8, + fontface = "bold", family = title_bold_font) + + scale_fill_viridis_c(option = "mako", trans = "log10", limits = c(0.73, 2.1)) + + scale_x_continuous(limits = c(-0.2, 1.6)) + + labs(title = "Top 5 Lowest") + + theme_void() + + theme( + legend.position = "none", + plot.title = element_text(family = title_bold_font, face = "bold", size = 30, hjust = 0.5, + margin = margin(b = 5)), + plot.background = element_rect(fill = background_colour, color = NA) + ) +``` + +We position the ranking in the Pacific Ocean, to the left of South America. + +```{r ranking-position} +ranking_pos <- tibble(lon = -125, lat = -20) |> + st_as_sf(coords = c("lon", "lat"), crs = 4326) |> + st_transform(crs = "+proj=robin") |> + mutate( + x = st_coordinates(geometry)[,1], + y = st_coordinates(geometry)[,2] + ) |> + st_drop_geometry() +``` + +### Improved Map + +```{r improvement-map} +improvement_map <- ggplot(improvement_db) + + geom_sf(aes(fill = value_display), color = "black", size = 0.25) + + scale_fill_viridis_c(option = "mako", trans = "log10", na.value = "grey85") + + annotation_custom( + grob = ggplotGrob(ranking_top5), + xmin = ranking_pos$x - 2500000, + xmax = ranking_pos$x + 2500000, + ymin = ranking_pos$y - 2500000, + ymax = ranking_pos$y + 2500000 + ) + + theme_minimal() + + theme( + plot.background = element_rect(fill = background_colour, color = NA), + axis.text = element_blank(), + axis.title = element_blank(), + panel.grid = element_blank(), + legend.position = "none" + ) + + coord_sf(crs = "+proj=robin") +``` + +### Header for Improvement + +```{r improvement-header} +text_title <- "THE SHRINKING NATIONS" +text_explanation <- "A Replacement Level of 2.1 births is the threshold for a stable population size. Countries below this level face potential population decline. This map shows all nations currently below replacement level." +text_explanation_wrapped <- str_wrap(text_explanation, width = 80) + +legend_bar <- ggplot() + + geom_tile( + data = data.frame( + x = seq(0, 1, length.out = 100), + y = 0.5, + fill = seq(0.73, 2.1, length.out = 100) + ), + aes(x = x, y = y, fill = fill), + height = 0.7, + width = 0.0101 + ) + + scale_fill_viridis_c(option = "mako", trans = "log10") + + annotate("text", x = 0, y = -0.5, label = "0.73", size = 7, hjust = 0, family = title_regular_font) + + annotate("text", x = 0.5, y = -0.5, label = "1.2", size = 7, hjust = 0.5, family = title_regular_font) + + annotate("text", x = 1, y = -0.5, label = "2.1", size = 7, hjust = 1, family = title_regular_font) + + annotate("text", x = 0.5, y = 1.5, label = "Fertility Rate (2025)", size = 10, hjust = 0.5, + family = title_bold_font, fontface = "bold") + + scale_x_continuous(expand = c(0, 0)) + + scale_y_continuous(expand = c(0, 0), limits = c(-1, 2)) + + theme_void() + + theme(legend.position = "none") + +header_plot_improvement <- ggdraw() + + theme(plot.background = element_rect(fill = background_colour, color = NA)) + + draw_label(text_title, x = 0.5, y = 0.85, hjust = 0.5, size = 80, fontface = "bold", + fontfamily = title_bold_font, color = "black") + + draw_label(text_explanation_wrapped, x = 0.05, y = 0.4, hjust = 0, vjust = 0.5, size = 24, + fontface = "plain", fontfamily = title_regular_font, color = "black", lineheight = 0.5) + + draw_plot(legend_bar, x = 0.65, y = 0.15, width = 0.3, height = 0.5) +``` + +### Footer + +```{r improvement-footer} +footer_plot <- ggplot() + + annotate("text", x = 0.70, y = 0.5, label = "Source:", size = 10, hjust = 1, + fontface = "bold", family = title_regular_font, color = "black") + + annotate("text", x = 0.71, y = 0.5, label = "United Nations Population Division", size = 10, + hjust = 0, family = title_regular_font, color = "black") + + scale_x_continuous(limits = c(0, 1), expand = c(0, 0)) + + scale_y_continuous(limits = c(0, 1), expand = c(0, 0)) + + theme_void() + + theme(plot.background = element_rect(fill = background_colour, color = NA)) +``` + +### Final Assembly + +```{r improvement-final} +final_improvement <- ggdraw() + + theme(plot.background = element_rect(fill = background_colour, color = NA)) + + draw_plot(header_plot_improvement, x = 0, y = 0.65, width = 1, height = 0.33) + + draw_plot(improvement_map, x = 0, y = 0.05, width = 1, height = 0.63, scale = 1.1) + + draw_plot(footer_plot, x = 0, y = 0, width = 1, height = 0.05) +``` + +### Exporting the Improvement + +```{r save-improvement} +ggsave("shrinking_nations.png", final_improvement, width = 8, height = 6, dpi = 300) +``` + +```{r show-improvement, echo=FALSE} +knitr::include_graphics("shrinking_nations.png") +``` + +### Limitations + +By focusing only on below-replacement countries, we lose the global perspective that shows the contrast with high-fertility nations. The 2.1 replacement level used as threshold is a simplification; actual replacement levels vary by country based on mortality rates. Additionally, the static nature of the visualization doesn't capture how countries have moved relative to this threshold over time, which could provide valuable context about demographic trends. + + + + diff --git a/_projects/2025/100571079/100571079.html b/_projects/2025/100571079/100571079.html new file mode 100644 index 00000000..997fdc1d --- /dev/null +++ b/_projects/2025/100571079/100571079.html @@ -0,0 +1,2208 @@ + + + + +
+ + + + + + + + + + + + + + + +Replication based on UN Population Division data.
+The total fertility rate is a demographic indicator. This metric is crucial for understanding population dynamics and planning for future societal needs.
+For this project, I selected an infographic by Iswardi Ishak that visualizes global fertility rates using a choropleth map combined with ranking charts. The visualization tries to communicate the contrast between high-fertility regions (primarily in Sub-Saharan Africa) and low-fertility regions (East Asia and Europe).
+The following infographic was created by Iswardi Ishak using UN Population Division data for 2024.
+
+
+We begin by loading the necessary packages for data manipulation, spatial analysis, and visualization.
+We use the “rnaturalearth” package to obtain world geometries and join them with the United Nations Population Division fertility rate data. Some ISO codes need manual correction for countries like Kosovo, France, and Norway.
+world <- ne_countries(scale = "medium", returnclass = "sf")
+
+geo_world <- world |>
+ select(geounit, iso3 = iso_a3) |>
+ mutate(
+ iso3 = case_when(
+ geounit == "Kosovo" ~ "XKX",
+ geounit == "France" ~ "FRA",
+ geounit == "Norway" ~ "NOR",
+ TRUE ~ iso3
+ )
+ )
+
+fertility_rate <- read_csv("data/un_fertility_rates.csv.gz")
+
+fertility_rate_2024 <- fertility_rate |>
+ filter(Time == 2024) |>
+ select(Location, iso3 = Iso3, Value)
+
+db <- geo_world |>
+ left_join(fertility_rate_2024, by = "iso3") |>
+ select(country = geounit, iso3, value = Value, geometry) |>
+ filter(iso3 != "ATA") |>
+ mutate(value = round(value, 2))
+We define the countries that have labels displayed on the map by their ISO3 name code.
+iso_map_plot <- c(
+ "AFG", "DZA", "AGO", "ARG", "AUS", "BOL", "BWA", "BRA", "CAN", "CAF",
+ "TCD", "CHL", "CHN", "COL", "CUB", "COD", "DNK", "ECU", "EGY", "FIN",
+ "FRA", "DEU", "IND", "IDN", "IRN", "IRL", "JPN", "KAZ", "KEN", "LBY",
+ "MDG", "MYS", "MLI", "MRT", "MEX", "MNG", "MAR", "MOZ", "MMR", "NAM",
+ "NZL", "NER", "NGA", "NOR", "PAK", "PNG", "PRY", "PER", "PHL", "PRT",
+ "RUS", "SAU", "SGP", "SOM", "ZAF", "KOR", "ESP", "LKA", "SDN", "SWE",
+ "TWN", "TZA", "THA", "UKR", "GBR", "USA", "URY", "VEN", "VNM", "YEM",
+ "ZWE"
+)
+
+db <- db |>
+ mutate(
+ show_label = iso3 %in% iso_map_plot,
+ .after = value
+ ) |>
+ mutate(
+ country = case_when(
+ country == "United States of America" ~ "USA",
+ country == "Democratic Republic of the Congo" ~ "DR Congo",
+ country == "Central African Republic" ~ "C.A.R",
+ country == "United Kingdom" ~ "UK",
+ TRUE ~ country
+ )
+ )
+One of the key challenges in replicating this visualization was positioning labels for each country. Rather than relying on automatic centroid placement, I created a manual positioning system that allows fine-tuned control over each label’s location, size, color, and offset from the coordinate point.
+manual_positions <- tibble::tribble(
+ ~iso3, ~lon, ~lat, ~label_size, ~label_color, ~value_color, ~label_offset,
+
+ # Americas
+ "MEX", -110, 16, 7, "black", "black", 200000,
+ "USA", -100, 40, 7, "black", "black", 200000,
+ "CAN", -110, 60, 7, "black", "black", 200000,
+ "CUB", -68, 26, 7, "black", "black", 200000,
+ "COL", -88, 5, 7, "black", "black", 200000,
+ "VEN", -53, 12, 7, "black", "black", 200000,
+ "ECU", -87, -5, 7, "black", "black", 200000,
+ "PER", -82, -14, 7, "black", "black", 200000,
+ "BRA", -53, -10, 7, "black", "black", 200000,
+ "BOL", -81, -22, 7, "black", "black", 200000,
+ "PRY", -40, -27, 7, "black", "black", 200000,
+ "CHL", -80, -35, 7, "black", "black", 200000,
+ "ARG", -50, -42, 7, "black", "black", 200000,
+ "URY", -44, -34, 7, "black", "black", 200000,
+
+ # Europe
+ "IRL", -30, 58, 7, "black", "black", 200000,
+ "GBR", -17, 58, 7, "black", "black", 200000,
+ "PRT", -28, 40, 7, "black", "black", 200000,
+ "ESP", -16, 40, 7, "black", "black", 200000,
+ "FRA", -12, 48, 7, "black", "black", 200000,
+ "DEU", -6, 66, 6, "black", "black", 175000,
+ "DNK", -4, 74, 6, "black", "black", 175000,
+ "NOR", 3, 83, 6, "black", "black", 175000,
+ "SWE", 34, 77, 6, "black", "black", 175000,
+ "FIN", 40, 61, 5, "black", "black", 150000,
+ "UKR", 42, 55, 5, "black", "black", 150000,
+ "RUS", 100, 62, 7, "black", "black", 200000,
+
+ # Africa
+ "MAR", -20, 32, 7, "black", "black", 200000,
+ "DZA", 3, 28, 6, "black", "black", 175000,
+ "LBY", 18, 27, 5, "black", "black", 150000,
+ "EGY", 30, 27, 4, "black", "black", 125000,
+ "MRT", -24, 22, 7, "black", "black", 200000,
+ "MLI", -22, 10, 7, "black", "black", 200000,
+ "NER", -11, 1, 7, "black", "black", 200000,
+ "TCD", 19, 14, 5, "#FFFDF5", "#FFFDF5", 150000,
+ "SDN", 30, 16, 5, "black", "black", 150000,
+ "NGA", 1, -1, 7, "black", "black", 200000,
+ "CAF", 20, 6, 4, "#FFFDF5", "#FFFDF5", 125000,
+ "COD", 24, -3, 4, "#FFFDF5", "#FFFDF5", 150000,
+ "AGO", 5, -12, 7, "black", "black", 200000,
+ "TZA", 57, -8, 6, "black", "black", 175000,
+ "KEN", 51, 0, 6, "black", "black", 175000,
+ "SOM", 58, 6, 6, "black", "black", 175000,
+ "NAM", 6, -22, 7, "black", "black", 200000,
+ "BWA", 8, -30, 7, "black", "black", 200000,
+ "ZWE", 40, -30, 6, "black", "black", 175000,
+ "MOZ", 60, -15, 6, "black", "black", 175000,
+ "ZAF", 29, -38, 7, "black", "black", 200000,
+ "MDG", 58, -26, 6, "black", "black", 175000,
+
+ # Asia and Middle East
+ "SAU", 44, 24, 5, "black", "black", 150000,
+ "YEM", 56, 14, 5, "black", "black", 150000,
+ "IRN", 54, 33, 5, "black", "black", 150000,
+ "AFG", 66, 34, 4, "black", "black", 125000,
+ "PAK", 66, 18, 5, "black", "black", 150000,
+ "IND", 79, 22, 6, "black", "black", 175000,
+ "LKA", 74, 2, 7, "black", "black", 200000,
+ "KAZ", 67, 48, 5, "black", "black", 150000,
+ "MNG", 104, 46, 5, "black", "black", 150000,
+ "CHN", 104, 35, 7, "black", "black", 200000,
+ "MMR", 105, 27, 5, "black", "black", 150000,
+ "THA", 89, 8, 6, "black", "black", 175000,
+ "VNM", 114, 14, 5, "black", "black", 150000,
+ "MYS", 90, -3, 7, "black", "black", 200000,
+ "SGP", 94, -12, 7, "black", "black", 200000,
+ "IDN", 112, -14, 7, "black", "black", 200000,
+ "PHL", 135, 12, 7, "black", "black", 200000,
+ "TWN", 135, 22, 7, "black", "black", 200000,
+ "KOR", 146, 30, 7, "black", "black", 200000,
+ "JPN", 155, 40, 7, "black", "black", 200000,
+
+ # Oceania
+ "AUS", 134, -25, 7, "black", "black", 200000,
+ "PNG", 142, 4, 7, "black", "black", 200000,
+ "NZL", 155, -50, 7, "black", "black", 200000
+)
+The coordinates are then transformed from WGS84 (longitude/latitude) to the Robinson projection, which is the same projection used for the map.
+manual_positions_sf <- manual_positions |>
+ st_as_sf(coords = c("lon", "lat"), crs = 4326) |>
+ st_transform(crs = "+proj=robin") |>
+ mutate(
+ lon_robin = st_coordinates(geometry)[,1],
+ lat_robin = st_coordinates(geometry)[,2]
+ ) |>
+ st_drop_geometry()
+
+final_db <- db |>
+ left_join(manual_positions_sf, by = "iso3")
+The color palette replicates the original’s gradient from light yellow to dark red. I used Google Fonts (Archivo and Archivo Black) to match the typographic style.
+color_palette <- c("#FCDCA7","#FCD0BA","#F9C8C2","#E58390","#CF4146","#C72729")
+
+background_colour <- "#FEF0EF"
+background_color <- "#FEF0EF"
+
+font_add_google(name = "Archivo Black", family = "archivoblack")
+font_add_google(name = "Archivo", family = "archivo")
+showtext_auto()
+
+font_regular <- "archivo"
+font_bold <- "archivoblack"
+The map uses “geom_sf” for the choropleth base, with “geom_text” for country names and “geom_label” for the fertility rate values. The “scale_size_identity()” and “scale_color_identity()” functions allow us to use the exact values specified in our manual positions table.
+labels_data <- final_db |> filter(show_label == TRUE)
+
+map_plot <- ggplot(final_db) +
+ geom_sf(aes(fill = value), color = "black", size = 0.25) +
+
+ geom_text(
+ data = labels_data,
+ aes(x = lon_robin, y = lat_robin + label_offset, label = country,
+ size = label_size, color = label_color),
+ fontface = "italic",
+ family = font_regular
+ ) +
+
+ geom_label(
+ data = labels_data,
+ aes(x = lon_robin, y = lat_robin - label_offset, label = value,
+ size = label_size, color = value_color),
+ fontface = "bold",
+ family = font_bold,
+ fill = NA,
+ label.size = 0.15,
+ label.padding = unit(c(0.1, 0.15, 0.1, 0.15), "lines")
+ ) +
+
+ scale_size_identity() +
+ scale_color_identity() +
+ scale_fill_gradientn(
+ colours = color_palette,
+ na.value = "grey90"
+ ) +
+
+ theme_minimal() +
+ theme(
+ plot.background = element_rect(fill = background_colour, color = NA),
+ axis.text = element_blank(),
+ axis.title = element_blank(),
+ panel.grid = element_blank(),
+ legend.position = "none"
+ ) +
+ coord_sf(crs = "+proj=robin")
+The original includes two gradient bars that serve as both legend and section dividers. These are created using “geom_tile” to simulate a color gradient.
+text_size <- 14.5
+text_size2 <- 12.5
+
+bar_plot <- ggplot() +
+ geom_tile(
+ data = data.frame(
+ x = seq(0, 1, length.out = 100),
+ y = 0.5,
+ fill = seq(0, 1, length.out = 100)
+ ),
+ aes(x = x, y = y, fill = fill),
+ height = 1,
+ width = 0.0101
+ ) +
+ scale_fill_gradientn(colours = color_palette) +
+
+ annotate("text", x = 0.02, y = 0.5, label = "Lowest",
+ family = font_bold, fontface = "bold", color = "black", hjust = 0, size = text_size) +
+ annotate("text", x = 0.12, y = 0.5, label = "0.73 South Korea",
+ family = font_regular, color = "black", hjust = 0, size = text_size) +
+ annotate("text", x = 0.865, y = 0.5, label = "Highest",
+ family = font_bold, fontface = "bold", color = "white", hjust = 1, size = text_size) +
+ annotate("text", x = 0.98, y = 0.5, label = "6.03 Chad",
+ family = font_regular, color = "white", hjust = 1, size = text_size) +
+
+ scale_x_continuous(expand = c(0, 0)) +
+ scale_y_continuous(expand = c(0, 0)) +
+ theme_void() +
+ theme(legend.position = "none", plot.margin = margin(0, 0, 0, 0, "pt"))
+
+bar_plot2 <- ggplot() +
+ geom_tile(
+ data = data.frame(
+ x = seq(0, 1, length.out = 100),
+ y = 0.5,
+ fill = seq(0, 1, length.out = 100)
+ ),
+ aes(x = x, y = y, fill = fill),
+ height = 1,
+ width = 0.0101
+ ) +
+ scale_fill_gradientn(colours = color_palette) +
+
+ annotate("text", x = 0.02, y = 0.5, label = "Top 10 Highest Total Fertility Rate (2024)",
+ family = font_bold, color = "black", hjust = 0, size = text_size2) +
+ annotate("text", x = 0.98, y = 0.5, label = "Top 10 Lowest Total Fertility Rate (2024)",
+ family = font_bold, color = "white", hjust = 1, size = text_size2) +
+
+ scale_x_continuous(expand = c(0, 0)) +
+ scale_y_continuous(expand = c(0, 0)) +
+ theme_void() +
+ theme(legend.position = "none", plot.margin = margin(0, 0, 0, 0, "pt"))
+The Top 10 highest and lowest fertility rate countries are displayed using bar charts with “ggchicklet” for slightly rounded corners.
+ranking_label_size <- 9
+ranking_axis_x_size <- 32
+ranking_axis_y_size <- 22
+
+data_high <- data.frame(
+ Country = c("Chad", "Somalia", "D.R Congo", "C.A.R", "Niger",
+ "Mali", "Angola", "Burundi", "Afghanistan", "Mozambique"),
+ Value = c(6.03, 6.01, 5.98, 5.95, 5.94, 5.51, 5.05, 4.79, 4.76, 4.69)
+)
+data_high$Country <- factor(data_high$Country, levels = data_high$Country)
+
+data_low <- data.frame(
+ Country = c("S. Korea", "Taiwan", "Singapore", "Ukraine", "China",
+ "Andorra", "Malta", "Chile", "San Marino", "Thailand"),
+ Value = c(0.73, 0.86, 0.95, 0.99, 1.01, 1.09, 1.11, 1.14, 1.16, 1.20)
+)
+data_low$Country <- factor(data_low$Country, levels = data_low$Country)
+
+col_high_bar <- "#CE4143"
+col_low_bar <- "#FDDDA8"
+
+p_high <- ggplot(data_high, aes(x = Country, y = Value)) +
+ geom_chicklet(fill = col_high_bar, width = 0.85, radius = grid::unit(2, "pt"), color = NA) +
+ geom_text(aes(label = sprintf("%.2f", Value)), vjust = -0.5, size = ranking_label_size, fontface = "bold") +
+ scale_y_continuous(limits = c(0, 7), expand = c(0, 0), breaks = seq(0, 7, 1)) +
+ theme_minimal(base_family = "sans") +
+ theme(
+ plot.background = element_blank(),
+ panel.background = element_blank(),
+ axis.title = element_blank(),
+ axis.text.x = element_text(color = "black", size = ranking_axis_x_size, face = "bold", angle = 45, hjust = 1),
+ axis.text.y = element_text(color = "black", size = ranking_axis_y_size, face = "bold"),
+ panel.grid.major.x = element_blank(),
+ panel.grid.minor = element_blank(),
+ panel.grid.major.y = element_line(color = "gray85", linewidth = 0.3)
+ )
+
+p_low <- ggplot(data_low, aes(x = Country, y = Value)) +
+ geom_chicklet(fill = col_low_bar, width = 0.85, radius = grid::unit(2, "pt"), color = NA) +
+ geom_text(aes(label = sprintf("%.2f", Value)), vjust = -0.5, size = ranking_label_size, fontface = "bold") +
+ scale_y_continuous(limits = c(0, 1.4), expand = c(0, 0), breaks = seq(0, 1.2, 0.2)) +
+ theme_minimal(base_family = "sans") +
+ theme(
+ plot.background = element_blank(),
+ panel.background = element_blank(),
+ axis.title = element_blank(),
+ axis.text.x = element_text(color = "black", size = ranking_axis_x_size, face = "bold", angle = 45, hjust = 1),
+ axis.text.y = element_text(color = "black", size = ranking_axis_y_size, face = "bold"),
+ panel.grid.major.x = element_blank(),
+ panel.grid.minor = element_blank(),
+ panel.grid.major.y = element_line(color = "gray85", linewidth = 0.3)
+ )
+
+ranking_grid <- plot_grid(p_high, NULL, p_low, ncol = 3, align = "h", axis = "tb", rel_widths = c(1, 0.0, 1))
+
+ranking_plot <- ggdraw(ranking_grid) +
+ theme(plot.background = element_rect(fill = background_colour, color = NA))
+The header includes the main title, subtitle, and a descriptive text explaining the metric.
+font_add_google("Oswald", family = "title_bold_font")
+font_add_google("Lora", family = "title_regular_font")
+showtext_auto()
+
+title_bold_font <- "title_bold_font"
+title_regular_font <- "title_regular_font"
+
+title_size <- 140
+subtitle_size <- 55
+desc_size <- 16
+
+text_title <- "TOTAL FERTILITY RATES"
+text_subtitle <- "BY COUNTRY"
+text_desc <- "The total fertility rate is defined as the average number of children that would be born alive to a woman during her lifetime if she were to pass through her childbearing years conforming to the age-specific fertility rates of a given year. (UN)"
+text_desc_wrapped <- str_wrap(text_desc, width = 105)
+
+header_plot <- ggdraw() +
+ theme(plot.background = element_rect(fill = "#FEF0EF", color = NA)) +
+ draw_label(text_title, x = 0.5, y = 0.75, hjust = 0.5, size = title_size,
+ fontface = "bold", fontfamily = title_bold_font, color = "black") +
+ draw_label(text_subtitle, x = 0.40, y = 0.35, hjust = 1, size = subtitle_size,
+ fontface = "bold", fontfamily = title_bold_font, color = "black") +
+ draw_label(text_desc_wrapped, x = 0.41, y = 0.35, hjust = 0, size = desc_size,
+ fontface = "plain", fontfamily = title_regular_font, color = "black", lineheight = 0.65)
+Using cowplot’s “ggdraw()” and “draw_plot()” functions, we assemble all components into the final infographic.
+final_plot <- ggdraw() +
+ theme(plot.background = element_rect(fill = background_colour, color = NA)) +
+ draw_plot(header_plot, x = 0, y = 0.85, width = 1, height = 0.15) +
+ draw_plot(bar_plot, x = 0, y = 0.82, width = 1, height = 0.045) +
+ draw_plot(map_plot, x = 0, y = 0.26, width = 0.88, height = 0.58, scale = 1.68) +
+ draw_plot(bar_plot2, x = 0, y = 0.25, width = 1, height = 0.045) +
+ draw_plot(ranking_plot, x = 0, y = 0, width = 1, height = 0.36, hjust = 0.01, vjust = 0.35)
+ggsave("fertility_infographic.png", final_plot, width = 8, height = 11, dpi = 300)
+
The plot has clean typography and a balanced layout that make the infographic visually appealing. However, with 70+ labels on the map, some regions become difficult to read. In terms of color scale, the linear gradient may not effectively show variations in the lower range of fertility rates. Regarding storytelling, the visualization doesn’t focus on any particular narrative or trend, and the excess of information can be overwhelming, making it harder to communicate a clear message.
+For the improvement, I chose to focus on storytelling. The visualization may look simpler, but simplicity can open a window to tell a more focused story that communicates a clear idea more effectively. In this case, I decided to use the same dataset, but addressing only countries below the replacement level. This threshold is critical because populations with fertility rates below this level will eventually decline without immigration. Instead of showing all fertility rates, we highlight only countries facing potential population decline. A logarithmic color scale was applied to bring better contrast among low-fertility countries. Only the Top 5 lowest countries are labeled, reducing visual clutter. 2025 projections from the same UN dataset were used for an up-to-date result.
+We filter the data to show only countries below the replacement level, setting others to NA (which will appear in grey).
+fertility_rate_2025 <- fertility_rate |>
+ filter(Time == 2025) |>
+ select(Location, iso3 = Iso3, Value)
+
+db2 <- geo_world |>
+ left_join(fertility_rate_2025, by = "iso3") |>
+ select(country = geounit, iso3, value = Value, geometry) |>
+ filter(iso3 != "ATA") |>
+ mutate(value = round(value, 2))
+
+improvement_db <- db2 |>
+ mutate(value_display = if_else(value < 2.1, value, NA))
+font_add_google("Oswald", family = "title_bold_font")
+font_add_google("Lora", family = "title_regular_font")
+showtext_auto()
+
+title_bold_font <- "title_bold_font"
+title_regular_font <- "title_regular_font"
+
+background_colour <- "#FAFAFA"
+We create a small ranking chart to be embedded directly on the map, showing the 5 countries with the lowest fertility rates.
+top5_low <- data.frame(
+ rank = 1:5,
+ country = c("S. Korea", "Taiwan", "Singapore", "Ukraine", "China"),
+ value = c(0.73, 0.86, 0.95, 0.99, 1.01)
+)
+
+ranking_top5 <- ggplot(top5_low, aes(y = reorder(country, -rank))) +
+ geom_tile(aes(x = 0, fill = value), width = 0.3, height = 0.8) +
+ geom_text(aes(x = 0.3, label = country), hjust = 0, size = 8, family = title_regular_font) +
+ geom_text(aes(x = 1.5, label = sprintf("%.2f", value)), hjust = 1, size = 8,
+ fontface = "bold", family = title_bold_font) +
+ scale_fill_viridis_c(option = "mako", trans = "log10", limits = c(0.73, 2.1)) +
+ scale_x_continuous(limits = c(-0.2, 1.6)) +
+ labs(title = "Top 5 Lowest") +
+ theme_void() +
+ theme(
+ legend.position = "none",
+ plot.title = element_text(family = title_bold_font, face = "bold", size = 30, hjust = 0.5,
+ margin = margin(b = 5)),
+ plot.background = element_rect(fill = background_colour, color = NA)
+ )
+We position the ranking in the Pacific Ocean, to the left of South America.
+ranking_pos <- tibble(lon = -125, lat = -20) |>
+ st_as_sf(coords = c("lon", "lat"), crs = 4326) |>
+ st_transform(crs = "+proj=robin") |>
+ mutate(
+ x = st_coordinates(geometry)[,1],
+ y = st_coordinates(geometry)[,2]
+ ) |>
+ st_drop_geometry()
+improvement_map <- ggplot(improvement_db) +
+ geom_sf(aes(fill = value_display), color = "black", size = 0.25) +
+ scale_fill_viridis_c(option = "mako", trans = "log10", na.value = "grey85") +
+ annotation_custom(
+ grob = ggplotGrob(ranking_top5),
+ xmin = ranking_pos$x - 2500000,
+ xmax = ranking_pos$x + 2500000,
+ ymin = ranking_pos$y - 2500000,
+ ymax = ranking_pos$y + 2500000
+ ) +
+ theme_minimal() +
+ theme(
+ plot.background = element_rect(fill = background_colour, color = NA),
+ axis.text = element_blank(),
+ axis.title = element_blank(),
+ panel.grid = element_blank(),
+ legend.position = "none"
+ ) +
+ coord_sf(crs = "+proj=robin")
+text_title <- "THE SHRINKING NATIONS"
+text_explanation <- "A Replacement Level of 2.1 births is the threshold for a stable population size. Countries below this level face potential population decline. This map shows all nations currently below replacement level."
+text_explanation_wrapped <- str_wrap(text_explanation, width = 80)
+
+legend_bar <- ggplot() +
+ geom_tile(
+ data = data.frame(
+ x = seq(0, 1, length.out = 100),
+ y = 0.5,
+ fill = seq(0.73, 2.1, length.out = 100)
+ ),
+ aes(x = x, y = y, fill = fill),
+ height = 0.7,
+ width = 0.0101
+ ) +
+ scale_fill_viridis_c(option = "mako", trans = "log10") +
+ annotate("text", x = 0, y = -0.5, label = "0.73", size = 7, hjust = 0, family = title_regular_font) +
+ annotate("text", x = 0.5, y = -0.5, label = "1.2", size = 7, hjust = 0.5, family = title_regular_font) +
+ annotate("text", x = 1, y = -0.5, label = "2.1", size = 7, hjust = 1, family = title_regular_font) +
+ annotate("text", x = 0.5, y = 1.5, label = "Fertility Rate (2025)", size = 10, hjust = 0.5,
+ family = title_bold_font, fontface = "bold") +
+ scale_x_continuous(expand = c(0, 0)) +
+ scale_y_continuous(expand = c(0, 0), limits = c(-1, 2)) +
+ theme_void() +
+ theme(legend.position = "none")
+
+header_plot_improvement <- ggdraw() +
+ theme(plot.background = element_rect(fill = background_colour, color = NA)) +
+ draw_label(text_title, x = 0.5, y = 0.85, hjust = 0.5, size = 80, fontface = "bold",
+ fontfamily = title_bold_font, color = "black") +
+ draw_label(text_explanation_wrapped, x = 0.05, y = 0.4, hjust = 0, vjust = 0.5, size = 24,
+ fontface = "plain", fontfamily = title_regular_font, color = "black", lineheight = 0.5) +
+ draw_plot(legend_bar, x = 0.65, y = 0.15, width = 0.3, height = 0.5)
+footer_plot <- ggplot() +
+ annotate("text", x = 0.70, y = 0.5, label = "Source:", size = 10, hjust = 1,
+ fontface = "bold", family = title_regular_font, color = "black") +
+ annotate("text", x = 0.71, y = 0.5, label = "United Nations Population Division", size = 10,
+ hjust = 0, family = title_regular_font, color = "black") +
+ scale_x_continuous(limits = c(0, 1), expand = c(0, 0)) +
+ scale_y_continuous(limits = c(0, 1), expand = c(0, 0)) +
+ theme_void() +
+ theme(plot.background = element_rect(fill = background_colour, color = NA))
+final_improvement <- ggdraw() +
+ theme(plot.background = element_rect(fill = background_colour, color = NA)) +
+ draw_plot(header_plot_improvement, x = 0, y = 0.65, width = 1, height = 0.33) +
+ draw_plot(improvement_map, x = 0, y = 0.05, width = 1, height = 0.63, scale = 1.1) +
+ draw_plot(footer_plot, x = 0, y = 0, width = 1, height = 0.05)
+ggsave("shrinking_nations.png", final_improvement, width = 8, height = 6, dpi = 300)
+
By focusing only on below-replacement countries, we lose the global perspective that shows the contrast with high-fertility nations. The 2.1 replacement level used as threshold is a simplification; actual replacement levels vary by country based on mortality rates. Additionally, the static nature of the visualization doesn’t capture how countries have moved relative to this threshold over time, which could provide valuable context about demographic trends.
+`,e.githubCompareUpdatesUrl&&(t+=`View all changes to this article since it was first published.`),t+=` + If you see mistakes or want to suggest changes, please create an issue on GitHub.
+ `);const n=e.journal;return'undefined'!=typeof n&&'Distill'===n.title&&(t+=` +Diagrams and text are licensed under Creative Commons Attribution CC-BY 4.0 with the source available on GitHub, unless noted otherwise. The figures that have been reused from other sources don’t fall under this license and can be recognized by a note in their caption: “Figure from …”.
+ `),'undefined'!=typeof e.publishedDate&&(t+=` +For attribution in academic contexts, please cite this work as
+${e.concatenatedAuthors}, "${e.title}", Distill, ${e.publishedYear}.
+ BibTeX citation
+${m(e)}
+ `),t}var An=Math.sqrt,En=Math.atan2,Dn=Math.sin,Mn=Math.cos,On=Math.PI,Un=Math.abs,In=Math.pow,Nn=Math.LN10,jn=Math.log,Rn=Math.max,qn=Math.ceil,Fn=Math.floor,Pn=Math.round,Hn=Math.min;const zn=['Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'],Bn=['Jan.','Feb.','March','April','May','June','July','Aug.','Sept.','Oct.','Nov.','Dec.'],Wn=(e)=>10>e?'0'+e:e,Vn=function(e){const t=zn[e.getDay()].substring(0,3),n=Wn(e.getDate()),i=Bn[e.getMonth()].substring(0,3),a=e.getFullYear().toString(),d=e.getUTCHours().toString(),r=e.getUTCMinutes().toString(),o=e.getUTCSeconds().toString();return`${t}, ${n} ${i} ${a} ${d}:${r}:${o} Z`},$n=function(e){const t=Array.from(e).reduce((e,[t,n])=>Object.assign(e,{[t]:n}),{});return t},Jn=function(e){const t=new Map;for(var n in e)e.hasOwnProperty(n)&&t.set(n,e[n]);return t};class Qn{constructor(e){this.name=e.author,this.personalURL=e.authorURL,this.affiliation=e.affiliation,this.affiliationURL=e.affiliationURL,this.affiliations=e.affiliations||[]}get firstName(){const e=this.name.split(' ');return e.slice(0,e.length-1).join(' ')}get lastName(){const e=this.name.split(' ');return e[e.length-1]}}class Gn{constructor(){this.title='unnamed article',this.description='',this.authors=[],this.bibliography=new Map,this.bibliographyParsed=!1,this.citations=[],this.citationsCollected=!1,this.journal={},this.katex={},this.publishedDate=void 0}set url(e){this._url=e}get url(){if(this._url)return this._url;return this.distillPath&&this.journal.url?this.journal.url+'/'+this.distillPath:this.journal.url?this.journal.url:void 0}get githubUrl(){return this.githubPath?'https://github.com/'+this.githubPath:void 0}set previewURL(e){this._previewURL=e}get previewURL(){return this._previewURL?this._previewURL:this.url+'/thumbnail.jpg'}get publishedDateRFC(){return Vn(this.publishedDate)}get updatedDateRFC(){return Vn(this.updatedDate)}get publishedYear(){return this.publishedDate.getFullYear()}get publishedMonth(){return Bn[this.publishedDate.getMonth()]}get publishedDay(){return this.publishedDate.getDate()}get publishedMonthPadded(){return Wn(this.publishedDate.getMonth()+1)}get publishedDayPadded(){return Wn(this.publishedDate.getDate())}get publishedISODateOnly(){return this.publishedDate.toISOString().split('T')[0]}get volume(){const e=this.publishedYear-2015;if(1>e)throw new Error('Invalid publish date detected during computing volume');return e}get issue(){return this.publishedDate.getMonth()+1}get concatenatedAuthors(){if(2 tag. We found the following text: '+t);const n=document.createElement('span');n.innerHTML=e.nodeValue,e.parentNode.insertBefore(n,e),e.parentNode.removeChild(e)}}}}).observe(this,{childList:!0})}}var Ti='undefined'==typeof window?'undefined'==typeof global?'undefined'==typeof self?{}:self:global:window,_i=f(function(e,t){(function(e){function t(){this.months=['jan','feb','mar','apr','may','jun','jul','aug','sep','oct','nov','dec'],this.notKey=[',','{','}',' ','='],this.pos=0,this.input='',this.entries=[],this.currentEntry='',this.setInput=function(e){this.input=e},this.getEntries=function(){return this.entries},this.isWhitespace=function(e){return' '==e||'\r'==e||'\t'==e||'\n'==e},this.match=function(e,t){if((void 0==t||null==t)&&(t=!0),this.skipWhitespace(t),this.input.substring(this.pos,this.pos+e.length)==e)this.pos+=e.length;else throw'Token mismatch, expected '+e+', found '+this.input.substring(this.pos);this.skipWhitespace(t)},this.tryMatch=function(e,t){return(void 0==t||null==t)&&(t=!0),this.skipWhitespace(t),this.input.substring(this.pos,this.pos+e.length)==e},this.matchAt=function(){for(;this.input.length>this.pos&&'@'!=this.input[this.pos];)this.pos++;return!('@'!=this.input[this.pos])},this.skipWhitespace=function(e){for(;this.isWhitespace(this.input[this.pos]);)this.pos++;if('%'==this.input[this.pos]&&!0==e){for(;'\n'!=this.input[this.pos];)this.pos++;this.skipWhitespace(e)}},this.value_braces=function(){var e=0;this.match('{',!1);for(var t=this.pos,n=!1;;){if(!n)if('}'==this.input[this.pos]){if(0 =k&&(++x,i=k);if(d[x]instanceof n||d[T-1].greedy)continue;w=T-x,y=e.slice(i,k),v.index-=i}if(v){g&&(h=v[1].length);var S=v.index+h,v=v[0].slice(h),C=S+v.length,_=y.slice(0,S),L=y.slice(C),A=[x,w];_&&A.push(_);var E=new n(o,u?a.tokenize(v,u):v,b,v,f);A.push(E),L&&A.push(L),Array.prototype.splice.apply(d,A)}}}}}return d},hooks:{all:{},add:function(e,t){var n=a.hooks.all;n[e]=n[e]||[],n[e].push(t)},run:function(e,t){var n=a.hooks.all[e];if(n&&n.length)for(var d,r=0;d=n[r++];)d(t)}}},i=a.Token=function(e,t,n,i,a){this.type=e,this.content=t,this.alias=n,this.length=0|(i||'').length,this.greedy=!!a};if(i.stringify=function(e,t,n){if('string'==typeof e)return e;if('Array'===a.util.type(e))return e.map(function(n){return i.stringify(n,t,e)}).join('');var d={type:e.type,content:i.stringify(e.content,t,n),tag:'span',classes:['token',e.type],attributes:{},language:t,parent:n};if('comment'==d.type&&(d.attributes.spellcheck='true'),e.alias){var r='Array'===a.util.type(e.alias)?e.alias:[e.alias];Array.prototype.push.apply(d.classes,r)}a.hooks.run('wrap',d);var l=Object.keys(d.attributes).map(function(e){return e+'="'+(d.attributes[e]||'').replace(/"/g,'"')+'"'}).join(' ');return'<'+d.tag+' class="'+d.classes.join(' ')+'"'+(l?' '+l:'')+'>'+d.content+''+d.tag+'>'},!t.document)return t.addEventListener?(t.addEventListener('message',function(e){var n=JSON.parse(e.data),i=n.language,d=n.code,r=n.immediateClose;t.postMessage(a.highlight(d,a.languages[i],i)),r&&t.close()},!1),t.Prism):t.Prism;var d=document.currentScript||[].slice.call(document.getElementsByTagName('script')).pop();return d&&(a.filename=d.src,document.addEventListener&&!d.hasAttribute('data-manual')&&('loading'===document.readyState?document.addEventListener('DOMContentLoaded',a.highlightAll):window.requestAnimationFrame?window.requestAnimationFrame(a.highlightAll):window.setTimeout(a.highlightAll,16))),t.Prism}();e.exports&&(e.exports=n),'undefined'!=typeof Ti&&(Ti.Prism=n),n.languages.markup={comment://,prolog:/<\?[\w\W]+?\?>/,doctype://i,cdata://i,tag:{pattern:/<\/?(?!\d)[^\s>\/=$<]+(?:\s+[^\s>\/=]+(?:=(?:("|')(?:\\\1|\\?(?!\1)[\w\W])*\1|[^\s'">=]+))?)*\s*\/?>/i,inside:{tag:{pattern:/^<\/?[^\s>\/]+/i,inside:{punctuation:/^<\/?/,namespace:/^[^\s>\/:]+:/}},"attr-value":{pattern:/=(?:('|")[\w\W]*?(\1)|[^\s>]+)/i,inside:{punctuation:/[=>"']/}},punctuation:/\/?>/,"attr-name":{pattern:/[^\s>\/]+/,inside:{namespace:/^[^\s>\/:]+:/}}}},entity:/?[\da-z]{1,8};/i},n.hooks.add('wrap',function(e){'entity'===e.type&&(e.attributes.title=e.content.replace(/&/,'&'))}),n.languages.xml=n.languages.markup,n.languages.html=n.languages.markup,n.languages.mathml=n.languages.markup,n.languages.svg=n.languages.markup,n.languages.css={comment:/\/\*[\w\W]*?\*\//,atrule:{pattern:/@[\w-]+?.*?(;|(?=\s*\{))/i,inside:{rule:/@[\w-]+/}},url:/url\((?:(["'])(\\(?:\r\n|[\w\W])|(?!\1)[^\\\r\n])*\1|.*?)\)/i,selector:/[^\{\}\s][^\{\};]*?(?=\s*\{)/,string:{pattern:/("|')(\\(?:\r\n|[\w\W])|(?!\1)[^\\\r\n])*\1/,greedy:!0},property:/(\b|\B)[\w-]+(?=\s*:)/i,important:/\B!important\b/i,function:/[-a-z0-9]+(?=\()/i,punctuation:/[(){};:]/},n.languages.css.atrule.inside.rest=n.util.clone(n.languages.css),n.languages.markup&&(n.languages.insertBefore('markup','tag',{style:{pattern:/(
+
+
+ ${e.map(l).map((e)=>`
`)}}const Mi=`
+d-citation-list {
+ contain: layout style;
+}
+
+d-citation-list .references {
+ grid-column: text;
+}
+
+d-citation-list .references .title {
+ font-weight: 500;
+}
+`;class Oi extends HTMLElement{static get is(){return'd-citation-list'}connectedCallback(){this.hasAttribute('distill-prerendered')||(this.style.display='none')}set citations(e){x(this,e)}}var Ui=f(function(e){var t='undefined'==typeof window?'undefined'!=typeof WorkerGlobalScope&&self instanceof WorkerGlobalScope?self:{}:window,n=function(){var e=/\blang(?:uage)?-(\w+)\b/i,n=0,a=t.Prism={util:{encode:function(e){return e instanceof i?new i(e.type,a.util.encode(e.content),e.alias):'Array'===a.util.type(e)?e.map(a.util.encode):e.replace(/&/g,'&').replace(/e.length)break tokenloop;if(!(y instanceof n)){c.lastIndex=0;var v=c.exec(y),w=1;if(!v&&f&&x!=d.length-1){if(c.lastIndex=i,v=c.exec(e),!v)break;for(var S=v.index+(g?v[1].length:0),C=v.index+v[0].length,T=x,k=i,p=d.length;T
+
+`);class Ni extends ei(Ii(HTMLElement)){renderContent(){if(this.languageName=this.getAttribute('language'),!this.languageName)return void console.warn('You need to provide a language attribute to your Footnotes
+
+`,!1);class Fi extends qi(HTMLElement){connectedCallback(){super.connectedCallback(),this.list=this.root.querySelector('ol'),this.root.style.display='none'}set footnotes(e){if(this.list.innerHTML='',e.length){this.root.style.display='';for(const t of e){const e=document.createElement('li');e.id=t.id+'-listing',e.innerHTML=t.innerHTML;const n=document.createElement('a');n.setAttribute('class','footnote-backlink'),n.textContent='[\u21A9]',n.href='#'+t.id,e.appendChild(n),this.list.appendChild(e)}}else this.root.style.display='none'}}const Pi=ti('d-hover-box',`
+
+
+