Commit 10620809 authored by Reinhold Kainhofer's avatar Reinhold Kainhofer

pensionTables: Add probs.arrange slot to hold the pensionTableProbArrange function

Some tables need to adjust probabilities (e.g. Heubeck needs to calculate the qg from all other probabilities)
parent 0ff21de2
#' @include mortalityTable.R fillAges.R #' @include mortalityTable.R fillAges.R
NULL NULL
pensionTableProbArrange = function(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, as.data.frame = TRUE, table, ...) {
if (as.data.frame) {
data.frame(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg)
} else {
states = c("a", "i", "p", "d")
transProb = array(0, dim = c(length(states), length(states), length(x)), dimnames = list(states, states, x))
transProb["a", "a", ] = (1 - i - q) * (1 - ap);
transProb["a", "i", ] = i;
transProb["a", "p", ] = (1 - i - q) * ap;
transProb["a", "d", ] = q;
transProb["i", "a", ] = r;
transProb["i", "i", ] = (1 - qi - r) * (1 - api);
transProb["i", "p", ] = (1 - qi - r) * api;
transProb["i", "d", ] = qi;
transProb["p", "p", ] = 1 - qp;
transProb["p", "d", ] = qp;
transProb["d", "d", ] = 1;
list(transitionProbabilities = transProb, widows = data.frame(x, h, qw, yx))
}
}
#' Class pensionTable #' Class pensionTable
#' #'
...@@ -59,40 +85,16 @@ pensionTable = setClass( ...@@ -59,40 +85,16 @@ pensionTable = setClass(
qwy = "mortalityTable", qwy = "mortalityTable",
yx = "mortalityTable", yx = "mortalityTable",
qgx = "mortalityTable", qgx = "mortalityTable",
invalids.retire = "logical" invalids.retire = "logical",
probs.arrange = "function"
), ),
prototype = list( prototype = list(
invalids.retire = FALSE invalids.retire = FALSE,
probs.arrange = pensionTableProbArrange
), ),
contains = "mortalityTable" contains = "mortalityTable"
) )
pensionTableProbArrange = function(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, as.data.frame = TRUE) {
if (as.data.frame) {
data.frame(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg)
} else {
states = c("a", "i", "p", "d")
transProb = array(0, dim = c(length(states), length(states), length(x)), dimnames = list(states, states, x))
transProb["a", "a", ] = (1 - i - q) * (1 - ap);
transProb["a", "i", ] = i;
transProb["a", "p", ] = (1 - i - q) * ap;
transProb["a", "d", ] = q;
transProb["i", "a", ] = r;
transProb["i", "i", ] = (1 - qi - r) * (1 - api);
transProb["i", "p", ] = (1 - qi - r) * api;
transProb["i", "d", ] = qi;
transProb["p", "p", ] = 1 - qp;
transProb["p", "d", ] = qp;
transProb["d", "d", ] = 1;
list(transitionProbabilities = transProb, widows = data.frame(x, h, qw, yx))
}
}
#' Return all transition probabilities of the pension table (generational probabilities) #' Return all transition probabilities of the pension table (generational probabilities)
#' #'
#' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class) #' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class)
...@@ -183,10 +185,10 @@ setMethod("transitionProbabilities", "pensionTable", ...@@ -183,10 +185,10 @@ setMethod("transitionProbabilities", "pensionTable",
yx = deathProbabilities(object@yx, ..., ages = ages, YOB = YOB); yx = deathProbabilities(object@yx, ..., ages = ages, YOB = YOB);
qg = deathProbabilities(object@qgx, ..., ages = ages, YOB = YOB); qg = deathProbabilities(object@qgx, ..., ages = ages, YOB = YOB);
if (!OverallMortality) { if (!OverallMortality) {
pensionTableProbArrange(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, as.data.frame = as.data.frame) object@probs.arrange(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, as.data.frame = as.data.frame, table = object)
} else { } else {
# Gesamttafel, i.e. actives, invalids and pensioners have the same mortality qg # Gesamttafel, i.e. actives, invalids and pensioners have the same mortality qg
pensionTableProbArrange(x, qg, i, qg, r, ap, api, qg, h, qw, yx, qg, as.data.frame = as.data.frame) object@probs.arrange(x, qg, i, qg, r, ap, api, qg, h, qw, yx, qg, as.data.frame = as.data.frame, table = object)
} }
}) })
...@@ -257,9 +259,9 @@ setMethod("periodTransitionProbabilities", "pensionTable", ...@@ -257,9 +259,9 @@ setMethod("periodTransitionProbabilities", "pensionTable",
yx = periodDeathProbabilities(object@yx, ..., ages = ages, Period = Period); yx = periodDeathProbabilities(object@yx, ..., ages = ages, Period = Period);
qg = periodDeathProbabilities(object@qgx, ..., ages = ages, Period = Period); qg = periodDeathProbabilities(object@qgx, ..., ages = ages, Period = Period);
if (!OverallMortality) { if (!OverallMortality) {
pensionTableProbArrange(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, as.data.frame = as.data.frame) object@probs.arrange(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, as.data.frame = as.data.frame, table = object)
} else { } else {
pensionTableProbArrange(x, qg, i, qg, r, ap, api, qg, h, qw, yx, qg, as.data.frame = as.data.frame) object@probs.arrange(x, qg, i, qg, r, ap, api, qg, h, qw, yx, qg, as.data.frame = as.data.frame, table = object)
} }
}) })
......
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