diff --git a/R/utilityFunctions.R b/R/utilityFunctions.R index f6445c1783c8440dfbd3652dd0eea6c90871f090..2ae81b2544835b8b56c3d36d6091d6c6c69274bb 100644 --- a/R/utilityFunctions.R +++ b/R/utilityFunctions.R @@ -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(...) diff --git a/R/whittaker.mortalityTable.R b/R/whittaker.mortalityTable.R index cd3c3279a68505ec39b3c9935a0e85a56413fc9c..0628e6b03f6f71e9b093a45fbccc30c1f88e1ad6 100644 --- a/R/whittaker.mortalityTable.R +++ b/R/whittaker.mortalityTable.R @@ -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)) {