resume <- "baseret på demografiske tendenser med faldende dødelighed i hele fremskrivningsperioden, faldende fertilitet de næste 10 år, vandringsmønster på niveau med de seneste 5 års erfaringer, justeret, så perioden med Covid-19 ikke får indflydelse på beregningerne"Befolkningsfremskrivning 2025
(opdateret den 22. april 2025)
…tilbage
Hovedalternativ
Resumé 2025 forudsætninger baseret på demografiske tendenser med faldende dødelighed i hele fremskrivningsperioden, faldende fertilitet de næste 10 år, vandringsmønster på niveau med de seneste 5 års erfaringer, justeret, så perioden med Covid-19 ikke får indflydelse på beregningerne
Her redegøres for kilde(r) samt afledte beregninger, som giver det fuldstændige datagrundlag for fremskrivningsalternativet. Se alle grundlagsdata i base_main.xlsx
# content
content <- "Main alternative"
#CRAN
library(tidyverse)
library(gt)
library(janitor)
library(ggplot2)
library(openxlsx) # createWorkbook hedder noget andet i openxlsx2
library(openxlsx2)
library(MortalityLaws)
# statgl - package by Statistics Greenland
# devtools::install_github("StatisticsGreenland/statgl")
library(statgl)
options(scipen = 999)
# helper function to convert list of integers to ranges
integer_to_ranges <- function(integer_list) {
ranges <- list()
current_range <- c(integer_list[1], integer_list[1])
for (i in 2:length(integer_list)) {
if (integer_list[i] == integer_list[i - 1] + 1) {
current_range[2] <- integer_list[i]
} else {
ranges <- c(ranges, list(current_range))
current_range <- c(integer_list[i])
}
}
ranges <- c(ranges, list(current_range))
new_ranges <- ranges %>%
map_chr(~ paste(.x, collapse = "-")) %>%
paste(collapse = ", ")
return(new_ranges)
}
# Official colors of Statistics Greenland --------------------------------------
statgl_colors <- c(
# From design manual
"darkblue" = "#004459",
"darkgreen" = "#939905",
"green" = "#94BB1F",
"blue" = "#007F99",
"lightgreen" = "#CEE007",
"orange" = "#faa41a",
"peach" = "#F97242",
"darkorange" = "#F95602",
# Greys
"darkgrey" = "#848c8c",
"grey" = "#b8bab8",
"lightgrey" = "#f1f2f2",
# Not from design manual, strictly for logo
"logo_blue" = "#002a3a",
"logo_orange" = "#f16728"
)
project_path <- file.path("S:","STATGS","BE","Publ","Befolkningsfremskrivninger")
language <- "da"
# Statbank
use_bank <- "http://testbank.stat.gl/api/v1/en/Greenland" # internal test tables
#use_bank <- "https://bank.stat.gl/api/v1/en/Greenland" # published tables
# tables used in this document
popAcc <- "bexcalcr2" # consolidated population account
bexbbp <- "bexbbp" # births by birth order and age of mother
bexfertr <- "bexfertr" # fertility rates by age of mother
BEXREVANDR <- "BEXREVANDR" # remigration
BEXFLYTR <- "BEXFLYTR" # regional migration
###########################
# settings for calculations
###########################
# name on spreadsheet that holds all emperic data and assumptions
calcBase <- "Base_main.xlsx" # must have .xlsx extension
calcBase <- file.path(getwd(),"xlsx","Base_main.xlsx")
baseYear <- 2025
pubhorizonYear <- 2050
horizonYear <- baseYear + 100
# fertility
fertYears <- c(2020:2024)
fertAdapt <- 10
# fertility age structure change
fert_change_start_years <- c(2010:2014)
fert_change_end_years <- c(2020:2024)
fert_change_count_years <- 10
# Convert to ranges txt
fertYears_txt <- integer_to_ranges(fertYears)
txt_fert_change_start_years <- integer_to_ranges(fert_change_start_years)
txt_fert_change_end_years <- integer_to_ranges(fert_change_end_years)
# mortality
#mort_base_years <- c(2017:2019,2022,2023)
mort_base_years <- c(2020:2024)
mort_base_years_txt <- integer_to_ranges(mort_base_years)
mort_compare_years <- c(2010:2014)
mort_change_count_years <- 10
# mutate(value=ifelse(nochange_mort,qx,qx*(1+pct/100)^kvot))
# mutate(value=qx*(1+pct/100)^kvot)
# mutate(value=qx)
nochange_mort <- FALSE
mortYears <- unique(c(mort_base_years,mort_compare_years)) %>% as.character()
mortAdapt <- horizonYear-baseYear
mortAdaptStart <- 10+1
ltstartYear <- 1999
ltendYear <- 2024
num_years <- 20
# Convert to ranges txt for presentation
txt_mort_base_years <- integer_to_ranges(mort_base_years)
txt_mort_compare_years <- integer_to_ranges(mort_compare_years)
# emigration
imgrbaseYears <- c(2018,2019,2022,2023,2024)
emiYears <- imgrbaseYears
txt_emiYears <- integer_to_ranges(emiYears)
# remigration
revandYears <- c(2014:2018)
txt_revandYears <- integer_to_ranges(revandYears)
# regional migration
movematrixYears <- c(2018:2019,2022:2024)
txt_movematrixYears <- integer_to_ranges(movematrixYears)
###########################
# regions
###########################
sel_area <- c("ALL","NUK","RES","BY_","BGD","955","956","957","959","960","LP2","LP3","LP4","LP5","LP6")
###########################
# add text & formats
###########################
pxtxt1 <- "main"
pxtxt2 <- "2025 Main alternative"
pxtxt3 <- "2025 Hovedalternativ"
pxtxt4 <- "2025-imi Inuit amerlassusissaat pingaarneq"
get_codelist <- function(table_id, langs = c("en", "kl", "da")) {
enframe(langs, name = NULL, value = "langs") %>%
mutate(hi = map2_chr(table_id, langs, statgl_url) %>%
purrr::map(statgl_meta) %>%
purrr::map(pluck,"variables")
) %>%
unnest(hi) %>%
unnest(c(values, valueTexts)) %>%
select(variable = code,
`variable-code` = text,
code = values,
language = langs,
value = valueTexts) %>%
group_by(variable,language) %>%
mutate(sortorder = row_number())
}
# try to get code labels for a variable
area <- get_codelist("BEXCALCR2") %>%
filter(variable=="omr" & language == "da" & !str_detect(code, "^D") & code!="961") %>%
as.data.frame() %>%
select(area=code,area.lang=value)
sex <- get_codelist("BEXCALCR2") %>%
filter(variable=="sex" & language == "da") %>%
as.data.frame() %>%
select(sex=code,sex.lang=value)
# pob <- get_codelist("BEXCALCR2") %>%
# filter(variable=="place of birth" & language == "da") %>%
# as.data.frame() %>%
# select(pob=code,pob.lang=value)
pob <- read.csv2(file.path(project_path,"texts","BE_var_text.txt"), fileEncoding = "utf8") %>%
filter(variable=="pob") %>%
select(pob=code,pob.lang=language)
# format areas in groups
fmt_grp <- function(area){
case_when(area %in% c("ALL") ~ '1',
area %in% c("NUK","RES") ~ '2',
area %in% c("BY_","BGD") ~ '3',
area %in% c("955","956","957","959","960") ~ '4',
area %in% c("LP2","LP3","LP4","LP5","LP6") ~ '5',
.default='fejl')
}
###########################
# The first sheet in the workbook is introduction to the workbook content
# save xlsx data template
###########################
# first sheet - will have more content before release
#content <- "Main alternative"
txt1 <- "This spreadheet holds ALL data and derived/calculated rates as required by the projection engine."
txt2 <- "Further information and sourcecode can be found in Base_main.html"
txt3 <- "All sheets can be manually manipulated, but you are advised to use the .qmd "Udgangsbefolkning
Udgangsbefolkningen per 1. januar 2025, hentes fra
Befolkningsregnskabet. Her er befolkningen opdelt efter
fødestedsgrupperne, ‘født i Grønland(N)’, ‘født i Danmark/Færøerne(S)’
samt ‘født udenfor Rigsfællesskabet(A)’.
Det er alene befolkningen født i Grønland, som fremskives. For de som er født udenfor Grønland, holdes udgangsårets køn og aldersfordeling, konstant i hele fremskrivningsperioden.
popBase_tmp <- statgl_fetch(statgl_url(popAcc, api_url = use_bank),
omr=sel_area,
sex=c("M","F"),
fsted=c("N","S","A"),
ttype="P",
faar=px_all(),
trekant="9",
.val_code = TRUE) %>%
clean_names() %>%
mutate(age=strtoi(time)-strtoi(year_of_birth)-1,
pob=place_of_birth) %>%
filter(age>=0 & age<100 & !str_detect(area, "^D")) %>%
mutate(value=ifelse(is.na(value),0,value),
grp=fmt_grp(area)) %>%
select(time,grp,area,pob,sex,age,value) %>%
arrange(time,grp,area,pob,sex,age)
popBase <- popBase_tmp %>%
spread(key="pob",value="value") %>%
mutate(P=0) %>%
gather(key="pob",value="value", c(N,S,A,P)) %>%
spread(key="time",value="value")
popBase_baseYear <- popBase_tmp %>%
filter(time==baseYear)
popBase_baseYear %>%
filter(area=="ALL") %>%
left_join(sex) %>%
left_join(pob) %>%
mutate(label_str = ifelse(pob == "S",
sprintf("%4.0f", strtoi(time)),""
)) %>%
ggplot(aes(
x = age,
y = value,
color = factor(sex.lang)
)) +
geom_line(linewidth = 1) +
# geom_smooth(method= "gam" ,se=FALSE) +
geom_text(aes(label = label_str, x = 50, y = 400), size = 18, color = "lightgray") +
facet_wrap( ~ factor(pob.lang), ncol = 3) +
theme_statgl() +
labs(
title = paste0("Figur 1. Befolkningen, efter fødested, køn og alder"),
x = "alder",
y = "antal personer",
color=NULL
)
# Modellen er et fit fra følgende:
model <- mgcv::gam(value ~ grp + area + pob + sex + s(age, bs = "cs"), data = popBase_baseYear)
popfitBase <- broom::augment(model) %>%
mutate(time=as.character(baseYear+1)) %>%
select(-value) %>%
rename(value=.fitted) %>%
mutate(value=ifelse(value<0,0,value)) %>%
select(time,grp,area,pob,sex,age,value) %>%
spread(key="pob",value="value") %>%
mutate(P=0) %>%
gather(key="pob",value="value", c(N,S,A,P)) %>%
spread(key="time",value="value")Historik
eventcodes <- c("B","D","O","I","T","F")
event_raw <- purrr::map(
eventcodes,
~ statgl_fetch(statgl_url(popAcc, api_url = use_bank),
sex=c("F","M"),omr=sel_area,fsted=c("N"), trekant = c("0","1"), ttype = .x, .eliminate_rest = F, .col_code = T, .val_code = T)
)
# eventdata <- event_raw %>%
# bind_rows() %>%
# drop_na(value) %>%
# mutate(faar=strtoi(faar),
# lexis=strtoi(trekant),
# time=strtoi(taar),
# age=time-faar-lexis+1) %>%
# filter(age>=0 & age<100) %>%
# group_by(time,omr,sex,ttype,age) %>%
# summarise(value=sum(value),.groups = "rowwise") %>%
# mutate(grp=fmt_grp(omr)) %>%
# select(time,grp,area=omr,sex,event=ttype,age,value) %>%
# arrange(time,grp,area,sex,age,event) %>%
# spread(key="time",value="value")
event_raw_df <- bind_rows(event_raw, .id = "source")
alle_events <- event_raw_df %>%
pull(ttype) %>%
unique()
event_summ <- event_raw_df %>%
filter(!is.na(value)) %>%
mutate(
faar = as.integer(faar),
lexis = as.integer(trekant),
time = as.integer(taar),
age = time - faar - lexis + 1
) %>%
filter(age >= 0, age < 100) %>%
group_by(time, omr, sex, ttype, age) %>%
summarise(value = sum(value), .groups = "drop") %>%
mutate(grp = fmt_grp(omr)) %>%
select(grp, area = omr, sex, event = ttype, age, time, value) %>%
mutate(
grp = as.character(grp),
area = as.character(area),
sex = as.character(sex),
event = as.character(event),
age = as.integer(age),
time = as.integer(time)
)
combo_base <- event_summ %>%
distinct(grp, area, sex, age, time) %>%
crossing(event = alle_events) %>%
mutate(
grp = as.character(grp),
area = as.character(area),
sex = as.character(sex),
event = as.character(event),
age = as.integer(age),
time = as.integer(time)
)
eventdata <- combo_base %>%
left_join(event_summ, by = c("grp", "area", "sex", "age", "time", "event")) %>%
mutate(value = replace_na(value, 0)) %>%
pivot_wider(
names_from = time,
values_from = value
)
rm(event_raw)
# to calculate general sexratio all livebirth after 1973 is used
# and to have data on cohorts by regions
birth_raw <- statgl_fetch(statgl_url("bexfertr", api_url = use_bank), omr=sel_area,m_fsted=px_all(),sex=px_all(), .eliminate_rest = T, .col_code = T, .val_code = T) %>%
clean_names() %>%
mutate(grp=fmt_grp(omr)) %>%
select(grp,area=omr,everything())I de endelige tabeller skal det beregnede fremtidige folketal og hændelser direkte kunne præsenteres sammen med de historiske. Derfor er det praktisk at inkludere data om antal personer, fødsler, dødsfald, ud- og indvandringer samt til- og fraflytninger.
Historiske hændelser er alle opdelt efter køn, fødselsårgang og fødestedsgruppe. Historiske hændelser er ens for alle alternativer.
Fertilitet
childRBase_tmp <- statgl_fetch(statgl_url(bexfertr, api_url = use_bank),taar=fertYears, omr=sel_area, alder=px_all(), m_fsted=c("N"), .eliminate_rest = T, .col_code = T, .val_code = T) %>%
clean_names() %>%
select(-m_fsted) %>%
rename(C=value) %>%
mutate(alder=strtoi(alder),
taar=strtoi(taar))
fertRBase <- statgl_fetch(statgl_url(popAcc, api_url = use_bank),
taar=sort(unique(c(fertYears,fertYears+1))), sex=c("F"),omr=sel_area,
fsted=c("N"), trekant = c("9"), ttype = "P",
.eliminate_rest = F, .col_code = T, .val_code = T) %>%
clean_names() %>%
select(-trekant,-sex, -fsted, -ttype) %>%
mutate(taar=strtoi(taar),
alder=taar-strtoi(faar)-1) %>%
filter(alder>=12 & alder<50) %>%
select(-faar)
fert_Main <- childRBase_tmp %>%
left_join(fertRBase) %>%
mutate(Y1=taar,
taar=taar+1,
M1=value) %>%
select(-value) %>%
left_join(fertRBase) %>%
mutate(Y2=taar,
M2=value,
M=(M1+M2)/2) %>%
select(omr,alder,C,M) %>%
group_by(omr,alder) %>%
summarise_all(sum) %>%
ungroup() %>%
mutate(kvot=C/M*1000) %>%
rename(area=omr,age=alder)
fertYear_totfert <-
fert_Main %>%
select(area,age,kvot) %>%
drop_na(kvot) %>%
group_by(area) %>%
summarise(kvot=sum(kvot))Det fremtidige fødselstal beregnes ved antagelser om den fremtidige fertilitet og det fremtidige antal kvinder. I perioden 2010 til 2019 blev kalenderårsfertiliteten beregnet til et niveau på omkring 2 børn per kvinde. Siden 2020 er den observerede samlede fertilitet faldet fra 2,1 til under 1,8 barn per kvinde.
Til fremskrivningernes hovedalternativ er disse år: 2020-2024 valgt som basisår. Her beregnes den samlede fertilitet til 1847 per 1.000 kvinder. De seneste 2 år er den samlede fertilitet endnu lavere,
Aldersforskydning
Den fremtidige fertilitet tilpasses i en overgangsperiode på 10 år,
svarende til ændringen i de aldersbetingede fertilitetskvotienter de
seneste 10 år, hvorefter fertiliteten holdes konstant i resten af
fremskrivningsperioden
For 2025 beregnes fertiliteten for kalenderårene 2020-2024. De beregnede fertilitetskvotienter udglattes for at reducere effekten af tilfældige kalenderårs effekter, som især skyldes den lille befolkning.
# Can be manually adjusted, setting the age specific fertility change
#
# age38 <- as.list(12:49)
# change <- as.list(c(-40,-40,-40,
# -40,-40,-30,-20,-10,
# -10,-5,-5,-5,-5,
# -5,0,0,5,5,
# 5,5,5,5,5,
# 10,10,10,10,10,
# 15,15,15,15,15,
# 15,15,15,15,15))
#
# FertChg <- tibble(age38,change)
# fert_change <- strtoi(FertChg$change)
# fertility age structure change
# fert_change_start_years <- c(2012,2013)
# fert_change_end_years <- c(2022,2023)
# fert_change_count_years <- 10
# comp_year_old <- baseYear-6
# comp_year_new <- baseYear-1
# compare fertility rates for the two periods
comp_years <- c(fert_change_start_years,fert_change_end_years)
# number of children
childRBase_tmp <- statgl_fetch(statgl_url(bexfertr, api_url = use_bank),taar=comp_years,omr=sel_area, faar=px_all(), m_fsted=c("N"), .eliminate_rest = T, .col_code = T, .val_code = T) %>%
clean_names() %>%
select(-m_fsted) %>%
rename(C=value)
# meanpopulation
meanpop <- purrr::map(
c("P","U"),
~ statgl_fetch(statgl_url(popAcc, api_url = use_bank),
taar=comp_years,
sex=c("F"),omr=sel_area,
fsted=c("N"), trekant = c("9"), ttype = .x,
.eliminate_rest = F, .col_code = T, .val_code = T)
%>%
clean_names()
) %>%
bind_rows() %>%
select(-trekant,-sex, -fsted) %>%
# rename(mothers_year_of_birth=faar,time=taar) %>%
drop_na(value) %>%
pivot_wider(names_from=ttype,values_from = value) %>%
mutate(M=(P+U)/2) %>%
select(-P,-U)
# group periods and calculate fertility rates
fertRBase <- meanpop %>%
left_join(childRBase_tmp, by = join_by(omr, faar, taar)) %>%
mutate(ageult=strtoi(taar)-strtoi(faar),
taar=ifelse((taar %in% fert_change_start_years),"a","b")) %>%
select(omr,ageult,taar,C,M) %>%
filter(ageult>=12 & ageult <=49) %>%
gather(key="type",value = "value",C:M) %>%
group_by(omr,taar,ageult,type) %>%
summarise(value=sum(value)) %>%
spread(key=type,value=value) %>%
mutate(kvot=C/M*1000) %>%
select(-C,-M) %>%
spread(key=taar,value=kvot) %>%
mutate(fert_change=(b-a)/a*100)
fert_change <- fertRBase %>%
select(omr,age=ageult,value=fert_change) %>%
mutate(value=ifelse(is.na(value),0,value),
value=ifelse(is.infinite(value),0,value))
fert_change_all <- mgcv::gam(value ~ s(age, bs = "cs"), data = fert_change %>% filter(omr=="ALL"))
step_dta <- tibble(age=fert_change_all$model$age,
Agechn=as.integer(fert_change_all$fitted.values))
fert_all_dta <- fert_change %>%
filter(omr=="ALL") %>%
left_join(step_dta) %>%
select(age,Agechn,value) %>%
gather(key="type",value = "value",Agechn:value)
fert_all_dta %>%
ggplot(aes(x=age,y=value,col=type),ylim()) +
scale_colour_discrete(guide = 'none') +
geom_point(data=fert_all_dta %>% filter(type=="value"), linewidth = 1.2) +
geom_step(data=fert_all_dta %>% filter(type=="Agechn"), linewidth = 1.2) +
theme_statgl() +
labs(
title = paste0("Figur 2. Beregningsparameter: Model af aldersforkydning, fra (", txt_fert_change_start_years,") til (", txt_fert_change_end_years,")"),
subtitle = paste0("samlet pct ændring over ", fert_change_count_years, " år"),
x = "alder",
y = "pct ændring",
color = NULL
) +
ylim(-50,50)
#############
fert_change1 <- fert_change %>%
filter(omr=="ALL" &
age>=12 & age<=49) %>%
rename(Agecng=value) %>%
select(-omr)
fert_fut <- fert_Main %>%
mutate(grp=fmt_grp(area)) %>%
left_join(fert_change1, by = join_by(age)) %>%
mutate(Agecng=ifelse(is.na(Agecng),0,Agecng),
kvot_10 = kvot+10*(kvot*Agecng/1000)) %>%
select(grp,everything()) %>%
arrange(grp,area,age) %>%
filter(age<50)
fert_tot <- fert_fut %>%
select(grp,area,a=kvot,aa=kvot_10) %>%
group_by(grp,area) %>%
summarise_all(.funs=sum)
# fert_fut <- fert_Main %>%
# mutate(grp=fmt_grp(area),
# Agecng = cut(ageult, breaks = c(seq(12, 49, by = 1), Inf), labels = fert_change, right = FALSE),
# Agecng = strtoi(Agecng),
# kvot_01 = kvot+1*(kvot*Agecng/1000),
# kvot_02 = kvot+2*(kvot*Agecng/1000),
# kvot_03 = kvot+3*(kvot*Agecng/1000),
# kvot_04 = kvot+4*(kvot*Agecng/1000),
# kvot_05 = kvot+5*(kvot*Agecng/1000),
# kvot_06 = kvot+6*(kvot*Agecng/1000),
# kvot_07 = kvot+7*(kvot*Agecng/1000),
# kvot_08 = kvot+8*(kvot*Agecng/1000),
# kvot_09 = kvot+9*(kvot*Agecng/1000),
# kvot_10 = kvot+10*(kvot*Agecng/1000),
# kvot_11 = kvot_10) %>%
# select(grp,everything()) %>%
# arrange(grp,area,ageult)
#horizonYear-baseYear
fert_tot_fut <- fert_fut %>%
# filter(area=="ALL") %>%
select(area,age,a=kvot,aa=kvot_10) %>%
pivot_longer(cols=c(a,aa), names_to = "time") %>%
mutate(time=factor(ifelse(time=="a",baseYear-1,baseYear+9)))
fert_tot_fut %>%
filter(area=="ALL") %>%
ggplot(aes(
x = age,
y = value,
color = time
)) +
geom_line(linewidth = 1.2) +
geom_smooth(method = "gam", se = TRUE) +
theme_statgl() +
labs(
title = "Figur 3 Aldersbetinget fertilitet, 5-års grupper",
subtitle = glue::glue("{baseYear-1} & {baseYear+9}, Hele landet, kvinder født i Grønland"),
x = "alder",
y = "aldersbetinget fertilitetskvotient",
color = NULL
)
fert_fut_F5_10 <- fert_tot_fut %>%
filter(time==as.character(baseYear+9)) %>%
pivot_wider(names_from = c(area,time),values_from = value) %>%
summarise_all(.funs=sum) %>%
select(-age)
fert_tot_fut_1 <- fert_tot_fut %>% filter(time==baseYear-1)
fert_tot_fut_10 <- fert_tot_fut %>% filter(time==baseYear+9)
model_1 <- mgcv::gam(value ~ area+s(age, bs = "cs"), data = fert_tot_fut_1)
model_10 <- mgcv::gam(value ~ area+s(age, bs = "cs"), data = fert_tot_fut_10)
futfut_final <- broom::augment(model_1, fert_tot_fut_1) %>%
select(area,age,time,.fitted) %>%
rbind(broom::augment(model_10, fert_tot_fut_10) %>%
select(area,age,time,.fitted)) %>%
mutate(time=ifelse(time==baseYear-1,"kvot_fit","kvot_10_fit"),
.fitted=ifelse(.fitted<0,0,.fitted)) %>%
spread(key=time,.fitted) %>%
mutate(grp=fmt_grp(area)) %>%
select(grp,everything()) %>%
arrange(grp,area,age) %>%
left_join(fert_fut, by = join_by(grp, area, age)) %>%
select(grp,area,age,C,M,agecng=Agecng,kvot,kvot_10,kvot_fit,kvot_10_fit)
for (x in 1:fertAdapt){
varname <- paste0("kvot",x)
futfut_final[[varname]] <-futfut_final$kvot_fit+(x/fertAdapt*(futfut_final$kvot_10_fit-futfut_final$kvot_fit))
}
for (x in (fertAdapt+1):(horizonYear-baseYear)){
varname <- paste0("kvot",x)
futfut_final[[varname]] <-futfut_final$kvot_10_fit
}Med disse forventninger vil den samlede fertilitet falde fra 1847 i 2024 til 1707 i 2034 per 1.000 kvinder, for derefter at forblive konstant.
Dødelighed
# Anastasia Kostaki: Expanding an abridged life table
# https://www.demographic-research.org/articles/volume/5/1/
get_mort <- function(t,txt_t) {
popBase_tmp <- statgl_url(popAcc, api_url = use_bank) %>%
statgl_fetch(taar=t,
omr=sel_area,
sex=c("T","M","F"),
fsted=c("N"),
ttype=c("P","U"),
faar=px_all(),
trekant="9",
.val_code = TRUE) %>%
clean_names() %>%
mutate(yob=strtoi(year_of_birth),
age=strtoi(time)-yob-1) %>%
filter(age>=0 & !str_detect(area, "^D")) %>%
mutate(value=ifelse(is.na(value),0,value),
grp=fmt_grp(area)) %>%
select(time,grp,area,sex,yob,age,event,value) %>%
arrange(time,grp,area,sex,yob,event,age) %>%
spread(key=event,value=value)
# events - deaths
event_tmp <- statgl_url(popAcc, api_url = use_bank) %>%
statgl_fetch(taar = t,
sex=c("T","F","M"),
omr=sel_area,
fsted=c("N"),
faar=px_all(),
ttype = "D",
.eliminate_rest = T, .val_code = T) %>%
clean_names() %>%
mutate(yob=strtoi(year_of_birth),
age=strtoi(time)-yob-1) %>%
filter(age>=0) %>%
mutate(value=ifelse(is.na(value),0,value),
grp=fmt_grp(area)) %>%
select(time,grp,area,sex,yob,age,event,value) %>%
arrange(time,grp,area,sex,yob,event,age) %>%
spread(key=event,value=value)
# calcualte mortality rates
mortBase <- popBase_tmp %>%
left_join(event_tmp) %>%
filter(age<100) %>%
select(grp,area,sex,age,P,U,D) %>%
pivot_longer(cols=c(P,U,D),names_to = "type",values_to="value") %>%
group_by(grp,area,sex,age,type) %>%
summarise(value=sum(value)) %>%
spread(key="type",value=value) %>%
mutate(time=txt_t,
D=as.numeric(D),
M=(P+U)/2,
mxBase=ifelse(M==0,0,D/M)) %>%
ungroup()
return(mortBase)
}Selv når dødelighed beregnes for flere år under et, er befolkningen så lille, at der er stor usikkerhed omkring beregningerne, særligt i de ældre aldersklasser.
Til 2024-hovedalternativet beregnes dødelighed for disse år: 2020-2024 under et og den estimerede dødelighed glattes med r-pakken MortalityLaws hvor en Kostaki model anvendes. Både periodens observerede dødshyppigheder samt de glattede ses i figur 4.
mort_compare <- get_mort(mort_compare_years,txt_mort_compare_years)
mort_base <- get_mort(mort_base_years,txt_mort_base_years)
mort_base_compare <- mort_base %>%
bind_rows(mort_compare)
# Smoothening with ggplot cannot be used
# mort_base %>%
# filter(area=="ALL") %>%
# select(time,age,sex,mxBase) %>%
# ggplot(aes(x=age,
# y=mxBase,
# col=time)) +
# facet_wrap(~sex) +
# geom_line(linewidth=1.2) +
# geom_smooth(method = "gam", se = FALSE)
# From MortalityLaws we have these types:
# LEGEND:
# TYPE Coverage
# 1 Infant mortality
# 2 Accident hump
# 3 Adult mortality
# 4 Adult and/or old-age mortality
# 5 Old-age mortality
# 6 Full age range
# tab <- MortalityLaws::availableLaws() %>%
# .$table %>%
# filter(TYPE == "6") %>%
# pull(CODE)
fit_mort <- function(a,t,s) {
M1 <- mort_base_compare %>%
filter(area==a & time == t & sex == s) %>%
select(age,mxBase) %>%
mutate(age=as.integer(age)) %>%
as.data.frame()
age <- M1$age
mxBase <- M1$mxBase
M2 <- MortalityLaw(x = age, mx = mxBase, law = 'kostaki')
M3 <- data.frame(area=a,
time=t,
sex=s,
age=age,
mxBase=mxBase,
fit=M2$fitted.values)
return(M3)
}
# calculate fit for all combos of area, time and sex
fit_df_tmp <- data.frame()
for (a in sel_area){
for (t in c(txt_mort_base_years,txt_mort_compare_years)){
for (s in c("T","M","F")){
fit_part <- fit_mort(a,t,s)
fit_df_tmp <- rbind(fit_df_tmp, fit_part)
}}}
fit_tidy <- fit_df_tmp %>%
select(area,time,sex,age,mxBase,fit) %>%
left_join(sex) %>%
gather(key="type",value = "value",mxBase:fit)
fit_tidy %>% filter(sex!="T") %>%
filter(area=="ALL" & time==txt_mort_base_years) %>%
ggplot(aes(x=age,
y=value,
col=type)) +
scale_colour_discrete(guide = 'none') +
geom_point(data=fit_tidy %>% filter(area=="ALL" & time==txt_mort_base_years & type=="mxBase" & sex!="T"), linewidth = 1.2) +
geom_line(data=fit_tidy %>% filter(area=="ALL" & time==txt_mort_base_years & type=="fit" & sex!="T"), linewidth = 1.2) +
ylim(0,0.5) +
theme_statgl() +
facet_wrap(~sex.lang) +
labs(
title = "Figur 4 Aldersbetinget dødelighed",
subtitle = paste0("Kostaki glattet, Hele landet, beregnet for årene: ", txt_mort_base_years," samlet"),
x = "alder",
y = "dødskvotient",
color = NULL
)
De Kostaki-glattede dødshyppigheder fremskrives dernæst med den gennemsnitlige årlige køns- og aldersfordelte væksrate beregnet for perioden 1999 - 2024
BEXLTREG_raw <- statgl_fetch(statgl_url("BEXLTREG", api_url = use_bank),
area = px_all(),
calcbase = "B",
sex = c("T","F","M"),
age = px_all(),
measure = c("lx"),
pob = "N",
nop = "q5",
.val_code = T, .col_code = T)
nr1 <- BEXLTREG_raw %>%
mutate(age=strtoi(age),
time=strtoi(time)) %>%
filter(age<=99 & time>=ltstartYear & time<=ltendYear) %>%
select(time,area,sex,age,value)
nr2 <- nr1 %>%
mutate(time=time-num_years) %>%
rename(value_old=value) %>%
right_join(nr1,by = join_by(time, area, sex, age)) %>%
drop_na() %>%
mutate(pct=(value-value_old)/value_old*100)
death_change <- nr2 %>%
filter(time==max(time)) %>%
select(area,age,sex,pct) %>%
filter(!is.nan(pct) & !is.infinite(pct))
# drop_na()
death_change_reg <- mgcv::gam(pct ~ area+sex+s(age, bs = "cs"), data = death_change)
step_death <- tibble(area=death_change_reg$model$area,
sex=death_change_reg$model$sex,
age=death_change_reg$model$age,
pct=death_change_reg$model$pct,
fit=as.integer(death_change_reg$fitted.values))
future_death_pa <- step_death %>%
mutate(fit_pct=1+fit/100,
annual_growth_rate = (fit_pct)^(1/num_years) - 1,
annual_growth_rate_percent = annual_growth_rate * 100,
tjek=(1 + annual_growth_rate)^num_years,
total_growth_percent <- (tjek - 1) * 100
) %>%
select(area,sex,age,pct=annual_growth_rate_percent)options(future.globals.maxSize = 2 * 1024^3) # Øk til 2 GB
# calculate life table
lt_funk <- function(a,s,t) {
data <- fit_tidy %>%
filter(time==t & area==a & sex==s & type=="fit") %>%
select(age,value)
x <- 0:99
tmp <- LifeTable(x, mx = data$value, lx0 = 1000)
return(tmp[[1]])
}
lt_all <- data.frame()
for (t in c(txt_mort_base_years,txt_mort_compare_years)){
for (a in sel_area){
for (s in c("T","M","F")){
lt_sex <- lt_funk(a,s,t) %>%
mutate(time=t,
area=a,
sex=s,
age=x,
grp=fmt_grp(area)) %>%
select(time,grp,area,sex,age,everything())
lt_all <- rbind(lt_all, lt_sex)
}
}
}
# M1
# ls(M1)
# coef(M1)
# summary(M1)
# fitted(M1)
# predict(M1, x = 0:99)
# plot(M1)
mortBase_lt <- mort_base %>%
left_join(lt_all) %>%
mutate(const=1) %>%
left_join(future_death_pa) %>%
# select(area,sex,age,qx,pct) %>%
filter(age<=99) %>%
expand_grid(kvot=1:mortAdapt) %>%
mutate(value=
case_when(
nochange_mort != TRUE ~ qx*(1+pct/100)^kvot,
.default = qx
))
# calculate life table
lt_funk2 <- function(a,s,t) {
data <- mortBase_lt %>%
filter(kvot==t & area==a & sex==s) %>%
select(age,value)
x <- 0:99
tmp <- LifeTable(x, qx = data$value, lx0 = 1000)
return(tmp[[1]])
}
# lt_all2 <- data.frame()
#
# for (t in 1:mortAdapt){
# for (a in sel_area){
# for (s in c("T","M","F")){
# lt_sex <- lt_funk2(a,s,t) %>%
# mutate(time=t,
# area=a,
# sex=s,
# age=x,
# grp=fmt_grp(area)) %>%
# select(time,grp,area,sex,age,everything())
#
# lt_all2 <- rbind(lt_all2, lt_sex)
# }
# }
# }
library(furrr)
plan(multisession) # eller multicore
lt_all2 <- expand.grid(
time = 1:mortAdapt,
area = sel_area,
sex = c("T","M","F"),
stringsAsFactors = FALSE
) %>%
future_pmap_dfr(function(time, area, sex) {
lt_funk2(area, sex, time) %>%
mutate(
time = time,
area = area,
sex = sex,
age = x,
grp = fmt_grp(area)
) %>%
select(time, grp, area, sex, age, everything())
})
ex0 <- lt_all2 %>%
select(area,sex,age,time,ex) %>%
filter(age==0 & area=="ALL" & sex!="T") %>%
mutate(year=date(paste0(baseYear-1+time,"-01-01"))) %>%
select(area,sex,year,ex) %>%
filter(year<make_date(pubhorizonYear))
library(gganimate)
test <- mortBase_lt %>%
filter(area=="ALL" & time==txt_mort_base_years & sex!="T") %>%
mutate(year=date(paste0(baseYear-1+kvot,"-01-01"))) %>%
select(area,age,sex,year,value) %>%
filter(year<make_date(pubhorizonYear)) %>%
left_join(ex0)
# library(jpeg)
# library(ggimage)
# library(grid)
#
# male <- readJPEG(file.path(project_path,"qmd","alternatives","male.jpeg"))
# female <- readJPEG(file.path(project_path,"qmd","alternatives","female.jpeg"))
test %>% filter(sex!="T" & year<make_date(pubhorizonYear)) %>%
ggplot(aes(
x = age,
y = value,
col = sex
)) +
geom_line(linewidth = 1.2) +
theme_statgl() +
geom_text(aes(label = sprintf("%4.0f", (year(year))), x = 60, y = 0.15), size = 18, color = "lightgray") +
geom_text(aes(label = "Middellevetid:", x = 15, y = 0.25), size = 6, color = "lightgray") +
geom_text(aes(label = ifelse(is.na(ex), "", paste0("\u2640",sprintf(" %2.1f",ex))), x = 15, y = 0.1), size = 6, color = "#F97242", data = test[test$sex == "F",]) +
geom_text(aes(label = ifelse(is.na(ex), "", paste0("\u2642",sprintf(" %2.1f",ex))), x = 15, y = 0.17), size = 6, color = "#007F99", data = test[test$sex == "M",]) +
labs(
title = paste0("Figur 5 Middellevetid og dødshyppigheder: ",baseYear, " til ", pubhorizonYear),
subtitle = paste0("Hele landet, beregnet for årene: ", txt_mort_base_years," samlet"),
x = "alder",
y = "hyppighed",
color = NULL
) +
theme(legend.position="none") +
transition_time(year) +
ease_aes("linear")
mortBase_out <- mortBase_lt %>%
pivot_wider(names_from = kvot, names_prefix = "Y",values_from = value) %>%
mutate(time=ifelse(time==txt_mort_base_years,"b","a"))Figur 5 viser den forventede aldersbetingede dødelighed, samt det samlende begreb, middellevetid, fra 2025 frem mod 2125. I figur 6 ses dødshyppigheder og middellevetid for start og slutår.
test2 <- test %>% filter(sex!="T" & year<make_date(pubhorizonYear)) %>%
mutate(time=year(year)) %>%
filter(area %in% c("ALL") & time %in% c(baseYear, pubhorizonYear-1 )) %>%
select(time,area,sex,age,value,ex) %>%
left_join(sex)
test2 %>%
ggplot(aes(
x = age,
y = value,
col = sex.lang
)) +
geom_text(aes(label = ifelse(is.na(ex), "", paste0("\u2640",sprintf(" %2.1f",ex))), x = 15, y = 0.1), size = 6, color = "#F97242", data = test2[test2$sex == "F",]) +
geom_text(aes(label = ifelse(is.na(ex), "", paste0("\u2642",sprintf(" %2.1f",ex))), x = 15, y = 0.17), size = 6, color = "#007F99", data = test2[test2$sex == "M",]) +
geom_line(linewidth = 1.2) +
theme(legend.position="none") +
labs(
title = paste0("Figur 6 Middellevetid og dødshyppigheder: ",baseYear, " og ", pubhorizonYear-1),
subtitle = "Hele landet",
x = "alder",
y = "hyppighed",
color = NULL
) +
theme_statgl() +
facet_wrap(~time) 
Udvandringer
De årlige udvandringer beregnes ud fra erfaringer i perioderne 2018-2019, 2022-2024. I figur 7 vises de beregnede og glattede udvandringshyppigheder. Til fremskrivningerne anvendes de beregnede udvandringshyppigheder under alder 20 og de glattede i de øvrige aldre.
popBase_tmp <- statgl_fetch(statgl_url(popAcc, api_url = use_bank),
taar=emiYears,
omr=sel_area,
sex=c("M","F"),
fsted=c("N"),
ttype=c("P","U"),
faar=px_all(),
trekant="9",
.val_code = TRUE) %>%
clean_names() %>%
mutate(yob=strtoi(year_of_birth),
ageult=strtoi(time)-yob) %>%
filter(ageult>=0 & ageult<100 & !str_detect(area, "^D")) %>%
mutate(value=ifelse(is.na(value),0,value),
grp=fmt_grp(area)) %>%
select(time,grp,area,sex,yob,event,value) %>%
arrange(time,grp,area,sex,yob) %>%
spread(key=event,value=value)
event_tmp <- statgl_fetch(statgl_url(popAcc, api_url = use_bank),
taar = emiYears,
sex=c("F","M"),
omr=sel_area,
fsted=c("N"),
faar=px_all(),
ttype = "O",
.eliminate_rest = T, .val_code = T) %>%
clean_names() %>%
mutate(yob=strtoi(year_of_birth),
ageult=strtoi(time)-yob) %>%
filter(ageult>=0 & ageult<100) %>%
mutate(value=ifelse(is.na(value),0,value)) %>%
select(time,area,sex,yob,event,value) %>%
group_by(time,area,sex,yob,event) %>%
summarise(value=sum(value)) %>%
arrange(time,area,sex,yob) %>%
pivot_wider(names_from = event,values_from=value)
emiBase <- popBase_tmp %>%
left_join(event_tmp) %>%
mutate(ageult=strtoi(time)-yob,
grp=fmt_grp(area)) %>%
select(grp,area,sex,age=ageult,time,P,U,O) %>%
pivot_longer(cols=c(P,U,O),names_to = "type",values_to="value") %>%
group_by(grp,area,sex,age,type) %>%
summarise(value=sum(value)) %>%
ungroup() %>%
pivot_wider(names_from = type,values_from=value) %>%
mutate(M=(P+U)/2,
mxBase=ifelse(M==0,0,O/M),
const=1)
for (x in 1:(horizonYear-baseYear)){
varname <- paste0("kvot",x)
emiBase[[varname]] <- emiBase$mxBase
}
emiBase %>%
filter(area=="ALL") %>%
select(sex,age,mxBase) %>%
left_join(sex) %>%
ggplot(aes(x=age,
y=mxBase,
col=sex.lang)) +
geom_step() +
theme_statgl(palette = "spring") +
ylim(0,0.05) +
geom_smooth() +
labs(
title = paste0("Figur 7 Udvandringshyppigheder efter alder, undtagen alder 16"),
subtitle = paste0("Hele landet, beregnet for årene: ", txt_emiYears," samlet"),
x = "alder",
y = "hyppighed",
color = NULL
) 
Genindvandringer
I Statistikbanken findes genvandringer fra 1993 og frem. Først omkring 8 år efter udvandring, er de, som vil genindvandre, næsten alle med. Her anvendes erfaringer fra perioden 2014-2018.
revandR <- statgl_url(BEXREVANDR,api_url = use_bank) %>% statgl_fetch(omr = sel_area,
fsted = "N",
sex = c("F","M"),
alder_ult = px_all(),
vandrnmd = px_all(),
vandrn = c("2"),
.col_code = TRUE,
.val_code = TRUE
) %>%
select(area=omr,
duration=vandrnmd,
age=alder_ult,
sex,
time=taar,
value) %>%
drop_na(value) %>%
filter(strtoi(time) %in% revandYears) %>%
mutate(age=strtoi(age),
duration=strtoi(duration),
grp=fmt_grp(area)) %>%
group_by(grp,area,sex,age,duration) %>%
summarise(value=sum(value), .groups = "rowwise") %>%
pivot_wider(names_prefix = "c",names_from = duration,values_from = value, values_fill = 0) %>%
mutate(col5=c5+c6+c7) %>%
select(-c5,-c6,-c7) %>%
# select(-c4,-c5,-c6,-c7,-c8,-c9) %>%
mutate(total=c1+c2+c3+c4+col5+c99,
u1=c1/total*100,
u2=c2/total*100,
u3=c3/total*100,
u4=c4/total*100,
c5=col5,
u5=c5/total*100,
u99=c99/total*100) %>%
select(grp,area,sex,age,u1,u2,u3,u4,u5,u99)
# revandR %>%
# rename('under 1 år'=u1, '1-2 år'=u2, '2-3 år'=u3, '3-4 år'=u4, '4-5 år'=u5, 'uoplyst'=u99) %>%
# pivot_longer(col = c('under 1 år', '1-2 år', '2-3 år', '3-4 år', '4-5 år', 'uoplyst'), names_to = "duration", values_to = "value") %>%
# filter(area == "ALL") %>%
# mutate(value=value/100) %>%
# select(-grp, -area) %>%
# left_join(sex) %>%
# # left_join(varighed) %>%
# mutate(duration = factor(duration, levels = rev(c('under 1 år', '1-2 år', '2-3 år', '3-4 år', '4-5 år', 'uoplyst')))) %>%
# ggplot(aes(x = age, y = value, col = duration)) +
# geom_line(position = "stack", size = 1.2) +
# theme_statgl() +
# # scale_fill_statgl(reverse = TRUE, palette = "spring", guide = guide_legend(reverse = TRUE)) +
# scale_y_continuous(labels = scales::percent) +
# labs(
# title = "Figur 7 Genindvandringsandel efter køn, alder og varighed",
# subtitle = txt_revandYears,
# x = "",
# y = "andel",
# col = NULL
# ) +
# facet_wrap(~sex.lang)
library(scales)
revandR %>%
rename(
'under 1 år' = u1,
'1-2 år' = u2,
'2-3 år' = u3,
'3-4 år' = u4,
'4-5 år' = u5,
'uoplyst' = u99
) %>%
pivot_longer(
cols = c('under 1 år', '1-2 år', '2-3 år', '3-4 år', '4-5 år', 'uoplyst'),
names_to = "duration",
values_to = "value"
) %>%
filter(area == "ALL" & duration!='uoplyst' & age <= 75) %>%
mutate(value = value / 100) %>%
select(-grp, -area) %>%
left_join(sex) %>%
mutate(duration = factor(duration, levels = rev(c('under 1 år', '1-2 år', '2-3 år', '3-4 år', '4-5 år', 'uoplyst')))) %>%
ggplot(aes(x = age, y = value, col = duration)) +
geom_line(position = "stack", size = 1.2) +
theme_statgl() +
scale_color_discrete(guide = guide_legend(reverse = TRUE)) + # Reverse legend
scale_y_continuous(labels = scales::percent) +
labs(
title = "Figur 8 Genindvandringsandel efter køn, alder og varighed",
subtitle = txt_revandYears,
x = "",
y = "andel",
col = NULL
) +
facet_wrap(~sex.lang)
Historisk befolkning hentes fra Statistikbankens befolkningsregnskab
popHist <- statgl_url(popAcc,api_url = use_bank) %>%
statgl_fetch(taar=px_top(5),
omr=sel_area,
sex=c("M","F"),
fsted=c("N","S","A"),
ttype="P",
faar=px_all(),
trekant="9",
.val_code = TRUE) %>%
clean_names() %>%
mutate(age=strtoi(time)-strtoi(year_of_birth)-1,
pob=place_of_birth) %>%
filter(age>=0 & age<100 & !str_detect(area, "^D")) %>%
mutate(value=ifelse(is.na(value),0,value),
grp=fmt_grp(area)) %>%
select(grp,area,time,pob,sex,age,value) %>%
arrange(grp,area,time,pob,sex,age)Indenlandske flytninger
De indenlandske flytninger beregnes ud fra fraflytningskvotienter i årene: 2018-2019, 2022-2024. I 2024-fremskrivningerne antages at fraflytninger omfang og mønster er konstant i hele fremskrivningens horisont.
Pga den lille befolkning, benyttes kvotienterne ikke direkte. I stedet antages, at der findes en bagvedliggende ‘sand’ fraflytningsfordeling, som derfor udglattes for hvert køn, hvert område med en generel additiv model, på en måde, som sikrer pæne glatte kurver.
For de ældste aldersklasser ses en forøget fraflytning i de mindste bosteder.
Det beregnede antal fraflyttere fordeles dernæst til de regioner de tilflytter ud fra erfaringer i perioden 2018-2019, 2022-2024. For de 2 fremskrivnings regioner Nuuk/‘Resten af landet’ og By/Bygd er denne beregning enkel, men for lokalitetsstørrelse og kommune ses flyttematricene i denne oversigt:
Flyttematice, mellem regioner 2018-2019, 2022-2024
Lokalitetsstørrelse
| Fraflytningslokalitet |
Tilflytningslokalitet
|
Total | ||||
|---|---|---|---|---|---|---|
| Andre lokaliteter | Bosteder: 200 - 700 indb. | Større bosteder: 700 - 3.000 indb. | Hovedbosteder: 3000+ indb. | Hovedstad | ||
| Andre lokaliteter | ... | 15.4 | 33.7 | 36.4 | 14.6 | 100 |
| Bosteder: 200 - 700 indb. | 14 | ... | 32.7 | 35.1 | 18.1 | 100 |
| Større bosteder: 700 - 3.000 indb. | 13.6 | 14.8 | ... | 36.6 | 35 | 100 |
| Hovedbosteder: 3000+ indb. | 11.6 | 12.9 | 32.1 | ... | 43.4 | 100 |
| Hovedstad | 7.1 | 9.6 | 37.1 | 46.1 | ... | 100 |
Kommune
| Fraflytningskommune |
Tilflytningskommune
|
Total | ||||
|---|---|---|---|---|---|---|
| Kommune Kujalleq | Kommuneqarfik Sermersooq | Qeqqata Kommunia | Kommune Qeqertalik | Avannaata Kommunia | ||
| Kommune Kujalleq | ... | 59.5 | 17.3 | 8.8 | 14.4 | 100 |
| Kommuneqarfik Sermersooq | 23.3 | ... | 33.5 | 17.9 | 25.3 | 100 |
| Qeqqata Kommunia | 9.4 | 56 | ... | 16.6 | 18 | 100 |
| Kommune Qeqertalik | 6.3 | 33.3 | 20.1 | ... | 40.3 | 100 |
| Avannaata Kommunia | 8.7 | 41.8 | 18.8 | 30.7 | ... | 100 |
Flyttematricene er ud over region og fordelt på køn og alder.