merged with master

.Rbuildignore

@@ -1,3 +1,4 @@
 ^.travis\.yml$
 ^README\.md$
 ^.github$
+^data-raw

.github/workflows/check-standard.yaml

@@ -9,6 +9,7 @@ on:
     branches:
       - master
       - cran
+
 name: R-CMD-check
 
 jobs:
@@ -23,57 +24,30 @@ jobs:
         config:
           - {os: windows-latest, r: 'release'}
           - {os: macOS-latest, r: 'release'}
-          - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
-          - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
+          - {os: ubuntu-latest, r: 'release'}
+          - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'}
 
     env:
-      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
-      RSPM: ${{ matrix.config.rspm }}
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      R_KEEP_PKG_SOURCE: yes
 
     steps:
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v3
+
+      - uses: r-lib/actions/setup-pandoc@v2
 
-      - uses: r-lib/actions/setup-r@v1
+      - uses: r-lib/actions/setup-r@v2
         with:
           r-version: ${{ matrix.config.r }}
+          http-user-agent: ${{ matrix.config.http-user-agent }}
+          use-public-rspm: true
 
-      - uses: r-lib/actions/setup-pandoc@v1
-
-      - name: Query dependencies
-        run: |
-          install.packages('remotes')
-          saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
-          writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version")
-        shell: Rscript {0}
-
-      - name: Cache R packages
-        if: runner.os != 'Windows'
-        uses: actions/cache@v2
+      - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          path: ${{ env.R_LIBS_USER }}
-          key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}
-          restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-
-
-      - name: Install system dependencies
-        if: runner.os == 'Linux'
-        run: |
-          while read -r cmd
-          do
-            eval sudo $cmd
-          done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))')
-
-      - name: Install dependencies
-        run: |
-          remotes::install_deps(dependencies = TRUE)
-          remotes::install_cran("rcmdcheck")
-        shell: Rscript {0}
+          extra-packages: any::rcmdcheck
+          needs: check
 
-      - name: Check
-        env:
-          _R_CHECK_CRAN_INCOMING_REMOTE_: false
-        run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check")
-        shell: Rscript {0}
+      - uses: r-lib/actions/check-r-package@v2
 
       - name: Upload check results
         if: failure()

ChangeLog

@@ -1,3 +1,24 @@
+5.1-1 (02/04/2023)
+-----
+Allow use of annual supplemental data.
+
+New mapping function e0.ggmap.
+
+Added/updated priors used by the UN in WPP 2022.
+
+Function for projection adjustments to WPPs.
+
+
+5.1-0 (11/09/2022)
+-----
+Changes related to using wpp2022.
+
+5.0-3 (09/28/2021)
+-----
+Fix bug in e0.diagnose (thanks to Asmida Binti Mustafa).
+
+Depends now on bayesTFR >= 7.0-5.
+
 5.0-1 (04/04/2021)
 -----
 Support for annual simulations added.

DESCRIPTION

@@ -1,13 +1,16 @@
 Package: bayesLife
 Type: Package
 Title: Bayesian Projection of Life Expectancy
-Version: 5.0-1.9001
-Date: 2021-09-09
+Version: 5.1-1
+Date: 2023-02-04
 Author: Hana Sevcikova, Adrian Raftery, Jennifer Chunn 
 Maintainer: Hana Sevcikova <[email protected]>
 Description: Making probabilistic projections of life expectancy for all countries of the world, using a Bayesian hierarchical model <doi:10.1007/s13524-012-0193-x>. Subnational projections are also supported.
-Depends: bayesTFR (>= 7.0-2)
+Depends: 
+    bayesTFR (>= 7.3-0),
+    R (>= 3.5.0)
 Imports: wpp2019, hett, car, coda, data.table
 Suggests: wpp2017, wpp2015, wpp2012, wpp2010
 License: GPL-3 | file LICENSE
 URL: https://bayespop.csss.washington.edu
+LazyData: false

NAMESPACE

