Commit 4562c68a authored by Reinhold Kainhofer's avatar Reinhold Kainhofer

Make package check happy: Add examples, fix documentation, document all parameters,

parent c4243b2a
...@@ -5,6 +5,7 @@ NULL ...@@ -5,6 +5,7 @@ NULL
#' #'
#' @param object The life table object (class inherited from mortalityTable) #' @param object The life table object (class inherited from mortalityTable)
#' @param ... Other parameters to be passed to the deathProbabilities call (e.g. YOB) #' @param ... Other parameters to be passed to the deathProbabilities call (e.g. YOB)
#' @param ages Vector of ages for which the probabilities should be extracted and commutation numbers calculates
#' @param i Interest rate used for the calculation of the commutation numbers #' @param i Interest rate used for the calculation of the commutation numbers
#' #'
#' @examples #' @examples
...@@ -12,14 +13,14 @@ NULL ...@@ -12,14 +13,14 @@ NULL
#' commutationNumbers(AVOe2005R.male, i = 0.03, YOB = 1975) #' commutationNumbers(AVOe2005R.male, i = 0.03, YOB = 1975)
#' #'
#' @exportMethod commutationNumbers #' @exportMethod commutationNumbers
setGeneric("commutationNumbers", function(object, ..., i = 0.03) standardGeneric("commutationNumbers")); setGeneric("commutationNumbers", function(object, ..., ages = NULL, i = 0.03) standardGeneric("commutationNumbers"));
#' @describeIn commutationNumbers Calculate the commutation numbers for the given #' @describeIn commutationNumbers Calculate the commutation numbers for the given
#' parameters, using the mortality table and an interest rate #' parameters, using the mortality table and an interest rate
setMethod("commutationNumbers", "mortalityTable", setMethod("commutationNumbers", "mortalityTable",
function(object, ..., i = 0.03) { function(object, ..., ages = NULL, i = 0.03) {
ages = ages(object, ...) ages = if(is.null(ages)) ages(object, ...) else ages
qx = deathProbabilities(object, ...) qx = deathProbabilities(object, ..., ages = ages)
commutationNumbers(qx, ages = ages, i = i) commutationNumbers(qx, ages = ages, i = i)
}) })
...@@ -49,8 +50,8 @@ setMethod("commutationNumbers", "numeric", ...@@ -49,8 +50,8 @@ setMethod("commutationNumbers", "numeric",
#' parameters, using the pension table and an interest rate #' parameters, using the pension table and an interest rate
#' Return value is a list of data frames #' Return value is a list of data frames
setMethod("commutationNumbers", "pensionTable", setMethod("commutationNumbers", "pensionTable",
function(object, ..., i = 0.03) { function(object, ..., ages = NULL, i = 0.03) {
probs = transitionProbabilities(object, ...) probs = transitionProbabilities(object, ..., ages = ages)
ages = probs$x ages = probs$x
# Exit probabilities of actives are: - not dead or invalid & no transition to pension # Exit probabilities of actives are: - not dead or invalid & no transition to pension
act.exit = (1 - probs$q - probs$i) * (1 - probs$ap) act.exit = (1 - probs$q - probs$i) * (1 - probs$ap)
......
...@@ -5,6 +5,7 @@ NULL ...@@ -5,6 +5,7 @@ NULL
#' #'
#' @param object The life table object (class inherited from mortalityTable) #' @param object The life table object (class inherited from mortalityTable)
#' @param ... Other parameters (currently unused) #' @param ... Other parameters (currently unused)
#' @param ages Desired age range (if NULL, the probabilities of the age range provided by the table will be returned), missing ages will be filled with NA
#' @param YOB The birth year for which the death probabilities should be calculated #' @param YOB The birth year for which the death probabilities should be calculated
#' #'
#' @examples #' @examples
......
...@@ -2,8 +2,13 @@ ...@@ -2,8 +2,13 @@
#' Fill the given probabilities with NA to match the desired age range. #' Fill the given probabilities with NA to match the desired age range.
#' #'
#' @param probs Numeric vector #' @param probs Numeric vector
#' @param haveAges ages assigned to the given vector #' @param givenAges ages assigned to the given vector
#' @param neededAges desired age range for output #' @param neededAges desired age range for output
#' @param fill If set, missing values will be replaced with this value. Default is to fill with NA.
#'
#' @examples
#' # Ages 20-70 have linearly increasing death probabilities. Fill with 0 for the whole age range 0-120
#' fillAges(probs = c(0:50/50), givenAges = 20:70, neededAges = 0:120, fill = 0)
#' #'
#' @export fillAges #' @export fillAges
fillAges = function(probs = c(), givenAges = c(), neededAges = NULL, fill = NA_real_) { fillAges = function(probs = c(), givenAges = c(), neededAges = NULL, fill = NA_real_) {
......
...@@ -15,6 +15,26 @@ setClassUnion("numericOrNULL", c("numeric", "NULL")) ...@@ -15,6 +15,26 @@ setClassUnion("numericOrNULL", c("numeric", "NULL"))
#' @slot exposures (Optional) exposured used to determine death probabilities #' @slot exposures (Optional) exposured used to determine death probabilities
#' (can be used as weights for smoothing, for variances, etc.) #' (can be used as weights for smoothing, for variances, etc.)
#' #'
#' @examples
#' linTable = mortalityTable.period(name="linear mortality", ages = 0:50, deathProbs = 0:50/50)
#' constTable = mortalityTable.period(name="const. mortality", ages = 0:50,
#' deathProbs = c(rep(0.1, 50), 1))
#' plot(linTable, constTable, title="Comparison of linear and constand death probabilities")
#'
#' # A sample observation table with exposures and raw probabilities
#' obsTable = mortalityTable.period(
#' name = "trivial observed table",
#' ages = 0:15,
#' deathProbs = c(
#' 0.0072, 0.00212, 0.00081, 0.0005, 0.0013,
#' 0.001, 0.00122, 0.00142, 0.007, 0.0043,
#' 0.0058, 0.0067, 0.0082, 0.0091, 0.0075, 0.01),
#' exposures = c(
#' 150, 222, 350, 362, 542,
#' 682, 1022, 1053, 1103, 1037,
#' 968, 736, 822, 701, 653, 438))
#' plot(obsTable, title = "Observed death probabilities")
#'
#' @export mortalityTable.period #' @export mortalityTable.period
#' @exportClass mortalityTable.period #' @exportClass mortalityTable.period
mortalityTable.period = setClass( mortalityTable.period = setClass(
......
...@@ -22,6 +22,30 @@ NULL ...@@ -22,6 +22,30 @@ NULL
#' the dumping function simply modifies the coefficients of #' the dumping function simply modifies the coefficients of
#' \code{trend}. #' \code{trend}.
#' #'
#' @examples
#' obsTable = mortalityTable.trendProjection(
#' name = "Const. table with trend",
#' baseYear = 2018,
#' ages = 0:15,
#' deathProbs = rep(0.02, 16),
#' trend = c(
#' 0.045, 0.04, 0.03, 0.04, 0.042, 0.041, 0.038, 0.035,
#' 0.032, 0.031, 0.028, 0.020, 0.015, 0.01, 0.005, 0))
#' # In 2018 the flat mortality can be seen
#' plotMortalityTables(obsTable, Period = 2018, title = "Period death probabilities 2018")
#' # In 2038, the age-specific trend affected the probabilities differently for 20 years:
#' plotMortalityTables(obsTable, Period = 2038, title = "Period death probabilities 2038")
#' # Consequently, a person born 2018 will also not have constand death probabilities
#' plotMortalityTables(obsTable, YOB = 2018, title = "Cohort death probabilities, YOB 2018")
#'
#' plotMortalityTables(
#' lapply(2018:2033, function(y) getCohortTable(obsTable, YOB = y)),
#' title = "Cohort tables for different YOBs", legend.position = c(0.99, 0.01))
#' plotMortalityTables(
#' lapply(2018:2033, function(y) getPeriodTable(obsTable, Period = y)),
#' title = "Period tables for different years", legend.position = c(0.99, 0.01))
#'
#'
#' @export mortalityTable.trendProjection #' @export mortalityTable.trendProjection
#' @exportClass mortalityTable.trendProjection #' @exportClass mortalityTable.trendProjection
mortalityTable.trendProjection = setClass( mortalityTable.trendProjection = setClass(
......
...@@ -7,6 +7,12 @@ ...@@ -7,6 +7,12 @@
#' Multiple packages can be given as a vector. #' Multiple packages can be given as a vector.
#' @param prefix The file prefix, defaults to MortalityTables. Can be overridden to list other types of files, like "PensionTables" #' @param prefix The file prefix, defaults to MortalityTables. Can be overridden to list other types of files, like "PensionTables"
#' #'
#' @examples
#' mortalityTables.list()
#' mortalityTables.list("Austria_*")
#' mortalityTables.list("*Annuities")
#' mortalityTables.list(package = c("MyCustomPackage"))
#'
#' @export #' @export
mortalityTables.list = function(pattern = "*", package = c("MortalityTables", "MortalityTablesPrivate"), prefix = "MortalityTables") { mortalityTables.list = function(pattern = "*", package = c("MortalityTables", "MortalityTablesPrivate"), prefix = "MortalityTables") {
ret = c() ret = c()
...@@ -27,6 +33,11 @@ mortalityTables.list = function(pattern = "*", package = c("MortalityTables", "M ...@@ -27,6 +33,11 @@ mortalityTables.list = function(pattern = "*", package = c("MortalityTables", "M
#' directory. Defaults to the "MortalityTables" package. #' directory. Defaults to the "MortalityTables" package.
#' Multiple packages can be given as a vector. #' Multiple packages can be given as a vector.
#' #'
#' @examples
#' pensionTables.list()
#' pensionTables.list("USA_*")
#' pensionTables.list(package = c("MyCustomPackage"))
#'
#' @export #' @export
pensionTables.list = function(pattern = "*", package = c("MortalityTables", "MortalityTablesPrivate")) { pensionTables.list = function(pattern = "*", package = c("MortalityTables", "MortalityTablesPrivate")) {
mortalityTables.list(pattern = pattern, package = package, prefix = "PensionTables") mortalityTables.list(pattern = pattern, package = package, prefix = "PensionTables")
......
...@@ -8,6 +8,13 @@ ...@@ -8,6 +8,13 @@
#' Multiple packages can be given as a vector. #' Multiple packages can be given as a vector.
#' @param prefix The prefix for the data sets (default is "MortalityTables"). #' @param prefix The prefix for the data sets (default is "MortalityTables").
#' #'
#' @examples
#' mortalityTables.list()
#' mortalityTables.load("Austria_Annuities_*")
#' mortalityTables.load("Austria_Annuities_AVOe2005R")
#' mortalityTables.load("*Annuities")
#' mortalityTables.load("MyCustomTable", package = c("MyCustomPackage"))
#'
#' @export #' @export
mortalityTables.load = function(dataset, package = c("MortalityTables", "MortalityTablesPrivate"), prefix = "MortalityTables") { mortalityTables.load = function(dataset, package = c("MortalityTables", "MortalityTablesPrivate"), prefix = "MortalityTables") {
sets = mortalityTables.list(dataset, package = package, prefix = prefix); sets = mortalityTables.list(dataset, package = package, prefix = prefix);
...@@ -41,6 +48,10 @@ mortalityTables.load = function(dataset, package = c("MortalityTables", "Mortali ...@@ -41,6 +48,10 @@ mortalityTables.load = function(dataset, package = c("MortalityTables", "Mortali
#' directory. Defaults to the "MortalityTables" package. #' directory. Defaults to the "MortalityTables" package.
#' Multiple packages can be given as a vector. #' Multiple packages can be given as a vector.
#' #'
#' pensionTables.list()
#' pensionTables.load("*")
#' pensionTables.load("USA_PensionPlan_RP2014")
#'
#' @export #' @export
pensionTables.load = function(dataset, package = c("MortalityTables", "MortalityTablesPrivate")) { pensionTables.load = function(dataset, package = c("MortalityTables", "MortalityTablesPrivate")) {
mortalityTables.load(dataset = dataset, package = package, prefix = "PensionTables") mortalityTables.load(dataset = dataset, package = package, prefix = "PensionTables")
......
...@@ -98,6 +98,7 @@ pensionTableProbArrange = function(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, a ...@@ -98,6 +98,7 @@ pensionTableProbArrange = function(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, a
#' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class) #' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class)
#' @param ... Currently unused #' @param ... Currently unused
#' @param YOB Year of birth #' @param YOB Year of birth
#' @param ages Desired age range (if NULL, the probabilities of the age range provided by the table will be returned), missing ages will be filled with NA
#' @param Period Observation year to calculate period transition probabilities. #' @param Period Observation year to calculate period transition probabilities.
#' If given, this arguments overrides the \code{YOB} parameter #' If given, this arguments overrides the \code{YOB} parameter
#' and this function returns period transition probabilities. #' and this function returns period transition probabilities.
...@@ -115,6 +116,7 @@ pensionTableProbArrange = function(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, a ...@@ -115,6 +116,7 @@ pensionTableProbArrange = function(x, q, i, qi, r, ap, api, qp, h, qw, yx, qg, a
#' invalids retire like actives (i.e. same death #' invalids retire like actives (i.e. same death
#' probabilities after retirement) or stay invalid until #' probabilities after retirement) or stay invalid until
#' death. #' death.
#' @param OverallMortality Whether the overall mortality should be returned for actives, or the active mortality
#' #'
#' @examples #' @examples
#' pensionTables.load("USA_PensionPlans") #' pensionTables.load("USA_PensionPlans")
...@@ -136,7 +138,6 @@ setMethod("transitionProbabilities", "pensionTable", ...@@ -136,7 +138,6 @@ setMethod("transitionProbabilities", "pensionTable",
as.data.frame = as.data.frame)) as.data.frame = as.data.frame))
} }
x = if (is.null(ages)) ages(object@qx) else ages; x = if (is.null(ages)) ages(object@qx) else ages;
# TODO: Make sure all sub-tables have the same age range!
q = deathProbabilities(object@qx, ..., ages = ages, YOB = YOB); q = deathProbabilities(object@qx, ..., ages = ages, YOB = YOB);
i = deathProbabilities(object@ix, ..., ages = ages, YOB = YOB); i = deathProbabilities(object@ix, ..., ages = ages, YOB = YOB);
qi = deathProbabilities(object@qix, ..., ages = ages, YOB = YOB); qi = deathProbabilities(object@qix, ..., ages = ages, YOB = YOB);
...@@ -194,6 +195,7 @@ setMethod("transitionProbabilities", "pensionTable", ...@@ -194,6 +195,7 @@ setMethod("transitionProbabilities", "pensionTable",
#' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class) #' @param object A pension table object (instance of a \code{\linkS4class{pensionTable}} class)
#' @param Period Observation year #' @param Period Observation year
#' @param ... Currently unused #' @param ... Currently unused
#' @param ages Desired age range (if NULL, the probabilities of the age range provided by the table will be returned), missing ages will be filled with NA
#' @param retirement Override the retirement transition probabilities of the pension table. Possible values are:\itemize{ #' @param retirement Override the retirement transition probabilities of the pension table. Possible values are:\itemize{
#' \item Single age (describing a deterministric retirement at the given age) #' \item Single age (describing a deterministric retirement at the given age)
#' \item mortalityTable object: transition probabilities for retirement #' \item mortalityTable object: transition probabilities for retirement
...@@ -204,6 +206,7 @@ setMethod("transitionProbabilities", "pensionTable", ...@@ -204,6 +206,7 @@ setMethod("transitionProbabilities", "pensionTable",
#' probabilities after retirement) or stay invalid until #' probabilities after retirement) or stay invalid until
#' death. #' death.
#' @param as.data.frame Whether the return value should be a data.frame or an array containing transition matrices #' @param as.data.frame Whether the return value should be a data.frame or an array containing transition matrices
#' @param OverallMortality Whether the overall mortality should be returned for actives, or the active mortality
#' #'
#' @examples #' @examples
#' pensionTables.load("USA_PensionPlans") #' pensionTables.load("USA_PensionPlans")
......
...@@ -6,8 +6,14 @@ NULL ...@@ -6,8 +6,14 @@ NULL
#' #'
#' @param object The life table object (class inherited from mortalityTable) #' @param object The life table object (class inherited from mortalityTable)
#' @param ... Other parameters (currently unused) #' @param ... Other parameters (currently unused)
#' @param ages Desired age range (if NULL, the probabilities of the age range provided by the table will be returned), missing ages will be filled with NA
#' @param Period The observation year for which the period death probabilities should be determined #' @param Period The observation year for which the period death probabilities should be determined
#' #'
#' @examples
#' mortalityTables.load("Austria_Annuities")
#' periodDeathProbabilities(AVOe2005R.male, Period = 1975)
#' periodDeathProbabilities(AVOe2005R.male, Period = 2017)
#'
#' @exportMethod periodDeathProbabilities #' @exportMethod periodDeathProbabilities
setGeneric("periodDeathProbabilities", function(object, ..., ages = NULL, Period = 1975) standardGeneric("periodDeathProbabilities")); setGeneric("periodDeathProbabilities", function(object, ..., ages = NULL, Period = 1975) standardGeneric("periodDeathProbabilities"));
......
...@@ -5,6 +5,23 @@ ...@@ -5,6 +5,23 @@
#' @inheritParams plotMortalityTables #' @inheritParams plotMortalityTables
#' @param reference The reference table that determines the 100\% values. If not given, the first argument of \code{data} is used as reference table. #' @param reference The reference table that determines the 100\% values. If not given, the first argument of \code{data} is used as reference table.
#' #'
#' @examples
#' # Load the Austrian census data
#' mortalityTables.load("Austria_Census")
#'
#' # Compare some census tables with the mortality of 2011 Austrian males
#' # plot with the reference argument is the same as calling plotMortalityTableComparisons
#' plot(mort.AT.census.1869.male, mort.AT.census.1869.female,
#' mort.AT.census.1971.male, mort.AT.census.1971.female,
#' mort.AT.census.2011.male, mort.AT.census.2011.female,
#' title = "Austrian Census tables, relative to 1971 males",
#' reference = mort.AT.census.1971.male)
#' plotMortalityTableComparisons(mort.AT.census.1869.male, mort.AT.census.1869.female,
#' mort.AT.census.1971.male, mort.AT.census.1971.female,
#' mort.AT.census.2011.male, mort.AT.census.2011.female,
#' title = "Austrian Census tables, relative to 1971 males",
#' reference = mort.AT.census.1971.male)
#'
#' @import scales #' @import scales
#' @export #' @export
plotMortalityTableComparisons = function( plotMortalityTableComparisons = function(
......
...@@ -12,8 +12,30 @@ ...@@ -12,8 +12,30 @@
#' @param legend.position The position of the legend (default is \code{c(0.9,0.1)}) #' @param legend.position The position of the legend (default is \code{c(0.9,0.1)})
#' @param legend.justification The justification of the legend (default is \code{c(1,)}) #' @param legend.justification The justification of the legend (default is \code{c(1,)})
#' @param legend.key.width The keywith of the lines in the legend (default is \code{unit(25,"mm")}) #' @param legend.key.width The keywith of the lines in the legend (default is \code{unit(25,"mm")})
#' @param legend.title Title of the legend
#' @param ages Plot only the given ages #' @param ages Plot only the given ages
#' #'
#' @examples
#' # Load the Austrian census data
#' mortalityTables.load("Austria_Annuities")
#' mortalityTables.load("Austria_Census")
#'
#' # Plot some select census tables in a log-linear plot (plot called
#' # with mortalityTable objects is equla to calling plotMortalitytTables directly)
#' plot(mort.AT.census.1869.male, mort.AT.census.1869.female,
#' mort.AT.census.1971.male, mort.AT.census.1971.female,
#' mort.AT.census.2011.male, mort.AT.census.2011.female,
#' title="Austrian census tables",
#' ylab=expression(q[x]), xlab="Age",
#' xlim=c(0,90),
#' legend.position=c(0.95,0.05))
#'
#' # To compare period or cohort life tables, use the YOB and Period arguments:
#' plot(AVOe2005R.male, AVOe2005R.female, AVOe1996R.male, AVOe1996R.female,
#' Period = 2018, title = "Austrian Annuity Tables, Period 2018")
#' plot(AVOe2005R.male, AVOe2005R.female, AVOe1996R.male, AVOe1996R.female,
#' YOB = 2000, title = "Austrian Annuity Tables for cohort YOB=2000")
#'
#' @import scales #' @import scales
#' @export #' @export
plotMortalityTables = function( plotMortalityTables = function(
...@@ -72,7 +94,7 @@ plotMortalityTables = function( ...@@ -72,7 +94,7 @@ plotMortalityTables = function(
pl pl
} }
globalVariables(c("x", "y", ".x")) globalVariables(c("x", "y", ".x", "group"))
# #
......
...@@ -14,7 +14,25 @@ ...@@ -14,7 +14,25 @@
#' @param legend.position The position of the legend (default is \code{c(0.9,0.1)}) #' @param legend.position The position of the legend (default is \code{c(0.9,0.1)})
#' @param legend.key.width The keywith of the lines in the legend (default is \code{unit(25,"mm")}) #' @param legend.key.width The keywith of the lines in the legend (default is \code{unit(25,"mm")})
#' #'
#' @import scales #' @examples
#' # Load the Austrian aunnity data
#' mortalityTables.load("Austria_Annuities")
#'
#' # Compare the trends of these tables
#' plotMortalityTrend(AVOe2005R.male, AVOe2005R.female, AVOe1996R.male, AVOe1996R.female,
#' Period = 2002, title = "Trends of Austrian Annuity Tables")
#' # For tables with a non-constant trend, the Period and YOB can be used to compare
#' # the age-specific trends that apply to the death probabilities during a given
#' # period or for a given birth year
#' plotMortalityTrend(AVOe2005R.male, AVOe2005R.female, AVOe1996R.male, AVOe1996R.female,
#' YOB = 1950, title = "Trends of Austrian Annuity Tables for cohort YOB=1950")
#' plotMortalityTrend(AVOe2005R.male, AVOe2005R.female, AVOe1996R.male, AVOe1996R.female,
#' YOB = 2000, title = "Trends of Austrian Annuity Tables for cohort YOB=2000")
#' plotMortalityTrend(AVOe2005R.male, AVOe2005R.female, AVOe1996R.male, AVOe1996R.female,
#' Period = 1999, title = "Trends of Austrian Annuity Tables for Period 2002")
#' plotMortalityTrend(AVOe2005R.male, AVOe2005R.female, AVOe1996R.male, AVOe1996R.female,
#' Period = 2030, title = "Trends of Austrian Annuity Tables for Period 2030")
#'#' @import scales
#' @export #' @export
plotMortalityTrend = function(data, ..., xlim=NULL, ylim=NULL, xlab=NULL, ylab=NULL, title = "", legend.position=c(0.9,0.9), legend.key.width = unit(25, "mm")) { plotMortalityTrend = function(data, ..., xlim=NULL, ylim=NULL, xlab=NULL, ylab=NULL, title = "", legend.position=c(0.9,0.9), legend.key.width = unit(25, "mm")) {
if (!is.data.frame(data)) { if (!is.data.frame(data)) {
......
...@@ -6,6 +6,11 @@ NULL ...@@ -6,6 +6,11 @@ NULL
#' @param object A life table object (instance of a \code{mortalityTable} class) #' @param object A life table object (instance of a \code{mortalityTable} class)
#' @param loading The additional (security) loading to be added to the table. #' @param loading The additional (security) loading to be added to the table.
#' #'
#' @examples
#' mortalityTables.load("Austria_Census")
#' # Austrian census mortality 2011 reduced by 30%
#' setLoading(mort.AT.census.2011.male, loading = -0.3)
#'
#' @exportMethod setLoading #' @exportMethod setLoading
setGeneric("setLoading", function(object, loading = 0) standardGeneric("setLoading")); setGeneric("setLoading", function(object, loading = 0) standardGeneric("setLoading"));
......
...@@ -6,6 +6,24 @@ NULL ...@@ -6,6 +6,24 @@ NULL
#' @param object A life table object (instance of a \code{mortalityTable} class) #' @param object A life table object (instance of a \code{mortalityTable} class)
#' @param modification The postprocessing modification function (for example, so enforce a lower bound). #' @param modification The postprocessing modification function (for example, so enforce a lower bound).
#' #'
#' @examples
#' mortalityTables.load("Austria_Census")
#' # Austrian census mortality 2011, with a lower floor of 0.1% death probability
#' at11.mod1perm = setModification(mort.AT.census.2011.male,
#' modification = function(qx) {pmax(qx, 0.001)})
#' at11.mod1perm@name = paste(at11.mod1perm@name, "at least 0.1%")
#' # Austrian census mortality 2011, modified with 40% selection for ages
#' # below 60, vanishing linearly to age 80
#' at11.modSelection = setModification(mort.AT.census.2011.male,
#' modification = function(qx) {
#' qx * c(rep(0.6, 60), 0.6 + 0.4 * (0:20)/20, rep(1, length(qx)-81))
#' })
#' at11.modSelection@name = paste(at11.modSelection@name, " 40% selection below 60")
#'
#' plot(mort.AT.census.2011.male, at11.mod1perm, at11.modSelection,
#' title = "Austrian census mortality with modifications", legend.position = c(0.99, 0.01))
#'
#'
#' @exportMethod setModification #' @exportMethod setModification
setGeneric("setModification", function(object, modification = 0) standardGeneric("setModification")); setGeneric("setModification", function(object, modification = 0) standardGeneric("setModification"));
......
...@@ -5,13 +5,21 @@ NULL ...@@ -5,13 +5,21 @@ NULL
#' #'
#' @param object The life table object (class inherited from mortalityTable) #' @param object The life table object (class inherited from mortalityTable)
#' #'
#' @examples
#' mortalityTables.load("Austria_Annuities")
#' AVOe2005R.male.undamped = undampenTrend(AVOe2005R.male)
#' AVOe2005R.male.undamped@name = paste(AVOe2005R.male.undamped@name, "no trend dampening")
#'
#' plot(AVOe2005R.male, AVOe2005R.male.undamped,
#' title = "AVOe 2005R with trend dampening and without", YOB = 2000)
#'
#' @exportMethod undampenTrend #' @exportMethod undampenTrend
setGeneric("undampenTrend", function (object) standardGeneric("undampenTrend")); setGeneric("undampenTrend", function(object) standardGeneric("undampenTrend"));
#' @describeIn undampenTrend Return a \code{mortalityTable.trendProjection} #' @describeIn undampenTrend Return a \code{mortalityTable.trendProjection}
#' object with the trend damping removed. #' object with the trend damping removed.
setMethod("undampenTrend", "mortalityTable.trendProjection", setMethod("undampenTrend", "mortalityTable.trendProjection",
function (object) { function(object) {
object@dampingFunction=identity; object@dampingFunction = identity;
object object
}) })
...@@ -3,7 +3,13 @@ ...@@ -3,7 +3,13 @@
#' \code{whittaker.mortalityTable} uses the Whittaker-Henderson graduation method #' \code{whittaker.mortalityTable} uses the Whittaker-Henderson graduation method
#' to smooth a table of raw observed death probabilities, optionally using the #' 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 #' 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 #' weights are applied). The weights (either explicitly given, implicitly taken
#' from the exposures or implicit equal weights) will be normalized to sum 1.
#' The parameter lambda indicates the importance of smootheness. A lower value of lambda
#' will put more emphasis on reproducing the observation as good as possible at the cost of
#' less smoothness. In turn, a higher value of lambda will force the smoothed result to be
#' as smooth as possible with possibly larger deviation from the input data.
#' All ages with a death probability of \code{NA} will be
#' interpolated in the Whittaker-Henderson method (see e.g. Lowrie) #' interpolated in the Whittaker-Henderson method (see e.g. Lowrie)
#' #'
#' @param table Mortality table to be graduated. Must be an instance of a #' @param table Mortality table to be graduated. Must be an instance of a
...@@ -13,22 +19,48 @@ ...@@ -13,22 +19,48 @@
#' @param name.postfix Postfix appended to the name of the graduated table #' @param name.postfix Postfix appended to the name of the graduated table
#' @param weights Vector of weights used for graduation. Entries with weight 0 #' @param weights Vector of weights used for graduation. Entries with weight 0
#' will be interpolated. If not given, the exposures of the table #' will be interpolated. If not given, the exposures of the table
#' or equal weights are used. #' or equal weights are used. Weight 0 for a certain age indicates
#' #' that the observation will not be used for smoothing at all,
#' and will rather be interpolated from the smoothing of all other values.
#' @param ... additional arguments (currently unused) #' @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 #' @references
#' Walter B. Lowrie: An Extension of the Whittaker-Henderson Method of Graduation, Transactions of Society of Actuaries, 1982, Vol. 34, pp. 329--372 #' Walter B. Lowrie: An Extension of the Whittaker-Henderson Method of Graduation, Transactions of Society of Actuaries, 1982, Vol. 34, pp. 329--372
#' #'
#' @examples #' @examples
#' # TODO #' # A sample observation table with exposures and raw probabilities
#' obsTable = mortalityTable.period(
#' name = "trivial observed table",
#' ages = 0:15,
#' deathProbs = c(
#' 0.0072, 0.00212, 0.00081, 0.0005, 0.0013,
#' 0.001, 0.00122, 0.00142, 0.007, 0.0043,
#' 0.0058, 0.0067, 0.0082, 0.0091, 0.0075, 0.01),
#' exposures = c(
#' 150, 222, 350, 362, 542,
#' 682, 1022, 1053, 1103, 1037,
#' 968, 736, 822, 701, 653, 438))
#'
#' # Effect of the different parameters
#' obsTable.smooth = whittaker.mortalityTable(obsTable,
#' lambda = 1/10, d = 2, name.postfix = " smoothed (d=2, lambda=1/10)")
#' obsTable.smooth1 = whittaker.mortalityTable(obsTable,
#' lambda = 1, d = 2, name.postfix = " smoothed (d=2, lambda=1)")
#' obsTable.smooth2 = whittaker.mortalityTable(obsTable,
#' lambda = 1/10, d = 3, name.postfix = " smoothed (d=3, lambda=1/10)")
#' plot(obsTable, obsTable.smooth, obsTable.smooth1, obsTable.smooth2,
#' title = "Observed death probabilities")
#'
#' # Missing values are interpolated from the Whittaker Henderson
#' obsTable.missing = obsTable
#' obsTable.missing@deathProbs[c(6,10,11,12)] = NA_real_
#' obsTable.interpolated = whittaker.mortalityTable(obsTable,
#' lambda = 1/10, d = 2, name.postfix = " missing values interpolated")
#' plot(obsTable.missing, obsTable.interpolated,
#' title = "Missing values are automatically interpolated") + geom_point(size = 3)
#'
#' #'
#' @seealso \code{\link{whittaker}} #' @seealso \code{\link[pracma]{whittaker}}
#' #'
#' @import scales #' @import scales
#' @export #' @export
...@@ -41,7 +73,6 @@ whittaker.mortalityTable = function(table, lambda = 10, d = 2, name.postfix = ", ...@@ -41,7 +73,6 @@ whittaker.mortalityTable = function(table, lambda = 10, d = 2, name.postfix = ",
table@name = paste0(table@name, name.postfix) table@name = paste0(table@name, name.postfix)
} }
# browser()
probs = table@deathProbs probs = table@deathProbs
orig.probs = probs orig.probs = probs
ages = table@ages ages = table@ages
...@@ -82,7 +113,7 @@ whittaker.mortalityTable = function(table, lambda = 10, d = 2, name.postfix = ", ...@@ -82,7 +113,7 @@ whittaker.mortalityTable = function(table, lambda = 10, d = 2, name.postfix = ",
whittaker.interpolate = function(y, lambda = 1600, d = 2, weights = rep(1, length(y))) { whittaker.interpolate = function(y, lambda = 1600, d = 2, weights = rep(1, length(y))) {
m <- length(y) m <- length(y)
E <- eye(m) E <- diag(1, m, m)
weights = weights * is.finite(y) # non-finite or missing values in y get zero weight weights = weights * is.finite(y) # non-finite or missing values in y get zero weight
y[!is.finite(y)] = 0 y[!is.finite(y)] = 0
W <- diag(weights) W <- diag(weights)
......
...@@ -8,19 +8,23 @@ ...@@ -8,19 +8,23 @@
\alias{commutationNumbers,pensionTable-method} \alias{commutationNumbers,pensionTable-method}
\title{Calculate the commutation numbers for the given parameters, using the mortality table and an interest rate} \title{Calculate the commutation numbers for the given parameters, using the mortality table and an interest rate}
\usage{ \usage{
commutationNumbers(object, ..., i = 0.03) commutationNumbers(object, ..., ages = NULL, i = 0.03)
\S4method{commutationNumbers}{mortalityTable}(object, ..., i = 0.03) \S4method{commutationNumbers}{mortalityTable}(object, ..., ages = NULL,
i = 0.03)
\S4method{commutationNumbers}{numeric}(object, ages, i = 0.03) \S4method{commutationNumbers}{numeric}(object, ages, i = 0.03)