Add class mortalityTable.jointLives to handle first-death joint life insurances.

The different insured persons are identified by their age difference to the first insured. Different base tables for each insured can be given, by default the same table is used for all insured persons.

DESCRIPTION

@@ -43,9 +43,10 @@ Collate:
     'lifeTable.R'
     'makeQxDataFrame.R'
     'mortalityComparisonTable.R'
+    'periodDeathProbabilities.R'
+    'mortalityTable.jointLives.R'
     'mortalityTables.list.R'
     'mortalityTables.load.R'
-    'periodDeathProbabilities.R'
     'plot.mortalityTable.R'
     'plotMortalityTableComparisons.R'
     'plotMortalityTables.R'

NAMESPACE

 # Generated by roxygen2: do not edit by hand
 
 S3method(plot,mortalityTable)
+export(deathProbabilitiesIndividual)
 export(makeQxDataFrame)
 export(mortalityComparisonTable)
 export(mortalityTable)
 export(mortalityTable.ageShift)
 export(mortalityTable.improvementFactors)
 export(mortalityTable.joined)
+export(mortalityTable.jointLives)
 export(mortalityTable.mixed)
 export(mortalityTable.observed)
 export(mortalityTable.period)
@@ -19,6 +21,7 @@ exportClasses(mortalityTable)
 exportClasses(mortalityTable.ageShift)
 exportClasses(mortalityTable.improvementFactors)
 exportClasses(mortalityTable.joined)
+exportClasses(mortalityTable.jointLives)
 exportClasses(mortalityTable.mixed)
 exportClasses(mortalityTable.observed)
 exportClasses(mortalityTable.period)

R/baseTable.R

