Commit 2e9e7333 authored by Reinhold Kainhofer's avatar Reinhold Kainhofer

Properly implement tables with yearly improvement factors (given as a matrix), like the RP2014

- Add function calculateImprovements to obtain the cumulated improvements for each age (for given period or birth year)
- Implement American RP 2014 (death probabilities only, no disability)
parent 1fbd30ea
......@@ -42,6 +42,7 @@ exportMethods(ageShift)
exportMethods(ages)
exportMethods(baseTable)
exportMethods(baseYear)
exportMethods(calculateImprovements)
exportMethods(deathProbabilities)
exportMethods(getCohortTable)
exportMethods(getOmega)
......
......@@ -65,8 +65,8 @@ setMethod("deathProbabilities","mortalityTable.trendProjection",
setMethod("deathProbabilities","mortalityTable.improvementFactors",
function(object, ..., YOB = 1975) {
qx = object@deathProbs * (1 + object@loading);
finalqx = (1 - object@improvement)^(YOB + 0:(length(qx) - 1) - object@baseYear) * qx;
object@modification(finalqx)
impr = calculateImprovements(object, ..., YOB = YOB)
object@modification(impr * qx)
})
#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
......
#' @include mortalityTable.R mortalityTable.period.R
NULL
setClassUnion("vectorOrMatrix", c("numeric", "matrix"))
#' Class mortalityTable.improvementFactors - Cohort life table with improvement
#' factors
#'
......@@ -33,7 +35,7 @@ mortalityTable.improvementFactors = setClass(
"mortalityTable.improvementFactors",
slots = list(
baseYear = "numeric",
improvement = "numeric"
improvement = "vectorOrMatrix"
),
prototype = list(
baseYear = 2012,
......@@ -41,3 +43,87 @@ mortalityTable.improvementFactors = setClass(
),
contains = "mortalityTable.period"
)
#' Calculate the improvement factors for the given birth-year and the
#' \code{\linkS4class{mortalityTable.improvementsFactors}} object
#'
#' @param object A pension table object (instance of a \code{\linkS4class{mortalityTable.improvementFactors}} class)
#' @param ... Currently unused
#' @param Period Observation period (either \code{Period} or \code{YOB} should be given)
#' @param YOB Year of birth (either \code{Period} or \code{YOB} should be given)
#'
#' @examples
#' pensionTables.load("USA_PensionPlan_RP2014")
#' calculateImprovements(RP2014.male, YOB = 2017)
#'
#' @exportMethod calculateImprovements
setGeneric("calculateImprovements", function(object, ...) standardGeneric("calculateImprovements"));
#' @describeIn calculateImprovements Calculate the total mortality improvement
#' factors relative to the base year for the given birth-year and the
#' \code{\linkS4class{mortalityTable.improvementsFactors}} object
setMethod("calculateImprovements", "mortalityTable.improvementFactors",
function(object, ..., Period = NULL, YOB = 1982) {
if (is.array(object@improvement)) {
# All years outside the observation interval use the improvements
# at the boundaries
minObservation = strtoi(head(colnames(object@improvement), 1))
maxObservation = strtoi(tail(colnames(object@improvement), 1))
if (!missing(Period) && !is.null(Period)) {
# Period improvements:
if (Period == object@baseYear) {
ags = ages(object)
improvements = rep(1, length(ags))
names(improvements) = ags
} else if (Period < object@baseYear) {
# Past mortalities
years = Period:(object@baseYear - 1)
years = sapply(years, function(x) { max(x, minObservation) } )
imprY = 1 - object@improvement[,as.character(years), drop = FALSE]
improvements = 1 / apply(imprY, 1, prod)
} else {
# Projection into the future
years = object@baseYear:(Period - 1)
years = sapply(years, function(x) { min(x, maxObservation) } )
imprY = 1 - object@improvement[,as.character(years), drop = FALSE]
improvements = apply(imprY, 1, prod)
}
} else {
# Generational improvements
ags = ages(object)
# For each age, determine the year and the improvement factors
# until/from the base year and multiply them
improvements = sapply(ags, function(a) {
yr = YOB + a
if (yr == object@baseYear) {
1
} else if (yr < object@baseYear) {
# Past mortalities
years = yr:(object@baseYear - 1)
years = sapply(years, function(x) { max(x, minObservation) } )
imprY = 1 - object@improvement[as.character(a), as.character(years)]
1 / prod(imprY)
} else {
# Projection into the future
years = object@baseYear:(yr - 1)
years = sapply(years, function(x) { min(x, maxObservation) } )
imprY = 1 - object@improvement[as.character(a), as.character(years)]
prod(imprY)
}
})
names(improvements) = ags
}
} else {
if (!missing(Period) && !is.null(Period)) {
improvements = (1 - object@improvement) ^ (Period - object@baseYear);
} else {
improvements = (1 - object@improvement) ^ (YOB + ages(object) - object@baseYear);
}
}
improvements
}
)
......@@ -54,8 +54,8 @@ setMethod("periodDeathProbabilities", "mortalityTable.trendProjection",
setMethod("periodDeathProbabilities", "mortalityTable.improvementFactors",
function (object, ..., Period = 1975) {
qx = object@deathProbs * (1 + object@loading);
finalqx = (1 - object@improvement) ^ (Period - object@baseYear) * qx;
object@modification(finalqx)
impr = calculateImprovements(object, ..., Period = Period)
object@modification(qx * impr)
})
#' @describeIn periodDeathProbabilities Return the (period) death probabilities
......
#' @import MortalityTables
NULL
stopifnot(require(methods), require(utils), require(MortalityTables)) # MortalityTable classes; new; Excel reader
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))
}
###############################################################################
# USA: RP2014 pension plan table with MP2014 mortality improvement factors
###############################################################################
RP2014.data = utils::read.csv(
system.file("extdata", "USA_PensionPlans_RP2014.csv", package = "MortalityTables"),
skip = 4,
header = FALSE,
col.names = c(
"age",
"qax", "qpx", "qix",
"qay", "qpy", "qiy",
"SPACER",
"qax_blue", "qpx_blue",
"qay_blue", "qpy_blue",
"SPACER",
"qax_white", "qpx_white",
"qay_white", "qpy_white",
"SPACER",
"age_young", "qx_young", "qy_young")
#, colClasses = c(age = "numeric", qax = "numeric", qpx = "numeric", qix = "numeric", qay = "numeric", qpy = "numeric", qiy = "numeric")
);
RP2014.readImprovements = function(file) {
data = as.matrix(utils::read.csv(
system.file("extdata", "USA_PensionPlans_MP2014_Male.csv", package = "MortalityTables"),
skip = 1,
check.names = FALSE,
header = TRUE,
row.names = 1
))
cn = colnames(data)
lastyear = tail(cn,1)
lastyear = substr(lastyear, 1, nchar(lastyear) - 1);
colnames(data) = c(head(cn, -1), lastyear)
bel20 = data["≤ 20",];
young = matrix(bel20, ncol = length(bel20), nrow = 21, byrow = TRUE, dimnames = list(0:20, colnames(data)))
rbind(young, data[-1,])
}
RP2014.improvement.male = RP2014.readImprovements("USA_PensionPlans_MP2014_Male.csv");
RP2014.improvement.female = RP2014.readImprovements("USA_PensionPlans_MP2014_Female.csv");
nameRP14 = function(name = "", desc = "") {
paste("RP2014", name, ", ", desc, sep = "")
}
tableRP14 = function(name, data = data, agevar = "age", probvar, improvement = NULL, ..., baseyear = 2014) {
if (is.null(improvement)) {
mortalityTable.period(
name = name, ages = data[[agevar]], baseYear = baseyear,
deathProbs = data[[probvar]], ...)
} else {
mortalityTable.improvementFactors(
name = name, ages = data[[agevar]], baseYear = baseyear,
deathProbs = data[[probvar]], improvement = improvement, ...)
}
}
RP2014.zeroes = mortalityTable.zeroes(name = "No transition", ages = RP2014.data[["age"]])
################################################################################
# Total Dataset (RP-2014 with MP-2014 improvements)
################################################################################
name = "";
RP2014.male = pensionTable(
name = nameRP14(desc = "male"),
baseYear = 2014,
qx = tableRP14(nameRP14(name, "qax, active males"), RP2014.data, "age", "qax", improvement = RP2014.improvement.male),
# The RP2014 table does not contain any invalidity probabilities
ix = RP2014.zeroes,
qgx = RP2014.zeroes,
qix = tableRP14(nameRP14(name, "qix, disabled males"), RP2014.data, "age", "qix", improvement = RP2014.improvement.male),
rx = RP2014.zeroes,
apx = RP2014.zeroes,
apix = RP2014.zeroes,
qpx = tableRP14(nameRP14(name, "qpx, retired males"), RP2014.data, "age", "qpx", improvement = RP2014.improvement.male),
hx = RP2014.zeroes,
qwy = RP2014.zeroes,
yx = RP2014.zeroes
)
RP2014.female = pensionTable(
name = nameRP14(desc = "female"),
baseYear = 2014,
qx = tableRP14(nameRP14(name, "qay, active females"), RP2014.data, "age", "qay", improvement = RP2014.improvement.female),
# The RP2014 table does not contain any invalidity probabilities
ix = RP2014.zeroes,
qgx = RP2014.zeroes,
qix = tableRP14(nameRP14(name, "qiy, disabled females"), RP2014.data, "age", "qiy", improvement = RP2014.improvement.female),
rx = RP2014.zeroes,
apx = RP2014.zeroes,
apix = RP2014.zeroes,
qpx = tableRP14(nameRP14(name, "qpy, retired females"), RP2014.data, "age", "qpy", improvement = RP2014.improvement.female),
hx = RP2014.zeroes,
qwy = RP2014.zeroes,
yx = RP2014.zeroes
)
################################################################################
# White collar dataset (RP-2014 with MP-2014 improvements)
################################################################################
name = "White Collar";
RP2014.male.whitecollar = pensionTable(
name = nameRP14(desc = "male"),
baseYear = 2014,
qx = tableRP14(nameRP14(name, "qax, active males"), RP2014.data, "age", "qax_white", improvement = RP2014.improvement.male),
# The RP2014 table does not contain any invalidity probabilities
ix = RP2014.zeroes,
qgx = RP2014.zeroes,
qix = tableRP14(nameRP14(name, "qix, disabled males"), RP2014.data, "age", "qix", improvement = RP2014.improvement.male),
rx = RP2014.zeroes,
apx = RP2014.zeroes,
apix = RP2014.zeroes,
qpx = tableRP14(nameRP14(name, "qpx, retired males"), RP2014.data, "age", "qpx_white", improvement = RP2014.improvement.male),
hx = RP2014.zeroes,
qwy = RP2014.zeroes,
yx = RP2014.zeroes
)
RP2014.female.whitecollar = pensionTable(
name = nameRP14(desc = "female"),
baseYear = 2014,
qx = tableRP14(nameRP14(name, "qay, active females"), RP2014.data, "age", "qay_white", improvement = RP2014.improvement.female),
# The RP2014 table does not contain any invalidity probabilities
ix = RP2014.zeroes,
qgx = RP2014.zeroes,
qix = tableRP14(nameRP14(name, "qiy, disabled females"), RP2014.data, "age", "qiy", improvement = RP2014.improvement.female),
rx = RP2014.zeroes,
apx = RP2014.zeroes,
apix = RP2014.zeroes,
qpx = tableRP14(nameRP14(name, "qpy, retired females"), RP2014.data, "age", "qpy_white", improvement = RP2014.improvement.female),
hx = RP2014.zeroes,
qwy = RP2014.zeroes,
yx = RP2014.zeroes
)
################################################################################
# Blue collar dataset (RP-2014 with MP-2014 improvements)
################################################################################
name = "Blue Collar";
RP2014.male.bluecollar = pensionTable(
name = nameRP14(desc = "male"),
baseYear = 2014,
qx = tableRP14(nameRP14(name, "qax, active males"), RP2014.data, "age", "qax_blue", improvement = RP2014.improvement.male),
# The RP2014 table does not contain any invalidity probabilities
ix = RP2014.zeroes,
qgx = RP2014.zeroes,
qix = tableRP14(nameRP14(name, "qix, disabled males"), RP2014.data, "age", "qix", improvement = RP2014.improvement.male),
rx = RP2014.zeroes,
apx = RP2014.zeroes,
apix = RP2014.zeroes,
qpx = tableRP14(nameRP14(name, "qpx, retired males"), RP2014.data, "age", "qpx_blue", improvement = RP2014.improvement.male),
hx = RP2014.zeroes,
qwy = RP2014.zeroes,
yx = RP2014.zeroes
)
RP2014.female.bluecollar = pensionTable(
name = nameRP14(desc = "female"),
baseYear = 2014,
qx = tableRP14(nameRP14(name, "qay, active females"), RP2014.data, "age", "qay_blue", improvement = RP2014.improvement.female),
# The RP2014 table does not contain any invalidity probabilities
ix = RP2014.zeroes,
qgx = RP2014.zeroes,
qix = tableRP14(nameRP14(name, "qiy, disabled females"), RP2014.data, "age", "qix", improvement = RP2014.improvement.female),
rx = RP2014.zeroes,
apx = RP2014.zeroes,
apix = RP2014.zeroes,
qpx = tableRP14(nameRP14(name, "qpy, retired females"), RP2014.data, "age", "qpy_blue", improvement = RP2014.improvement.female),
hx = RP2014.zeroes,
qwy = RP2014.zeroes,
yx = RP2014.zeroes
)
rm(RP2014.data, tableRP14, nameRP14, RP2014.readImprovements, RP2014.zeroes)
stopifnot(require(methods), require(utils), require(MortalityTables))
pensionTables.load("USA_PensionPlan_*")
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/mortalityTable.improvementFactors.R
\docType{methods}
\name{calculateImprovements}
\alias{calculateImprovements}
\alias{calculateImprovements,mortalityTable.improvementFactors-method}
\title{Calculate the improvement factors for the given birth-year and the
\code{\linkS4class{mortalityTable.improvementsFactors}} object}
\usage{
calculateImprovements(object, ...)
\S4method{calculateImprovements}{mortalityTable.improvementFactors}(object, ...,
Period = NULL, YOB = 1982)
}
\arguments{
\item{object}{A pension table object (instance of a \code{\linkS4class{mortalityTable.improvementFactors}} class)}
\item{...}{Currently unused}
\item{Period}{Observation period (either \code{Period} or \code{YOB} should be given)}
\item{YOB}{Year of birth (either \code{Period} or \code{YOB} should be given)}
}
\description{
Calculate the improvement factors for the given birth-year and the
\code{\linkS4class{mortalityTable.improvementsFactors}} object
}
\section{Methods (by class)}{
\itemize{
\item \code{mortalityTable.improvementFactors}: Calculate the total mortality improvement
factors relative to the base year for the given birth-year and the
\code{\linkS4class{mortalityTable.improvementsFactors}} object
}}
\examples{
pensionTables.load("USA_PensionPlan_RP2014")
calculateImprovements(RP2014.male, YOB = 2017)
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment