diff --git a/DESCRIPTION b/DESCRIPTION index 77ac3ff..f89eb80 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: bayesPop Type: Package Title: Probabilistic Population Projection -Version: 10.0-1.9024 +Version: 10.0-1.9025 Date: 2024-12-12 Author: Hana Sevcikova, Adrian Raftery, Thomas Buettner Maintainer: Hana Sevcikova diff --git a/R/aggregate.R b/R/aggregate.R index a725580..1e1c224 100644 --- a/R/aggregate.R +++ b/R/aggregate.R @@ -301,10 +301,11 @@ pop.aggregate.countries <- function(pop.pred, regions, name, kannisto.est.ages <- seq(80, 95, by = 5) } fert.age.idx <- seq(fert.age.start, length = max.lage.fert) - obs.cols.ve <- colnames(obs.data[["male"]]) + obs.cols <- colnames(obs.data[["male"]]) + obs.cols.ve <- obs.cols if(!pop.pred$annual) obs.cols.ve <- paste(as.integer(colnames(obs.data[["male"]]))-5, obs.cols.ve, sep = "-") prev.year <- as.character(pop.pred$proj.years.pop[1]-time.step) - if(! prev.year %in% obs.cols.ve && !no.vital.events){ + if(! prev.year %in% obs.cols && !no.vital.events){ warning("Year ", prev.year, " needed in observed population to abridge various aggregated quantities. Present year used instead." ) prev.year <- as.character(pop.pred$proj.years.pop[1]) } diff --git a/R/get_outputs.R b/R/get_outputs.R index 4ee3c67..e2755e0 100644 --- a/R/get_outputs.R +++ b/R/get_outputs.R @@ -662,6 +662,7 @@ get.popVE.trajectories.and.quantiles <- function(pop.pred, country, event <- match.arg(event) sex <- match.arg(sex) time.labels <- colnames(pop.pred$inputs$pop.matrix$male) + if(!pop.pred$annual) time.labels <- as.character(as.integer(time.labels) - 2) #if (!is.element(event, input.indicators)) { traj.file <- file.path(pop.output.directory(pop.pred), paste('vital_events_country', country, '.rda', sep='')) @@ -744,6 +745,11 @@ get.popVE.trajectories.and.quantiles <- function(pop.pred, country, fertility = list(female=myenv$asfert, female.hch=myenv$asfert.hch), pasfr = list(female=myenv$pasfert, female.hch=myenv$pasfert.hch) ) + if(is.observed) { + for(s in names(alltraj)) + if(!is.null(alltraj[[s]])) + dimnames(alltraj[[s]])[[2]] <- time.labels[(length(time.labels)-dim(alltraj[[s]])[2]+1):length(time.labels)] + } } has.hch <- !is.observed && (!is.null(alltraj$male.hch) || !is.null(alltraj$female.hch) || !is.null(alltraj$both.hch)) max.age <- NULL @@ -807,9 +813,13 @@ get.popVE.trajectories.and.quantiles <- function(pop.pred, country, if(is.observed) { if(length(dim(traj)) < 3) # age dimension is missing traj <- abind(traj, NULL, along=0) - if(dim(traj)[[2]] < nperiods) { - traj <- abind(array(NA, dim=c(dim(traj)[[1]], nperiods-dim(traj)[[2]], dim(traj)[[3]]), - dimnames=list(NULL, colnames(pop.pred$inputs$pop.matrix$male)[1:(nperiods-dim(traj)[[2]])], NULL)), + if(dim(traj)[[2]] < nperiods) { # attach missing time periods + nmiss <- nperiods-dim(traj)[[2]] + step <- if(pop.pred$annual) 1 else 5 + first.time <- as.integer(dimnames(traj)[[2]][1]) + add.time <- sort(seq(first.time-step, by = -step, length = nmiss)) + traj <- abind(array(NA, dim=c(dim(traj)[[1]], nmiss, dim(traj)[[3]]), + dimnames=list(NULL, as.character(add.time), NULL)), traj, along=2) } } @@ -1034,12 +1044,14 @@ get.pop <- function(object, pop.pred, aggregation=NULL, observed=FALSE, ...) { if(!has.ve) { traj <- get.pop.observed.with.age(pop.pred, country=country.object$code, sex=sex, age=age) d <- traj$data[traj$age.idx,,drop = FALSE] + colnms <- colnames(traj$data) } else { traj <- get.popVE.trajectories.and.quantiles(pop.pred, country.object$code, event=get.expression.indicators()[[what]], sex=sex, age=age, sum.over.ages=FALSE, is.observed=TRUE, ...) traj$age.idx <- traj$age.idx.raw d <- traj$trajectories + colnms <- colnames(traj$trajectories) } if(is.null(d)) return(NULL) if(sum.over.ages) { @@ -1048,7 +1060,7 @@ get.pop <- function(object, pop.pred, aggregation=NULL, observed=FALSE, ...) { else d <- colSums(d) data <- as.matrix(d) # adds trajectory dimension if missing dim(data) <- c(1, dim(data)) # adding age dimension - dimnames(data) <- list(NULL, colnames(traj$trajectories), NULL) + dimnames(data) <- list(NULL, colnms, NULL) } else {# only if it was not summed up, because then the as.matrix command adds a dimension data <- if(is.null(dim(d)) || !is.array(d)) as.matrix(d) else d #data <- as.matrix(d) diff --git a/README.md b/README.md index 59873b4..b0f6f79 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # bayesPop -[![R build status](https://github.com/PPgp/bayesPop/workflows/R-CMD-check/badge.svg?branch=master)](https://github.com/PPgp/bayesPop/actions?workflow=R-CMD-check) +[![R build status](https://github.com/PPgp/bayesPop/workflows/R-CMD-check/badge.svg)](https://github.com/PPgp/bayesPop/actions?workflow=R-CMD-check) R package for obtaining probabilistic population projections. [This paper](http://www.unece.org/fileadmin/DAM/stats/documents/ece/ces/ge.11/2013/WP_13.2.pdf) diff --git a/tests/test_functions.R b/tests/test_functions.R index d63f1d0..0c6ddd3 100644 --- a/tests/test_functions.R +++ b/tests/test_functions.R @@ -116,6 +116,7 @@ test.expressions.with.VE <- function(map=TRUE, parallel = FALSE) { sim.dir <- tempfile() pred <- pop.predict(countries=c(528, 218), nr.traj = 3, verbose=FALSE, output.dir=sim.dir, keep.vital.events=TRUE, parallel = parallel) + filename <- tempfile() png(filename=filename) pop.trajectories.plot(pred, expression='F528_F[10]')