Allow data.frame / matrix as age-dependent selection factors

R/baseProbabilities.R

 #' @include mortalityTable.R mortalityTable.period.R mortalityTable.ageShift.R mortalityTable.trendProjection.R mortalityTable.improvementFactors.R mortalityTable.mixed.R fillAges.R
 NULL
 
-#' Return the base death probabilities of the life table
+#' Return the base death probabilities of the life table (with a possible
+#' selection effect applied, but without further processing like modifications,
+#' margins or trend extrapolation)
 #'
 #' @param object The life table object (class inherited from mortalityTable)
 #' @param ... Other parameters (currently unused)
@@ -42,13 +44,52 @@ setMethod("baseProbabilities", "mortalityTable.period",
                   probs = object@deathProbs[cbind(rws, cols)]
               }
               if (!is.null(object@selectionFactors)) {
-                  # Add a terminal 1 just in case, so that after the selection period, no modification occurs
-                  sel.factors = c(object@selectionFactors, 1)
-                  # For each age, determine the index into the selection factor
-                  # (ages below selection Age get index 1) and multiply the base
-                  # probability with the corresponding selection factor
-                  sel.offset = pmin(length(sel.factors), offsets)
-                  probs = sel.factors[sel.offset] * probs
+                  if (is.vector(object@selectionFactors)) {
+                      # Add a terminal 1 just in case, so that after the selection period, no modification occurs
+                      sel.factors = c(object@selectionFactors, 1)
+                      # For each age, determine the index into the selection factor
+                      # (ages below selection Age get index 1) and multiply the base
+                      # probability with the corresponding selection factor
+                    sel.offset = pmin(length(sel.factors), offsets)
+                    factors = sel.factors[sel.offset]
+                  } else {
+                      # Assume that the array / data.frame given as selectionFactors
+                      # has the same ages as the base table
+                      # Optionally, allow an "age" or "Age" column in the data.frame or array
+                      # (of course, remove that column before extracting the factors)
+                      sf = cbind(object@selectionFactors, Ultimate = 1)
+                      ages = ages(object)
+                      if ("age" %in% colnames(sf)) {
+                          ages = sf$age
+                          sf$age = NULL
+                      }
+                      if ("Age" %in% colnames(sf)) {
+                          ages = sf$Age
+                          sf$Age = NULL
+                      }
+                      # Extract the selection factors just like the base probabilities
+                      # were extracted from the array / data.frame
+                      offsets = pmax(1, ages - selectionAge + 1)
+                      cols = pmin(ncol(sf), offsets)
+                      rws = seq_along(cols)
+                      if (object@selectInitialAge) {
+                          # if data gives selection by initial age, make sure to
+                          # walk along thw same row until the ultimate table is reached
+                          rws = rws - cols + 1
+                          # For ages before the first attained age of the ultimate table,
+                          # use the select probabilities, even before the desired select age
+                          cols = cols + pmin(0, rws - 1)
+                          rws = pmax(1, rws)
+                      }
+                      # exctract the corresponding columns for each age:
+                      # See https://stackoverflow.com/questions/20036255/get-the-vector-of-values-from-different-columns-of-a-matrix
+                      # TODO: Check if any index is outside the existing dimensions!
+                      factors = as.matrix(sf)[cbind(rws, cols)]
+
+                    # TODO: handle age-specific selection factors (e.g. 1980 CSO 10-year selection factors)
+
+                  }
+                  probs = factors * probs
               }
               object@modification(probs * (1 + object@loading))
           })

R/mortalityTable.period.R

 #' @include mortalityTable.R
 NULL
 
-setClassUnion("numericArray", c("numeric", "array", "matrix"))
-setClassUnion("numericArrayOrNULL", c("numeric", "array", "matrix", "NULL"))
+setClassUnion("numericArray", c("numeric", "array", "matrix", "data.frame"))
+setClassUnion("numericArrayOrNULL", c("numeric", "array", "matrix", "data.frame", "NULL"))
 setClassUnion("numericOrNULL", c("numeric", "NULL"))
 setClassUnion("mortalityTableOrNULL", c("mortalityTable", "NULL"))
 
@@ -47,7 +47,7 @@ mortalityTable.period = setClass(
         ages = "numeric",
         deathProbs = "numericArray",
         exposures = "numericArrayOrNULL",
-        selectionFactors = "numericOrNULL",
+        selectionFactors = "numericArrayOrNULL",
         selectInitialAge = "logical",
         tableBeforeSelection = "mortalityTableOrNULL"
     ),

man/baseProbabilities.Rd

@@ -32,6 +32,8 @@ life table given the birth year (if needed)
 }}
 
 \examples{
-# TODO
+baseProbabilities(DAV2004R.male.selekt)
+baseProbabilities(DAV2004R.male.selekt, selectionAge = 60)
+baseProbabilities(DAV2004R.male.selekt, selectionAge = 65)
 
 }

man/getOmega.Rd

@@ -4,6 +4,7 @@
 \name{getOmega}
 \alias{getOmega}
 \alias{getOmega,mortalityTable.period-method}
+\alias{getOmega,mortalityTable.mixed-method}
 \alias{getOmega,mortalityTable.jointLives-method}
 \alias{getOmega,mortalityTable.observed-method}
 \title{Return the maximum age of the life table}
@@ -12,6 +13,8 @@ getOmega(object)
 
 \S4method{getOmega}{mortalityTable.period}(object)
 
+\S4method{getOmega}{mortalityTable.mixed}(object)
+
 \S4method{getOmega}{mortalityTable.jointLives}(object)
 
 \S4method{getOmega}{mortalityTable.observed}(object)
@@ -26,6 +29,8 @@ Return the maximum age of the life table
 \itemize{
 \item \code{mortalityTable.period}: Return the maximum age of the period life table
 
+\item \code{mortalityTable.mixed}: Return the maximum age of the mixed life table
+
 \item \code{mortalityTable.jointLives}: 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)
 
 \item \code{mortalityTable.observed}: Return the maximum age of the life table