Skip to content
Snippets Groups Projects
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)
}