Commit c6107537 authored by Reinhold Kainhofer's avatar Reinhold Kainhofer

More work on pension tables: Specifying and overriding pension age in transitionProbabilities

- Remove apix (pension transition of invalids) and replace it by a invalids.retire flag in the class (default FALSE)
- Allow the Period argument to transitionProbabilities (=> calls periodTransitionProbabilities)
- Allow overriding invalids.retire in the call to transitionProbabilities
- Add a retirement argument (number or mortalityTable) to transitionProbabilities to override the retirement age given in the pension table

- fix RP2014 improvement factors (young ages are included in improvments, but not in base probabilities)
parent 8a701e19
......@@ -22,11 +22,14 @@ NULL
#' \item{qix}{death probability of invalid (invalid -> dead)}
#' \item{rx}{reactivation probability (incapacity -> active)}
#' \item{apx}{retirement probability (active -> retirement), typically 1 for a fixed age}
#' \item{apx}{retirement probability of invalids (invalid -> retirement), typically 0 or 1 for a fixed age}
#' \item{qpx}{death probability of retired (retired -> dead)}
#' \item{hx}{probability of a widow at moment of death (dead -> widow), y(x) age difference}
#' \item{qxw}{death probability of widows/widowers}
#' \item{qgx}{death probability of total group (irrespective of state)}
#' \item{invalids.retire}{Flag to indicate whether invalid persons retire
#' like active (one death probability for all retirees) or whether
#' they stay invalid until death with death probabilities specific to
#' invalids.}
#' }
#'
#' @slot qx Death probability table of actives (derived from mortalityTable)
......@@ -34,12 +37,12 @@ NULL
#' @slot qix Death probability table of invalids (derived from mortalityTable)
#' @slot rx Reactivation probability of invalids (derived from mortalityTable)
#' @slot apx Retirement probability of actives (derived from mortalityTable)
#' @slot apix Retirement probability of invalids (derived from mortalityTable)
#' @slot qpx Death probability of old age pensioners (derived from mortalityTable)
#' @slot hx Probability of a widow at the moment of death (derived from mortalityTable)
#' @slot qwy Death probability of widow(er)s (derived from mortality Table)
#' @slot yx Age difference of the widow to the deceased
#' @slot qgx Death probability of whole group (derived from mortalityTable), irrespective of state
#' @slot invalids.retire Whether invalids retire like actives or stay invalid until death
#'
#' @export pensionTable
#' @exportClass pensionTable
......@@ -51,12 +54,15 @@ pensionTable = setClass(
qix = "mortalityTable",
rx = "mortalityTable",
apx = "mortalityTable",
apix = "mortalityTable",
qpx = "mortalityTable",
hx = "mortalityTable",
qwy = "mortalityTable",
yx = "mortalityTable",
qgx = "mortalityTable"
qgx = "mortalityTable",
invalids.retire = "logical"
),
prototype = list(
invalids.retire = FALSE
),
contains = "mortalityTable"
)
......@@ -92,26 +98,83 @@ pensionTableProbArrange = function(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, a
#' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class)
#' @param ... Currently unused
#' @param YOB Year of birth
#' @param as.data.frame Whether the return value should be a data.frame or an array containing transition matrices
#' @param Period Observation year to calculate period transition probabilities.
#' If given, this arguments overrides the \code{YOB} parameter
#' and this function returns period transition probabilities.
#' If this argument is not given or is null, then this function
#' returns generational transition probabilities.
#' @param as.data.frame Whether the return value should be a data.frame or an
#' array containing transition matrices
#' @param retirement Override the retirement transition probabilities of the
#' pension table. Possible values are:\itemize{
#' \item Single age (describing a deterministric retirement at the given age)
#' \item mortalityTable object: transition probabilities for retirement
#' }
#' @param invalids.retire Override the \code{\linkS4class{pensionTable}}'s
#' \code{invalids.retire} flag, which indicates whether
#' invalids retire like actives (i.e. same death
#' probabilities after retirement) or stay invalid until
#' death.
#'
#' @examples
#' pensionTables.load("Austria_*")
#' # transitionProbabilities(EttlPagler.male)
#' pensionTables.load("USA_PensionPlans")
#' transitionProbabilities(RP2014.male, YOB = 1962)
#' transitionProbabilities(RP2014.male, Period = 1955)
#' transitionProbabilities(RP2014.male, Period = 2025)
#'
#' @exportMethod transitionProbabilities
setGeneric("transitionProbabilities", function(object, ...) standardGeneric("transitionProbabilities"));
#' @describeIn transitionProbabilities Return all transition probabilities of the pension table for the generation YOB
setMethod("transitionProbabilities", "pensionTable",
function(object, YOB = 1982, ..., as.data.frame = TRUE) {
na.zero = function(x) { x[is.na(x)] = 0; x }
function(object, YOB = 1982, ..., Period = NULL, retirement = NULL,
invalids.retire = object@invalids.retire, as.data.frame = TRUE) {
if (!missing(Period) && !is.null(Period)) {
return(periodTransitionProbabilities(
object, ..., Period = Period, retirement = retirement,
invalids.retire = invalids.retire,
as.data.frame = as.data.frame))
}
x = ages(object@qx);
q = deathProbabilities(object@qx, ..., YOB = YOB);
i = deathProbabilities(object@ix, ..., YOB = YOB);
qi = deathProbabilities(object@qix, ..., YOB = YOB);
r = deathProbabilities(object@rx, ..., YOB = YOB);
ap = deathProbabilities(object@apx, ..., YOB = YOB);
api = deathProbabilities(object@apix, ..., YOB = YOB);
apTab = object@apx
if (!missing(retirement) && !is.null(retirement)) {
if (inherits(retirement, "mortalityTable")) {
apTab = retirement
} else if (is.numeric(retirement) && length(retirement) == 1) {
# Single retirement age given
apTab = mortalityTable.once(
transitionAge = retirement - 1, ages = x,
name = paste("Retirement at age ", retirement))
} else {
warning("transitionProbabilities: Invalid value for ",
"argument retirement. Allowed are only: numeric ",
"(retirement age) or mortalityTable (retirement ",
"probabilities). Given: ", retirement);
apTab = mortalityTable.zeroes(ages = x)
}
}
ap = deathProbabilities(apTab, ..., YOB = YOB);
if (!missing(retirement) && !is.null(retirement)) {
if (inherits(retirement, "mortalityTable")) {
} else if (is.numeric(retirement) && length(retirement) == 1) {
} else {
warning("transitionProbabilities: Invalid value for ",
"argument retirement. Allowed are only: numeric ",
"(retirement age) or mortalityTable (retirement ",
"probabilities). Given: ", retirement);
apTab = mortalityTable.zeroes(ages = x)
}
}
if (invalids.retire) {
api = ap
} else {
api = deathProbabilities(mortalityTable.zeroes(ages = x), ..., YOB = YOB)
}
qp = deathProbabilities(object@qpx, ..., YOB = YOB);
h = deathProbabilities(object@hx, ..., YOB = YOB);
qw = deathProbabilities(object@qwy, ..., YOB = YOB);
......@@ -125,11 +188,24 @@ setMethod("transitionProbabilities", "pensionTable",
#' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class)
#' @param Period Observation year
#' @param ... Currently unused
#' @param retirement Override the retirement transition probabilities of the pension table. Possible values are:\itemize{
#' \item Single age (describing a deterministric retirement at the given age)
#' \item mortalityTable object: transition probabilities for retirement
#' }
#' @param invalids.retire Override the \code{\linkS4class{pensionTable}}'s
#' \code{invalids.retire} flag, which indicates whether
#' invalids retire like actives (i.e. same death
#' probabilities after retirement) or stay invalid until
#' death.
#' @param as.data.frame Whether the return value should be a data.frame or an array containing transition matrices
#'
#' @examples
#' pensionTables.load("Austria_*")
#' # periodTransitionProbabilities(EttlPagler.male, Period = 2017)
#' pensionTables.load("USA_PensionPlans")
#' # transitionProbabilities internally calls periodTransitionProbabilities
#' # if a Period is given:
#' transitionProbabilities(RP2014.male, Period = 1955)
#' periodTransitionProbabilities(RP2014.male, Period = 1955)
#' periodTransitionProbabilities(RP2014.male, Period = 2025)
#'
#' @exportMethod periodTransitionProbabilities
setGeneric("periodTransitionProbabilities", function(object, ...) standardGeneric("periodTransitionProbabilities"));
......@@ -137,15 +213,36 @@ setGeneric("periodTransitionProbabilities", function(object, ...) standardGeneri
#' @describeIn periodTransitionProbabilities Return all transition probabilities of the pension table for the period Period
setMethod("periodTransitionProbabilities", "pensionTable",
function(object, Period = 2017, ..., as.data.frame = TRUE) {
na.zero = function(x) { x[is.na(x)] = 0; x }
function(object, Period = 2017, ..., retirement = NULL, invalids.retire = object@invalids.retire, as.data.frame = TRUE) {
x = ages(object@qx);
q = na.zero(periodDeathProbabilities(object@qx, ..., Period = Period));
i = na.zero(periodDeathProbabilities(object@ix, ..., Period = Period));
browser()
q = periodDeathProbabilities(object@qx, ..., Period = Period);
i = periodDeathProbabilities(object@ix, ..., Period = Period);
qi = periodDeathProbabilities(object@qix, ..., Period = Period);
r = periodDeathProbabilities(object@rx, ..., Period = Period);
ap = periodDeathProbabilities(object@apx, ..., Period = Period);
api = periodDeathProbabilities(object@apix, ..., Period = Period);
apTab = object@apx
if (!missing(retirement) && !is.null(retirement)) {
if (inherits(retirement, "mortalityTable")) {
apTab = retirement
} else if (is.numeric(retirement) && length(retirement) == 1) {
# Single retirement age given
apTab = mortalityTable.once(
transitionAge = retirement - 1, ages = x,
name = paste("Retirement at age ", retirement))
} else {
warning("transitionProbabilities: Invalid value for ",
"argument retirement. Allowed are only: numeric ",
"(retirement age) or mortalityTable (retirement ",
"probabilities). Given: ", retirement);
apTab = mortalityTable.zeroes(ages = x)
}
}
ap = deathProbabilities(apTab, ..., Period = Period)
if (invalids.retire) {
api = ap
} else {
api = deathProbabilities(mortalityTable.zeroes(ages = x), ..., Period = Period)
}
qp = periodDeathProbabilities(object@qpx, ..., Period = Period);
h = periodDeathProbabilities(object@hx, ..., Period = Period);
qw = periodDeathProbabilities(object@qwy, ..., Period = Period);
......
......@@ -51,8 +51,12 @@ RP2014.readImprovements = function(file) {
rbind(young, data[-1,])
}
RP2014.improvement.male = RP2014.readImprovements("USA_PensionPlans_MP2014_Male.csv");
RP2014.improvement.female = RP2014.readImprovements("USA_PensionPlans_MP2014_Female.csv");
RP2014.ages = RP2014.data[["age"]]
# The improvements include all ages from 0, while the qx start at 18 => cut off young ages in the improvements
RP2014.improvement.male.full = RP2014.readImprovements("USA_PensionPlans_MP2014_Male.csv");
RP2014.improvement.male = RP2014.improvement.male.full[as.character(RP2014.ages),]
RP2014.improvement.female.full = RP2014.readImprovements("USA_PensionPlans_MP2014_Female.csv");
RP2014.improvement.female = RP2014.improvement.female.full[as.character(RP2014.ages),]
nameRP14 = function(name = "", desc = "") {
......@@ -71,6 +75,7 @@ tableRP14 = function(name, data = data, agevar = "age", probvar, improvement = N
}
}
RP2014.zeroes = mortalityTable.zeroes(name = "No transition", ages = RP2014.data[["age"]])
......@@ -89,11 +94,11 @@ RP2014.male = pensionTable(
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
yx = RP2014.zeroes,
invalids.retire = FALSE
)
RP2014.female = pensionTable(
name = nameRP14(desc = "female"),
......@@ -105,11 +110,11 @@ RP2014.female = pensionTable(
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
yx = RP2014.zeroes,
invalids.retire = FALSE
)
......@@ -128,11 +133,11 @@ RP2014.male.whitecollar = pensionTable(
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
yx = RP2014.zeroes,
invalids.retire = FALSE
)
RP2014.female.whitecollar = pensionTable(
name = nameRP14(desc = "female"),
......@@ -144,11 +149,11 @@ RP2014.female.whitecollar = pensionTable(
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
yx = RP2014.zeroes,
invalids.retire = FALSE
)
......@@ -167,11 +172,11 @@ RP2014.male.bluecollar = pensionTable(
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
yx = RP2014.zeroes,
invalids.retire = FALSE
)
RP2014.female.bluecollar = pensionTable(
name = nameRP14(desc = "female"),
......@@ -183,11 +188,11 @@ RP2014.female.bluecollar = pensionTable(
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
yx = RP2014.zeroes,
invalids.retire = FALSE
)
......
......@@ -24,11 +24,14 @@ Correspondingly, the following transition probabilities can be given:\describe{
\item{qix}{death probability of invalid (invalid -> dead)}
\item{rx}{reactivation probability (incapacity -> active)}
\item{apx}{retirement probability (active -> retirement), typically 1 for a fixed age}
\item{apx}{retirement probability of invalids (invalid -> retirement), typically 0 or 1 for a fixed age}
\item{qpx}{death probability of retired (retired -> dead)}
\item{hx}{probability of a widow at moment of death (dead -> widow), y(x) age difference}
\item{qxw}{death probability of widows/widowers}
\item{qgx}{death probability of total group (irrespective of state)}
\item{invalids.retire}{Flag to indicate whether invalid persons retire
like active (one death probability for all retirees) or whether
they stay invalid until death with death probabilities specific to
invalids.}
}
}
\section{Slots}{
......@@ -44,8 +47,6 @@ Correspondingly, the following transition probabilities can be given:\describe{
\item{\code{apx}}{Retirement probability of actives (derived from mortalityTable)}
\item{\code{apix}}{Retirement probability of invalids (derived from mortalityTable)}
\item{\code{qpx}}{Death probability of old age pensioners (derived from mortalityTable)}
\item{\code{hx}}{Probability of a widow at the moment of death (derived from mortalityTable)}
......@@ -55,5 +56,7 @@ Correspondingly, the following transition probabilities can be given:\describe{
\item{\code{yx}}{Age difference of the widow to the deceased}
\item{\code{qgx}}{Death probability of whole group (derived from mortalityTable), irrespective of state}
\item{\code{invalids.retire}}{Whether invalids retire like actives or stay invalid until death}
}}
......@@ -9,7 +9,8 @@
periodTransitionProbabilities(object, ...)
\S4method{periodTransitionProbabilities}{pensionTable}(object, Period = 2017,
..., as.data.frame = TRUE)
..., retirement = NULL, invalids.retire = object@invalids.retire,
as.data.frame = TRUE)
}
\arguments{
\item{object}{A pension table object (instance of a \code{\linkS4class{pensionTable}} class)}
......@@ -18,6 +19,17 @@ periodTransitionProbabilities(object, ...)
\item{Period}{Observation year}
\item{retirement}{Override the retirement transition probabilities of the pension table. Possible values are:\itemize{
\item Single age (describing a deterministric retirement at the given age)
\item mortalityTable object: transition probabilities for retirement
}}
\item{invalids.retire}{Override the \code{\linkS4class{pensionTable}}'s
\code{invalids.retire} flag, which indicates whether
invalids retire like actives (i.e. same death
probabilities after retirement) or stay invalid until
death.}
\item{as.data.frame}{Whether the return value should be a data.frame or an array containing transition matrices}
}
\description{
......@@ -29,7 +41,11 @@ Return all period transition probabilities of the pension table
}}
\examples{
pensionTables.load("Austria_*")
# periodTransitionProbabilities(EttlPagler.male, Period = 2017)
pensionTables.load("USA_PensionPlans")
# transitionProbabilities internally calls periodTransitionProbabilities
# if a Period is given:
transitionProbabilities(RP2014.male, Period = 1955)
periodTransitionProbabilities(RP2014.male, Period = 1955)
periodTransitionProbabilities(RP2014.male, Period = 2025)
}
......@@ -9,7 +9,8 @@
transitionProbabilities(object, ...)
\S4method{transitionProbabilities}{pensionTable}(object, YOB = 1982, ...,
as.data.frame = TRUE)
Period = NULL, retirement = NULL,
invalids.retire = object@invalids.retire, as.data.frame = TRUE)
}
\arguments{
\item{object}{A pension table object (instance of a \code{\linkS4class{pensionTable}} class)}
......@@ -18,7 +19,26 @@ transitionProbabilities(object, ...)
\item{YOB}{Year of birth}
\item{as.data.frame}{Whether the return value should be a data.frame or an array containing transition matrices}
\item{Period}{Observation year to calculate period transition probabilities.
If given, this arguments overrides the \code{YOB} parameter
and this function returns period transition probabilities.
If this argument is not given or is null, then this function
returns generational transition probabilities.}
\item{retirement}{Override the retirement transition probabilities of the
pension table. Possible values are:\itemize{
\item Single age (describing a deterministric retirement at the given age)
\item mortalityTable object: transition probabilities for retirement
}}
\item{invalids.retire}{Override the \code{\linkS4class{pensionTable}}'s
\code{invalids.retire} flag, which indicates whether
invalids retire like actives (i.e. same death
probabilities after retirement) or stay invalid until
death.}
\item{as.data.frame}{Whether the return value should be a data.frame or an
array containing transition matrices}
}
\description{
Return all transition probabilities of the pension table (generational probabilities)
......@@ -29,7 +49,9 @@ Return all transition probabilities of the pension table (generational probabili
}}
\examples{
pensionTables.load("Austria_*")
# transitionProbabilities(EttlPagler.male)
pensionTables.load("USA_PensionPlans")
transitionProbabilities(RP2014.male, YOB = 1962)
transitionProbabilities(RP2014.male, Period = 1955)
transitionProbabilities(RP2014.male, Period = 2025)
}
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