Alternativ 1 - uændret dødelighed
Resumé 2026 forudsætninger samme demografiske tendenser som hovedalternativ med uændret dødelighed i hele fremskrivningsperioden
Her redegøres for kilde(r) samt afledte beregninger, som giver det fuldstændige datagrundlag for fremskrivningsalternativet. Se alle grundlagsdata i base_alt1.xlsx
`%||%` <- function(x, y) {
if (is.null(x) || length(x) == 0) y else x
}
calcBase <- file.path(getwd(), "xlsx", calcbase_name)
html_name <- sub("\\.xlsx$", ".html", calcbase_name)
if (!exists("txt1")) txt1 <- "This spreadheet holds ALL data and derived/calculated rates as required by the projection engine."
if (!exists("txt2")) txt2 <- paste0("Further information and sourcecode can be found in ", html_name)
if (!exists("txt3")) txt3 <- "All sheets can be manually manipulated, but you are advised to use the .qmd "
if (!exists("emiYears")) {
if (exists("imgrbaseYears")) {
emiYears <- imgrbaseYears
} else {
stop("Hverken emiYears eller imgrbaseYears er defineret.")
}
}
if (!exists("remigrate_adjust")) remigrate_adjust <- 0
if (!exists("emigration_shift_rules")) emigration_shift_rules <- list()
if (!exists("const_breaks")) const_breaks <- c(0, 5, 15, 18, 30, 50, 65)
if (!exists("const_values")) const_values <- c(1, 1, 1, 1, 1, 1)
if (!exists("const_breaks2")) const_breaks2 <- c(0, 5, 15, 18, 30, 50, 65)
if (!exists("const_values2")) const_values2 <- c(1, 1, 1, 1, 1, 1)
#CRAN
library(tidyverse)
library(gt)
library(janitor)
library(ggplot2)
library(openxlsx)
library(openxlsx2)
library(MortalityLaws)
# statgl - package by Statistics Greenland
library(statgl)
options(scipen = 999)
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], integer_list[i])
}
}
ranges <- c(ranges, list(current_range))
new_ranges <- ranges %>%
map_chr(~ paste(.x, collapse = "-")) %>%
paste(collapse = ", ")
return(new_ranges)
}
expand_rule_values <- function(x) {
if (is.null(x)) return(character(0))
as.character(unlist(x, recursive = TRUE, use.names = FALSE))
}
expand_rule_ages <- function(x) {
if (is.null(x)) return(integer(0))
vals <- unlist(x, recursive = TRUE, use.names = FALSE)
vals <- suppressWarnings(as.integer(vals))
vals[!is.na(vals)]
}
const_values_to_profile <- function(values, allow_percent = FALSE) {
values <- as.numeric(values)
if (length(values) == 0) return(numeric(0))
if (any(is.na(values))) stop("const/const2-værdier indeholder NA.")
if (isTRUE(allow_percent) && any(values < 0 | values > 2)) {
return(1 + values / 100)
}
values
}
piecewise_age_profile <- function(age, breaks, values, allow_percent = FALSE) {
breaks <- as.numeric(breaks)
values <- const_values_to_profile(values, allow_percent = allow_percent)
if (length(breaks) != length(values) + 1) {
stop("Antal breaks skal være præcis én større end antal values for const/const2.")
}
age <- suppressWarnings(as.numeric(age))
idx <- findInterval(age, vec = breaks, rightmost.closed = FALSE, all.inside = FALSE)
idx[idx < 1] <- 1
idx[idx > length(values)] <- length(values)
values[idx]
}
transition_weight <- function(k, start_offset, end_offset, transition = "linear") {
transition <- tolower(as.character(transition %||% "linear"))
if (k <= start_offset) {
return(0)
}
if (transition == "step") {
return(1)
}
if (is.null(end_offset) || is.na(end_offset)) {
end_offset <- k
}
if (end_offset <= start_offset) {
return(1)
}
p <- (k - start_offset) / (end_offset - start_offset)
p <- min(max(p, 0), 1)
if (transition == "smooth") {
return(p * p * (3 - 2 * p))
}
p
}
apply_emigration_shift_rules <- function(emiBase, rules, horizon_n, const_breaks2, const_values2) {
if (is.null(rules) || length(rules) == 0) {
return(emiBase)
}
out <- emiBase
if (!"mxBase" %in% names(out)) {
stop("emiBase mangler kolonnen mxBase.")
}
resolve_rule_offset <- function(year_value = NULL, offset_value = NULL, default = 0L, baseYear, pubhorizonYear, horizon_n) {
# Prioritet:
# 1) eksplicit year
# 2) eksplicit offset
# 3) "auto"
# 4) default
if (!is.null(year_value) && length(year_value) > 0 && !all(is.na(year_value))) {
y <- suppressWarnings(as.integer(year_value[[1]]))
if (!is.na(y)) {
return(y - baseYear)
}
}
if (!is.null(offset_value) && length(offset_value) > 0 && !all(is.na(offset_value))) {
if (is.character(offset_value) && length(offset_value) == 1) {
txt <- trimws(tolower(offset_value))
if (txt == "auto") {
return(pubhorizonYear - baseYear)
}
}
off <- suppressWarnings(as.integer(offset_value[[1]]))
if (!is.na(off)) {
return(off)
}
}
default
}
for (rule in rules) {
areas <- expand_rule_values(rule$area)
sexes <- expand_rule_values(rule$sex)
ages <- expand_rule_ages(rule$age)
start_offset <- resolve_rule_offset(
year_value = rule$start_year,
offset_value = rule$start_offset,
default = 0L,
baseYear = baseYear,
pubhorizonYear = pubhorizonYear,
horizon_n = horizon_n
)
end_offset <- resolve_rule_offset(
year_value = rule$end_year,
offset_value = rule$end_offset,
default = horizon_n,
baseYear = baseYear,
pubhorizonYear = pubhorizonYear,
horizon_n = horizon_n
)
transition <- tolower(as.character(rule$transition %||% "linear"))
target_mode <- tolower(as.character(rule$target_mode %||% "pct"))
target_pct <- suppressWarnings(as.numeric(rule$target_pct %||% 0))
if (is.na(start_offset)) start_offset <- 0L
if (is.na(end_offset)) end_offset <- horizon_n
hit <- rep(TRUE, nrow(out))
if (length(areas) > 0) hit <- hit & out$area %in% areas
if (length(sexes) > 0) hit <- hit & out$sex %in% sexes
if (length(ages) > 0) hit <- hit & out$age %in% ages
if (!any(hit)) next
target_factor <- switch(
target_mode,
"pct" = rep(1 + target_pct / 100, sum(hit)),
"const2" = out$const2[hit],
stop("Ukendt target_mode i emigration_shift_rules: ", target_mode)
)
for (k in seq_len(horizon_n)) {
col_k <- paste0("asor", k)
if (!col_k %in% names(out)) next
w <- transition_weight(
k = k,
start_offset = start_offset,
end_offset = end_offset,
transition = transition
)
out[[col_k]][hit] <- out$mxBase[hit] * (1 + w * (target_factor - 1))
}
}
out
}
# Official colors of Statistics Greenland --------------------------------------
statgl_colors <- c(
"darkblue" = "#004459",
"darkgreen" = "#939905",
"green" = "#94BB1F",
"blue" = "#007F99",
"lightgreen" = "#CEE007",
"orange" = "#faa41a",
"peach" = "#F97242",
"darkorange" = "#F95602",
"darkgrey" = "#848c8c",
"grey" = "#b8bab8",
"lightgrey" = "#f1f2f2",
"logo_blue" = "#002a3a",
"logo_orange" = "#f16728"
)
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)
mort_base_years_txt <- integer_to_ranges(mort_base_years)
mortYears <- unique(c(mort_base_years, mort_compare_years)) %>% as.character()
mortAdapt <- horizonYear - baseYear
mortAdaptStart <- 10 + 1
txt_mort_base_years <- integer_to_ranges(mort_base_years)
txt_mort_compare_years <- integer_to_ranges(mort_compare_years)
txt_emiYears <- integer_to_ranges(emiYears)
txt_revandYears <- integer_to_ranges(revandYears)
txt_movematrixYears <- integer_to_ranges(movematrixYears)
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())
}
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 <- read.csv2(file.path(project_path, "texts", "BE_var_text.txt"), fileEncoding = "utf8") %>%
filter(variable=="pob") %>%
select(pob=code, pob.lang=language)
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"
)
}Udgangsbefolkning
Udgangsbefolkningen per 1. januar 2026, 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(asfr=C/M*1000) %>%
rename(area=omr,age=alder)
fertYear_totfert <-
fert_Main %>%
select(area,age,asfr) %>%
drop_na(asfr) %>%
group_by(area) %>%
summarise(asfr=sum(asfr))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: 2021-2025 valgt som basisår. Her beregnes den samlede fertilitet til 1763 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 2026 beregnes fertiliteten for kalenderårene 2021-2025. 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 default sat i yaml_defaults-chunk
# 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(asfr=C/M*1000) %>%
select(-C,-M) %>%
spread(key=taar,value=asfr) %>%
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),
asfr_10 = asfr+10*(asfr*Agecng/1000)) %>%
select(grp,everything()) %>%
arrange(grp,area,age) %>%
filter(age<50)
fert_tot <- fert_fut %>%
select(grp,area,a=asfr,aa=asfr_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),
# asfr_01 = asfr+1*(asfr*Agecng/1000),
# asfr_02 = asfr+2*(asfr*Agecng/1000),
# asfr_03 = asfr+3*(asfr*Agecng/1000),
# asfr_04 = asfr+4*(asfr*Agecng/1000),
# asfr_05 = asfr+5*(asfr*Agecng/1000),
# asfr_06 = asfr+6*(asfr*Agecng/1000),
# asfr_07 = asfr+7*(asfr*Agecng/1000),
# asfr_08 = asfr+8*(asfr*Agecng/1000),
# asfr_09 = asfr+9*(asfr*Agecng/1000),
# asfr_10 = asfr+10*(asfr*Agecng/1000),
# asfr_11 = asfr_10) %>%
# select(grp,everything()) %>%
# arrange(grp,area,ageult)
#horizonYear-baseYear
fert_tot_fut <- fert_fut %>%
# filter(area=="ALL") %>%
select(area,age,a=asfr,aa=asfr_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,"asfr_fit","asfr_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,asfr,asfr_10,asfr_fit,asfr_10_fit)
for (x in 1:fertAdapt){
varname <- paste0("asfr",x)
futfut_final[[varname]] <-futfut_final$asfr_fit+(x/fertAdapt*(futfut_final$asfr_10_fit-futfut_final$asfr_fit))
}
for (x in (fertAdapt+1):(horizonYear-baseYear)){
varname <- paste0("asfr",x)
futfut_final[[varname]] <-futfut_final$asfr_10_fit
}Med disse forventninger vil den samlede fertilitet falde fra 1763 i 2025 til 1581 i 2035 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 beregning af 2026-hovedalternativet benyttes observerede dødshyppigheder for perioden 2021-2025. De estimerede dødeligheder glattes ved hjælp af R-pakken MortalityLaws, hvor en Kostaki-model anvendes. Kostaki-modellen er en udvidelse af den klassiske Heligman-Pollard-model, der giver yderligere fleksibilitet ved at tillade en asymmetrisk specifikation af den såkaldte “ulykkes-pukkel” blandt unge voksne. Glatningen er desuden væsentlig for de ældste aldersgrupper, hvor datamaterialet er meget tyndt — for aldre over 90 år foreligger kun omkring 50 observationer, og der er ingen observationer over 99 år. Her sikrer modellen en plausibel ekstrapolation af dødelighedskurven, som de rå dødshyppigheder alene ikke kan give. Både periodens observerede dødshyppigheder og de glattede værdier fremgår af 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 - 2025
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 = "asmr",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 2026 frem mod 2126. 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 2016-2019, 2022-2025. 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=piecewise_age_profile(age, const_breaks, const_values, allow_percent = FALSE),
const2=piecewise_age_profile(age, const_breaks2, const_values2, allow_percent = TRUE))
emi_horizon_n <- horizonYear - baseYear
for (x in seq_len(emi_horizon_n)) {
varname <- paste0("asor", x)
emiBase[[varname]] <- emiBase$mxBase
}
emiBase <- apply_emigration_shift_rules(
emiBase = emiBase,
rules = emigration_shift_rules,
horizon_n = emi_horizon_n,
const_breaks2 = const_breaks2,
const_values2 = const_values2
)
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 2015-2019.
Genindvandringsraterne (u1–u4) fanger tilbagevandring inden for 1–4
år efter udvandring. En del udvandrede vender dog først tilbage efter 5+
år. Parameteren remigrate_adjust (= 4.5 %) angiver, hvor
stor en andel af de ikke allerede genindvandrede der tillægges
som ekstra genindvandring i fremskrivningen. Ved 0 bruges kun u1–u4; ved
f.eks. 5 tillægges 5 % af restgruppen.
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: 2019-2019, 2022-2025. I 2026-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 2019-2019, 2022-2025. 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 2019-2019, 2022-2025
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.6 | 33.8 | 35.9 | 14.7 | 100 |
| Bosteder: 200 - 700 indb. | 13.1 | ... | 33 | 34.9 | 19 | 100 |
| Større bosteder: 700 - 3.000 indb. | 12.5 | 15.1 | ... | 35.8 | 36.6 | 100 |
| Hovedbosteder: 3000+ indb. | 12.3 | 12.8 | 30.6 | ... | 44.4 | 100 |
| Hovedstad | 7.1 | 10 | 36 | 46.9 | ... | 100 |
Kommune
| Fraflytningskommune |
Tilflytningskommune
|
Total | ||||
|---|---|---|---|---|---|---|
| Kommune Kujalleq | Kommuneqarfik Sermersooq | Qeqqata Kommunia | Kommune Qeqertalik | Avannaata Kommunia | ||
| Kommune Kujalleq | ... | 61.7 | 16.1 | 8.2 | 14.1 | 100 |
| Kommuneqarfik Sermersooq | 23.6 | ... | 32.5 | 17.9 | 26 | 100 |
| Qeqqata Kommunia | 9.3 | 56.7 | ... | 16 | 18 | 100 |
| Kommune Qeqertalik | 6.3 | 33.9 | 20 | ... | 39.8 | 100 |
| Avannaata Kommunia | 8.9 | 42.8 | 18.8 | 29.4 | ... | 100 |
Flyttematricene er ud over region også fordelt på køn og alder.