From 10620809471fb8deb12882abb119edebac5af9ae Mon Sep 17 00:00:00 2001 From: Reinhold Kainhofer Date: Mon, 30 Jul 2018 00:18:10 +0200 Subject: [PATCH] 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) --- R/pensionTable.R | 66 +++++++++++++++++++++++++----------------------- 1 file changed, 34 insertions(+), 32 deletions(-) diff --git a/R/pensionTable.R b/R/pensionTable.R index 405550c..e95c1d3 100644 --- a/R/pensionTable.R +++ b/R/pensionTable.R @@ -1,6 +1,32 @@ #' @include mortalityTable.R fillAges.R 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 #' @@ -59,40 +85,16 @@ pensionTable = setClass( qwy = "mortalityTable", yx = "mortalityTable", qgx = "mortalityTable", - invalids.retire = "logical" + invalids.retire = "logical", + probs.arrange = "function" ), prototype = list( - invalids.retire = FALSE + invalids.retire = FALSE, + probs.arrange = pensionTableProbArrange ), 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) #' #' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class) @@ -183,10 +185,10 @@ setMethod("transitionProbabilities", "pensionTable", yx = deathProbabilities(object@yx, ..., ages = ages, YOB = YOB); qg = deathProbabilities(object@qgx, ..., ages = ages, YOB = YOB); 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 { # 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", yx = periodDeathProbabilities(object@yx, ..., ages = ages, Period = Period); qg = periodDeathProbabilities(object@qgx, ..., ages = ages, Period = Period); 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 { - 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) } }) -- GitLab