Commit 03b2c5e7 authored by Reinhold Kainhofer's avatar Reinhold Kainhofer

Allow list of mortalityTables objects in the mT.* utility functions

parent fc41147e
......@@ -76,8 +76,11 @@ fitExpExtrapolation = function(data, idx, up = TRUE, verbose = FALSE) {
#' @export
mT.setName = function(table, name = table@name) {
if (is.list(table)) {
return(lapply(table, mT.setName, name = name))
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable.")
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
table@name = name
table
......@@ -87,8 +90,11 @@ mT.setName = function(table, name = table@name) {
#' @export
mT.fillAges = function(table, neededAges, fill = 0) {
if (is.list(table)) {
return(lapply(table, mT.fillAges, neededAges = neededAges, fill = fill))
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable.")
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
existingAges = ages(table)
if (.hasSlot(table, "ages"))
......@@ -110,6 +116,12 @@ mT.fillAges = function(table, neededAges, fill = 0) {
#' @export
mT.scaleProbs = function(table, factor = 1.0, name.postfix = "scaled", name = paste(table@name, name.postfix)) {
if (is.list(table)) {
return(lapply(table, mT.scaleProbs, factor = factor, name.postfix = name.postfix, name = name))
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
table@deathProbs = factor * table@deathProbs
if (!is.null(name)) {
table@name = name
......@@ -120,8 +132,11 @@ mT.scaleProbs = function(table, factor = 1.0, name.postfix = "scaled", name = pa
#' @export
mT.setTrend = function(table, trend, trendages = ages(table), baseYear = table@baseYear, dampingFunction = identity) {
if (is.list(table)) {
return(lapply(table, mT.setTrend, trend = trend, trendages = trendages, baseYear = baseYear, dampingFunction = dampingFunction))
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable.")
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
t = mortalityTable.trendProjection(
table,
......@@ -139,8 +154,11 @@ mT.addTrend = mT.setTrend
#' @export
mT.extrapolateTrendExp = function(table, idx, up = TRUE) {
if (is.list(table)) {
return(lapply(table, mT.extrapolateTrendExp, idx = idx, up = up))
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable.")
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
if (.hasSlot(table, "trend") && !is.null(table@trend))
table@trend = fitExpExtrapolation(table@trend, idx = idx,up = up)
......@@ -152,8 +170,11 @@ mT.extrapolateTrendExp = function(table, idx, up = TRUE) {
#' @export
mT.translate = function(table, baseYear, name = table@name) {
if (is.list(table)) {
return(lapply(table, mT.translate, baseYear = baseYear, name = name))
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable.")
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
table@deathProbs = periodDeathProbabilities(table, Period = baseYear)
table@baseYear = baseYear
......@@ -164,8 +185,11 @@ mT.translate = function(table, baseYear, name = table@name) {
#' @export
mT.extrapolateProbsExp = function(table, age, up = TRUE) {
if (is.list(table)) {
return(lapply(table, mT.extrapolateProbsExp, age = age, up = up))
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable.")
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
if (.hasSlot(table, "deathProbs")) {
idx = match(age, ages(table))
......@@ -222,8 +246,11 @@ mT.fitExtrapolationLaw = function(table, method = "LF2", law = "HP",
#' @export
mT.setDimInfo = function(table, ..., append = TRUE) {
if (is.list(table)) {
return(lapply(table, mT.setDimInfo, ..., append = append))
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable.")
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
if (append) {
table@data$dim[names(list(...))] = list(...)
......
......@@ -67,8 +67,11 @@
#' @import scales
#' @export
whittaker.mortalityTable = function(table, lambda = 10, d = 2, name.postfix = ", smoothed", ..., weights = NULL, log = TRUE) {
if (is.list(table)) {
return(lapply(table, whittaker.mortalityTable, lambda = lambda, d = d, name.postfix = name.postfix, ..., weights = weights, log = log))
}
if (!is(table, "mortalityTable")) {
stop("Table object must be an instance of mortalityTable in whittaker.mortalityTable.")
stop("Table object must be an instance (or list of instances) 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)) {
......
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