From 3c64a96b4798d9adcdb5b71f35c9e6965153bd60 Mon Sep 17 00:00:00 2001
From: Reinhold Kainhofer <reinhold@kainhofer.com>
Date: Sun, 18 Aug 2019 19:22:29 +0200
Subject: [PATCH] Properly handle NA values in all utility functions
-) Handle NA values in all utility functions
-) Provide AT population forecast as array
-) Fix AVOe1999-R
---
R/utilityFunctions.R | 24 +++++++++++++++++++
R/whittaker.mortalityTable.R | 2 ++
...talityTables_Austria_Annuities_AVOe1996R.R | 2 +-
...rtalityTables_Austria_PopulationForecast.R | 11 +++++++++
4 files changed, 38 insertions(+), 1 deletion(-)
diff --git a/R/utilityFunctions.R b/R/utilityFunctions.R
index 2e33569..b7c3335 100644
--- a/R/utilityFunctions.R
+++ b/R/utilityFunctions.R
@@ -98,6 +98,8 @@ mT.setName = function(table, name) {
)
} else if (is.list(table)) {
return(lapply(table, mT.setName, name = name))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -128,6 +130,8 @@ mT.fillAges = function(table, neededAges, fill = 0) {
)
} else if (is.list(table)) {
return(lapply(table, mT.fillAges, neededAges = neededAges, fill = fill))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -172,6 +176,8 @@ mT.scaleProbs = function(table, factor = 1.0, name.postfix = "scaled", name = NU
)
} else if (is.list(table)) {
return(lapply(table, mT.scaleProbs, factor = factor, name.postfix = name.postfix, name = name))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -206,6 +212,8 @@ mT.setTrend = function(table, trend, trendages = NULL, baseYear = NULL, dampingF
)
} else if (is.list(table)) {
return(lapply(table, mT.setTrend, trend = trend, trendages = trendages, baseYear = baseYear, dampingFunction = dampingFunction))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -233,6 +241,8 @@ mT.extrapolateTrendExp = function(table, idx, up = TRUE) {
)
} else if (is.list(table)) {
return(lapply(table, mT.extrapolateTrendExp, idx = idx, up = up))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -254,6 +264,8 @@ mT.translate = function(table, baseYear, name = NULL) {
)
} else if (is.list(table)) {
return(lapply(table, mT.translate, baseYear = baseYear, name = name))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -276,6 +288,8 @@ mT.extrapolateProbsExp = function(table, age, up = TRUE) {
)
} else if (is.list(table)) {
return(lapply(table, mT.extrapolateProbsExp, age = age, up = up))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -348,6 +362,8 @@ pT.setDimInfo = function(table, ..., append = TRUE) {
)
} else if (is.list(table)) {
return(lapply(table, pT.setDimInfo, ..., append = append))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "pensionTable"))
stop("First argument must be a pensionTable or a list of pensionTable objects.")
@@ -382,6 +398,8 @@ mT.setDimInfo = function(table, ..., append = TRUE) {
return(lapply(table, mT.setDimInfo, ..., append = append))
} else if (is(table, "pensionTable")) {
return(pT.setDimInfo(table, ..., append = append))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "mortalityTable"))
@@ -405,6 +423,8 @@ pT.getSubTable = function(table, subtable = "qx") {
)
} else if (is.list(table)) {
return(lapply(table, pT.getSubTable, subtable = subtable))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "pensionTable"))
stop("First argument must be a pensionTable or a list of pensionTable objects.")
@@ -428,6 +448,8 @@ mT.switchover = function(table, to, at, weights = NULL) {
)
} else if (is.list(table)) {
return(lapply(table, mT.switchover, to = to, at = at, weights = weights))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "mortalityTable"))
stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -581,6 +603,8 @@ pT.recalculateTotalMortality = function(object, ...) {
)
} else if (is.list(table)) {
return(lapply(table, pT.recalculateTotalMortality, ...))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "pensionTable"))
stop("First argument must be a pensionTable or a list of pensionTable objects.")
diff --git a/R/whittaker.mortalityTable.R b/R/whittaker.mortalityTable.R
index 736ad03..7861e2c 100644
--- a/R/whittaker.mortalityTable.R
+++ b/R/whittaker.mortalityTable.R
@@ -74,6 +74,8 @@ whittaker.mortalityTable = function(table, lambda = 10, d = 2, name.postfix = ",
)
} else if (is.list(table)) {
return(lapply(table, whittaker.mortalityTable, lambda = lambda, d = d, name.postfix = name.postfix, ..., weights = weights, log = log))
+ } else if (is.na(c(table))) {
+ return(table)
}
if (!is(table, "mortalityTable")) {
stop("Table object must be an instance (or list of instances) of mortalityTable in whittaker.mortalityTable.")
diff --git a/inst/extdata/MortalityTables_Austria_Annuities_AVOe1996R.R b/inst/extdata/MortalityTables_Austria_Annuities_AVOe1996R.R
index 3d93fb5..ae9c07e 100644
--- a/inst/extdata/MortalityTables_Austria_Annuities_AVOe1996R.R
+++ b/inst/extdata/MortalityTables_Austria_Annuities_AVOe1996R.R
@@ -95,7 +95,7 @@ AVOe1996R.female.av325 = mortalityTable.ageShift(
AVOe1996R = array(
data = c(mortalityTable.NA),
- dim = c(2, 2, 2),
+ dim = c(2, 3),
dimnames = list(Geschlecht = c("m", "w"), Collar = c("Einzel", "Gruppe", "AV"))
)
diff --git a/inst/extdata/MortalityTables_Austria_PopulationForecast.R b/inst/extdata/MortalityTables_Austria_PopulationForecast.R
index e592689..586d7cc 100644
--- a/inst/extdata/MortalityTables_Austria_PopulationForecast.R
+++ b/inst/extdata/MortalityTables_Austria_PopulationForecast.R
@@ -30,6 +30,17 @@ mort.AT.forecast.female = mortalityTable.trendProjection(
)
)
+
+mort.AT.forecast = array(
+ data = c(mortalityTable.NA),
+ dim = c(2),
+ dimnames = list(Geschlecht = c("m", "w"))
+)
+mort.AT.forecast[["m"]] = mort.AT.forecast.male
+mort.AT.forecast[["w"]] = mort.AT.forecast.female
+
+
+
rm(AT.pop.fc)
###############################################################################
--
GitLab