Commit e75d86ac authored by Reinhold Kainhofer's avatar Reinhold Kainhofer

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

parent d3bbae41
...@@ -60,4 +60,5 @@ Collate: ...@@ -60,4 +60,5 @@ Collate:
'setLoading.R' 'setLoading.R'
'setModification.R' 'setModification.R'
'undampenTrend.R' 'undampenTrend.R'
'whittaker.mortalityTable.R'
VignetteBuilder: knitr VignetteBuilder: knitr
...@@ -27,6 +27,7 @@ export(periodDeathProbabilitiesIndividual) ...@@ -27,6 +27,7 @@ export(periodDeathProbabilitiesIndividual)
export(plotMortalityTableComparisons) export(plotMortalityTableComparisons)
export(plotMortalityTables) export(plotMortalityTables)
export(plotMortalityTrend) export(plotMortalityTrend)
export(whittaker.mortalityTable)
exportClasses(mortalityTable) exportClasses(mortalityTable)
exportClasses(mortalityTable.MakehamGompertz) exportClasses(mortalityTable.MakehamGompertz)
exportClasses(mortalityTable.Weibull) exportClasses(mortalityTable.Weibull)
......
...@@ -9,6 +9,8 @@ NULL ...@@ -9,6 +9,8 @@ NULL
#' #'
#' @slot ages The ages corresponding to the entries of the deathProbs #' @slot ages The ages corresponding to the entries of the deathProbs
#' @slot deathProbs The one-year death probabilities for the ages #' @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 #' @export mortalityTable.period
#' @exportClass mortalityTable.period #' @exportClass mortalityTable.period
...@@ -16,11 +18,13 @@ mortalityTable.period = setClass( ...@@ -16,11 +18,13 @@ mortalityTable.period = setClass(
"mortalityTable.period", "mortalityTable.period",
slots = list( slots = list(
ages = "numeric", ages = "numeric",
deathProbs = "numeric" deathProbs = "numeric",
exposures = "numeric"
), ),
prototype = list( prototype = list(
ages = eval(0:120), ages = eval(0:120),
deathProbs = rep(1,120) deathProbs = rep(1,120),
exposures = NULL
), ),
contains = "mortalityTable" contains = "mortalityTable"
) )
......
#' 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)
...@@ -16,5 +16,8 @@ information about the period. ...@@ -16,5 +16,8 @@ information about the period.
\item{\code{ages}}{The ages corresponding to the entries of the deathProbs} \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{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.)}
}} }}
...@@ -4,8 +4,9 @@ ...@@ -4,8 +4,9 @@
\alias{plotMortalityTableComparisons} \alias{plotMortalityTableComparisons}
\title{Plot multiple mortality tables (life tables) in one plot, relative to a given reference table} \title{Plot multiple mortality tables (life tables) in one plot, relative to a given reference table}
\usage{ \usage{
plotMortalityTableComparisons(data, ..., xlim = NULL, ylim = NULL, plotMortalityTableComparisons(data, ..., ages = NULL, xlim = NULL,
xlab = NULL, ylab = NULL, title = "", legend.position = c(0.9, 0.1), 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) legend.key.width = unit(25, "mm"), reference = NULL)
} }
\arguments{ \arguments{
...@@ -13,6 +14,8 @@ plotMortalityTableComparisons(data, ..., xlim = NULL, ylim = NULL, ...@@ -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{...}{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{xlim}{X-axis limitatation (as a two-element vector)}
\item{ylim}{Y-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, ...@@ -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.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{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.} \item{reference}{The reference table that determines the 100\% values. If not given, the first argument of \code{data} is used as reference table.}
......
...@@ -4,8 +4,8 @@ ...@@ -4,8 +4,8 @@
\alias{plotMortalityTables} \alias{plotMortalityTables}
\title{Plot multiple mortality tables (life tables) in one plot} \title{Plot multiple mortality tables (life tables) in one plot}
\usage{ \usage{
plotMortalityTables(data, ..., legend.title = "Sterbetafel", xlim = NULL, plotMortalityTables(data, ..., ages = NULL, legend.title = "Sterbetafel",
ylim = NULL, xlab = NULL, ylab = NULL, title = "", xlim = NULL, ylim = NULL, xlab = NULL, ylab = NULL, title = "",
legend.position = c(0.9, 0.1), legend.justification = c(1, 0), legend.position = c(0.9, 0.1), legend.justification = c(1, 0),
legend.key.width = unit(25, "mm")) legend.key.width = unit(25, "mm"))
} }
...@@ -14,6 +14,8 @@ plotMortalityTables(data, ..., legend.title = "Sterbetafel", xlim = NULL, ...@@ -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{...}{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{xlim}{X-axis limitatation (as a two-element vector)}
\item{ylim}{Y-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, ...@@ -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.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{legend.key.width}{The keywith of the lines in the legend (default is \code{unit(25,"mm")})}
} }
\description{ \description{
......
% 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}}
}
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