diff --git a/NAMESPACE b/NAMESPACE index d36512a2fdaa35a37c6f8eccef18103f17790112..673e1acfa6fbee8f8572a7290f1ab7f4c8f754e1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -34,6 +34,7 @@ export(mortalityTable.zeroes) export(mortalityTables.list) export(mortalityTables.load) export(pT.getSubTable) +export(pT.setDimInfo) export(pensionTable) export(pensionTables.list) export(pensionTables.load) @@ -64,6 +65,7 @@ exportMethods(getCohortTable) exportMethods(getOmega) exportMethods(getPeriodTable) exportMethods(lifeTable) +exportMethods(mT.cleanup) exportMethods(mT.round) exportMethods(mortalityImprovement) exportMethods(periodDeathProbabilities) diff --git a/R/utilityFunctions.R b/R/utilityFunctions.R index 6269857255e3990e69977199cf3710a3673d4bcf..8ee6af9c633a86b436ea2df3a07472f1d37d4ad9 100644 --- a/R/utilityFunctions.R +++ b/R/utilityFunctions.R @@ -293,6 +293,38 @@ mT.fitExtrapolationLaw = function(table, method = "LF2", law = "HP", table } +#' @export +pT.setDimInfo = function(table, ..., append = TRUE) { + if (is.array(table)) { + return(array( + lapply(table, pT.setDimInfo, ..., append = append), + dim = dim(table), dimnames = dimnames(table)) + ) + } else if (is.list(table)) { + return(lapply(table, pT.setDimInfo, ..., append = append)) + } + if (!is(table, "pensionTable")) + stop("First argument must be a pensionTable or a list of pensionTable objects.") + + if (append) { + table@data[names(list(...))] = list(...) + } else { + table@data = list(...) + } + + table@qx = mT.setDimInfo(table@qx, ..., append = append) + table@ix = mT.setDimInfo(table@ix, ..., append = append) + table@qix = mT.setDimInfo(table@qix, ..., append = append) + table@rx = mT.setDimInfo(table@rx, ..., append = append) + table@apx = mT.setDimInfo(table@apx, ..., append = append) + table@qpx = mT.setDimInfo(table@qpx, ..., append = append) + table@hx = mT.setDimInfo(table@hx, ..., append = append) + table@qwy = mT.setDimInfo(table@qwy, ..., append = append) + table@qgx = mT.setDimInfo(table@qgx, ..., append = append) + table +} + + #' @export mT.setDimInfo = function(table, ..., append = TRUE) { if (is.array(table)) { @@ -302,7 +334,10 @@ mT.setDimInfo = function(table, ..., append = TRUE) { ) } else if (is.list(table)) { return(lapply(table, mT.setDimInfo, ..., append = append)) + } else if (is(table, "pensionTable")) { + return(pT.setDimInfo(table, ..., append = append)) } + if (!is(table, "mortalityTable")) stop("First argument must be a mortalityTable or a list of mortalityTable objects.") @@ -328,10 +363,14 @@ pT.getSubTable = function(table, subtable = "qx") { if (!is(table, "pensionTable")) stop("First argument must be a pensionTable or a list of pensionTable objects.") - if (.hasSlot(table, subtable)) - slot(table, subtable) - else - NULL + if (length(subtable) > 1) { + return(lapply(subtable, function(st) pT.getSubTable(table, subtable = st))) + } else { + if (.hasSlot(table, subtable)) + slot(table, subtable) + else + NULL + } } #' @export @@ -380,7 +419,7 @@ setMethod("mT.round", "mortalityTable.trendProjection", o@trend = round(o@trend, digits = digits) } if (!is.null(o@trend2) && !is.na(o@trend2)) { - o@trend2 = round(o@trend2, digits = digits) + o@trend2 = round(o@trend2, digits = digits) } o }) @@ -419,6 +458,92 @@ setMethod("mT.round", "pensionTable", }) + +#' @exportMethod mT.cleanup +setGeneric("mT.cleanup", function(object) standardGeneric("mT.cleanup")); + +setMethod("mT.cleanup", "mortalityTable", + function(object) { + object@data = list(dim = object@data$dim) + object + }) +setMethod("mT.cleanup", "mortalityTable.period", + function(object) { + o = callNextMethod() + o@ages = unname(o@ages) + o@deathProbs = unname(o@deathProbs) + o@exposures = NULL + o + }) +setMethod("mT.cleanup", "mortalityTable.trendProjection", + function(object) { + o = callNextMethod() + o@trend = unname(o@trend) + o@trend2 = unname(o@trend2) + o + }) +setMethod("mT.cleanup", "array", + function(object) { + array( + lapply(object, mT.cleanup), + dim = dim(object), dimnames = dimnames(object)) + }) +setMethod("mT.cleanup", "list", + function(object) { + lapply(object, mT.cleanup) + }) + +setMethod("mT.cleanup", "pensionTable", + function(object) { + object = callNextMethod() + object@qx = mT.cleanup(object@qx) + object@ix = mT.cleanup(object@ix) + object@qix = mT.cleanup(object@qix) + object@rx = mT.cleanup(object@rx) + object@apx = mT.cleanup(object@apx) + object@qpx = mT.cleanup(object@qpx) + object@hx = mT.cleanup(object@hx) + object@qwy = mT.cleanup(object@qwy) + object@qgx = mT.cleanup(object@qgx) + object + }) + + +#' @export +pT.calculateTotalMortality = function(object, ...) { + probs = transitionProbabilities(object, Period = object@baseYear, as.data.frame = TRUE) + probs$qgALT = probs$qg + + la = head(Reduce('*', (1 - probs$q - probs$i), init = 100000, accumulate = TRUE), -1) + lg = la + for (idx in seq_along(lg)) { + probs$qg[idx] = probs$qi[idx] - la[idx]/lg[idx] * (probs$qi[idx] - probs$q[idx] - probs$i[idx] * 1/2 * probs$qi[idx] / (1 - 1/2*probs$qi[idx])) + lg[idx + 1] = lg[idx] * (1 - probs$qg[idx]) + } + lg = head(lg, -1) + + probs$qg +} + + +#' @export +pT.recalculateTotalMortality = function(object, ...) { + if (is.array(table)) { + return(array( + lapply(table, pT.recalculateTotalMortality, ...), + dim = dim(table), dimnames = dimnames(table)) + ) + } else if (is.list(table)) { + return(lapply(table, pT.recalculateTotalMortality, ...)) + } + if (!is(table, "pensionTable")) + stop("First argument must be a pensionTable or a list of pensionTable objects.") + + qg = pT.calculateTotalMortality(object) + object@qgx@deathProbs = qg + object +} + # pensionTables.list() # pensionTables.load("*") # library(tidyverse)