click to see/hide status
############################
#
# Status
#
# 2024-10-1 Version 1
#
# Next:
#
# Improve metadata with footnotes, explanations
#
############################# Projections
Link to a px-file with all previous published projections
Published October, 1st 2024 - (version 1, updated 01. oktober 2024)
click to see/hide used packages
library(tidyverse)
library(statgl)
library(pxmake)Data
To allow comparing various projections, these steps are followed to combine to one px-file:
Versions 2012-2017
BEXPROG in Statbank Greenland holds 6 projection versions from 2012 to 2017. They all share the same horizon (2040) as well as same start period (1977).
bexprog <- statgl_url("BEXPROG") %>%
statgl_fetch(.eliminate_rest = F,
.col_code = T,
.val_code = F) %>%
mutate(sex=ifelse(gender=="Total","T",ifelse(gender=="Men","M","F")),
pob=ifelse(`place of birth`=="All population","T","N")) %>%
select(-gender,-`place of birth`) %>%
filter(sex!="T")Version 2018
BEXP18 in Statbank Greenland holds 4 projections from 2018 to 2050. Start year in table is 1996.
bexp18 <- statgl_fetch(statgl_url("BEXP18"),
version="0",
.eliminate_rest = F,
.col_code = T,
.val_code = F) %>%
mutate(sex=ifelse(sex=="Men","M","F"),
pob=ifelse(`place of birth`=="Total","T","N"),
version="2018") %>%
select(-`place of birth`) Version 2019
BEXP19 in Statbank Greenland holds 4 projections from 2019 to 2050. Start year in table is 1996.
bexp19 <- statgl_url("BEXP19") %>%
statgl_fetch(version="0",
region="ALL",
.eliminate_rest = F,
.col_code = T,
.val_code = F) %>%
mutate(sex=ifelse(sex=="Men","M","F"),
pob=ifelse(`place of birth`=="Total","T","N"),
version="2019") %>%
select(-`place of birth`, -region) Version 2020
BEXP20 in Statbank Greenland holds 3 projections from 2020 to 2050. Start year in table is 1996.
bexp20 <- statgl_url("BEXP20") %>%
statgl_fetch(version=px_all(),
region="ALL",
.eliminate_rest = F,
.col_code = T,
.val_code = F) %>%
mutate(sex=ifelse(sex=="Men","M","F"),
pob=ifelse(`place of birth`=="Total","T","N"),
version=ifelse(version=="2020 main alternative","2020",
ifelse(version=="2020 unchanged mortality","2020a1",
"2020a2"))
) %>%
select(-`place of birth`, -region)
bexp20a0 <- bexp20 %>% filter(version=="2020")
bexp20a1 <- bexp20 %>% filter(version=="2020a1")
bexp20a2 <- bexp20 %>% filter(version=="2020a2")Version 2024
BEXP24 in Statbank Greenland holds 4 projections from 2024 to 2050. Start year in table is 1999.
bexp24 <- statgl_fetch(statgl_url("BEXP24"),
area="ALL",
p_prefix=px_all(),
sex=c("M","F"),
pob=c("T","N"),
.eliminate_rest = F,
.col_code = T,
.val_code = F) %>%
mutate(sex=ifelse(sex=="Men","M","F"),
pob=ifelse(pob=="Total","T","N"),
version=ifelse(p_prefix=="2024 Main alternative","2024",
ifelse(p_prefix=="2024 Unchanged mortality","2024a1",
ifelse(p_prefix=="2024 Low outmigration","2024a2",
"2024a3")))
) %>%
select(-area,-p_prefix)
bexp24a0 <- bexp24 %>% filter(version=="2024")
bexp24a1 <- bexp24 %>% filter(version=="2024a1")
bexp24a2 <- bexp24 %>% filter(version=="2024a2")
bexp24a3 <- bexp24 %>% filter(version=="2024a3")Versions combined
Combine all versions above to one dataframe and define non-existing code labels.
Also modify missing values in the dataframe from 2 simple rules:
- If value==NA and time< 2000, set value==2012
- If value==NA and time> 2040, set value==2040
for each combination of place of birth, sex, age
codelist_version <- expand_grid(
language = c('en', 'da', 'kl'),
`variable-code` = 'version',
code = as.character(2012:2020), # Years from 2012 to 2024
value = as.character(2012:2020)
) %>%
filter(code==value) %>%
mutate(
order = ifelse(language == 'en', row_number(), NA) # Assign order for 'en', NA for 'da'
) %>%
bind_rows(tribble(~language, ~`variable-code`, ~code, ~value, ~order,
'en', 'version','2020a1', '2020 Unchanged mortality',10,
'da', 'version','2020a1', '2020 Uændret dødelighed',NA,
'kl', 'version','2020a1', '2020-imi toqusut taamaaginnarpata',NA,
'en', 'version','2020a2', '2020 Low netmigration',11,
'da', 'version','2020a2', '2020 Lavere nettoudvandring',NA,
'kl', 'version','2020a2', '2020-imi nunanut allanut nuuttut ikinneruppata',NA,
'en', 'version','2024', '2024',12,
'da', 'version','2024', '2024',NA,
'kl', 'version','2024', '2024',NA,
'en', 'version','2024a1', '2024 Unchanged mortality',14,
'da', 'version','2024a1', '2024 Uændret dødelighed',NA,
'kl', 'version','2024a1', '2024-imi toqusut taamaaginnarpata',NA,
'en', 'version','2024a2', '2024 Low outmigration',15,
'da', 'version','2024a2', '2024 Lav udvandring',NA,
'kl', 'version','2024a2', '2024-imi nunanut allanut nuuttut ikinneruppata',NA,
'en', 'version','2024a3', '2024 High fertility',16,
'da', 'version','2024a3', '2024 Høj fertilitet',NA,
'kl', 'version','2024a3', '2024-imi Ilimagilluinnagaq',NA,
))
bexp <- bexprog %>%
bind_rows(bexp18) %>%
bind_rows(bexp19) %>%
bind_rows(bexp20a0) %>%
bind_rows(bexp20a1) %>%
bind_rows(bexp20a2) %>%
bind_rows(bexp24a0) %>%
bind_rows(bexp24a1) %>%
bind_rows(bexp24a2) %>%
bind_rows(bexp24a3) %>%
pivot_wider(names_from = version,values_from = value) %>%
mutate(across(everything(), ~ifelse(is.na(.), `2012`, .))) %>%
pivot_longer(cols=5:ncol(.), names_to = "version", values_to = "value") %>%
pivot_wider(names_from = time,values_from = value) %>%
mutate(across(everything(), ~ifelse(is.na(.), `2040`, .))) %>%
pivot_longer(cols=5:ncol(.), names_to = "time", values_to = "value")Helpers
The purpose with these helpers is to reuse metadata/translations from existing files in Statbank Greenland
get_codelist <- function(table_id, langs = c("en", "kl", "da")) {
enframe(langs, name = NULL, value = "langs") %>%
mutate(try = map2_chr(table_id, langs, statgl_url) %>%
purrr::map(statgl_meta) %>%
purrr::map(pluck,"variables")
) %>%
unnest(try) %>%
unnest(c(values, valueTexts)) %>%
select(variable = code,
`variable-code` = text,
code = values,
language = langs,
value = valueTexts) %>%
group_by(variable,language) %>%
mutate(order = row_number())
}
# try to get code labels for a variable
# codelist_age <- get_codelist("BEXSTA") %>%
# filter(variable=="age") %>%
# as.data.frame() %>%
# select(`variable-code`=variable,code,language,value,order)
get_variable_labels <- function(table_id, langs = c("en", "kl", "da")) {
enframe(langs, name = NULL, value = "langs") %>%
mutate(try = map2_chr(table_id, langs, statgl_url) %>%
purrr::map(statgl_meta) %>%
purrr::map(pluck,"variables")
) %>%
unnest(try) %>%
unnest(c(values, valueTexts)) %>%
select(`variable-label` = text,
`variable-code` = code,
language = langs) %>%
unique()
}
# try to get the variable labels for the table
# var_label_time <- get_variable_labels("BEXSTA") %>%
# filter(`variable-code`=="time")Metadata
Steal/reuse as much as possible
var_label_version <- get_variable_labels("BEXPROG") %>%
filter(`variable-code`=="version")
var_label_time <- get_variable_labels("BEXPROG") %>%
filter(`variable-code`=="time") %>%
mutate(`variable-code`="time")
var_label_sex <- get_variable_labels("BEXFLYTR") %>%
filter(`variable-code`=="sex")
var_label_age <- get_variable_labels("BEXPROG") %>%
filter(`variable-code`=="age")
var_label_pob <- get_variable_labels("BEXFLYTR") %>%
filter(`variable-code`=="fsted") %>%
mutate(`variable-code`="pob")
codelist_pob <- get_codelist("BEXP24") %>%
filter(variable=="pob") %>%
as.data.frame() %>%
select(`variable-code`=variable,code,language,value,order) %>%
filter(code %in% c("T","N"))
codelist_sex <- get_codelist("BEXCALCR2") %>%
filter(variable=="sex") %>%
as.data.frame() %>%
select(`variable-code`=variable,code,language,value,order) %>%
mutate(`variable-code`="sex")
codelist_age <- get_codelist("BEXSTA") %>%
filter(variable=="age") %>%
as.data.frame() %>%
select(`variable-code`=variable,code,language,value,order) %>%
mutate(`variable-code`="age")
prefix_values <- tibble::tribble(
~`variable-code`, ~code, ~language, ~value, ~order,
) %>%
bind_rows(codelist_version) %>%
bind_rows(codelist_age) %>%
bind_rows(codelist_pob) %>%
bind_rows(codelist_sex)
var_elimination_sex <- codelist_sex %>%
filter(`variable-code`=="sex" & code=="T") %>%
select(`variable-code`,language,elimination=value)
var_elimination_pob <- codelist_pob %>%
filter(`variable-code`=="pob" & code=="T") %>%
select(`variable-code`,language,elimination=value)
prefix_values_no_order <- prefix_values %>% select(-order)
prefix_values_order <- prefix_values %>%
filter(language=="en") %>% select(`variable-code`, code, order)px object
Turn it all into a px-object x,
lastupdated <- "20240925 09:00"
nextupdate <- "20250601 09:00"
lastYear <- "2024"
matrix <- "BEXPALL"
x <- px(bexp) %>%
px_charset("ANSI") %>%
px_codepage("utf-8") %>%
px_language("en") %>%
px_languages(c("en", "da", "kl")) %>%
px_matrix(matrix) %>%
px_timeval("time") %>%
px_decimals("0") %>%
px_showdecimals("0") %>%
px_subject_code("BE") %>%
px_subject_area(data.frame(language = c("en", "da", "kl"),
value = c("Population", "Befolkning", "Innuttaasut"))) %>%
px_variable_label(var_label_version) %>%
px_variable_label(var_label_age) %>%
px_variable_label(var_label_sex) %>%
px_variable_label(var_label_pob) %>%
px_variable_label(var_label_time) %>%
px_values(prefix_values_no_order) %>%
px_order(prefix_values_order) %>%
px_elimination(var_elimination_sex) %>%
px_elimination(var_elimination_pob) %>%
px_elimination(tribble(~`variable-code`, ~elimination,
'age', 'YES')) %>%
px_contents(data.frame(language = c("en", "da", "kl"),
value = c("Projections",
"Fremskrivninger",
"Innuttaasut amerlassusissaat"))) %>%
px_creation_date(format(lastupdated,format='%Y%m%d %H:%M')) %>%
px_domain(tibble::tribble(~`variable-code` , ~language,~domain,
"age" , "en","VPAge",
"age" , "da","VPAlder",
"age" , "kl","VPUkiut",)) %>%
px_description(data.frame(language = c("en", "da", "kl"),
value = c(paste0("All projections 2012-2024 <em>[BEEPALL]</em>"),
paste0("Fremskrivninger 2012-2024, oversigt <em>[BEDPALL]</em>"),
paste0("Innuttaasut amerlassusissaat 2012-2024 <em>[BENPALL]</em>")))) %>%
px_title(data.frame(language = c("en", "da", "kl"),
value = c("Projections",
"Fremskrivninger",
"Innuttaasut amerlassusissaat"))) %>%
px_units(data.frame(language = c("en", "da", "kl"),
value = c("Persons",
"Personer",
"Inuit"))) %>%
px_update_frequency("Annual") %>%
px_creation_date("20240925 09:00") %>%
px_last_updated(lastupdated) %>%
px_next_update(nextupdate) %>%
px_contact(tribble(~language, ~value,
'en', 'LARP@stat.gl, Lars Pedersen',
'da', 'LARP@stat.gl, Lars Pedersen',
'kl', 'LARP@stat.gl, Lars Pedersen')) %>%
px_add_totals("sex")sim-sa-la-santa
Enjoy, consume with : Pxweb, Pxwin, Pxedit, pxmake
px_save(x,paste0(matrix,".px"))