@@ -15,12 +15,12 @@ setGeneric("baseTable", function(object, ...) standardGeneric("baseTable"));
 
 #' @describeIn baseTable Return the base table of the life table
 setMethod("baseTable", "mortalityTable",
-          function (object,  ...) {
+          function(object,  ...) {
               c()
           })
 
 #' @describeIn baseTable Return the base table of the life table
 setMethod("baseTable", "mortalityTable.period",
-          function (object,  ...) {
+          function(object,  ...) {
               object@deathProbs
           })

R/getCohortTable.R

@@ -13,11 +13,11 @@ setGeneric("getCohortTable", function(object, YOB, ...) standardGeneric("getCoho
 #' @describeIn getCohortTable Return the cohort life table as a
 #'             \code{mortalityTable.period} object
 setMethod("getCohortTable","mortalityTable",
-          function (object, YOB, ...) {
+          function(object, YOB, ...) {
               mortalityTable.period(
                   name = paste(object@name, ", YOB ", YOB),
                   baseYear = YOB,
                   ages = ages(object),
-                  deathProbs = deathProbabilities(object, YOB = YOB)
+                  deathProbs = deathProbabilities(object, YOB = YOB, ...)
               );
           })

R/getPeriodTable.R

@@ -22,6 +22,6 @@ setMethod("getPeriodTable","mortalityTable",
                   name = paste(object@name, ", Period ", Period),
                   baseYear = Period,
                   ages = ages(object),
-                  deathProbs = periodDeathProbabilities(object, Period = Period)
+                  deathProbs = periodDeathProbabilities(object, Period = Period, ...)
               )
           })

R/mortalityTable.R

@@ -32,7 +32,7 @@ mortalityTable = setClass(
     ),
     prototype = list(
         name = "Actuarial Mortality Table",
-        baseYear = 2000,
+        baseYear = 0,
         loading = 0,
         modification = identity
     ),

R/mortalityTable.jointLives.R

+#' @include mortalityTable.R periodDeathProbabilities.R
+NULL
+
+#' Class mortalityTable.jointLives - Life table for multiple joint lives
+#'
+#' A cohort life table obtained by calculating joint death probabilities for
+#' multiple lives, each possibly using a different mortality table.
+#'
+#' @slot table The \code{mortalityTable} object for all lives (vector if different tables should be used for the different persons)
+#'
+#' @export mortalityTable.jointLives
+#' @exportClass mortalityTable.jointLives
+mortalityTable.jointLives = setClass(
+    "mortalityTable.jointLives",
+    slots = list(
+        table = "mortalityTable"
+    ),
+    contains = "mortalityTable"
+)
+
+
+pad0 = function(v, l, value=0) {
+    if (l >= length(v)) {
+        c(v, rep(value, l - length(v)))
+    } else {
+        v[0:l]
+    }
+}
+padLast = function(v, l) {
+    pad0(v, l, tail(v, n = 1))
+}
+
+#' @export
+deathProbabilitiesIndividual = function(tables, YOB, ageDifferences) {
+    n = max(length(YOB), length(ageDifferences) + 1);
+    if (length(YOB) == 1) {
+        YOB = c(YOB, YOB + ageDifferences);
+    }
+    if (length(ageDifferences) < length(YOB) - 1) {
+        ageDifferences = diff(YOB);
+    }
+    # prepend a 0, because the first entry has no offset
+    ageDifferences = c(0, ageDifferences);
+    tables = padLast(tables, n);
+
+    # Find the required length to have all (shifted) death probabilities fit
+    # last value will be repeated for shorter tables
+    qxlen = max(mapply(
+        function(table, yob, difference) {
+            getOmega(table) - difference
+        },
+        tables, YOB, ageDifferences)) + 1;
+    qxMatrix = mapply(
+        function(table, yob, difference) {
+            qx = deathProbabilities(table, yob);
+            if (difference <= 0) {
+                # Person is younger, so we need to pad with qx=0 for x<=difference, i.e. pad with difference zeroes
+                # This code also works with difference==0!
+                qxtmp = c(
+                    rep(0, -difference),
+                    qx);
+            } else {
+                qxtmp = tail(qx, -difference);
+            }
+            qxnew = padLast(qxtmp, qxlen)
+            str(qxnew);
+            qxnew
+        },
+        tables, YOB, ageDifferences);
+    qxMatrix
+}
+
+periodDeathProbabilitiesIndividual = function(tables, period, ageDifferences) {
+    # prepend a 0, because the first entry has no offset
+    ageDifferences = c(0, ageDifferences);
+    tables = padLast(tables, length(ageDifferences));
+
+    # Find the required length to have all (shifted) death probabilities fit
+    # last value will be repeated for shorter tables
+    qxlen = max(mapply(
+        function(table, difference) {
+            getOmega(table) - difference
+        },
+        tables, ageDifferences)) + 1;
+    qxMatrix = mapply(
+        function(table, difference) {
+            qx = periodDeathProbabilities(table, Period = period);
+            if (difference <= 0) {
+                # Person is younger, so we need to pad with qx=0 for x<=difference, i.e. pad with difference zeroes
+                # This code also works with difference==0!
+                qxtmp = c(
+                    rep(0, -difference),
+                    qx);
+            } else {
+                qxtmp = tail(qx, -difference);
+            }
+            qxnew = padLast(qxtmp, qxlen)
+            qxnew
+        },
+        tables, ageDifferences);
+    qxMatrix
+}
+
+#' @describeIn ages Return the defined ages of the joint lives mortality table (returns the ages of the first table used for joint lives)
+setMethod("ages", "mortalityTable.jointLives",
+          function(object, ...) {
+              ages(c(object@table)[1], ...);
+          })
+
+#' @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("baseTable", "mortalityTable.jointLives",
+          function(object,  ...) {
+              baseTable(c(object@table)[1], ...)
+          })
+
+#' @describeIn baseYear Return the base year of the life table
+setMethod("baseYear", "mortalityTable.jointLives",
+          function(object,  ...) {
+              baseYear(c(object@table)[1], ...)
+          })
+
+#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
+#'                                life table given the birth year (if needed)
+setMethod("deathProbabilities", "mortalityTable.jointLives",
+          function(object,  ..., ageDifferences = c(), YOB = 1975) {
+              qxMatrix = deathProbabilitiesIndividual(c(object@table), YOB = YOB, ageDifferences = ageDifferences);
+              # First death probabilities are characterized as p_x1x2x3.. = \prod p_xi, i.e.
+              # q_x1x2x3... = 1 - \prod (1 - p_xi)
+              qx = 1 - apply(1 - qxMatrix, 1, prod)
+              object@modification(qx * (1 + object@loading));
+          })
+
+#' @describeIn getOmega Return the maximum age of the joint lives mortality table (returns the maximum age of the first table used for joint lives, as the ages of the joint lives are now known to the function)
+setMethod("getOmega", "mortalityTable.observed",
+          function(object) {
+              max(object@ages, na.rm = TRUE);
+          })
+
+
+#' @describeIn periodDeathProbabilities Return the (period) death probabilities
+#'             of the joint lives mortality table for a given observation year
+setMethod("periodDeathProbabilities", "mortalityTable.jointLives",
+          function(object,  ..., ageDifferences = c(), Period = 1975) {
+              qxMatrix = periodDeathProbabilitiesIndividual(c(object@table), period = Period, ageDifferences = ageDifferences);
+              # First death probabilities are characterized as p_x1x2x3.. = \prod p_xi, i.e.
+              # q_x1x2x3... = 1 - \prod (1 - p_xi)
+              qx = 1 - apply(1 - qxMatrix, 1, prod)
+              object@modification(qx * (1 + object@loading));
+          })
+
+
+# Examples
+if (FALSE) {
+    mortalityTables.load("Germany_Census")
+    table.JL = mortalityTable.jointLives(
+        name = "ADSt 24/26 auf verbundene Leben",
+        table = mort.DE.census.1924.26.male
+    )
+    deathProbabilities(table.JL, YOB = 1977, ageDifferences = c(1, 5, -5, 16))
+    deathProbabilities(table.JL, ageDifferences = c(0))
+    deathProbabilities(table.JL, ageDifferences = c(1, 5, 16))
+
+}

man/ages.Rd

 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/ages.R
+% Please edit documentation in R/ages.R, R/mortalityTable.jointLives.R
 \docType{methods}
 \name{ages}
 \alias{ages}
 \alias{ages,mortalityTable.joined-method}
+\alias{ages,mortalityTable.jointLives-method}
 \alias{ages,mortalityTable.mixed-method}
 \alias{ages,mortalityTable.observed-method}
 \alias{ages,mortalityTable.period-method}
@@ -18,6 +19,8 @@ ages(object, ...)
 \S4method{ages}{mortalityTable.joined}(object, ...)
 
 \S4method{ages}{mortalityTable.observed}(object, ...)
+
+\S4method{ages}{mortalityTable.jointLives}(object, ...)
 }
 \arguments{
 \item{object}{A life table object (instance of a \code{\linkS4class{mortalityTable}} class)}
@@ -36,6 +39,8 @@ Return the defined ages of the life table
 \item \code{mortalityTable.joined}: Return the defined ages of the joined life table
 
 \item \code{mortalityTable.observed}: Return the defined ages of the observed life table
+
+\item \code{mortalityTable.jointLives}: Return the defined ages of the joint lives mortality table (returns the ages of the first table used for joint lives)
 }}
 \examples{
 mortalityTables.load("Austria_*", wildcard=TRUE)

man/baseTable.Rd

 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/baseTable.R
+% Please edit documentation in R/baseTable.R, R/mortalityTable.jointLives.R
 \docType{methods}
 \name{baseTable}
 \alias{baseTable}
 \alias{baseTable,mortalityTable-method}
+\alias{baseTable,mortalityTable.jointLives-method}
 \alias{baseTable,mortalityTable.period-method}
 \title{Return the base table of the life table}
 \usage{
@@ -12,6 +13,8 @@ baseTable(object, ...)
 \S4method{baseTable}{mortalityTable}(object, ...)
 
 \S4method{baseTable}{mortalityTable.period}(object, ...)
+
+\S4method{baseTable}{mortalityTable.jointLives}(object, ...)
 }
 \arguments{
 \item{object}{The life table object (class inherited from mortalityTable)}
@@ -26,6 +29,8 @@ Return the base table of the life table
 \item \code{mortalityTable}: 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)
 }}
 \examples{
 mortalityTables.load("Austria_Annuities")

man/baseYear.Rd

 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/baseYear.R
+% Please edit documentation in R/baseYear.R, R/mortalityTable.jointLives.R
 \docType{methods}
 \name{baseYear}
 \alias{baseYear}
 \alias{baseYear,mortalityTable-method}
+\alias{baseYear,mortalityTable.jointLives-method}
 \alias{baseYear,mortalityTable.mixed-method}
 \title{Return the base year of the life table}
 \usage{
@@ -12,6 +13,8 @@ baseYear(object, ...)
 \S4method{baseYear}{mortalityTable}(object, ...)
 
 \S4method{baseYear}{mortalityTable.mixed}(object, ...)
+
+\S4method{baseYear}{mortalityTable.jointLives}(object, ...)
 }
 \arguments{
 \item{object}{The life table object (class inherited from mortalityTable)}
@@ -26,6 +29,8 @@ Return the base year of the life table
 \item \code{mortalityTable}: Return the base year of the life table
 
 \item \code{mortalityTable.mixed}: Return the base year of the life table
+
+\item \code{mortalityTable.jointLives}: Return the base year of the life table
 }}
 \examples{
 mortalityTables.load("Austria_Annuities")

man/deathProbabilities.Rd

 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/deathProbabilities.R
+% Please edit documentation in R/deathProbabilities.R, R/mortalityTable.jointLives.R
 \docType{methods}
 \name{deathProbabilities}
 \alias{deathProbabilities}
 \alias{deathProbabilities,mortalityTable.ageShift-method}
 \alias{deathProbabilities,mortalityTable.improvementFactors-method}
+\alias{deathProbabilities,mortalityTable.jointLives-method}
 \alias{deathProbabilities,mortalityTable.mixed-method}
 \alias{deathProbabilities,mortalityTable.period-method}
 \alias{deathProbabilities,mortalityTable.trendProjection-method}
@@ -24,6 +25,9 @@ deathProbabilities(object, ..., YOB = 1975)
   YOB = 1975)
 
 \S4method{deathProbabilities}{mortalityTable.mixed}(object, ..., YOB = 1975)
