pensionTable.R 14.4 KB
Newer Older
1
#' @include mortalityTable.R fillAges.R
2 3 4 5 6 7 8 9 10
NULL


#' Class pensionTable
#'
#' Class \code{pensionTable} is the (virtual) base class for all pensions
#' tables. It contains the name and some general values applying to all
#' types of tables. In particular, it holds individual tables for each of the
#' transition probabilities. Possible states are:
Reinhold Kainhofer's avatar
Reinhold Kainhofer committed
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
#' \itemize{
#'     \item active: healty, no pension, typically paying some kin of premium
#'     \item incapacity: disablity pension, in most cases permanent, not working, early pension
#'     \item retirement: old age pension, usually starting with a fixed age
#'     \item dead \itemize{
#'       \item Widow/widower pension
#'     }
#' }
#' Correspondingly, the following transition probabilities can be given:\describe{
#'     \item{qxaa}{death probability of actives (active -> dead)}
#'     \item{ix}{invalidity probability (active -> incapacity)}
#'     \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{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)}
29 30 31 32
#'     \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.}
Reinhold Kainhofer's avatar
Reinhold Kainhofer committed
33
#' }
34 35 36
#'
#' @slot qx     Death probability table of actives (derived from mortalityTable)
#' @slot ix     Invalidity probability of actives (derived from mortalityTable)
37
#' @slot qix    Death probability table of invalids (derived from mortalityTable)
38 39 40 41 42 43 44
#' @slot rx     Reactivation probability of invalids (derived from mortalityTable)
#' @slot apx    Retirement probability of actives (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
45
#' @slot invalids.retire    Whether invalids retire like actives or stay invalid until death
46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
#'
#' @export pensionTable
#' @exportClass pensionTable
pensionTable = setClass(
    "pensionTable",
    slots = list(
        qx    = "mortalityTable",
        ix    = "mortalityTable",
        qix   = "mortalityTable",
        rx    = "mortalityTable",
        apx   = "mortalityTable",
        qpx   = "mortalityTable",
        hx    = "mortalityTable",
        qwy   = "mortalityTable",
        yx    = "mortalityTable",
61 62 63 64 65
        qgx   = "mortalityTable",
        invalids.retire = "logical"
    ),
    prototype = list(
        invalids.retire = FALSE
66 67 68 69
    ),
    contains = "mortalityTable"
)

70 71 72 73
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 {
74 75
        states = c("a", "i", "p", "d")
        transProb = array(0, dim = c(length(states), length(states), length(x)), dimnames = list(states, states, x))
76 77 78

        transProb["a", "a", ] = (1 - i - q) * (1 - ap);
        transProb["a", "i", ] = i;
79
        transProb["a", "p", ] = (1 - i - q) * ap;
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
        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)
97 98 99 100
#'
#' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class)
#' @param ... Currently unused
#' @param YOB Year of birth
101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
#' @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.
118 119
#'
#' @examples
120 121 122 123
#' pensionTables.load("USA_PensionPlans")
#' transitionProbabilities(RP2014.male, YOB = 1962)
#' transitionProbabilities(RP2014.male, Period = 1955)
#' transitionProbabilities(RP2014.male, Period = 2025)
124 125
#'
#' @exportMethod transitionProbabilities
126
setGeneric("transitionProbabilities", function(object, ...) standardGeneric("transitionProbabilities"));
127

128
#' @describeIn transitionProbabilities Return all transition probabilities of the pension table for the generation YOB
129
setMethod("transitionProbabilities", "pensionTable",
130
          function(object, YOB = 1982, ..., ages = NULL, OverallMortality = FALSE, Period = NULL, retirement = NULL,
131 132 133
                   invalids.retire = object@invalids.retire, as.data.frame = TRUE) {
              if (!missing(Period) && !is.null(Period)) {
                  return(periodTransitionProbabilities(
134
                      object, ..., ages = ages, Period = Period, retirement = retirement,
135 136 137
                      invalids.retire = invalids.retire,
                      as.data.frame = as.data.frame))
              }
138
              x   = if (is.null(ages)) ages(object@qx) else  ages;
139 140 141 142 143
              # TODO: Make sure all sub-tables have the same age range!
              q   = deathProbabilities(object@qx, ..., ages = ages, YOB = YOB);
              i   = deathProbabilities(object@ix, ..., ages = ages, YOB = YOB);
              qi  = deathProbabilities(object@qix, ..., ages = ages, YOB = YOB);
              r   = deathProbabilities(object@rx, ..., ages = ages, YOB = YOB);
144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
              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)
                  }
              }
