Commit f7a48c8c authored by Reinhold Kainhofer's avatar Reinhold Kainhofer

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.
parent ee50b3bc
......@@ -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'
......
# 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)
......
......@@ -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
})
......@@ -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, ...)
);
})
......@@ -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, ...)
)
})
......@@ -32,7 +32,7 @@ mortalityTable = setClass(
),
prototype = list(
name = "Actuarial Mortality Table",
baseYear = 2000,
baseYear = 0,
loading = 0,
modification = identity
),
......
#' @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))
}
% 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)
......
% 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")
......
% 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")
......
% 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)
}}
% 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)
}}
% 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)}
}}
% 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
}}
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