data aligned with time periods

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 <[email protected]>

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])
 	}

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)

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)

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]')