Add functions for pension tables and other utility functions

- mortalityTable.zeroes: Generate a mortality table with all zero transition probabilities
- mortalityTable.once: Generates a (deterministic) mortality table with one transition at a given age
- pensionTables.list: Lists all pension tables (similar to mortalityTables.list)
- pensionTables.load: Load a provided pension table (similar to mortalityTables.load)
- transitionProbabilities: Obtain data.frame containing all transition probabilities for a pension table (given the YOB)
- anwartschaften: First attempt to calculate all "Anwartschaften" for a given pensionTable - WORK IN PROGRESS, NOT FINISHED

NAMESPACE

@@ -12,11 +12,15 @@ export(mortalityTable.joined)
 export(mortalityTable.jointLives)
 export(mortalityTable.mixed)
 export(mortalityTable.observed)
+export(mortalityTable.once)
 export(mortalityTable.period)
 export(mortalityTable.trendProjection)
+export(mortalityTable.zeroes)
 export(mortalityTables.list)
 export(mortalityTables.load)
 export(pensionTable)
+export(pensionTables.list)
+export(pensionTables.load)
 export(plotMortalityTableComparisons)
 export(plotMortalityTables)
 exportClasses(mortalityTable)
@@ -41,6 +45,7 @@ exportMethods(lifeTable)
 exportMethods(periodDeathProbabilities)
 exportMethods(setLoading)
 exportMethods(setModification)
+exportMethods(transitionProbabilities)
 exportMethods(undampenTrend)
 import(ggplot2)
 import(methods)

R/mortalityTable.period.R

@@ -24,3 +24,28 @@ mortalityTable.period = setClass(
     ),
     contains = "mortalityTable"
 )
+
+#' Generate a mortality table with all probabilities set to zero.
+#'
+#' @param name The name of the table
+#' @param ages The ages of the table
+#'
+#' @export
+mortalityTable.zeroes = function(name = "Zero mortality table", ages = 0:99) {
+    mortalityTable.period(name = name, ages = ages, deathProbs = ages * 0)
+}
+
+#' Generate a (deterministic) mortality table with only one probability set to 1 (for the given age)
+#'
+#' @param name The name of the table
+#' @param ages The ages of the table
+#'
+#' @export
+mortalityTable.once = function(transitionAge, name = "Deterministic mortality table", ages = 0:99) {
+    mortalityTable.period(
+        name = name,
+        ages = ages,
+        deathProbs = sapply(ages, function(x) { if (x == transitionAge) 1 else 0})
+    )
+}
+

R/mortalityTables.list.R

@@ -6,10 +6,21 @@
 #'                directory. Defaults to the "MortalityTables" package.
 #'
 #' @export
