-
Reinhold Kainhofer authoredReinhold Kainhofer authored
PensionTables_Austria_AVOe2008P.R 10.69 KiB
#' @import MortalityTables
NULL
stopifnot(require(methods), require(utils), require(MortalityTables), require(readxl)) # MortalityTable classes; new; Excel reader
###############################################################################
# AVÖ 2008P exact (Male, Female)
###############################################################################
AVOe2008P = array(
data = c(pensionTable.NA),
dim = c(2, 2),
dimnames = list(Geschlecht = c("m", "w"), Bestand = c("Angestellte", "Mischbestand"))
)
AVOe2008PK = array(
data = c(pensionTable.NA),
dim = c(2, 2),
dimnames = list(Geschlecht = c("m", "w"), Bestand = c("Angestellte", "Mischbestand"))
)
if (is.null(getOption("MortalityTables.AVOe2008P"))) {
message("The pension table AVÖ 1999P requires the Excel file 'Austria_Pensions_AVOe2008P.xlsx'. Please set its path with options(\"MortalityTables.AVOe2008P\" = \"/path/to/Austria_Pensions_AVOe2008P.xlsx\").")
} else {
my.natrim <- function(v, ...) {
# Add a NA at the beginning and end, so the first and last entry of the rle
# call will always be for a NA => Use them to call head and tail accordingly:
vv = c(NA, v, NA);
r = rle(!is.na(vv));
tail(head(vv, -tail(r$lengths, 1)), -head(r$lengths, 1))
}
#' Modification function to add certain loading or special effect ending at a given age.
#'
#' Example: In the AVÖ 2008-P table, ix has a biological, fixed component, and
#' a surcharge that applies only during the last 7 years before the pension age
#'
#' @param effect The surcharge (numeric vector) to add. The last entry will
#' be aligned to apply to the given end age, all previous values
#' will apply to ages below.
#' @param pensionAge The age to which to align the end of the effect
#' @param ages The ages of the table (default: 0:100). Needed to properly
#' align the effect.
#' @export
modArbeitsmarkteffekt = function(effect, pensionAge = 65, ages = 0:100) {
function(probs) {
# cut off the effect to a maximum of pensionAge+1 entries (starting at age 0):
effect = tail(effect, pensionAge + 1)
# properly pad with 0 to cover the full age range from 0 to max(ages)
surcharge = c(
rep(0, pensionAge + 1 - length(effect)),
effect,
rep(0, max(ages) - pensionAge)
);
# Use the proper ages as dimnames, so we can later subset with the
# required ages (not all tables start with age 0!)
names(surcharge) = 0:max(ages);
# Set all base probabilities above the pensionAge to 0:
probs[ages > pensionAge] = 0;
# Add the surcharge to the original probabilities
probs + surcharge[as.character(ages)]
}
}
# if (FALSE) {
# mA = modArbeitsmarkteffekt(effect = 0:7/8, pensionAge = 30, ages = 10:20*2)
# mA(10:20*2)
# mA = modArbeitsmarkteffekt(effect = 0:7/8, pensionAge = 30, ages = 20:40)
# mA(20:40)
# }
AVOe2008P.generate = function(tab, name = "P", collar = "Angestellte") {
table08 = function(name, data, agevar = "x", probvar, trendvar = NULL, dim = list(), ..., baseyear = 1982) {
if (is.null(trendvar)) {
mortalityTable.period(
name = name, ages = data[[agevar]], baseYear = baseyear,
deathProbs = data[[probvar]], ...,
data = list(dim = dim))
} else {
mortalityTable.trendProjection(
name = name, ages = data[[agevar]], baseYear = baseyear,
deathProbs = data[[probvar]],
trend = data[[trendvar]],
dampingFunction = function(x) max(x, 0),
data = list(dim = dim),
...)
}
}
name08p = function(name, desc) {
paste("AVÖ 2008-", name, ", ", desc, sep = "")
}
data = read_excel(getOption("MortalityTables.AVOe2008P"), sheet = tab,
skip = 4,
col_names = c(
"x",
"qaax", "qix", "qpx", "qgx", "qwy", "ix", "hx", "yx",
"SPACER1",
"qaay", "qiy", "qpy", "qgy", "qwx", "iy", "hy", "xy",
"SPACER2", "lambdax", "lambday",
"SPACER3", "SPACER4", "Arbeitsmarkt_M", "Arbeitsmarkt_F")
# , colClasses = c(qpx = "numeric", qgx = "numeric", qpy = "numeric", qgy = "numeric")
);
male = pensionTable(
name = name08p(name, "Männer"),
baseYear = 1982,
qx = table08(name08p(name, "qax, active males"), data, "x", "qaax", "lambdax",
dim = list(sex = "m", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Tod")),
# ix has a biological, fixed component, and a surcharge that depends
# on the pension age => use a modification
ix = table08(
name08p(name, "ix, probability of invalidity"), data, "x", "ix",
modification = modArbeitsmarkteffekt(
my.natrim(data[["Arbeitsmarkt_M"]]),
pensionAge = 65,
ages = data[["x"]]
),
dim = list(sex = "m", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Invalidisierung")),
qgx = table08(name08p(name, "qgx, total males"), data, "x", "qgx", "lambdax",
dim = list(sex = "m", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Tod")),
qix = table08(name08p(name, "qix, disabled males"), data, "x", "qix", "lambdax",
dim = list(sex = "m", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Tod")),
rx = mortalityTable.zeroes(name = "No reactivation", ages = data[["x"]]),
apx = mortalityTable.onceAndFuture(transitionAge = 65 - 1, name = "Pensionsalter 65", ages = data[["x"]]),
qpx = table08(name08p(name, "qpx, retired males"), data, "x", "qpx", "lambdax",
dim = list(sex = "m", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Tod")),
hx = table08(name08p(name, "hx, marriage probability"), data, "x", "hx",
dim = list(sex = "m", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Partnerwahrscheinlichkeit im Tod")),
qwy = table08(name08p(name, "qwy, widows"), data, "x", "qwy", "lambday",
dim = list(sex = "w", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Tod")),
yx = table08(name08p(name, "y(x), age of widow"), data, "x", "yx",
dim = list(sex = "m", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "mittl. Hinterbliebenenalter")),
invalids.retire = FALSE,
data = list(
Geschlecht = "Männer",
Bestand = if (endsWith(name, "Arb./Ang.")) "Mischbestand" else "Angestellte",
Invalidisierung = "Invaliditätspension"
)
)
pensionAge = 65
female = pensionTable(
name = name08p(name, "Frauen"),
baseYear = 1982,
qx = table08(name08p(name, "qay, active females"), data, "x", "qaay", "lambday",
dim = list(sex = "w", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Tod")),
# ix has a biological, fixed component, and a surcharge that depends
# on the pension age => use a modification
ix = table08(
name08p(name, "iy, probability of invalidity"), data, "x", "iy",
modification = modArbeitsmarkteffekt(
my.natrim(data[["Arbeitsmarkt_F"]]),
pensionAge = pensionAge,
ages = data[["x"]]
),
dim = list(sex = "w", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Invalidisierung")),
qgx = table08(name08p(name, "qgy, total females"), data, "x", "qgy", "lambday",
dim = list(sex = "w", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Tod")),
qix = table08(name08p(name, "qiy, disabled females"), data, "x", "qiy", "lambday",
dim = list(sex = "w", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Tod")),
rx = mortalityTable.zeroes(name = "No reactivation", ages = data[["x"]]),
apx = mortalityTable.once(transitionAge = pensionAge - 1, name = "Pensionsalter 65", ages = data[["x"]]),
qpx = table08(name08p(name, "qpy, retired females"), data, "x", "qpy", "lambday",
dim = list(sex = "w", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Tod")),
hx = table08(name08p(name, "hy, marriage probability"), data, "x", "hy",
dim = list(sex = "w", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Partnerwahscheinlichkeit im Tod")),
qwy = table08(name08p(name, "qwx, widowers"), data, "x", "qwx", "lambdax",
dim = list(sex = "m", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "Tod")),
yx = table08(name08p(name, "x(y), age of widower"), data, "x", "xy",
dim = list(sex = "w", collar = collar, type = "Pensionstafel Österreich", data = "official", year = "AVÖ 2008-P", risk = "mittl. Hinterbliebenenalter")),
invalids.retire = FALSE,
data = list(
Geschlecht = "Frauen",
Bestand = if (endsWith(name, "Arb./Ang.")) "Mischbestand" else "Angestellte",
Invalidisierung = "Invaliditätspension"
)
)
list(male = male, female = female)
}
############################################################################## #
# Die Tafel als Array ----
############################################################################## #
AVOe2008P[, "Angestellte"] = AVOe2008P.generate("Angestellte", "P", collar = "Angestellte")
AVOe2008P[, "Mischbestand"] = AVOe2008P.generate("Arbeiter+Angestellte", "P Arb./Ang.", collar = "Mischbestand")
AVOe2008PK[, "Angestellte"] = AVOe2008P.generate("Angestellte PK", "P", collar = "Angestellte")
AVOe2008PK[, "Mischbestand"] = AVOe2008P.generate("Arbeiter+Angestellte PK", "P Arb./Ang.", collar = "Mischbestand")
AVOe2008P.male = AVOe2008P[["m", "Angestellte"]]
AVOe2008P.female = AVOe2008P[["w", "Angestellte"]]
AVOe2008P.male.Misch = AVOe2008P[["m", "Mischbestand"]]
AVOe2008P.female.Misch = AVOe2008P[["w", "Mischbestand"]]
rm(AVOe2008P.generate, AVOe2008P.tmp)
}