+
+\S4method{deathProbabilities}{mortalityTable.jointLives}(object, ...,
+  ageDifferences = c(), YOB = 1975)
 }
 \arguments{
 \item{object}{The life table object (class inherited from mortalityTable)}
@@ -51,5 +55,8 @@ life table given the birth year (if needed)
 
 \item \code{mortalityTable.mixed}: Return the (cohort) death probabilities of the
 life table given the birth year (if needed)
+
+\item \code{mortalityTable.jointLives}: Return the (cohort) death probabilities of the
+life table given the birth year (if needed)
 }}
 

man/getOmega.Rd

 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/getOmega.R
+% Please edit documentation in R/getOmega.R, R/mortalityTable.jointLives.R
 \docType{methods}
 \name{getOmega}
 \alias{getOmega}
@@ -17,6 +17,8 @@ getOmega(object)
 
 \S4method{getOmega}{mortalityTable.joined}(object)
 
+\S4method{getOmega}{mortalityTable.observed}(object)
+
 \S4method{getOmega}{mortalityTable.observed}(object)
 }
 \arguments{
@@ -34,5 +36,7 @@ Return the maximum age of the life table
 \item \code{mortalityTable.joined}: Return the maximum age of the joined life table
 
 \item \code{mortalityTable.observed}: Return the maximum age of the joined life table
+
+\item \code{mortalityTable.observed}: Return the maximum age of the joint lives mortality table (returns the maximum age of the first table used for joint lives, as the ages of the joint lives are now known to the function)
 }}
 

