Skip to content
Snippets Groups Projects
Commit c6107537 authored by Reinhold Kainhofer's avatar Reinhold Kainhofer
Browse files

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
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
R/pensionTable.R
+ 116
− 19
View file @ c6107537
......@@ -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);
......
inst/extdata/PensionTables_USA_PensionPlan_RP2014.R
+ 19
− 14
View file @ c6107537
......@@ -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
)
......
man/pensionTable-class.Rd
+ 6
− 3
View file @ c6107537
......@@ -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}
}}
man/periodTransitionProbabilities.Rd
+ 19
− 3
View file @ c6107537
......@@ -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)
}
man/transitionProbabilities.Rd
+ 26
− 4
View file @ c6107537
......@@ -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)
}
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment