From 10620809471fb8deb12882abb119edebac5af9ae Mon Sep 17 00:00:00 2001
From: Reinhold Kainhofer <reinhold@kainhofer.com>
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