vignette fixes

R/aggregate.R

@@ -221,27 +221,37 @@ utils::globalVariables(c("from"))
 #'
 #' @inheritParams blend
 #'
-#' @param outcomes a long-format `data.frame` with columns `model_from` and
-#' `value`, optionally others that will be preserved
+#' @param outcomes_dt a long-format `data.frame` with a column either named
+#' `from` or `model_from` and a column `value` (other columns will be silently
+#' ignored)
 #'
-#' @return a `data.frame` mirroring `outcomes`, but with
+#' @details
+#' When the `value` column is re-calculated, note that it will aggregate all
+#' matching `from` / `model_from` rows in `outcomes_dt`. If you need to group
+#' by other features in your input data (e.g. if you need to distill outcomes
+#' across multiple simulation outputs), that has to be done outside of any call
+#' to `distill()`.
+#'
+#'
+#' @return a `data.frame`, with `new_from` and recalculated `value` column
 #'
 #' @import data.table
 #' @export
 distill <- function(
-  outcomes, alembic_dt
+  alembic_dt, outcomes_dt
 ) {
 
-  setnames(setDT(outcomes), "from", "model_from", skip_absent = TRUE)
+  setnames(setDT(outcomes_dt), "from", "model_from", skip_absent = TRUE)
 
   mapping <- alembic_dt[, .(
-    new_from, model_fraction = weight / sum(weight)),
-    by = model_from
+    new_from, model_fraction = weight / sum(weight)
+    ), by = model_from
   ]
 
-  return(outcomes[mapping, on = .(model_from)][, .(
-    value = sum(value * model_fraction)
-  ), by = new_from])
+  return(outcomes_dt[mapping, on = .(model_from)][,
+    .(value = sum(value * model_fraction)),
+    by = new_from
+  ])
 
 }
 

R/plotting.R

@@ -171,7 +171,7 @@ distill_summary <- function(
 
     # approach 4: proportionally to age *and* relative mortality rates
     setnames(
-      distill(model_outcomes_dt, alembic_dt)[, method := "wm_f"],
+      distill(alembic_dt, model_outcomes_dt)[, method := "wm_f"],
       "new_from", "partition"
     )
   ))

vignettes/intro.Rmd

@@ -83,21 +83,23 @@ model_agelimits <- c(0, 5, 20, 65, 101)
 # get select data from World Population Prospects estimates
 data("popF", package = "wpp2019")
 data("popM", package = "wpp2019")
+
 pop_dt <- as.data.table(popF)[,
   .(name, age, popF = `2020`)
 ][
   as.data.table(popM), on = c("name", "age"),
-  .(name, age = as.integer(gsub("^(\\d+)[-+].*$","\\1",age)), popF, popM = `2020`)
-][
+  .(name, age, popF, popM = `2020`)
+][, age := as.integer(gsub("^(\\d+)[-+].*$","\\1", age)) ][
   name %like% "Afghanistan|United Kingdom"
 ]
 
-density_dt <- pop_dt[
+density_dt <- pop_dt[,
   .(
     name, from = age,
     weight = popF + popM
   )
 ]
+
 rm(popF)
 rm(popM)
 ```
@@ -288,17 +290,17 @@ life_expectancy_dt <- as.data.table(mxF)[,
 ][pop_dt, on = .(name, age), .(name, age, mx = (mxF*popF + mxM*popM)/(popF + popM))]
 
 life_expectancy_dt[,
-  ax := fifelse(age == 0, 0.2, 0.5)
+  ax := 0.5
 ][,
-  qx := fifelse(age == max(age), 1, mx / (1 + mx * (1 - ax)))
+  qx := fifelse(age == max(age), 1, c(diff(age), 0)*mx / (1 + c(diff(age), 0)*mx * (1 - ax)))
 ]
 life_expectancy_dt[age == 0, lx := 1000]
 life_expectancy_dt[, lx := {
   tmp <- lx
   for (i in 2:.N) {
     tmp[i] <- (1 - qx[i - 1]) * tmp[i - 1]
   }
-  tmp
+  pmax(tmp, 0)
 }, by = name]
 life_expectancy_dt[,
   Lx := c(
@@ -308,6 +310,10 @@ life_expectancy_dt[,
 ]
 life_expectancy_dt[, ex := rev(cumsum(rev(Lx) / 1000)), by = name]
 
+life_ex_interpolated_dt <- life_expectancy_dt[,
+  .(age = 0:100, ex = stats::approxfun(age, ex)(0:100))
+, by=name]
+
 # because of the selected breakpoints, there are some half-ages, so will
 # linearly interpolate between the relevant ages
 expander <- distill_methods_dt[, .(
@@ -316,8 +322,8 @@ expander <- distill_methods_dt[, .(
   lower = floor(age), upper = ceiling(age), tar = age, index = seq_len(.N)
 ), by = name]
 
-lower_dt <- life_expectancy_dt[expander, on = .(name, age = lower), .(name, index, age, ex)]
-upper_dt <- life_expectancy_dt[expander, on = .(name, age = upper), .(name, index, age, ex)]
+lower_dt <- life_ex_interpolated_dt[expander, on = .(name, age = lower), .(name, index, age, ex)]
+upper_dt <- life_ex_interpolated_dt[expander, on = .(name, age = upper), .(name, index, age, ex)]
 
 expand_dt <- lower_dt[
   upper_dt, on = .(name, index)
@@ -328,7 +334,7 @@ expand_dt <- lower_dt[
 ][, .(name, age, ex)]
 
 lex_dt <- rbind(
-  life_expectancy_dt[, .(name, age, ex)],
+  life_ex_interpolated_dt[, .(name, age, ex)],
   expand_dt
 )