man/mortalityTable.jointLives-class.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mortalityTable.jointLives.R
+\docType{class}
+\name{mortalityTable.jointLives-class}
+\alias{mortalityTable.jointLives}
+\alias{mortalityTable.jointLives-class}
+\title{Class mortalityTable.jointLives - Life table for multiple joint lives}
+\description{
+A cohort life table obtained by calculating joint death probabilities for
+multiple lives, each possibly using a different mortality table.
+}
+\section{Slots}{
+
+\describe{
+\item{\code{table}}{The \code{mortalityTable} object for all lives (vector if different tables should be used for the different persons)}
+}}
+

man/periodDeathProbabilities.Rd

 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/periodDeathProbabilities.R
+% Please edit documentation in R/periodDeathProbabilities.R, R/mortalityTable.jointLives.R
 \docType{methods}
 \name{periodDeathProbabilities}
 \alias{periodDeathProbabilities}
 \alias{periodDeathProbabilities,mortalityTable.ageShift-method}
 \alias{periodDeathProbabilities,mortalityTable.improvementFactors-method}
+\alias{periodDeathProbabilities,mortalityTable.jointLives-method}
 \alias{periodDeathProbabilities,mortalityTable.mixed-method}
 \alias{periodDeathProbabilities,mortalityTable.period-method}
 \alias{periodDeathProbabilities,mortalityTable.trendProjection-method}
@@ -27,6 +28,9 @@ periodDeathProbabilities(object, ..., Period = 1975)
 
 \S4method{periodDeathProbabilities}{mortalityTable.mixed}(object, ...,
   Period = 1975)
+
+\S4method{periodDeathProbabilities}{mortalityTable.jointLives}(object, ...,
+  ageDifferences = c(), Period = 1975)
 }
 \arguments{
 \item{object}{The life table object (class inherited from mortalityTable)}
@@ -55,5 +59,8 @@ of the life table for a given observation year
 
 \item \code{mortalityTable.mixed}: Return the (period) death probabilities
 of the life table for a given observation year
+
+\item \code{mortalityTable.jointLives}: Return the (period) death probabilities
+of the joint lives mortality table for a given observation year
 }}