Add whittaker.mortalityTable function, add exposures slot to mortalityTable.period

DESCRIPTION

@@ -60,4 +60,5 @@ Collate:
     'setLoading.R'
     'setModification.R'
     'undampenTrend.R'
+    'whittaker.mortalityTable.R'
 VignetteBuilder: knitr

NAMESPACE

@@ -27,6 +27,7 @@ export(periodDeathProbabilitiesIndividual)
 export(plotMortalityTableComparisons)
 export(plotMortalityTables)
 export(plotMortalityTrend)
+export(whittaker.mortalityTable)
 exportClasses(mortalityTable)
 exportClasses(mortalityTable.MakehamGompertz)
 exportClasses(mortalityTable.Weibull)

R/mortalityTable.period.R

@@ -9,6 +9,8 @@ NULL
 #'
 #' @slot ages       The ages corresponding to the entries of the deathProbs
 #' @slot deathProbs The one-year death probabilities for the ages
+#' @slot exposures  (Optional) exposured used to determine death probabilities
+#'                  (can be used as weights for smoothing, for variances, etc.)
 #'
 #' @export mortalityTable.period
 #' @exportClass mortalityTable.period
@@ -16,11 +18,13 @@ mortalityTable.period = setClass(
     "mortalityTable.period",
     slots = list(
         ages = "numeric",
-        deathProbs = "numeric"
+        deathProbs = "numeric",
+        exposures = "numeric"
     ),
     prototype = list(
         ages = eval(0:120),
-        deathProbs = rep(1,120)
+        deathProbs = rep(1,120),
+        exposures = NULL
     ),
     contains = "mortalityTable"
 )

R/whittaker.mortalityTable.R

+#' Smooth a life table using the Whittaker-Henderson method, intepolation possibly missing values
+#'
+#' \code{whittaker.mortalityTable} uses the Whittaker-Henderson graduation method
+#' to smooth a table of raw observed death probabilities, optionally using the
+#' exposures stored in the table as weights (if no exposures are given, equal
+#' weights are applied). All ages with a death probability of \code{NA} will be
+#' interpolated in the Whittaker-Henderson method (see e.g. Lowrie)
+#'
+#' @param table Mortality table to be graduated. Must be an instance of a
+#'              \code{mortalityTable}-derived class.
+#' @param lambda Smoothing parameter (default 10)
+#' @param d order of differences (default 2)
+#' @param name.postfix Postfix appended to the name of the graduated table
+#' @param weights Vector of weights used for graduation. Entries with weight 0
+#'                will be interpolated. If not given, the exposures of the table
+#'                or equal weights are used.
+#'
+#' @param ... additional arguments (currently unused)
+#' @param reference The reference table that determines the 100\% values.
+#'                  If not given, the absolute mortality values are
+#'                  compared and plotted on a log-linear scale.
+#' @param trend If set to \code{TRUE}, the function \code{\link{plotMortalityTrend}}
+#'              is used to plot the trends of the given tables.
+#'
+#' @references
+#' Walter B. Lowrie: An Extension of the Whittaker-Henderson Method of Graduation, Transactions of Society of Actuaries, 1982, Vol. 34, pp. 329--372
+#'
+#' @examples
+#' # TODO
+#'
+#' @seealso \code{\link{whittaker}}
+#'
+#' @import scales
+#' @export
+whittaker.mortalityTable = function(table, lambda = 10, d = 2, name.postfix = ", smoothed", ..., weights = NULL) {
+    if (!is(table, "mortalityTable")) {
+        stop("Table object must be an instance of mortalityTable in whittaker.mortalityTable.")
+    }
+    # append the postfix to the table name to distinguish it from the original (raw) table
+    if (!is.null(name.postfix)) {
+        table@name = paste0(table@name, name.postfix)
+    }
+
+    probs = table@deathProbs
+    ages = table@ages
+
+    if (missing(weights) || is.null(weights)) {
+        if (is.na(table@exposures) || is.null(table@exposures)) {
+            weights = table@exposures
+        } else {
+            weights = rep(1, length(ages))
+        }
+    }
+    # Missing values are always interpolated, i.e. assigned weight 0:
+    weights = weights * is.na(probs)
+
+    probs.smooth = exp(whittaker.interpolate(log(probs[!NApos]), lambda = lambda, d = d, weights = weights))
+    table@deathProbs = probs.smooth
+
+    table
+}
+
+
+whittaker.interpolate = function(y, lambda = 1600, d = 2, weights = rep(1, length(y))) {
+    m <- length(y)
+    E <- eye(m)
+    W <- diag(weights)
+    D <- diff(E, lag = 1, differences = d)# - r * diff(E, lab = 1, differences = d - 1)
+    B <- W + (lambda * t(D) %*% D)
+    z <- solve(B, W %*% y)
+    return(z)
+}
+#
+# y = c(0.25288, 0, 0.31052, 0, 0, 0, 0.4062, 0, 0, 0, 0, 0.65162)
+# weights = c(2115646, 0, 3413643, 0, 0, 0, 2487602, 0, 0, 0, 0, 999053)
+#
+#
+# whittaker.interpolate(y, lambda = 10, d = 2, weights = weights)

man/mortalityTable.period-class.Rd

@@ -16,5 +16,8 @@ information about the period.
 \item{\code{ages}}{The ages corresponding to the entries of the deathProbs}
 
 \item{\code{deathProbs}}{The one-year death probabilities for the ages}
