diff --git a/NAMESPACE b/NAMESPACE
index 3212ce0a81f169d138bf7a06ed94023585f954c7..05e80c9ed5aa0658d960dda9c837755db358846a 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -42,6 +42,7 @@ exportMethods(ageShift)
exportMethods(ages)
exportMethods(baseTable)
exportMethods(baseYear)
+exportMethods(calculateImprovements)
exportMethods(deathProbabilities)
exportMethods(getCohortTable)
exportMethods(getOmega)
diff --git a/R/deathProbabilities.R b/R/deathProbabilities.R
index c172cfa5fdbcd76fe7ec9a563709274d916ad4f8..92ff4da3280046de905ecc50c30a8c7a53c4e9f2 100644
--- a/R/deathProbabilities.R
+++ b/R/deathProbabilities.R
@@ -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
diff --git a/R/mortalityTable.improvementFactors.R b/R/mortalityTable.improvementFactors.R
index 80d599f5348149d929c90b8bb819a9633420d628..bf456d2e4c1ace4fa89cb506cd21e3857d7aae85 100644
--- a/R/mortalityTable.improvementFactors.R
+++ b/R/mortalityTable.improvementFactors.R
@@ -1,6 +1,8 @@
#' @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
+ }
+)
+
diff --git a/R/periodDeathProbabilities.R b/R/periodDeathProbabilities.R
index 3423faa8eac977e94a6e33f606e535aff4efae33..6a8a0c29600b63aea2240113d78714c9e9d72112 100644
--- a/R/periodDeathProbabilities.R
+++ b/R/periodDeathProbabilities.R
@@ -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
diff --git a/inst/extdata/PensionTables_USA_PensionPlan_RP2014.R b/inst/extdata/PensionTables_USA_PensionPlan_RP2014.R
new file mode 100644
index 0000000000000000000000000000000000000000..0b86d76908f14a7821372edb4ea60cff990bfcb9
--- /dev/null
+++ b/inst/extdata/PensionTables_USA_PensionPlan_RP2014.R
@@ -0,0 +1,195 @@
+#' @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)
+
diff --git a/inst/extdata/PensionTables_USA_PensionPlans.R b/inst/extdata/PensionTables_USA_PensionPlans.R
new file mode 100644
index 0000000000000000000000000000000000000000..24ad28e7ebfb45cebebcdbe7e129c0fc48d92fc7
--- /dev/null
+++ b/inst/extdata/PensionTables_USA_PensionPlans.R
@@ -0,0 +1,3 @@
+stopifnot(require(methods), require(utils), require(MortalityTables))
+
+pensionTables.load("USA_PensionPlan_*")
diff --git a/man/calculateImprovements.Rd b/man/calculateImprovements.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..56da9d3cafe13219688588509e285816857b3c23
--- /dev/null
+++ b/man/calculateImprovements.Rd
@@ -0,0 +1,39 @@
+% 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)
+
+}