161
              ap  = deathProbabilities(apTab, ..., ages = ages, YOB = YOB);
162 163 164 165 166 167 168 169 170 171 172 173 174 175 176

              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 {
177
                  api = deathProbabilities(mortalityTable.zeroes(ages = x), ..., ages = ages, YOB = YOB)
178
              }
179 180 181 182 183
              qp  = deathProbabilities(object@qpx, ..., ages = ages, YOB = YOB);
              h   = deathProbabilities(object@hx, ..., ages = ages, YOB = YOB);
              qw  = deathProbabilities(object@qwy, ..., ages = ages, YOB = YOB);
              yx  = deathProbabilities(object@yx, ..., ages = ages, YOB = YOB);
              qg  = deathProbabilities(object@qgx, ..., ages = ages, YOB = YOB);
184 185 186 187
              if (!OverallMortality) {
                  pensionTableProbArrange(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, as.data.frame = as.data.frame)
              } else {
                  # Gesamttafel, i.e. actives, invalids and pensioners have the same mortality qg
188
                  pensionTableProbArrange(x, qg, i, qg, r, ap, api, qg, h, qw, yx, qg, as.data.frame = as.data.frame)
189
              }
190 191
          })

192
#' Return all period transition probabilities of the pension table
193 194
#'
#' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class)
195
#' @param Period Observation year
196
#' @param ... Currently unused
197 198 199 200 201 202 203 204 205
#' @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.
206
#' @param as.data.frame Whether the return value should be a data.frame or an array containing transition matrices
207 208
#'
#' @examples
209 210 211 212 213 214
#' 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)
215
#'
216 217
#' @exportMethod periodTransitionProbabilities
setGeneric("periodTransitionProbabilities", function(object, ...) standardGeneric("periodTransitionProbabilities"));
218 219


220 221
#' @describeIn periodTransitionProbabilities Return all transition probabilities of the pension table for the period Period
setMethod("periodTransitionProbabilities", "pensionTable",
222 223
          function(object, Period = 2017, ..., ages = NULL, OverallMortality = FALSE, retirement = NULL, invalids.retire = object@invalids.retire, as.data.frame = TRUE) {
              x   = if (is.null(ages)) ages(object@qx) else  ages;
224 225 226 227
              q   = periodDeathProbabilities(object@qx, ..., ages = ages, Period = Period);
              i   = periodDeathProbabilities(object@ix, ..., ages = ages, Period = Period);
              qi  = periodDeathProbabilities(object@qix, ..., ages = ages, Period = Period);
              r   = periodDeathProbabilities(object@rx, ..., ages = ages, Period = Period);
228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
              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)
                  }
              }
245
              ap = deathProbabilities(apTab, ..., ages = ages, Period = Period)
246 247 248
              if (invalids.retire) {
                  api = ap
              } else {
249
                  api = deathProbabilities(mortalityTable.zeroes(ages = x), ..., ages = ages, Period = Period)
250
              }
251 252 253 254 255
              qp  = periodDeathProbabilities(object@qpx, ..., ages = ages, Period = Period);
              h   = periodDeathProbabilities(object@hx, ..., ages = ages, Period = Period);
              qw  = periodDeathProbabilities(object@qwy, ..., ages = ages, Period = Period);
              yx  = periodDeathProbabilities(object@yx, ..., ages = ages, Period = Period);
              qg  = periodDeathProbabilities(object@qgx, ..., ages = ages, Period = Period);
256 257 258
              if (!OverallMortality) {
                  pensionTableProbArrange(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, as.data.frame = as.data.frame)
              } else  {
259
                  pensionTableProbArrange(x, qg, i, qg, r, ap, api, qg, h, qw, yx, qg, as.data.frame = as.data.frame)
260
              }
261
          })
262

263

264
if (FALSE) {
265
    pensionTables.load("Austria_AVOe2008P")
266 267 268 269
    transitionProbabilities(AVOe2008P.male, YOB = 1977, as.data.frame = FALSE)
    epP = transitionProbabilities(EttlPagler.male, YOB = 1982)
#    avoe08p =
        transitionProbabilities(AVOe2008P.male, YOB = 1977, as.data.frame = TRUE)
270 271 272 273
avoe08p.period = periodTransitionProbabilities(AVOe2008P.male, Period = 2007, as.data.frame = TRUE)

pensionTables.list(package = "MortalityTablesPrivate")
pensionTables.load("Austria_AVOe1999P")
274
}
275