-mortalityTables.list = function(pattern = "*", package = "MortalityTables") {
+mortalityTables.list = function(pattern = "*", package = "MortalityTables", prefix = "MortalityTables") {
     filepath = system.file("extdata", package = package);
-    files = Sys.glob(file.path(filepath, paste("MortalityTables_", pattern, ".R", sep = "")))
-    gsub('^MortalityTables_(.*).R$', '\\1', basename(files))
+    files = Sys.glob(file.path(filepath, paste(prefix, "_", pattern, ".R", sep = "")))
+    gsub(paste('^', prefix, '_(.*).R$', sep = ""), '\\1', basename(files))
 }
 
 
+#' List all available sets of pension tables provided by the \link[MortalityTables]{MortalityTables-package} package
+#' An existing pension table can then be loaded with \link{pensionTables.load}.
+#'
+#' @param pattern Restrict the results only to pension table sets that match the pattern (default: "*" to show all sets)
+#' @param package The package that contains the desired dataset in its \code{extdata/}
+#'                directory. Defaults to the "MortalityTables" package.
+#'
+#' @export
+pensionTables.list = function(pattern = "*", package = "MortalityTables") {
+    mortalityTables.list(pattern = pattern, package = package, prefix = "PensionTables")
+}

R/mortalityTables.load.R

@@ -6,18 +6,19 @@
 #'                 datasets matching the pattern will be loaded
 #' @param package The package that contains the dataset in its \code{extdata/}
 #'                directory. Defaults to the "MortalityTables" package.
+#' @param prefix The prefix for the data sets (default is "MortalityTables")
 #'
 #' @export
-mortalityTables.load = function(dataset, wildcard=FALSE, package="MortalityTables") {
+mortalityTables.load = function(dataset, wildcard = FALSE, package = "MortalityTables", prefix = "MortalityTables") {
     if (wildcard) {
-        sets = mortalityTables.list(dataset, package = package);
+        sets = mortalityTables.list(dataset, package = package, prefix = prefix);
     } else {
         sets = c(dataset);
     }
     for (set in sets) {
         sname = gsub("[^-A-Za-z0-9_.]", "", set);
-        message("Loading mortality table data set '", sname, "'");
-        filename = system.file("extdata", paste("MortalityTables_", sname, ".R", sep = ""), package = package);
+        message("Loading table dataset '", sname, "'");
+        filename = system.file("extdata", paste(prefix, "_", sname, ".R", sep = ""), package = package);
         if (filename != "") {
             sys.source(filename, envir = globalenv())
         } else {
@@ -25,3 +26,20 @@ mortalityTables.load = function(dataset, wildcard=FALSE, package="MortalityTable
         }
     }
 }
+
+
+#' Load a named set of pension tables provided by the \link{MortalityTables} package
+#'
+#' @param dataset The set of lifpensione tables to be loaded. A list of all available
+#'                data sets is provided by the function \code{\link{pensionTables.list}}.
+#' @param wildcard Whether the dataset name contains wildcard. If TRUE, all
+#'                 datasets matching the pattern will be loaded
+#' @param package The package that contains the dataset in its \code{extdata/}
+#'                directory. Defaults to the "MortalityTables" package.
+#'
+#' @export
+pensionTables.load = function(dataset, wildcard = FALSE, package = "MortalityTables") {
+    mortalityTables.load(dataset = dataset, wildcard = wildcard, package = package, prefix = "PensionTables")
+}
+
+

R/pensionTable.R

@@ -58,12 +58,72 @@ pensionTable = setClass(
     contains = "mortalityTable"
 )
 
+#' Return all transition probabilities of the pension table
+#'
+#' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class)
+#' @param ... Currently unused
+#' @param YOB Year of birth
+#'
+#' @examples
+#' pensionTables.load("Austria_*", wildcard=TRUE)
+#' transitionProbabilities(EttlPagler.male)
+#'
+#' @exportMethod transitionProbabilities
+setGeneric("transitionProbabilities", function(object, ...) standardGeneric("transitionProbabilities"));
+
 #' @describeIn baseTable Return the base table of the joint lives mortality table (returns the base table of the first table used for joint lives)
 setMethod("transitionProbabilities", "pensionTable",
           function(object, ...,  YOB = 1982) {
               x = ages(object@qx);
               q = deathProbabilities(object@qx, ..., YOB = YOB);
               i = deathProbabilities(object@ix, ..., YOB = YOB);
-              data.frame(x, q, i)
+              qi = deathProbabilities(object@qix, ..., YOB = YOB);
+              r = deathProbabilities(object@rx, ..., YOB = YOB);
+              ap = deathProbabilities(object@apx, ..., YOB = YOB);
+              api = deathProbabilities(object@apix, ..., YOB = YOB);
+              qp = deathProbabilities(object@qpx, ..., YOB = YOB);
+              h = deathProbabilities(object@hx, ..., YOB = YOB);
+              qw = deathProbabilities(object@qwy, ..., YOB = YOB);
+              yx = deathProbabilities(object@yx, ..., YOB = YOB);
+              qg = deathProbabilities(object@qgx, ..., YOB = YOB);
+              data.frame(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg)
           })
 
+
+if (FALSE) {
+    epP = transitionProbabilities(EttlPagler.male, YOB = 1982)
+    avoe08p = transitionProbabilities(AVOe2008P.male, YOB = 1977)
+}
+
+
+setGeneric("anwartschaften", function(object, ...) standardGeneric("anwartschaften"));
+
+setMethod("anwartschaften", "pensionTable",
+    function(object, ...,  i = 0.03, YOB = 1982) {
+        probs = transitionProbabilities(object, ..., YOB);
+        anwartschaften(probs, ..., YOB)
+    }
+);
+
+bwRente = function(p, v) {
+    Reduce(function(pp, ax1) { 1 + pp * ax1 * v }, p, 0.0, right = TRUE, accumulate = TRUE)[-(length(p) + 1)];
+}
+
+setMethod("anwartschaften", "data.frame",
+    function(object, ...,  i = 0.03) {
+        x = object$x;
+        v = 1 / (1 + i);
+        # Anwartschaft auf Witwenrente und Alterspension
+        # 1) Barwerte:
+        aa = bwRente(1.0 - object$q, v);
+        ai = bwRente(1. - object$qi - object$r, v);
+        ap = bwRente(1. - object$qp, v);
+        aw = bwRente(1. - object$qw, v);
+        data.frame(x, aa, ai, ap, aw)
+    }
+)
+
+if (FALSE) {
+    probs = transitionProbabilities(AVOe2008P.female, YOB = 1977)
+    an = anwartschaften(probs, YOB = 1977); an
+}

man/baseTable.Rd

 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/baseTable.R, R/mortalityTable.jointLives.R
+% Please edit documentation in R/baseTable.R, R/mortalityTable.jointLives.R,
+%   R/pensionTable.R
 \docType{methods}
 \name{baseTable}
 \alias{baseTable}
 \alias{baseTable,mortalityTable-method}
 \alias{baseTable,mortalityTable.period-method}
 \alias{baseTable,mortalityTable.jointLives-method}
+\alias{transitionProbabilities,pensionTable-method}
 \title{Return the base table of the life table}
 \usage{
 baseTable(object, ...)
@@ -15,6 +17,8 @@ baseTable(object, ...)
 \S4method{baseTable}{mortalityTable.period}(object, ...)
 
 \S4method{baseTable}{mortalityTable.jointLives}(object, ...)
+
+\S4method{transitionProbabilities}{pensionTable}(object, ..., YOB = 1982)
 }
 \arguments{
 \item{object}{The life table object (class inherited from mortalityTable)}
@@ -31,6 +35,8 @@ Return the base table of the life table
 \item \code{mortalityTable.period}: Return the base table of the life table
 
 \item \code{mortalityTable.jointLives}: Return the base table of the joint lives mortality table (returns the base table of the first table used for joint lives)
+
+\item \code{pensionTable}: Return the base table of the joint lives mortality table (returns the base table of the first table used for joint lives)
 }}
 
 \examples{

man/mortalityTable.once.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mortalityTable.period.R
+\name{mortalityTable.once}
+\alias{mortalityTable.once}
+\title{Generate a (deterministic) mortality table with only one probability set to 1 (for the given age)}
+\usage{
+mortalityTable.once(transitionAge, name = "Deterministic mortality table",
+  ages = 0:99)
+}
+\arguments{
+\item{name}{The name of the table}
+
+\item{ages}{The ages of the table}
+}
+\description{
+Generate a (deterministic) mortality table with only one probability set to 1 (for the given age)
+}

man/mortalityTable.zeroes.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mortalityTable.period.R
+\name{mortalityTable.zeroes}
+\alias{mortalityTable.zeroes}
+\title{Generate a mortality table with all probabilities set to zero.}
+\usage{
+mortalityTable.zeroes(name = "Zero mortality table", ages = 0:99)
+}
+\arguments{
+\item{name}{The name of the table}
+
+\item{ages}{The ages of the table}
+}
+\description{
+Generate a mortality table with all probabilities set to zero.
+}

man/mortalityTables.list.Rd

@@ -5,7 +5,8 @@
 \title{List all available sets of life tables provided by the \link[MortalityTables]{MortalityTables-package} package
 An existing life table can then be loaded with \link{mortalityTables.load}.}
 \usage{
-mortalityTables.list(pattern = "*", package = "MortalityTables")
+mortalityTables.list(pattern = "*", package = "MortalityTables",
+  prefix = "MortalityTables")
 }
 \arguments{
 \item{pattern}{Restrict the results only to life table sets that match the pattern (default: "*" to show all sets)}

man/mortalityTables.load.Rd

@@ -4,7 +4,8 @@
 \alias{mortalityTables.load}
 \title{Load a named set of mortality tables provided by the \link{MortalityTables} package}
 \usage{
-mortalityTables.load(dataset, wildcard = FALSE, package = "MortalityTables")
+mortalityTables.load(dataset, wildcard = FALSE, package = "MortalityTables",
+  prefix = "MortalityTables")
 }
 \arguments{
 \item{dataset}{The set of life tables to be loaded. A list of all available
@@ -15,6 +16,8 @@ datasets matching the pattern will be loaded}
 
 \item{package}{The package that contains the dataset in its \code{extdata/}
 directory. Defaults to the "MortalityTables" package.}
+
+\item{prefix}{The prefix for the data sets (default is "MortalityTables")}
 }
 \description{
 Load a named set of mortality tables provided by the \link{MortalityTables} package

man/pensionTable-class.Rd

@@ -20,13 +20,14 @@ transition probabilities. Possible states are:
 Correspondingly, the following transition probabilities can be given:
     * qxaa:  death probability of actives (active -> dead)
     * ix:    invalidity probability (active -> incapacity)
-    * qxi:   death probability of invaid (invalid -> dead)
+    * qix:   death probability of invalid (invalid -> dead)
     * rx:    reactivation probability (incapacity -> active)
     * apx:   retirement probability (active -> retirement), typically 1 for a fixed age
     * apx:   retirement probability of invalids (invalid -> retirement), typically 0 or 1 for a fixed age
-    * qxApm: death probability of retired (retired -> dead)
+    * qpx:   death probability of retired (retired -> dead)
     * hx:    probability of a widow at moment of death (dead -> widow), y(x) age differene
     * qxw:   death probability of widows/widowers
+    * qgx:   death probability of total group (irrespective of state)
 }
 \section{Slots}{
 
@@ -41,14 +42,16 @@ Correspondingly, the following transition probabilities can be given:
 
 \item{\code{apx}}{Retirement probability of actives (derived from mortalityTable)}
 
-\item{\code{apxi}}{Retirement probability of invalids (derived from mortalityTable)}
+\item{\code{apix}}{Retirement probability of invalids (derived from mortalityTable)}
 
-\item{\code{qxApm}}{Death probability of old age pensioners (derived from mortalityTable)}
+\item{\code{qpx}}{Death probability of old age pensioners (derived from mortalityTable)}
 
 \item{\code{hx}}{Probability of a widow at the moment of death (derived from mortalityTable)}
 
-\item{\code{qxw}}{Death probability of widow(er)s (derived from mortality Table)}
+\item{\code{qwy}}{Death probability of widow(er)s (derived from mortality Table)}
 
-\item{\code{xy}}{Age difference of the widow to the deceased}
+\item{\code{yx}}{Age difference of the widow to the deceased}
+
+\item{\code{qgx}}{Death probability of whole group (derived from mortalityTable), irrespective of state}
 }}
 

man/pensionTables.list.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mortalityTables.list.R
+\name{pensionTables.list}
+\alias{pensionTables.list}
+\title{List all available sets of pension tables provided by the \link[MortalityTables]{MortalityTables-package} package
+An existing pension table can then be loaded with \link{pensionTables.load}.}
+\usage{
+pensionTables.list(pattern = "*", package = "MortalityTables")
+}
+\arguments{
+\item{pattern}{Restrict the results only to pension table sets that match the pattern (default: "*" to show all sets)}
+
+\item{package}{The package that contains the desired dataset in its \code{extdata/}
+directory. Defaults to the "MortalityTables" package.}
+}
+\description{
+List all available sets of pension tables provided by the \link[MortalityTables]{MortalityTables-package} package
+An existing pension table can then be loaded with \link{pensionTables.load}.
+}

man/pensionTables.load.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mortalityTables.load.R
+\name{pensionTables.load}
+\alias{pensionTables.load}
+\title{Load a named set of pension tables provided by the \link{MortalityTables} package}
+\usage{
+pensionTables.load(dataset, wildcard = FALSE, package = "MortalityTables")
+}
+\arguments{
+\item{dataset}{The set of lifpensione tables to be loaded. A list of all available
+data sets is provided by the function \code{\link{pensionTables.list}}.}
+
+\item{wildcard}{Whether the dataset name contains wildcard. If TRUE, all
+datasets matching the pattern will be loaded}
+
+\item{package}{The package that contains the dataset in its \code{extdata/}
+directory. Defaults to the "MortalityTables" package.}
+}
+\description{
+Load a named set of pension tables provided by the \link{MortalityTables} package
+}

man/transitionProbabilities.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/pensionTable.R
+\name{transitionProbabilities}
+\alias{transitionProbabilities}
+\title{Return all transition probabilities of the pension table}
+\usage{
+transitionProbabilities(object, ...)
+}
+\arguments{
+\item{object}{A pension table object (instance of a \code{\linkS4class{pensionTable}} class)}
+
+\item{...}{Currently unused}
+
+\item{YOB}{Year of birth}
+}
+\description{
+Return all transition probabilities of the pension table
+}
+\examples{
+pensionTables.load("Austria_*", wildcard=TRUE)
+transitionProbabilities(EttlPagler.male)
+
+}