Population pyramid in statgl_plot #29
Description
Hi Emil,
Can you consider this to be included in statgl_plot? More generic, for wider use, perhaps also including animated charts over time
This is the code I use :
```{r}
library(tidyverse)
library(statgl)
library(highcharter)
df <- statgl_fetch("BEESTA", time = px_top(), gender = c("K","M"), age = "*") %>%
mutate(age=as.character(age)) %>%
select(-time)
make_pyramid_hc <- function(df,
gender_col = "gender",
age_col = "age",
value_col = "value",
male_levels = c("Men", "M", "Male", "Mænd", "Mand"),
female_levels = c("Women", "W", "F", "Female", "Kvinder", "Kvinde"),
title = NULL,
subtitle = NULL,
debug = FALSE) {
d <- df %>%
dplyr::transmute(
gender_raw = .data[[gender_col]],
age_raw = .data[[age_col]],
value_raw = .data[[value_col]]
) %>%
dplyr::mutate(
gender = dplyr::case_when(
as.character(gender_raw) %in% male_levels ~ "Mænd",
as.character(gender_raw) %in% female_levels ~ "Kvinder",
TRUE ~ as.character(gender_raw)
),
age = suppressWarnings(as.integer(gsub("[^0-9]", "", as.character(age_raw)))),
value = as.numeric(value_raw)
) %>%
dplyr::filter(!is.na(age), !is.na(value), gender %in% c("Mænd", "Kvinder")) %>%
dplyr::group_by(gender, age) %>%
dplyr::summarise(value = sum(value), .groups = "drop")
# Alder: høj -> lav
ages_desc <- sort(unique(d$age), decreasing = TRUE)
age_labels <- as.character(ages_desc)
# Byg gitter i samme rækkefølge som age_labels
d_full <- tidyr::expand_grid(
age = ages_desc,
gender = c("Mænd", "Kvinder")
) %>%
dplyr::left_join(d, by = c("age", "gender")) %>%
dplyr::mutate(value = tidyr::replace_na(value, 0)) %>%
dplyr::mutate(
age = factor(age, levels = ages_desc),
gender = factor(gender, levels = c("Mænd", "Kvinder"))
) %>%
dplyr::arrange(age, gender)
males_plot <- d_full %>%
dplyr::filter(gender == "Mænd") %>%
dplyr::arrange(age) %>%
dplyr::pull(value) %>%
`*`(-1)
females_plot <- d_full %>%
dplyr::filter(gender == "Kvinder") %>%
dplyr::arrange(age) %>%
dplyr::pull(value)
# ---- X-akse ticks: 0,10,...,90 (kategoriakse => tickPositions via indeks)
tick_ages <- as.character(seq(0, 90, by = 10))
tick_positions <- which(age_labels %in% tick_ages) - 1 # Highcharts = 0-baseret
# Hvis nogle af tick_ages ikke findes i data, bliver de bare udeladt (which() giver intet)
hc <- highcharter::highchart() %>%
highcharter::hc_chart(type = "bar") %>%
highcharter::hc_title(text = title) %>%
highcharter::hc_subtitle(text = subtitle) %>%
highcharter::hc_xAxis(
categories = age_labels,
title = list(text = "Alder"),
reversed = TRUE,
tickPositions = tick_positions
) %>%
highcharter::hc_yAxis(
title = list(text = "Antal"),
labels = list(
formatter = highcharter::JS(
"function(){ return Highcharts.numberFormat(Math.abs(this.value), 0); }"
)
),
maxPadding = 0.05
) %>%
highcharter::hc_plotOptions(
series = list(
stacking = "normal",
borderWidth = 0,
pointPadding = 0,
groupPadding = 0.1
)
) %>%
highcharter::hc_tooltip(
shared = TRUE,
formatter = highcharter::JS(
"function () {
const pts = this.points || [];
const age = this.x;
let s = '<b>Alder: ' + age + '</b><br/>';
pts.forEach(p => {
s += p.series.name + ': <b>' + Highcharts.numberFormat(Math.abs(p.y), 0) + '</b><br/>';
});
return s;
}"
)
) %>%
highcharter::hc_add_series(name = "Mænd", data = males_plot) %>%
highcharter::hc_add_series(name = "Kvinder", data = females_plot) %>%
highcharter::hc_legend(reversed = FALSE) %>%
highcharter::hc_credits(enabled = FALSE)
if (debug) {
return(list(
age_labels = age_labels,
tick_positions = tick_positions,
males_plot = males_plot,
females_plot = females_plot,
d_full = d_full,
hc = hc
))
} else {
return(hc)
}
}
hc_1 <- make_pyramid_hc(df)
hc_1