+
+\item{\code{exposures}}{(Optional) exposured used to determine death probabilities
+(can be used as weights for smoothing, for variances, etc.)}
 }}
 

man/plotMortalityTableComparisons.Rd

@@ -4,8 +4,9 @@
 \alias{plotMortalityTableComparisons}
 \title{Plot multiple mortality tables (life tables) in one plot, relative to a given reference table}
 \usage{
-plotMortalityTableComparisons(data, ..., xlim = NULL, ylim = NULL,
-  xlab = NULL, ylab = NULL, title = "", legend.position = c(0.9, 0.1),
+plotMortalityTableComparisons(data, ..., ages = NULL, xlim = NULL,
+  ylim = NULL, xlab = NULL, ylab = NULL, title = "",
+  legend.position = c(0.9, 0.1), legend.justification = c(1, 0),
   legend.key.width = unit(25, "mm"), reference = NULL)
 }
 \arguments{
@@ -13,6 +14,8 @@ plotMortalityTableComparisons(data, ..., xlim = NULL, ylim = NULL,
 
 \item{...}{Additional life tables to be plotted (if \code{data} is a \code{mortalityTable} object)}
 
+\item{ages}{Plot only the given ages}
+
 \item{xlim}{X-axis limitatation (as a two-element vector)}
 
 \item{ylim}{Y-axis limitatation (as a two-element vector)}
@@ -25,6 +28,8 @@ plotMortalityTableComparisons(data, ..., xlim = NULL, ylim = NULL,
 
 \item{legend.position}{The position of the legend (default is \code{c(0.9,0.1)})}
 
+\item{legend.justification}{The justification of the legend (default is \code{c(1,)})}
+
 \item{legend.key.width}{The keywith of the lines in the  legend (default is \code{unit(25,"mm")})}
 
 \item{reference}{The reference table that determines the 100\% values. If not given, the first argument of \code{data} is used as reference table.}

man/plotMortalityTables.Rd

@@ -4,8 +4,8 @@
 \alias{plotMortalityTables}
 \title{Plot multiple mortality tables (life tables) in one plot}
 \usage{
-plotMortalityTables(data, ..., legend.title = "Sterbetafel", xlim = NULL,
-  ylim = NULL, xlab = NULL, ylab = NULL, title = "",
+plotMortalityTables(data, ..., ages = NULL, legend.title = "Sterbetafel",
+  xlim = NULL, ylim = NULL, xlab = NULL, ylab = NULL, title = "",
   legend.position = c(0.9, 0.1), legend.justification = c(1, 0),
   legend.key.width = unit(25, "mm"))
 }
@@ -14,6 +14,8 @@ plotMortalityTables(data, ..., legend.title = "Sterbetafel", xlim = NULL,
 
 \item{...}{Additional life tables to be plotted (if \code{data} is a \code{mortalityTable} object)}
 
+\item{ages}{Plot only the given ages}
+
 \item{xlim}{X-axis limitatation (as a two-element vector)}
 
 \item{ylim}{Y-axis limitatation (as a two-element vector)}
@@ -26,6 +28,8 @@ plotMortalityTables(data, ..., legend.title = "Sterbetafel", xlim = NULL,
 
 \item{legend.position}{The position of the legend (default is \code{c(0.9,0.1)})}
 
+\item{legend.justification}{The justification of the legend (default is \code{c(1,)})}
+
 \item{legend.key.width}{The keywith of the lines in the  legend (default is \code{unit(25,"mm")})}
 }
 \description{

man/whittaker.mortalityTable.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/whittaker.mortalityTable.R
+\name{whittaker.mortalityTable}
+\alias{whittaker.mortalityTable}
+\title{Smooth a life table using the Whittaker-Henderson method, intepolation possibly missing values}
+\usage{
+whittaker.mortalityTable(table, lambda = 10, d = 2,
+  name.postfix = ", smoothed", ..., weights = NULL)
+}
+\arguments{
+\item{table}{Mortality table to be graduated. Must be an instance of a
+\code{mortalityTable}-derived class.}
+
+\item{lambda}{Smoothing parameter (default 10)}
+
+\item{d}{order of differences (default 2)}
+
+\item{name.postfix}{Postfix appended to the name of the graduated table}
+
+\item{...}{additional arguments (currently unused)}
+
+\item{weights}{Vector of weights used for graduation. Entries with weight 0
+will be interpolated. If not given, the exposures of the table
+or equal weights are used.}
+
+\item{reference}{The reference table that determines the 100\% values.
+If not given, the absolute mortality values are
+compared and plotted on a log-linear scale.}
+
+\item{trend}{If set to \code{TRUE}, the function \code{\link{plotMortalityTrend}}
+is used to plot the trends of the given tables.}
+}
+\description{
+\code{whittaker.mortalityTable} uses the Whittaker-Henderson graduation method
+to smooth a table of raw observed death probabilities, optionally using the
+exposures stored in the table as weights (if no exposures are given, equal
+weights are applied). All ages with a death probability of \code{NA} will be
+interpolated in the Whittaker-Henderson method (see e.g. Lowrie)
+}
+\examples{
+# TODO
+
+}
+\references{
+Walter B. Lowrie: An Extension of the Whittaker-Henderson Method of Graduation, Transactions of Society of Actuaries, 1982, Vol. 34, pp. 329--372
+}
+\seealso{
+\code{\link{whittaker}}
+}