applying the mT.* utility functions to arrays of tables caused the dimensions...

applying the mT.* utility functions to arrays of tables caused the dimensions to disappear => add the dimensions back

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.array(table)) {
+        return(array(
+            lapply(table, mT.setName, name = name),
+            dim = dim(table), dimnames = dimnames(table))
+        )
     }
     if (!is(table, "mortalityTable"))
         stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -90,8 +93,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.array(table)) {
+        return(array(
+            lapply(table, mT.fillAges, neededAges = neededAges, fill = fill),
+            dim = dim(table), dimnames = dimnames(table))
+        )
     }
     if (!is(table, "mortalityTable"))
         stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -116,8 +122,11 @@ 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.array(table)) {
+        return(array(
+            lapply(table, mT.scaleProbs, factor = factor, name.postfix = name.postfix, name = name),
+            dim = dim(table), dimnames = dimnames(table))
+        )
     }
     if (!is(table, "mortalityTable"))
         stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -132,8 +141,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.array(table)) {
+        return(array(
+            lapply(table, mT.setTrend, trend = trend, trendages = trendages, baseYear = baseYear, dampingFunction = dampingFunction),
+            dim = dim(table), dimnames = dimnames(table))
+        )
     }
     if (!is(table, "mortalityTable"))
         stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -154,8 +166,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.array(table)) {
+        return(array(
+            lapply(table, mT.extrapolateTrendExp, idx = idx, up = up),
+            dim = dim(table), dimnames = dimnames(table))
+        )
     }
     if (!is(table, "mortalityTable"))
         stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -170,8 +185,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.array(table)) {
+        return(array(
+            lapply(table, mT.translate, baseYear = baseYear, name = name),
+            dim = dim(table), dimnames = dimnames(table))
+        )
     }
     if (!is(table, "mortalityTable"))
         stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -185,8 +203,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.array(table)) {
+        return(array(
+            lapply(table, mT.extrapolateProbsExp, age = age, up = up),
+            dim = dim(table), dimnames = dimnames(table))
+        )
     }
     if (!is(table, "mortalityTable"))
         stop("First argument must be a mortalityTable or a list of mortalityTable objects.")
@@ -246,8 +267,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.array(table)) {
+        return(array(
+            lapply(table, mT.setDimInfo, ..., append = append),
+            dim = dim(table), dimnames = dimnames(table))
+        )
     }
     if (!is(table, "mortalityTable"))
         stop("First argument must be a mortalityTable or a list of mortalityTable objects.")

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.array(table)) {
+        return(array(
+            lapply(table, whittaker.mortalityTable, lambda = lambda, d = d, name.postfix = name.postfix, ..., weights = weights, log = log),
+            dim = dim(table), dimnames = dimnames(table))
+        )
     }
     if (!is(table, "mortalityTable")) {
         stop("Table object must be an instance (or list of instances) of mortalityTable in whittaker.mortalityTable.")