Add fillAges function, ages argument to deathProbabilities function

All probs will be intersected with the desired ages, missing values will be filled with NA

DESCRIPTION

@@ -34,6 +34,7 @@ Collate:
     'ages.R'
     'baseTable.R'
     'baseYear.R'
+    'fillAges.R'
     'pensionTable.R'
     'commutationNumbers.R'
     'mortalityTable.improvementFactors.R'

NAMESPACE

@@ -2,6 +2,7 @@
 
 S3method(plot,mortalityTable)
 export(deathProbabilitiesIndividual)
+export(fillAges)
 export(generateAgeShift)
 export(makeQxDataFrame)
 export(mortalityComparisonTable)

R/deathProbabilities.R

-#' @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

+
+#' 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

@@ -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

-#' @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

-#' @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

@@ -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

+% 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

@@ -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

@@ -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)}