Commit 10620809 by 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 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) } }) ... ...
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