@@ -8,7 +8,7 @@ importFrom("graphics", "abline", "grid", "legend", "lines", "plot", "points", "t
 importFrom("grDevices", "rainbow")
 importFrom("stats", "dgamma", "dnorm", "dunif", "median", "pnorm", "quantile", "rexp", "rgamma", 
            "rnorm", "rt", "runif", "sd", "C", "approxfun", "lowess", "na.omit")
-importFrom("utils", "modifyList")
+importFrom("utils", "modifyList", "data")
 
 #exportPattern("^[[:alpha:]]+")
 useDynLib(bayesLife, .registration = TRUE)
@@ -24,6 +24,7 @@ export(
 	e0.median.set,
 	e0.median.reset,
 	e0.median.adjust.jmale,
+	e0.shift.prediction.to.wpp,
 	get.e0.shift,
 	convert.e0.trajectories,
 	write.e0.projection.summary,
@@ -66,6 +67,7 @@ export(
 	get.e0.map.parameters,
 	e0.map.all,
 	e0.map,
+	e0.ggmap,
 	e0.map.gvis,
 	e0.raftery.diag,
 	e0.diagnose,
@@ -83,6 +85,8 @@ export(
 	e0options,
 	e0mcmc.options,
 	e0pred.options,
+	e0mcmc.dlpriors.options,
+	get.DLpriors,
 	compute.loess,
 	compute.residuals,
 	using.bayesLife

R/diagnostics.R

@@ -5,7 +5,11 @@ e0.raftery.diag <- function(mcmc = NULL,
 							 country.sampling.prop = 1,
 							 verbose = TRUE, ...) {
     mcmc.set <- if (is.null(mcmc)) get.e0.mcmc(sim.dir = sim.dir, low.memory = TRUE) else mcmc
+<<<<<<< HEAD
     if(bayesTFR:::is.missing(par.names))
+=======
+    if(bayesTFR:::is.missing(par.names)) 
+>>>>>>> master
         par.names <- e0.parameter.names(mcmc.set$meta$mcmc.options)
     if(bayesTFR:::is.missing(par.names.cs)) 
         par.names.cs <- e0.parameter.names.cs(mcmc.set$meta$mcmc.options)

R/e0options.R

@@ -4,10 +4,18 @@ data(loess_sd, envir = environment())
 e0options <- function()
     .e0options
 
-e0mcmc.options <- function(...) {
+e0mcmc.options <- function(..., annual = FALSE) {
+    if(annual) e0mcmc1y.options(...) else e0mcmc5y.options(...)
+}
+
+e0mcmc5y.options <- function(...) {
     e0.options("mcmc", ...)
 }
 
+e0mcmc1y.options <- function(...) {
+    e0.options("mcmc1y", ...)
+}
+
 e0pred.options <- function(...) {
     e0.options("pred", ...)
 }
@@ -41,23 +49,79 @@ e0.options <- function(what, ...) {
 e0.options.default <- function() {
     structure(list(
         mcmc = e0.mcmc.options.default(),
+        mcmc1y = e0.mcmc1y.options.default(),
         pred = e0.pred.options.default(),
         admin = list(package = "bayesLifeHIV")
     ))
 }
 
+get.DLpriors <- function(prior.choice = NULL, annual = FALSE){
+    e <- new.env()
+    data("DLpriors", envir = e)
+    priors <- e$DLpriors
+    if(annual){
+        for(col in c("k", "z", "Uz"))
+            priors[, col] <- priors[, col]/5
+    }
+    if(!is.null(prior.choice))
+        priors <- priors[e$DLpriors$option == prior.choice,, drop = FALSE]
+    return(priors)
+}
+
+e0mcmc.dlpriors.options <- function(prior.choice = "B", annual = FALSE, 
+                            un.constraints = FALSE){
+    pars <- e0mcmc.options(annual = annual)
+    if(!is.null(prior.choice)) {
+        prior.pars <- get.DLpriors(prior.choice, annual = annual)
+        estpars <- prior.pars[, 1:6]
+        rownames(estpars) <- prior.pars[, "parname"]
+        z.up <- prior.pars[1, "Uz"]
+        #denom <- if(annual) 5 else 1
+        #denom.arr <- c(1, 1, 1, 1, denom, denom)
+        pars <- within(pars, {
+            a <- as.numeric(estpars["a",])#/denom.arr
+            delta <- as.numeric(estpars["delta",])#/denom.arr
+            tau <- as.numeric(estpars["tau",])#/denom.arr
+            z <- modifyList(z, list(ini.up = z.up, #/denom, 
+                                    prior.up = z.up #/denom
+                                    ))
+            z.c <- modifyList(z.c, list(prior.up = z.up, #/denom, 
+                                        ini.norm = c(mean = round(z$ini.low + (z$ini.up - z$ini.low)/2, 2),
+                                                     sd = z.c$ini.norm['sd']))
+                                        )
+            #z$ini.up <- z.up /denom
+            #z$prior.up <- z.up /denom
+            #z.c$prior.up <- z.up /denom
+            #z.c$ini.norm["mean"] <- round(z$ini.low + (z$ini.up - z$ini.low)/2, 2)
+            sumTriangle.lim[2] <- prior.pars[1, "Sa"]
+        })
+    }
+    if(un.constraints){
+        pars <- within(pars, {
+            Triangle <- modifyList(Triangle, list(prior.low = c(5.9, 36, 10.1, 15.5)))
+            Triangle.c <- modifyList(Triangle, list(prior.low = c(0.5, 30.9, 9.1, 14.7)))
+            #Triangle$prior.low = c(5.9, 36, 10.1, 15.5)
+            #Triangle.c$prior.low = c(0.5, 30.9, 9.1, 14.7)
+        })
+    }
+    e0mcmc.options(pars, annual = annual)
+}
+
 e0.mcmc.options.default <- function() {
+    prior.pars <- get.DLpriors("B")
+    estpars <- prior.pars[, 1:6]
+    rownames(estpars) <- prior.pars[, "parname"]
+    z.up <- prior.pars[1, "Uz"]
+
     pars <- list(
-        a = c(13.215, 41.070, 9.235, 17.605, 2.84, 0.385),
-        #a=c(15.7669391,40.9658241,0.2107961,19.8188061,2.9306625,0.400688628),
-        delta = c(3.844, 4.035, 11.538, 5.639, 0.901, 0.4),
-        #delta=c(1.887, 1.982, 1.99, 1.949, 0.995, 0.4), 
-        tau = c(15.5976503,23.6500060,14.5056919,14.7185980,3.4514285,0.5667531),
+        a = as.numeric(estpars["a",]),
+        delta = as.numeric(estpars["delta",]),
+        tau = as.numeric(estpars["tau",]),
         Triangle = structure(
             list(ini = list(T1 = NULL, T2 = NULL, T3 = NULL, T4 = NULL),
                  ini.low = c(10, 30, 0.1, 10),
                  ini.up  = c(30, 50, 10, 30),
-                 prior.low = c(0, 0, -20, 0),
+                 prior.low = c(0, 0, 0, 0),
                  prior.up  = c(100, 100, 50, 100),
                  slice.width = c(10, 10, 10, 10)
             ), npar = 4),
@@ -67,8 +131,8 @@ e0.mcmc.options.default <- function() {
             ),
             npar = 1),
         z = structure(
-            list(ini = NULL, ini.low = 0.0001, ini.up = 0.653, 
-                 prior.low = 0, prior.up = 0.653, slice.width = 1),
+            list(ini = NULL, ini.low = 0.0001, ini.up = z.up, 
+                 prior.low = 0, prior.up = z.up, slice.width = 1),
             npar = 1),
         lambda = structure(
             list(ini = list(T1 = NULL, T2 = NULL, T3 = NULL, T4 = NULL),
@@ -83,7 +147,7 @@ e0.mcmc.options.default <- function() {
                                slice.width = 1), npar = 1),
         Triangle.c = structure(
             list(ini.norm = list(mean = NULL, sd = c(2, 2, 2, 2)),
-                 prior.low = c(0, 0, -20, 0), 
+                 prior.low = c(0, 0, 0, 0), 
                  prior.up  = c(100, 100, 50, 100),
                  slice.width = c(10, 10, 10, 10)
             ), npar = 4),
@@ -92,14 +156,14 @@ e0.mcmc.options.default <- function() {
                              prior.up = 10,
                              slice.width = 2), npar = 1),
         z.c = structure(list(ini.norm = c(mean = NA, sd = 0.2), 
-                             prior.low = 0, prior.up = 0.653,
+                             prior.low = 0, prior.up = z.up,
                              slice.width = 1), npar = 1),
         world.parameters = c(Triangle = 4, k = 1, z = 1, lambda = 4, 
                              lambda.k = 1, lambda.z = 1, omega = 1),
         country.parameters = c(Triangle.c = 4, k.c = 1, z.c = 1),
         country.overwrites = NULL,
         nu = 4, dl.p1 = 9, dl.p2 = 9, 
-        sumTriangle.lim = c(30, 86),
+        sumTriangle.lim = c(30, prior.pars[1, "Sa"]),
         outliers = c(-5, 10),
         buffer.size = 100,
         auto.conf = list(max.loops = 5, iter = 160000, iter.incr = 20000, 
@@ -118,6 +182,23 @@ e0.mcmc.options.default <- function() {
     pars
 }
 
+e0.mcmc1y.options.default <- function() {
+    pars <- e0.mcmc.options.default()
+    pars <- within(pars, {
+        a <- a / c(1,1,1,1,5,5)
+        delta <- delta / c(1,1,1,1,5,5)
+        tau <- tau / c(1,1,1,1,5,5)
+        k <- modifyList(k, lapply(k[c("ini.low", "ini.up", "prior.up")], function(x) x/5))
+        z <- modifyList(z, lapply(z[c("ini.up", "prior.up")], function(x) x/5))
+        k.c$ini.norm <- k.c$ini.norm / 5
+        k.c$prior.up <- k.c$prior.up / 5
+        z.c$ini.norm <- z.c$ini.norm / 5
+        z.c$prior.up <- z.c$prior.up / 5
+        outliers[2] <- outliers[2]/2
+    })
+    pars
+}
+
 e0.pred.options.default <- function() {
     pars <- list(
         quantiles = c(0, 0.025, 0.05, 0.1, 0.2, 0.25, 0.3, 0.4, 0.5, 

R/get_outputs.R

@@ -53,7 +53,7 @@ get.e0.mcmc <- function(sim.dir = file.path(getwd(), 'bayesLife.output'),
 .convert.meta.from.legacy.form <- function(meta) {
     # Put meta created with older version of bayesLife into the new format.
     # It means creating mcmc.options and removing relevant info from meta
-    opts <- e0mcmc.options()
+    opts <- e0mcmc.options(annual = meta$annual.simulation)
     for(par in c("a", "delta", "tau", "outliers", "country.overwrites", "nu", 
                  "dl.p1", "dl.p2", "sumTriangle.lim")) {
         opts[[par]] <- meta[[par]]
@@ -538,7 +538,7 @@ get.e0.trajectories <- function(e0.pred, country) {
 
 get.e0.trajectories.object <- function(e0.pred, country, nr.traj=NULL, typical.trajectory=FALSE, pi=NULL, ...) {
 	# here country must be a code; returns also indices
-	if(is.list(e0.pred) && class(e0.pred[[1]]) == 'bayesLife.prediction' && class(e0.pred[[2]]) == 'bayesLife.prediction'){
+	if(is.list(e0.pred) && inherits(e0.pred[[1]], 'bayesLife.prediction') && inherits(e0.pred[[2]], 'bayesLife.prediction')){
 		traj1 <- bayesTFR:::get.trajectories(e0.pred[[1]], country, nr.traj=NULL, ...) # we want all trajectories
 		traj2 <- bayesTFR:::get.trajectories(e0.pred[[2]], country, nr.traj=NULL, ...)
 		traj.res <- traj1$trajectories - (traj1$trajectories - traj2$trajectories)/2.

R/mcmc_estimate.R

@@ -137,7 +137,7 @@ store.sample.to.disk <- function(iter, niter, mcenv, verbose = FALSE) {
     # write samples simu/thin to disk
     mcenv$finished.iter <- mcenv$finished.iter + 1
     mcenv$rng.state <- .Random.seed         
-    if (iter %% mcenv$thin == 0) {
+    if (iter %% mcenv$thin == 0 || iter == niter) {
         mcenv$length <- mcenv$length + 1
         flush.buffer <- FALSE
         if (iter + 1 > niter) flush.buffer <- TRUE