Skip to content

GitLab

R
R - Mortality Tables
Commit 0d0425f6 authored by Reinhold Kainhofer's avatar Reinhold Kainhofer
Browse files
Options

Add fillAges function, ages argument to deathProbabilities function 

All probs will be intersected with the desired ages, missing values will be filled with NA
parent 2e3613af
Hide whitespace changes
Inline Side-by-side
Showing with 145 additions and 72 deletions
DESCRIPTION
View file @ 0d0425f6
......@@ -34,6 +34,7 @@ Collate:
'ages.R'
'baseTable.R'
'baseYear.R'
'fillAges.R'
'pensionTable.R'
'commutationNumbers.R'
'mortalityTable.improvementFactors.R'
......
NAMESPACE
View file @ 0d0425f6
......@@ -2,6 +2,7 @@
S3method(plot,mortalityTable)
export(deathProbabilitiesIndividual)
export(fillAges)
export(generateAgeShift)
export(makeQxDataFrame)
export(mortalityComparisonTable)
......
R/deathProbabilities.R
View file @ 0d0425f6
#' @include mortalityTable.R mortalityTable.period.R mortalityTable.ageShift.R mortalityTable.trendProjection.R mortalityTable.improvementFactors.R mortalityTable.mixed.R
#' @include mortalityTable.R mortalityTable.period.R mortalityTable.ageShift.R mortalityTable.trendProjection.R mortalityTable.improvementFactors.R mortalityTable.mixed.R fillAges.R
NULL
#' Return the (cohort) death probabilities of the life table given the birth year (if needed)
......@@ -13,19 +13,23 @@ NULL
#' deathProbabilities(AVOe2005R.male, YOB = 2017)
#'
#' @exportMethod deathProbabilities
setGeneric("deathProbabilities", function(object, ..., YOB = 1975) standardGeneric("deathProbabilities"));
setGeneric("deathProbabilities", function(object, ..., ages = NULL, YOB = 1975) standardGeneric("deathProbabilities"));
#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
#' life table given the birth year (if needed)
setMethod("deathProbabilities", "mortalityTable.period",
function(object, ..., YOB = 1975) {
object@modification(object@deathProbs * (1 + object@loading));
function(object, ..., ages = NULL, YOB = 1975) {
fillAges(
object@modification(object@deathProbs * (1 + object@loading)),
haveAges = ages(object),
needAges = ages
);
})
#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
#' life table given the birth year (if needed)
setMethod("deathProbabilities","mortalityTable.ageShift",
function(object, ..., YOB = 1975) {
function(object, ..., ages = NULL, YOB = 1975) {
qx = object@deathProbs * (1 + object@loading);
shift = ageShift(object, YOB);
if (shift > 0) {
......@@ -33,18 +37,18 @@ setMethod("deathProbabilities","mortalityTable.ageShift",
} else if (shift < 0) {
qx = c(rep(0, -shift), qx[1:(length(qx) - (-shift))])
}
object@modification(qx)
fillAges(object@modification(qx), haveAges = ages(object), needAges = ages)
})
#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
#' life table given the birth year (if needed)
setMethod("deathProbabilities","mortalityTable.trendProjection",
function(object, ..., YOB = 1975) {
function(object, ..., ages = NULL, YOB = 1975) {
qx = object@deathProbs * (1 + object@loading);
if (is.null(object@trend2) || length(object@trend2) <= 1) {
ages = object@ages;
haveAges = object@ages;
damping = sapply(
ages,
haveAges,
function(age) { object@dampingFunction(YOB + age - object@baseYear) }
);
finalqx = exp(-object@trend * damping) * qx;
......@@ -57,24 +61,28 @@ setMethod("deathProbabilities","mortalityTable.trendProjection",
-(object@trend * (1 - weights) + object@trend2 * weights) *
(YOB + 0:(length(qx) - 1) - object@baseYear))
}
object@modification(finalqx)
fillAges(object@modification(finalqx), givenAges = haveAges, neededAges = ages)
})
#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
#' life table given the birth year (if needed)
setMethod("deathProbabilities","mortalityTable.improvementFactors",
function(object, ..., YOB = 1975) {
function(object, ..., ages = NULL, YOB = 1975) {
qx = object@deathProbs * (1 + object@loading);
impr = calculateImprovements(object, ..., YOB = YOB)
object@modification(impr * qx)
fillAges(
object@modification(impr * qx),
haveAges = ages(object),
needAges = ages)
})
#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
#' life table given the birth year (if needed)
setMethod("deathProbabilities","mortalityTable.mixed",
function(object, ..., YOB = 1975) {
qx1 = deathProbabilities(object@table1, ..., YOB);
qx2 = deathProbabilities(object@table2, ..., YOB);
function(object, ..., ages = NULL, YOB = 1975) {
qx1 = deathProbabilities(object@table1, ..., ages = ages, YOB = YOB);
qx2 = deathProbabilities(object@table2, ..., ages = ages, YOB = YOB);
mixedqx = (object@weight1 * qx1 + object@weight2 * qx2)/(object@weight1 + object@weight2) * (1 + object@loading);
# We already have the correct ages from the deathProbabilities call above
object@modification(mixedqx)
})
R/fillAges.R 0 → 100644
View file @ 0d0425f6
#' Fill the given probabilities with NA to match the desired age range.
#'
#' @param probs Numeric vector
#' @param haveAges ages assigned to the given vector
#' @param neededAges desired age range for output
#'
#' @export fillAges
fillAges = function(probs = c(), haveAges = c(), neededAges = NULL) {
if (!is.null(neededAges)) {
# initialize result with NA, then fill in all known ages from probs
result = rep(NA_real_, length(neededAges))
providedAges = intersect(neededAges, haveAges)
result[match(providedAges, neededAges)] = probs[match(providedAges, haveAges)]
} else {
probs
}
}
#
# haveAges = c(12,16,20, 23:30, 32, 40)
# neededAges = c(0:24, 49:25)
# probs = c(12,16,20, 23:30, 32, 40)/10
#
# providedAges = intersect(neededAges, haveAges)
# result = rep(NA_real_, length(neededAges))
#
#
#
#
# names(result) = neededAges
# result
R/mortalityTable.jointLives.R
View file @ 0d0425f6
......@@ -187,12 +187,12 @@ setMethod("baseYear", "mortalityTable.jointLives",
#' deathProbabilities(table.JL, YOB = 1977, ageDifferences = c(1, 5, 16))
#'
setMethod("deathProbabilities", "mortalityTable.jointLives",
function(object, ..., ageDifferences = c(), YOB = 1975) {
function(object, ..., ageDifferences = c(), ages = NULL, 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));
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)
......@@ -218,7 +218,7 @@ setMethod("getOmega", "mortalityTable.jointLives",
#'
setMethod("periodDeathProbabilities", "mortalityTable.jointLives",
function(object, ..., ageDifferences = c(), Period = 1975) {
function(object, ..., ageDifferences = c(), ages = NULL, 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)
......
R/pensionTable.R
View file @ 0d0425f6
#' @include mortalityTable.R
#' @include mortalityTable.R fillAges.R
NULL
......@@ -127,7 +127,7 @@ setGeneric("transitionProbabilities", function(object, ...) standardGeneric("tra
#' @describeIn transitionProbabilities Return all transition probabilities of the pension table for the generation YOB
setMethod("transitionProbabilities", "pensionTable",
function(object, YOB = 1982, ..., OverallMortality = FALSE, Period = NULL, retirement = NULL,
function(object, YOB = 1982, ..., ages = NULL, OverallMortality = FALSE, Period = NULL, retirement = NULL,
invalids.retire = object@invalids.retire, as.data.frame = TRUE) {
if (!missing(Period) && !is.null(Period)) {
return(periodTransitionProbabilities(
......@@ -135,11 +135,12 @@ setMethod("transitionProbabilities", "pensionTable",
invalids.retire = invalids.retire,
as.data.frame = as.data.frame))
}
x = ages(object@qx);
q = deathProbabilities(object@qx, ..., YOB = YOB);
i = deathProbabilities(object@ix, ..., YOB = YOB);
qi = deathProbabilities(object@qix, ..., YOB = YOB);
r = deathProbabilities(object@rx, ..., YOB = YOB);
x = ifelse(is.null(ages), ages(object@qx), ages);
# 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);
apTab = object@apx
if (!missing(retirement) && !is.null(retirement)) {
if (inherits(retirement, "mortalityTable")) {
......@@ -157,7 +158,7 @@ setMethod("transitionProbabilities", "pensionTable",
apTab = mortalityTable.zeroes(ages = x)
}
}
ap = deathProbabilities(apTab, ..., YOB = YOB);
ap = deathProbabilities(apTab, ..., ages = ages, YOB = YOB);
if (!missing(retirement) && !is.null(retirement)) {
if (inherits(retirement, "mortalityTable")) {
......@@ -173,13 +174,13 @@ setMethod("transitionProbabilities", "pensionTable",
if (invalids.retire) {
api = ap
} else {
api = deathProbabilities(mortalityTable.zeroes(ages = x), ..., YOB = YOB)
api = deathProbabilities(mortalityTable.zeroes(ages = x), ..., ages = ages, 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);
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);
if (!OverallMortality) {
pensionTableProbArrange(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, as.data.frame = as.data.frame)
} else {
......@@ -219,11 +220,11 @@ setGeneric("periodTransitionProbabilities", function(object, ...) standardGeneri
#' @describeIn periodTransitionProbabilities Return all transition probabilities of the pension table for the period Period
setMethod("periodTransitionProbabilities", "pensionTable",
function(object, Period = 2017, ..., OverallMortality = FALSE, retirement = NULL, invalids.retire = object@invalids.retire, as.data.frame = TRUE) {
x = ages(object@qx);
q = periodDeathProbabilities(object@qx, ..., Period = Period);
i = periodDeathProbabilities(object@ix, ..., Period = Period);
qi = periodDeathProbabilities(object@qix, ..., Period = Period);
r = periodDeathProbabilities(object@rx, ..., Period = Period);
x = ifelse(is.null(ages), ages(object@qx), ages);
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);
apTab = object@apx
if (!missing(retirement) && !is.null(retirement)) {
if (inherits(retirement, "mortalityTable")) {
......@@ -241,17 +242,17 @@ setMethod("periodTransitionProbabilities", "pensionTable",
apTab = mortalityTable.zeroes(ages = x)
}
}
ap = deathProbabilities(apTab, ..., Period = Period)
ap = deathProbabilities(apTab, ..., ages = ages, Period = Period)
if (invalids.retire) {
api = ap
} else {
api = deathProbabilities(mortalityTable.zeroes(ages = x), ..., Period = Period)
api = deathProbabilities(mortalityTable.zeroes(ages = x), ..., ages = ages, Period = Period)
}
qp = periodDeathProbabilities(object@qpx, ..., Period = Period);
h = periodDeathProbabilities(object@hx, ..., Period = Period);
qw = periodDeathProbabilities(object@qwy, ..., Period = Period);
yx = periodDeathProbabilities(object@yx, ..., Period = Period);
qg = periodDeathProbabilities(object@qgx, ..., Period = Period);
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);
if (!OverallMortality) {
pensionTableProbArrange(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, as.data.frame = as.data.frame)
} else {
......
R/periodDeathProbabilities.R
View file @ 0d0425f6
#' @include mortalityTable.R mortalityTable.period.R mortalityTable.trendProjection.R mortalityTable.improvementFactors.R mortalityTable.mixed.R
#' @include mortalityTable.R mortalityTable.period.R mortalityTable.trendProjection.R mortalityTable.improvementFactors.R mortalityTable.mixed.R fillAges.R
NULL
#' Return the (period) death probabilities of the life table for a given
......@@ -9,31 +9,34 @@ NULL
#' @param Period The observation year for which the period death probabilities should be determined
#'
#' @exportMethod periodDeathProbabilities
setGeneric("periodDeathProbabilities", function(object, ..., Period = 1975) standardGeneric("periodDeathProbabilities"));
setGeneric("periodDeathProbabilities", function(object, ..., ages = NULL, Period = 1975) standardGeneric("periodDeathProbabilities"));
#' @describeIn periodDeathProbabilities Return the (period) death probabilities
#' of the life table for a given observation year
setMethod("periodDeathProbabilities", "mortalityTable.period",
function(object, ..., Period = 1975) {
function(object, ..., ages = NULL, Period = 1975) {
object@modification(object@deathProbs * (1 + object@loading));
})
#' @describeIn periodDeathProbabilities Return the (period) death probabilities
#' of the life table for a given observation year
setMethod("periodDeathProbabilities", "mortalityTable.ageShift",
function (object, ..., Period = 1975) {
function (object, ..., ages = NULL, Period = 1975) {
# TODO
qx = object@deathProbs * (1 + object@loading);
# TODO!!!
# shift.index = match(YOB, object@shifts, 0);
# if (shift.index) {}
object@modification(qx)
fillAges(
object@modification(qx),
haveAges = ages(object),
needAges = ages)
})
#' @describeIn periodDeathProbabilities Return the (period) death probabilities
#' of the life table for a given observation year
setMethod("periodDeathProbabilities", "mortalityTable.trendProjection",
function(object, ..., Period = 1975) {
function(object, ..., ages = NULL, Period = 1975) {
qx = object@deathProbs * (1 + object@loading);
if (is.null(object@trend2) || length(object@trend2) <= 1) {
# ages = 0:(length(qx)-1);
......@@ -46,25 +49,32 @@ setMethod("periodDeathProbabilities", "mortalityTable.trendProjection",
-(object@trend * (1 - weight) + object@trend2 * weight) *
(Period - object@baseYear))
}
object@modification(finalqx)
fillAges(
object@modification(finalqx),
haveAges = ages(object),
needAges = ages)
})
#' @describeIn periodDeathProbabilities Return the (period) death probabilities
#' of the life table for a given observation year
setMethod("periodDeathProbabilities", "mortalityTable.improvementFactors",
function(object, ..., Period = 1975) {
function(object, ..., ages = NULL, Period = 1975) {
qx = object@deathProbs * (1 + object@loading);
impr = calculateImprovements(object, ..., Period = Period)
object@modification(qx * impr)
fillAges(
object@modification(qx * impr),
haveAges = ages(object),
needAges = ages)
})
#' @describeIn periodDeathProbabilities Return the (period) death probabilities
#' of the life table for a given observation year
setMethod("periodDeathProbabilities", "mortalityTable.mixed",
function(object, ..., Period = 1975) {
qx1 = periodDeathProbabilities(object@table1, ..., Period = Period);
qx2 = periodDeathProbabilities(object@table2, ..., Period = Period);
function(object, ..., ages = NULL, Period = 1975) {
qx1 = periodDeathProbabilities(object@table1, ..., ages = ages, Period = Period);
qx2 = periodDeathProbabilities(object@table2, ..., ages = ages, Period = Period);
mixedqx = (object@weight1 * qx1 + object@weight2 * qx2) / (object@weight1 + object@weight2) * (1 + object@loading);
# We already have the correct ages from the deathProbabilities call above
object@modification(mixedqx)
})
man/deathProbabilities.Rd
View file @ 0d0425f6
......@@ -12,23 +12,25 @@
\alias{deathProbabilities,mortalityTable.jointLives-method}
\title{Return the (cohort) death probabilities of the life table given the birth year (if needed)}
\usage{
deathProbabilities(object, ..., YOB = 1975)
deathProbabilities(object, ..., ages = NULL, YOB = 1975)
\S4method{deathProbabilities}{mortalityTable.period}(object, ..., YOB = 1975)
\S4method{deathProbabilities}{mortalityTable.period}(object, ..., ages = NULL,
YOB = 1975)
\S4method{deathProbabilities}{mortalityTable.ageShift}(object, ...,
YOB = 1975)
ages = NULL, YOB = 1975)
\S4method{deathProbabilities}{mortalityTable.trendProjection}(object, ...,
YOB = 1975)
ages = NULL, YOB = 1975)
\S4method{deathProbabilities}{mortalityTable.improvementFactors}(object, ...,
YOB = 1975)
ages = NULL, YOB = 1975)
\S4method{deathProbabilities}{mortalityTable.mixed}(object, ..., YOB = 1975)
\S4method{deathProbabilities}{mortalityTable.mixed}(object, ..., ages = NULL,
YOB = 1975)
\S4method{deathProbabilities}{mortalityTable.jointLives}(object, ...,
ageDifferences = c(), YOB = 1975)
ageDifferences = c(), ages = NULL, YOB = 1975)
}
\arguments{
\item{object}{The life table object (class inherited from mortalityTable)}
......
man/fillAges.Rd 0 → 100644
View file @ 0d0425f6
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/fillAges.R
\name{fillAges}
\alias{fillAges}
\title{Fill the given probabilities with NA to match the desired age range.}
\usage{
fillAges(probs = c(), haveAges = c(), neededAges = NULL)
}
\arguments{
\item{probs}{Numeric vector}
\item{haveAges}{ages assigned to the given vector}
\item{neededAges}{desired age range for output}
}
\description{
Fill the given probabilities with NA to match the desired age range.
}
man/periodDeathProbabilities.Rd
View file @ 0d0425f6
......@@ -13,25 +13,25 @@
\title{Return the (period) death probabilities of the life table for a given
observation year}
\usage{
periodDeathProbabilities(object, ..., Period = 1975)
periodDeathProbabilities(object, ..., ages = NULL, Period = 1975)
\S4method{periodDeathProbabilities}{mortalityTable.period}(object, ...,
Period = 1975)
ages = NULL, Period = 1975)
\S4method{periodDeathProbabilities}{mortalityTable.ageShift}(object, ...,
Period = 1975)
ages = NULL, Period = 1975)
\S4method{periodDeathProbabilities}{mortalityTable.trendProjection}(object, ...,
Period = 1975)
ages = NULL, Period = 1975)
\S4method{periodDeathProbabilities}{mortalityTable.improvementFactors}(object,
..., Period = 1975)
..., ages = NULL, Period = 1975)
\S4method{periodDeathProbabilities}{mortalityTable.mixed}(object, ...,
Period = 1975)
ages = NULL, Period = 1975)
\S4method{periodDeathProbabilities}{mortalityTable.jointLives}(object, ...,
ageDifferences = c(), Period = 1975)
ageDifferences = c(), ages = NULL, Period = 1975)
}
\arguments{
\item{object}{The life table object (class inherited from mortalityTable)}
......
man/transitionProbabilities.Rd
View file @ 0d0425f6
......@@ -9,8 +9,9 @@
transitionProbabilities(object, ...)
\S4method{transitionProbabilities}{pensionTable}(object, YOB = 1982, ...,
OverallMortality = FALSE, Period = NULL, retirement = NULL,
invalids.retire = object@invalids.retire, as.data.frame = TRUE)
ages = NULL, OverallMortality = FALSE, Period = NULL,
retirement = NULL, invalids.retire = object@invalids.retire,
as.data.frame = TRUE)
}
\arguments{
\item{object}{A pension table object (instance of a \code{\linkS4class{pensionTable}} class)}
......
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