#--------------------------------------------------------------
# Leontine Alkema, 2011/2012
# F_output.R
#--------------------------------------------------------------
ReadWRA <- function(# Read WRA for all countries
### Read WRA for all countries
est.years, ##<< Years for which WRA are needed.
winbugs.data, ##<< Object of class \code{\link{winbugs.data}}
country.info,##<< Object of class \code{\link{country.info}}
WRA.csv ##<< Denominator counts
##[MCW-2016-11-21-1] :: Added to allow return of a data frame that has all
##country names and their ISO codes. This is used in 'allWomenCIs()'.
,return.iso = FALSE,
in_union,
verbose = TRUE
){
# read in number of women of reproductive ages in married/union
nyears <- length(est.years)
W.Lc.t <- list()
## [MCW-2016-11-21-2] :: Create data frame for ISO codes and c names.
if(return.iso) iso.c.name.df <-
data.frame(iso.c = rep(NA, nrow(country.info))
,name.c = rep(NA, nrow(country.info))
)
#matrix(NA, winbugs.data$C, nyears)
message("\nReading denominator counts from ", WRA.csv)
weight.data <- extractDenominators(denominator_csv = WRA.csv, in_union = in_union)
names(weight.data) <- gsub("X", "", names(weight.data))
locID.grepl <- grepl("LocID", names(weight.data))
if(identical(as.double(sum(locID.grepl)), 1) &&
!identical(names(weight.data)[locID.grepl], "LocID")
) {
names(weight.data)[locID.grepl] <- "LocID"
warning("Column ", which(locID.grepl), " in '", WRA.csv, "' has been used as the 'LocID' column. Its header has some other (possibly invisible) characters in it.")
}
names(weight.data)[names(weight.data) == "ISO.code"] <- "LocID"
## [MCW-2017-01-20-3] :: Allow for column names starting 'UMW_...' for unmarried women counts.
if (any(grepl("^MW_[0-9]{4}_", colnames(weight.data)))) {
age.range <-
strsplit(grep("^MW_[0-9]{4}_", colnames(weight.data), value = TRUE)[1]
,"_")[[1]][2]
names.weights.t <- paste0("MW_", age.range, "_", est.years-0.5)
} else if(any(grepl("^UMW_[0-9]{4}_", colnames(weight.data)))) {
age.range <-
strsplit(grep("^UMW_[0-9]{4}_", colnames(weight.data), value = TRUE)[1]
,"_")[[1]][2]
names.weights.t <- paste0("UMW_", age.range, "_", est.years-0.5)
} else {
names.weights.t <- paste0(est.years-0.5)
}
for (c in 1:nrow(country.info)){ #[MCW-2016-08-26-1] Change upper limit to whatever size of 'country.info' is.
no.est.msg.yrs <- vector()
W.Lc.t[[country.info$name.c[c]]] <- rep(0, nyears)
for (t in 1:nyears){
if (is.element(country.info$iso.c[c], weight.data$LocID) & is.element(names.weights.t[t],names(weight.data))){
W.Lc.t[[country.info$name.c[c]]][t] <- 1/1000*weight.data[weight.data$LocID==country.info$iso.c[c], names.weights.t[t]]
## [MCW-2016-11-21-3] :: Enter country in ISO dataframe.
if(return.iso) iso.c.name.df[c, c("iso.c", "name.c")] <-
c(country.info$iso.c[c], country.info$name.c[c])
} else {
no.est.msg.yrs <- c(no.est.msg.yrs, est.years[t])
}
}
if(length(no.est.msg.yrs) > 0) {
if (verbose) {
message(paste0("\nNo estimate for number of women for ", country.info$name.c[c], " for years\n",
paste(strwrap(paste(no.est.msg.yrs, collapse = ", "), initial = " ", prefix = " "), collapse = "\n")
))
} else {
message(paste0("No estimate for number of women for ", country.info$name.c[c], " for some or all years between ",
no.est.msg.yrs[1], " and ", no.est.msg.yrs[length(no.est.msg.yrs)], "."
))
}
}
}
##details<< If WRA information on a country is missing for a year, a warning message will be printed, and the WRA will be set to 0.
##value<< List W.Lc.t, where elements are named by country name (but matching was done using ISO codes),
## and contain WRA's (*1,000 women) for est.years.
## [MCW-2016-11-21-4] :: Return ISO dataframe, omitting incomplete cases.
if(return.iso) return(list(W.Lc.t, na.omit(iso.c.name.df)))
return(W.Lc.t)
}
#---------------------------------------------------------------------
GetCIs <- function (# Construct country-specific CIs
### Construct country-specific CIs for proportions, counts and changes
### (including posterior probabilities of a positive change).
### This function is called from \code{\link{ConstructOutput}}.
mcmc.meta, ##<< Object of class \code{\link{mcmc.meta}}
mcmc.array = NULL, ##<< Object of class \code{\link{mcmc.array}}
include.AR = TRUE, ##<< Logical: include AR(1) trajectories?
thin = 1, ##<< Optional additional thinning of MCMC samples
output.dir,## Where to save the folder with country trajectories?
start.year = 1990.5, ##<< First year of estimation period (will be centered at half-year)
## If given user-input, it will use min of 1990 and user input
end.year = 2015.5,##<< First year of estimation period (will be centered at half-year)
## If given user-input, it will use max of 2015 and user input
years.change = matrix(c(1990.5, 2000.5,
2000.5, 2010.5,
1990.5, 2010.5,
2000.5, 2017.5),
ncol = 2, byrow = TRUE), ##<< Matrix with 2 columns, with column 1
## containing yyyy1 and column 2 containing yyyy2 for calculating change yyyy1-yyyy2
years.change2 = matrix(c(2005.5, 2010.5, 2015.5,
2000.5, 2005.5, 2010.5,
1995.5, 2000.5, 2005.5,
1990.5, 1995.5, 2000.5,
1990.5, 2000.5, 2010.5
,2000.5, 2010.5, 2017.5),
ncol = 3, byrow = TRUE), ##<< Matrix with 3 columns, with column 1
## containing yyyy1, column 2 containing yyyy2 and column 3 containing yyyy3 for
## calculating change (yyyy2-yyyy3) - (yyyy1-yyyy2)
## The years 1990, 2000 and 2010 are always included.
## Years outside (\code{start.year}, \code{end.year}) are ignored.
## Mid-point years closest to the given \code{years.change} are used for calculations.
nrepeatARsampling = 1, ##<< DO NOT CHANGE!!!
## Optional additional sampling of AR(1) trajectories
## for each posterior sample of model parameters.
WRA.csv = NULL, ##<< csv-file for WRA, see \code{\link{ConstructOutput}}
seed = 1234, ##<< Seed (used for sampling of AR(1) trajectories), default is 1234
percentiles = c(0.025, 0.1, 0.5, 0.9, 0.975),##<< Percentiles (which define q in CIs.cqt),
in_union,
verbose = TRUE
){
winbugs.data <- mcmc.meta$winbugs.data
region.info <- mcmc.meta$data.raw$region.info
country.info <- mcmc.meta$data.raw$country.info
name.c <- as.character(country.info$name.c)
do.country.specific.run <- mcmc.meta$general$do.country.specific.run # change JR, 20131104
write.model.fun <- mcmc.meta$general$write.model.fun
## >>>>> RATE MODEL [MCW-2018-01-03] :: Copied from Niamh's version.
if (is.null(mcmc.meta$general$do.country.specific.targets.run)) { # change JR, 20150301
do.country.specific.targets.run <- FALSE # for old runs
} else {
do.country.specific.targets.run <- mcmc.meta$general$do.country.specific.targets.run
}
## <<<<< RATE MODEL
data.global <- mcmc.meta$data.global # change JR, 20131104
## [MCW-2016-08-26-4] From this point, combine countries with no data with
## other countries and apply rest of this function.. Note that 'region.info'
## already contains the union of (sub)regions across all countries, data or
## no.
if(mcmc.meta$general$include.c.no.data || isTRUE(mcmc.meta$validation.list$at.random.no.data)) {
country.info.no.data <- mcmc.meta$data.raw$country.info.no.data
countries.all <- rbind(country.info, country.info.no.data)
name.c <- countries.all$name.c
C.all <- winbugs.data$C + winbugs.data$C.no.data
if(isTRUE(mcmc.meta$validation.list$at.random.no.data)) {
N.unique.c <- c(winbugs.data$N.unique.c, winbugs.data$N.unique.c.test)
} else N.unique.c <- winbugs.data$N.unique.c
} else {
countries.all <- country.info
C.all <- winbugs.data$C
N.unique.c <- winbugs.data$N.unique.c
}
## IMPORTANT: when using names for lists, make sure they're character
## or paste the word, else alph ordering/level is used (and e.g. China and China HK are swapped)
##details<< Country trajectories are stored in \code{output.dir/countrytrajectories}.
## output.dir.countrytrajectories <- file.path(mcmc.meta$general$output.dir, "countrytrajectories/")
output.dir.countrytrajectories <- file.path(output.dir, "countrytrajectories")
if (dir.exists(output.dir.countrytrajectories) && is.null(mcmc.array)) {
all_ctraj_files <- file.path(output.dir.countrytrajectories, paste0("P.tp3s_country", 1:C.all, ".rda"))
not_exist <- all_ctraj_files[!file.exists(all_ctraj_files)]
if (length(not_exist))
stop("'mcmc.array' is missing; all country trajectory files must be saved in '",
dirname(not_exist[1]), "' but the following ", toString(length(not_exist)),
" files (out of ", toString(length(all_ctraj_files)), ") are missing: '",
toString(basename(not_exist)), "'.")
generate_c_traj <- FALSE
} else {
generate_c_traj <- TRUE
dir.create(output.dir.countrytrajectories, showWarnings = FALSE)
mcmc.array.thin <- mcmc.array[seq(1, length(mcmc.array[,1,1]), thin),,,drop = FALSE]
# [MCW-2018-01-17 (1)] :: If only one
# iteration make sure extra dimension
# not dropped.
if (length(mcmc.array[1,,1])==1) {# when there is only one chain the thinning changes array into matrix
mcmc.array.thin <- array(NA, c(length(seq(1, length(mcmc.array[,1,1]), thin)),
length(mcmc.array[1,,1]), length(mcmc.array[1,1,])))
mcmc.array.thin[,1,] <- mcmc.array[seq(1, length(mcmc.array[,1,1]), thin),,]
dimnames(mcmc.array.thin) <- list(NULL, NULL, names(mcmc.array[1,1,]))
}
n.s <- prod(dim(mcmc.array.thin)[1:2]) # nthinnedsim*nchains
}
nrepeatARsampling <- max(nrepeatARsampling, 1)
if (!include.AR) nrepeatARsampling = 1
## s refers to number of posterior samples
## S refers to total number of trajectories
## if nrepeatARsampling=2, then S=1,s+1 correspond to s=1 (parameter.s vectors are stacked).
##------------------------------------------------------------
## >>>>> RATE MODEL [MCW-2018-01-03] Copied from Niamh's version
est.years.input<-seq(start.year, end.year)
## <<<<< RATE MODEL
start.year <- min(floor(start.year)+0.5, 1990.5)
end.year <- max(floor(end.year)+0.5, 2015.5)
est.years <- seq(start.year, end.year)
##details<< The number of WRA are read using \code{\link{ReadWRA}}, which gives \code{W.Lg.t}.
W.Lg.t <- ReadWRA(est.years = est.years,
winbugs.data = winbugs.data,
country.info = countries.all,
WRA.csv = WRA.csv,
return.iso = TRUE,
in_union,
verbose = verbose
)
W.Lg.t.iso <- W.Lg.t[[2]]
W.Lg.t <- W.Lg.t[[1]]
nyears <- length(est.years)
## change JR, 20140317
## make sure 1990, 2000 and 2010 are included:
years.change <- unique(rbind(floor(years.change)+0.5,
matrix(c(1990.5, 2000.5,
2000.5, 2010.5,
1990.5, 2010.5),
ncol= 2, byrow = TRUE)))
years.change2 <- unique(rbind(floor(years.change2)+0.5,
matrix(c(2005.5, 2010.5, 2015.5,
2000.5, 2005.5, 2010.5,
1995.5, 2000.5, 2005.5,
1990.5, 1995.5, 2000.5,
1990.5, 2000.5, 2010.5),
ncol = 3, byrow = TRUE)))
check1 <- !(c(floor(years.change)) %in% floor(est.years))
check2 <- !(c(floor(years.change2)) %in% floor(est.years))
if (any(check1))
stop(paste0(c(years.change)[check1], " is not found in estimation years.\n"))
if (any(check2))
stop(paste0(c(years.change2)[check2], " is not found in estimation years.\n"))
years.change.unique <- unique(c(c(years.change), c(years.change2)))
## needed for AR(1)'s:
## [MCW-2016-08-26-15] Add in elements to 'years.ci' for countries with no
## data.
##
## For the LEVEL MODEL, enter the mid-point of all years in
## data. It is approximately 1997. This must be a half year
## because it is used as the basis for an index into a matrix in
## InternalInternalGetARTrajectories().
##
## For the RATE MODEL, set it to the same year 'setlevel.c' refers
## to (i.e., 1990.5).
##
## This year (roughly 1997 or 1990.5) is the year the posterior estimates of
## the AR(1) distortion terms are attributed to. In the JAGS model
## a sample for each of epsilon, eta, and theta (e.g.,
## 'mcmc.array[,,"eps.ci[1,1]"]'), was saved for the 'first'
## 'observation' year for countries with no data. This is not
## really a posterior because it is entirely defined by the
## distributions in Alkema et al. (2013, Appendix p. 10). AR
## distortion terms for all other years in the estimation period
## are generated by sequentially sampling from normal
## distributions forwards and backwards from this year. Going
## backwards, the first AR term is sampled from a normal
## distribution with mean equal to the posterior for 'rho.s' times
## the datum value, s.d. the posterior 'sigma.s', etc.,
## recursively. Similarly going forwards.
##
if(mcmc.meta$general$include.c.no.data) {
## Countries with no data but NOT validation
years.ci.no.data <- matrix(NA, nrow = winbugs.data$C.no.data, ncol = ncol(winbugs.data$gett.ci))
years.ci.no.data[,1] <- floor(mean(range(winbugs.data$gett.ci, na.rm = TRUE))) + 0.5
years.ci <- rbind(winbugs.data$gett.ci, years.ci.no.data)
if(ModelFunctionRateModel(write.model.fun)) {
## >>>>> RATE MODEL
year.est.c.no.data <- matrix(NA, nrow = winbugs.data$C.no.data,
ncol = ncol(winbugs.data$year.est.c))
year.est.c.no.data[,1] <- 1990.5
year.est.c <- rbind(winbugs.data$year.est.c, year.est.c.no.data)
N.obsperiod.c <- c(winbugs.data$N.obsperiod.c, rep(1, winbugs.data$C.no.data))
## <<<<< RATE MODEL
}
} else if(!is.null(mcmc.meta$validation.list)) {
## Validation
if(with(mcmc.meta$validation.list, at.random.no.data || leave.iso.out)) {
## 'at.random.no.data' or 'leave.iso.out'
years.ci <-
matrix(NA, nrow = nrow(winbugs.data$gett.ci) + nrow(winbugs.data$gett.ci.test)
,ncol = max(ncol(winbugs.data$gett.ci)
,ncol(winbugs.data$gett.ci.test)
)
)
years.ci[1:nrow(winbugs.data$gett.ci), 1:ncol(winbugs.data$gett.ci)] <-
winbugs.data$gett.ci
years.ci[(nrow(winbugs.data$gett.ci) + 1):nrow(years.ci), 1:ncol(winbugs.data$gett.ci.test)] <-
winbugs.data$gett.ci.test
if(ModelFunctionRateModel(write.model.fun)) {
## >>>>> RATE MODEL
year.est.c <- rbind(winbugs.data$year.est.c, winbugs.data$year.est.c.test)
N.obsperiod.c <- c(winbugs.data$N.obsperiod.c, winbugs.data$N.obsperiod.c.test)
## <<<<< RATE MODEL
}
} else {
## Other validation
years.ci <- winbugs.data$gett.ci
if(ModelFunctionRateModel(write.model.fun)) {
## >>>>> RATE MODEL
year.est.c <- winbugs.data$year.est.c
N.obsperiod.c <- winbugs.data$N.obsperiod.c
## <<<<< RATE MODEL
}
}
} else {
## Neither countries with no data nor validations
years.ci <- winbugs.data$gett.ci
if(ModelFunctionRateModel(write.model.fun)) {
## >>>>> RATE MODEL
year.est.c <- winbugs.data$year.est.c
N.obsperiod.c <- winbugs.data$N.obsperiod.c
## <<<<< RATE MODEL
}
}
if (!is.null(mcmc.array)) {
##------------------------------------------------------------
## output: World level unmet parametric function for p.seq
if (!do.country.specific.run) { # change JR, 20131104
a.s <- c(mcmc.array.thin[, , "a.unmet"])
b.s <- c(mcmc.array.thin[, , "b.unmet"])
c.s <- c(mcmc.array.thin[, , "c.unmet"])
} else {
a.s <- rep(winbugs.data$a.unmet0, n.s)
b.s <- rep(winbugs.data$b.unmet0, n.s)
c.s <- rep(winbugs.data$c.unmet0, n.s)
}
p.seq <- seq(0, 1, 0.01)
Zstar.cqp <- array(NA, c(C.all, length(percentiles), length(p.seq)))
logitZstar.sp <- matrix(NA, n.s, length(p.seq))
for (i in 1:length(p.seq)) {
logitZstar.sp[,i] <- (a.s + b.s*(p.seq[i]- winbugs.data$pmid.for.unmet) +
c.s*(p.seq[i]- winbugs.data$pmid.for.unmet)^2)
}
Zstar.qp <- apply(invlogit(logitZstar.sp), 2, quantile, percentiles)
## make a.s etc same dimension with added AR repetitions
a.S <- rep(a.s, nrepeatARsampling)
b.S <- rep(b.s, nrepeatARsampling)
c.S <- rep(c.s, nrepeatARsampling)
##rep(seq(1,2), 2)
##------------------------------------------------------------
## [MCW-2017-01-23-1] :: Create a data frame to record which country (ISO)
## goes with which 'P.tp3s_country' file.
iso.P.tp3s.df <-
data.frame(iso.c = rep(NA, C.all), name.c = NA ,filename = NA)
}
CIprop.Lg.Lcat.qt <- CIratio.Lg.Lcat.qt <- CIstar.Lg.Lcat.qt <-
## >>>>> RATE MODEL [MCW-2018-01-03] Copied from Niamh's version
CIrate.Lg.Lcat.qt<-
## <<<<< RATE MODEL
changeprop.Lg.Lcat.Ti <-
CIcount.Lg.Lcat.qt <- changecount.Lg.Lcat.Ti <- changeratio.Lg.Lcat.Ti <- meanProp.Lg.Lcat <-meanRatio.Lg.Lcat <-meanStar.Lg.Lcat <- metDemGT.Lg.Lcat.pr <- list()
##------------------------------------------------------------
for (c in 1:C.all) {
c_traj_file_path <- file.path(output.dir.countrytrajectories, paste0("P.tp3s_country", c, ".rda"))
if (generate_c_traj) {
if(verbose) message(paste0("(", format(c, width = nchar(C.all)), "/", C.all, ") Constructing output for ", countries.all$name.c[c], " (ISO ", countries.all$iso.c[c], ")"))
## [MCW-2017-01-23-2] :: Add country ISO code and name to data frame.
iso.P.tp3s.df[c, c("iso.c", "name.c")] <- c(countries.all$iso.c[c], name.c[c])
Zstar.St <- Z.St <- logitBstar.St <- B.St <- Bstar.St <-
D.St <- Dstar.St <- p.unmet.St <- pstar.unmet.St <-
matrix(NA, n.s*nrepeatARsampling, nyears)
seed.country <- seed*as.numeric(countries.all$iso.c[c]) # change JR, 20140317
CIprop.Lg.Lcat.qt[[name.c[c]]] <- CIratio.Lg.Lcat.qt[[name.c[c]]] <-
CIstar.Lg.Lcat.qt[[name.c[c]]] <-
## >>>>> RATE MODEL [MCW-2018-01-03-12][MCW-2018-01-03-] Copied from Niamh's version
CIrate.Lg.Lcat.qt[[name.c[c]]] <-
## <<<<< RATE MODEL
list()
pstar.st <- InternalInternalGetTrajectoriesCountryTotStar(c = c,
start.year = start.year,
end.year = end.year,
mcmc.array = mcmc.array.thin ,
write.model.fun = write.model.fun #there is a rate model version
)
Rstar.st <- InternalInternalGetTrajectoriesCountryRatStar(c = c, start.year = start.year, end.year = end.year,
mcmc.array = mcmc.array.thin)
if (!include.AR){
p.St <- pstar.st # here no resampling!
R.St <- Rstar.st
} else {
if(ModelFunctionRateModel(write.model.fun)) {
## >>>>> RATE MODEL [MCW-2018-01-03] Copied from Niamh's version
years.i <- years.ci[c,1:N.unique.c[c]] # change JR, 20150301
year.totCP.i<-year.est.c[c,1:N.obsperiod.c[c]]
GetTotTraj <- InternalGetTrajectoriesCountryTot(c = c, years.i = year.totCP.i,
start.year = start.year, end.year = end.year,
mcmc.array = mcmc.array.thin,
do.country.specific.run = do.country.specific.run,
winbugs.data = winbugs.data,
pstar.st = pstar.st, #rate model pstar.st
nrepeatARsampling = nrepeatARsampling,
seed.country = seed.country*1# change JR, 20140317
,write.model.fun = write.model.fun)
p.str<-GetTotTraj$p.str.final
rate.str<-GetTotTraj$rate.str.final
rate.St<-apply(rate.str,2, cbind)
p.St <- apply(p.str,2, cbind)
R.str <- InternalGetTrajectoriesCountryRat(c = c, years.i = years.i,
start.year = start.year, end.year = end.year,
mcmc.array = mcmc.array.thin,
do.country.specific.run = do.country.specific.run, # change JR, 20131104
winbugs.data = winbugs.data,
Rstar.st = Rstar.st,
nrepeatARsampling = nrepeatARsampling,
seed.country = seed.country*2) # change JR, 20140317
R.St <- apply(R.str, 2, cbind)
## <<<<< RATE MODEL
} else {
## ====> LEVEL MODEL
## note: dimension s changes if nrepreatARsampling is >1!!!
p.str <- InternalGetTrajectoriesCountryTot(c = c, years.i = years.ci[c,1:N.unique.c[c]],
start.year = start.year, end.year = end.year,
mcmc.array = mcmc.array.thin,
do.country.specific.run = do.country.specific.run, # change JR, 20131104
winbugs.data = winbugs.data, # change JR, 20131104
pstar.st = pstar.st,
nrepeatARsampling = nrepeatARsampling,
seed.country = seed.country*1# change JR, 20140317
,write.model.fun = write.model.fun)
p.St <- apply(p.str,2, cbind)
R.str <- InternalGetTrajectoriesCountryRat(c = c, years.i = years.ci[c,1:N.unique.c[c]],
start.year = start.year, end.year = end.year,
mcmc.array = mcmc.array.thin,
do.country.specific.run = do.country.specific.run, # change JR, 20131104
winbugs.data = winbugs.data, # change JR, 20131104
Rstar.st = Rstar.st,
nrepeatARsampling = nrepeatARsampling,
seed.country = seed.country*2) # change JR, 20140317
R.St <- apply(R.str,2, cbind)
## <==== LEVEL MODEL
}
##A <- array(seq(1,20), dim = c(2,2,3))
##A[1:2, 1:2,1]
##A[1:2, 1:2,2]
##apply(A,2, cbind)
# what if repeated sampling =1
##A <- array(seq(1,20), dim = c(2,2,1))
##A[1:2, 1:2,1]
##apply(A,2, cbind)
}
CIprop.Lg.Lcat.qt[[name.c[c]]][["Total"]] <- apply(p.St, 2, quantile, percentiles)
CIprop.Lg.Lcat.qt[[name.c[c]]][["Traditional"]] <- apply((1-R.St)*p.St, 2, quantile, percentiles)
CIprop.Lg.Lcat.qt[[name.c[c]]][["Modern"]] <- apply(R.St*p.St, 2, quantile, percentiles)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Total"]] <- apply(pstar.st, 2, quantile, percentiles)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Traditional"]] <- apply((1-Rstar.st)*pstar.st, 2, quantile, percentiles)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Modern"]] <- apply(Rstar.st*pstar.st, 2, quantile, percentiles)
CIratio.Lg.Lcat.qt[[name.c[c]]][["Modern/Total"]] <- apply(R.St, 2, quantile, percentiles)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Modern/Total"]] <- apply(Rstar.st, 2, quantile, percentiles)
## >>>>> RATE MODEL [MCW-2018-01-03] Copied from Niamh's version
if(ModelFunctionRateModel(write.model.fun)) {
if(include.AR) { #Only gets made if include.AR == TRUE
## [MCW 2018-11-09] This does not get used (checked in Niamh's code)
CIrate.Lg.Lcat.qt[[name.c[c]]][["TotalRate"]] <- apply(rate.St, 2, quantile, percentiles, na.rm = TRUE)
}
}
## <<<<< RATE MODEL
## [MCW-2016-07-12-2] :: Compute means for key CP indicators for UNPD outputs.
meanProp.Lg.Lcat[[name.c[c]]][["Total"]] <- apply(p.St, 2, mean, na.rm = TRUE)
meanProp.Lg.Lcat[[name.c[c]]][["Traditional"]] <- apply((1-R.St)*p.St, 2, mean, na.rm = TRUE)
meanProp.Lg.Lcat[[name.c[c]]][["Modern"]] <- apply(R.St*p.St, 2, mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Total"]] <- apply(pstar.st, 2, mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Traditional"]] <- apply((1-Rstar.st)*pstar.st, 2, mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Modern"]] <- apply(Rstar.st*pstar.st, 2, mean, na.rm = TRUE)
meanRatio.Lg.Lcat[[name.c[c]]][["Modern/Total"]] <- apply(R.St, 2, mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Modern/Total"]] <- apply(Rstar.st, 2, mean, na.rm = TRUE)
##------------------------------------------------------------------------
## Unmet
if (!include.AR){
theta.St <- matrix(0, n.s, nyears)
} else {
theta.is <- matrix(NA, N.unique.c[c], n.s)
for (i in 1:N.unique.c[c]){
theta.is[i,] <- c(mcmc.array.thin[, , paste0("theta.ci[", c, ",", i, "]")])
}
if (!do.country.specific.run) { # change JR, 20131104
rho.unmet <- c(mcmc.array.thin[, ,"rho.unmet"])
sigma.ar.unmet <- c(mcmc.array.thin[, ,"sigma.ar.unmet"])
} else {
rho.unmet <- rep(winbugs.data$rho.unmet0, n.s)
sigma.ar.unmet <- rep(winbugs.data$sigma.ar.unmet0, n.s)
}
if(ModelFunctionRateModel(write.model.fun)) {
## >>>>> RATE MODEL [MCW-2018-01-03] Copied from Niamh's version
theta.str <- InternalGetARTrajectories(rho.s = rho.unmet,
sigma.s = sigma.ar.unmet,
eps.is = theta.is,
years.i = years.i,
start.year = start.year, end.year = end.year,
nrepeatARsampling = nrepeatARsampling,
seed.country = seed.country*3) # change JR, 20140317
theta.St <- apply(theta.str,2, cbind)
## <<<<< RATE MODEL
} else {
## ====> LEVEL MODEL [MCW-2018-01-03] Copied from Niamh's version
theta.str <- InternalGetARTrajectories(rho.s = rho.unmet,
sigma.s = sigma.ar.unmet,
eps.is = theta.is,
years.i = years.ci[c,1:N.unique.c[c]],
start.year = start.year, end.year = end.year,
nrepeatARsampling = nrepeatARsampling,
seed.country = seed.country*3) # change JR, 20140317
theta.St <- apply(theta.str,2, cbind)
## ====< LEVEL MODEL
}
}
unmet.intercept.s <- c(mcmc.array.thin[,,paste0("unmet.intercept.c[",c, "]")])
unmet.intercept.S <- rep(unmet.intercept.s, nrepeatARsampling)
for (t in 1:nyears) {
Zstar.St[,t] <- invlogit(unmet.intercept.S
+ a.S + b.S*(p.St[,t] - winbugs.data$pmid.for.unmet) +
c.S*(p.St[,t]- winbugs.data$pmid.for.unmet)^2)
pstar.unmet.St[,t] <- Zstar.St[,t]*(1-p.St[,t])
Bstar.St[,t] <- p.St[,t]/(pstar.unmet.St[,t] + p.St[,t])
Z.St[,t] <- invlogit(logit(Zstar.St[,t]) + theta.St[,t])
p.unmet.St[,t] <- Z.St[,t]*(1-p.St[,t])
B.St[,t] <- p.St[,t]/(p.unmet.St[,t] + p.St[,t])
## change JR, 20140830: added demand met with modern methods
Dstar.St[,t] <- R.St[,t]*p.St[,t]/(pstar.unmet.St[,t] + p.St[,t])
D.St[,t] <- R.St[,t]*p.St[,t]/(p.unmet.St[,t] + p.St[,t])
}
for (i in 1:length(p.seq)){
## no ar sampling here
Zstar.cqp[c,,i] <- quantile(invlogit(logitZstar.sp[,i]+unmet.intercept.s), percentiles)
}
CIprop.Lg.Lcat.qt[[name.c[c]]][["Unmet"]] <- apply(p.unmet.St, 2, quantile, percentiles)
CIprop.Lg.Lcat.qt[[name.c[c]]][["TotalPlusUnmet"]] <- apply(p.unmet.St + p.St, 2, quantile, percentiles)
CIprop.Lg.Lcat.qt[[name.c[c]]][["TradPlusUnmet"]] <- apply(p.unmet.St + (1-R.St)*p.St, 2, quantile, percentiles)
CIratio.Lg.Lcat.qt[[name.c[c]]][["Met Demand"]] <- apply(B.St, 2, quantile, percentiles)
CIratio.Lg.Lcat.qt[[name.c[c]]][["Z"]] <- apply(Z.St, 2, quantile, percentiles)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Met Demand"]] <- apply(Bstar.St, 2, quantile, percentiles)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Z"]] <- apply(Zstar.St, 2, quantile, percentiles)
## change JR, 20140830: added demand met with modern methods
CIratio.Lg.Lcat.qt[[name.c[c]]][["Met Demand with Modern Methods"]] <- apply(D.St, 2, quantile, percentiles)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Met Demand with Modern Methods"]] <- apply(Dstar.St, 2, quantile, percentiles)
## [MCW-2016-07-12-4] :: Compute means for CP indicators for unmet.
meanProp.Lg.Lcat[[name.c[c]]][["Unmet"]] <- apply(p.unmet.St, 2, mean, na.rm = TRUE)
meanProp.Lg.Lcat[[name.c[c]]][["TotalPlusUnmet"]] <- apply(p.unmet.St + p.St, 2, mean, na.rm = TRUE)
meanProp.Lg.Lcat[[name.c[c]]][["TradPlusUnmet"]] <- apply(p.unmet.St + (1-R.St)*p.St, 2, mean, na.rm = TRUE)
meanRatio.Lg.Lcat[[name.c[c]]][["Met Demand"]] <- apply(B.St, 2, mean, na.rm = TRUE)
meanRatio.Lg.Lcat[[name.c[c]]][["Z"]] <- apply(Z.St, 2, mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Met Demand"]] <- apply(Bstar.St, 2, mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Z"]] <- apply(Zstar.St, 2, mean, na.rm = TRUE)
meanRatio.Lg.Lcat[[name.c[c]]][["Met Demand with Modern Methods"]] <- apply(D.St, 2, mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Met Demand with Modern Methods"]] <- apply(Dstar.St, 2, mean, na.rm = TRUE)
## Met Demand with modern methods > 75%
metDemGT.Lg.Lcat.pr[[name.c[c]]][["Met Demand with Modern Methods >= 75%"]] <-
matrix(colMeans(D.St >= 0.75, na.rm = TRUE), nrow = 1)
##------------------------------------------------------------------------
## keep old name with small s
P.tp3s <- array(NA, c(length(est.years), 3, n.s*nrepeatARsampling))
## >>>>> RATE MODEL [MCW-2018-01-03] Copied from Niamh's version
t.input<-match(est.years.input,est.years)
## <<<<< RATE MODEL
dimnames(P.tp3s) <- list(est.years, c("Traditional", "Modern", "Unmet"), NULL)
for (t in 1:length(est.years)){
P.tp3s[t,1,] <- (1-R.St[,t])*p.St[,t]
P.tp3s[t,2,] <- R.St[,t]*p.St[,t]
P.tp3s[t,3,] <- p.unmet.St[,t]
}
##details<<
## Country trajectories in form of array \code{P.tp3s} written to \code{"output.dir/country.trajectories/"}
## where t refers to estimation year, p3 to (trad, modern, unmet) and s to posterior sample
save(P.tp3s, file = c_traj_file_path) # change JR, 20140418
## [MCW-2017-01-23-3] :: Add 'P.tp3s_country' filename to data frame.
iso.P.tp3s.df[c, "filename"] <- paste0("P.tp3s_country", c, ".rda")
} else {
if(verbose) message(paste0("(", format(c, width = nchar(C.all)), "/", C.all, ") Loading existing trajectories for ", countries.all$name.c[c], " (ISO ", countries.all$iso.c[c], ")"))
load(file = c_traj_file_path)
##
## Must subset to est.years !!
##
traj_years <- dimnames(P.tp3s)[[1]] # character: "1970.5", "1971.5", etc.
est_years_not_in <- est.years[!est.years %in% as.numeric(traj_years)]
if (length(est_years_not_in))
stop("The following years are in 'est.years' but not in the the country trajectory file: '",
toString(est_years_not_in), "'.")
P.tp3s <- P.tp3s[as.character(est.years), , ,drop = TRUE]
##<< Proportions for Total, Traditional, Modern, Unmet, TotalPlusUnmet, TradPlusUnmet.
CIprop.Lg.Lcat.qt[[name.c[c]]][["Total"]] <-
apply(X = P.tp3s[, "Modern", , drop = TRUE] + P.tp3s[, "Traditional", , drop = TRUE],
1, FUN = quantile, probs = percentiles, na.rm = TRUE)
CIprop.Lg.Lcat.qt[[name.c[c]]][["Traditional"]] <-
apply(X = P.tp3s[, "Traditional", , drop = TRUE], MARGIN = 1, FUN = quantile,
probs = percentiles, na.rm = TRUE)
CIprop.Lg.Lcat.qt[[name.c[c]]][["Modern"]] <-
apply(X = P.tp3s[, "Modern", , drop = TRUE], MARGIN = 1, FUN = quantile,
probs = percentiles, na.rm = TRUE)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Total"]] <- NA
CIstar.Lg.Lcat.qt[[name.c[c]]][["Traditional"]] <- NA
CIstar.Lg.Lcat.qt[[name.c[c]]][["Modern"]] <- NA
##<<Ratios Met Demand, Met Demand with Modern Methods, Z
##(unmet/none) and modern/total (R). R and Z might not be
##included for aggregates.
CIratio.Lg.Lcat.qt[[name.c[c]]][["Modern/Total"]] <-
apply(X = P.tp3s[, "Modern", , drop = TRUE] / P.tp3s[, "Traditional", , drop = TRUE],
MARGIN = 1, FUN = quantile, probs = percentiles, na.rm = TRUE)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Modern/Total"]] <- NA
## >>>>> RATE MODEL [MCW-2018-01-03] Copied from Niamh's version
if(ModelFunctionRateModel(write.model.fun)) {
if(include.AR) { #Only gets made if include.AR == TRUE
## [MCW 2018-11-09] This does not get used (checked in Niamh's code)
CIrate.Lg.Lcat.qt[[name.c[c]]][["TotalRate"]] <- NA
}
}
## <<<<< RATE MODEL
## [MCW-2016-07-12-2] :: Compute means for key CP indicators for UNPD outputs.
meanProp.Lg.Lcat[[name.c[c]]][["Total"]] <-
apply(X = P.tp3s[, "Modern", , drop = TRUE] + P.tp3s[, "Traditional", , drop = TRUE],
MARGIN = 1, FUN = mean, na.rm = TRUE)
meanProp.Lg.Lcat[[name.c[c]]][["Traditional"]] <-
apply(X = P.tp3s[, "Traditional", , drop = TRUE], MARGIN = 1, FUN = mean, na.rm = TRUE)
meanProp.Lg.Lcat[[name.c[c]]][["Modern"]] <-
apply(X = P.tp3s[, "Modern", , drop = TRUE], MARGIN = 1, FUN = mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Total"]] <- NA
meanStar.Lg.Lcat[[name.c[c]]][["Traditional"]] <- NA
meanStar.Lg.Lcat[[name.c[c]]][["Modern"]] <- NA
meanRatio.Lg.Lcat[[name.c[c]]][["Modern/Total"]] <-
apply(X = P.tp3s[, "Modern", , drop = TRUE] / P.tp3s[, "Traditional", , drop = TRUE],
MARGIN = 1, FUN = mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Modern/Total"]] <- NA
Zstar.qp <- NA
Zstar.cqp <- NA
p.seq <- NA
CIprop.Lg.Lcat.qt[[name.c[c]]][["Unmet"]] <-
apply(X = P.tp3s[, "Unmet", , drop = TRUE], MARGIN = 1, FUN = quantile,
probs = percentiles, na.rm = TRUE)
CIprop.Lg.Lcat.qt[[name.c[c]]][["TotalPlusUnmet"]] <-
apply(X = P.tp3s[, "Modern", , drop = TRUE] + P.tp3s[, "Traditional", , drop = TRUE] +
P.tp3s[, "Unmet", , drop = TRUE], MARGIN = 1, FUN = quantile,
probs = percentiles, na.rm = TRUE)
CIprop.Lg.Lcat.qt[[name.c[c]]][["TradPlusUnmet"]] <-
apply(X = P.tp3s[, "Traditional", , drop = TRUE] + P.tp3s[, "Unmet", , drop = TRUE], MARGIN = 1,
FUN = quantile, probs = percentiles, na.rm = TRUE)
CIratio.Lg.Lcat.qt[[name.c[c]]][["Met Demand"]] <-
apply((P.tp3s[, "Modern", ] + P.tp3s[, "Traditional", ]) /
((P.tp3s[, "Modern", ] + P.tp3s[, "Traditional", ]) + P.tp3s[, "Unmet", ]), MARGIN = 1,
FUN = quantile, probs = percentiles, na.rm = TRUE)
CIratio.Lg.Lcat.qt[[name.c[c]]][["Z"]] <-
apply(X = P.tp3s[, "Unmet", ] / (1 - P.tp3s[, "Modern", ] - P.tp3s[, "Traditional", ]), MARGIN = 1,
FUN = quantile, probs = percentiles, na.rm = TRUE)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Met Demand"]] <- NA
CIstar.Lg.Lcat.qt[[name.c[c]]][["Z"]] <- NA
## change JR, 20140830: added demand met with modern methods
CIratio.Lg.Lcat.qt[[name.c[c]]][["Met Demand with Modern Methods"]] <-
apply(X = P.tp3s[, "Modern", ] / ((P.tp3s[, "Modern", ] + P.tp3s[, "Traditional", ]) +
P.tp3s[, "Unmet", ]), MARGIN = 1, FUN = quantile,
probs = percentiles, na.rm = TRUE)
CIstar.Lg.Lcat.qt[[name.c[c]]][["Met Demand with Modern Methods"]] <- NA
## [MCW-2016-07-12-4] :: Compute means for CP indicators for unmet.
meanProp.Lg.Lcat[[name.c[c]]][["Unmet"]] <- apply(X = P.tp3s[, "Unmet", , drop = TRUE], MARGIN = 1,
FUN = mean, na.rm = TRUE)
meanProp.Lg.Lcat[[name.c[c]]][["TotalPlusUnmet"]] <-
apply(X = P.tp3s[, "Modern", , drop = TRUE] + P.tp3s[, "Traditional", , drop = TRUE] +
P.tp3s[, "Unmet", , drop = TRUE],
MARGIN = 1, FUN = mean, na.rm = TRUE)
meanProp.Lg.Lcat[[name.c[c]]][["TradPlusUnmet"]] <-
apply(X = P.tp3s[, "Traditional", , drop = TRUE] + P.tp3s[, "Unmet", , drop = TRUE], MARGIN = 1,
FUN = mean, na.rm = TRUE)
meanRatio.Lg.Lcat[[name.c[c]]][["Met Demand"]] <-
apply((P.tp3s[, "Modern", ] + P.tp3s[, "Traditional", ]) /
((P.tp3s[, "Modern", ] + P.tp3s[, "Traditional", ]) + P.tp3s[, "Unmet", ]), MARGIN = 1,
FUN = mean, na.rm = TRUE)
meanRatio.Lg.Lcat[[name.c[c]]][["Z"]] <-
apply(X = P.tp3s[, "Unmet", ] / (1 - P.tp3s[, "Modern", ] - P.tp3s[, "Traditional", ]), MARGIN = 1,
FUN = mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Met Demand"]] <- NA
meanStar.Lg.Lcat[[name.c[c]]][["Z"]] <- NA
meanRatio.Lg.Lcat[[name.c[c]]][["Met Demand with Modern Methods"]] <-
apply(X = P.tp3s[, "Modern", ] / ((P.tp3s[, "Modern", ] + P.tp3s[, "Traditional", ]) +
P.tp3s[, "Unmet", ]), MARGIN = 1, FUN = mean, na.rm = TRUE)
meanStar.Lg.Lcat[[name.c[c]]][["Met Demand with Modern Methods"]] <- NA
## Met Demand with modern methods > 75%
metDemGT.Lg.Lcat.pr[[name.c[c]]][["Met Demand with Modern Methods >= 75%"]] <-
matrix(rowMeans((P.tp3s[, "Modern", ] /
((P.tp3s[, "Modern", ] + P.tp3s[, "Traditional", ]) + P.tp3s[, "Unmet", ])) >= 0.75,
na.rm = TRUE),
nrow = 1)
}
##------------------------------------------------------------
## construct changes in prop and count and ratios
P.yp3s <- P.tp3s[is.element(est.years, years.change.unique), ,]
changeprop.Lg.Lcat.Ti[[name.c[c]]] <-
GetInfoChange(P.yp3s = P.yp3s ,years.change = years.change
, years.change2 = years.change2) # change JR, 20140317
## get estimates of changes in counts
## easy and inefficient :) ...
Psum.yp3s <- array(NA, dim(P.yp3s))
dimnames(Psum.yp3s) <- dimnames(P.yp3s)
if(verbose) message(" ", rep(" ", nchar(C.all)), " ", rep(" ", nchar(C.all)), " ", "(denominator counts for ", names(W.Lg.t)[c], ")")
W.y <- W.Lg.t[[c]][is.element(est.years, years.change.unique)]
names(W.y) <- est.years[is.element(est.years, years.change.unique)]
# NB: this not done in Niamh's version (2018-01-03)
for (y in 1:dim(P.yp3s)[1]) {
Psum.yp3s[y,,] <- P.yp3s[y,,]*W.y[y]
}
changecount.Lg.Lcat.Ti[[name.c[c]]] <-
GetInfoChange(P.yp3s = Psum.yp3s, type.is.prop = FALSE,
years.change = years.change, years.change2 = years.change2) # change JR, 20140317
## [MCW-2017-08-14-3] :: Calculate change quantities for ratios, e.g., 'met demand'.
changeratio.Lg.Lcat.Ti[[name.c[c]]] <-
GetInfoChange(P.yp3s = Psum.yp3s #<-- the /counts/
, type.is.prop = FALSE, type.is.ratio = TRUE, W.y = W.y,
years.change = years.change, years.change2 = years.change2
) # change JR, 20140317
} # end country loop
if (generate_c_traj) {
## [MCW-2017-01-23-4] :: Save data frame.
write.csv(x = iso.P.tp3s.df
,file = file.path(output.dir, "iso.Ptp3s.key.csv")
, row.names = FALSE)
}
##print(dim(Psum.yp3s))
## get estimates of counts
CIcount.Lg.Lcat.qt <- FromCIpropToCIcount(
CIprop.Lg.Lcat.qt = CIprop.Lg.Lcat.qt, W.Lg.t = W.Lg.t)
## fix names for the qt matrices
## remove % for q dimension
CIprop.Lg.Lcat.qt <- lapply(CIprop.Lg.Lcat.qt, lapply, function(c.qt){
dimnames(c.qt) <- list(percentiles, est.years)
return(c.qt)})
if (generate_c_traj) {
CIstar.Lg.Lcat.qt <- lapply(CIstar.Lg.Lcat.qt, lapply, function(c.qt){
dimnames(c.qt) <- list(percentiles, est.years)
return(c.qt)})
}
CIratio.Lg.Lcat.qt <- lapply(CIratio.Lg.Lcat.qt, lapply, function(c.qt){
dimnames(c.qt) <- list(percentiles, est.years)
return(c.qt)})
CIcount.Lg.Lcat.qt <- lapply(CIcount.Lg.Lcat.qt, lapply, function(c.qt){
dimnames(c.qt) <- list(percentiles, est.years)
return(c.qt)})
## >>>>> RATE MODEL [MCW-2018-01-03] Copied from Niamh's version
if(ModelFunctionRateModel(write.model.fun)) {
if(include.AR) { #Only gets made if include.AR == TRUE
if (generate_c_traj) {
CIrate.Lg.Lcat.qt <- lapply(CIrate.Lg.Lcat.qt, lapply, function(c.qt){
dimnames(c.qt) <- list(percentiles, est.years[-1])
return(c.qt)})
}
}}
## <<<<< RATE MODEL
## Names for probabilities
metDemGT.Lg.Lcat.pr <- lapply(metDemGT.Lg.Lcat.pr, lapply, function(z) {
dimnames(z) <- list("Probability", est.years)
return(z)})
##value<< List of class CIs \code{\link{CIs-class}} with
out <- list(iso.g = countries.all$iso.c, ##<< Included to be consistent with results for aggregates
CIprop.Lg.Lcat.qt = CIprop.Lg.Lcat.qt, ##<< Proportions for Total, Traditional, Modern, Unmet, TotalPlusUnmet, TradPlusUnmet.
## Percentages are included as names in the \code{.qt}-matrix without percentage signs.
CIratio.Lg.Lcat.qt = CIratio.Lg.Lcat.qt,##<<Ratios Met Demand, Met Demand with Modern Methods, Z (unmet/none) and modern/total (R). R and Z might not be included for aggregates.
CIstar.Lg.Lcat.qt = CIstar.Lg.Lcat.qt,##<< Systematic trends for Total etc.
CIcount.Lg.Lcat.qt = CIcount.Lg.Lcat.qt,##<< Counts for same categories as under proportions.
## [MCW-2016-07-12-3] output means
meanProp.Lg.Lcat = meanProp.Lg.Lcat,
meanRatio.Lg.Lcat = meanRatio.Lg.Lcat,
meanStar.Lg.Lcat = meanStar.Lg.Lcat,
changeprop.Lg.Lcat.Ti = changeprop.Lg.Lcat.Ti,##<< Changes in proportions for \code{T = years.change}, \code{i} refers to percentiles and PPPC (the posterior probability of a positive change).
changecount.Lg.Lcat.Ti = changecount.Lg.Lcat.Ti,##<< Changes in counts, same notation as for proportions.
changeratio.Lg.Lcat.Ti = changeratio.Lg.Lcat.Ti,##<< Changes in ratios, same notation as for proportions.
W.Lg.t = W.Lg.t,##<< Number of WRA (*1,000 women)
Zstuff = list(
Zstar.qp = Zstar.qp, ##<< In list \code{Zstuff}: World trend in unmet/none for \code{p.seq}.
## (Note that \code{Zstuff} is not added for aggregates).
Zstar.cqp = Zstar.cqp, ##<< In list \code{Zstuff}: Country trend in unmet/none for \code{p.seq}
p.seq = p.seq ##<< In list \code{Zstuff}: Sequence of total prevalence to calculate Z
)
,metDemGT.Lg.Lcat.pr = metDemGT.Lg.Lcat.pr #prob of demand satisfied > xx%
##, output.dir.countrytrajectories = output.dir.countrytrajectories ##<< Directory with country trajectories.
)
## >>>>> RATE MODEL [MCW-2018-01-03] Copied from Niamh's version
if(ModelFunctionRateModel(write.model.fun)) {
if(include.AR) { #Only gets made if include.AR == TRUE
out <- c(out, list(CIrate.Lg.Lcat.qt = CIrate.Lg.Lcat.qt))
}}
## <<<<< RATE MODEL
return(out)
}
#----------------------------------------------------------------------------------
InternalGetTrajectoriesCountryTot <- function(# Get trajectories for total
### Get trajectories for total by adding AR(1) to main trend
### using posterior samples of \code{eps.ci, rho.tot} and \code{sigma.tot}.
c, ##<< Country index
years.i,##<< Observation years in country
start.year, ##<< First year estimation period
end.year, ##<< Last year estimation period
mcmc.array, ##<< Object
do.country.specific.run = FALSE, ##<< Logical: Do country-specific run?
winbugs.data = NULL, ##<< Object
pstar.st, ##<< Main trend in total for estimation period
nrepeatARsampling,
seed.country, ##<< Seed used for country
write.model.fun
){
eps.is <- matrix(NA, length(years.i), length(c(mcmc.array[,,1])))
for (i in 1:length(years.i)){
eps.is[i,] <- c(mcmc.array[, , paste0("eps.ci[", c, ",", i, "]")])
}
if (!do.country.specific.run) {
rho.tot <- c(mcmc.array[, ,"rho.tot"])
sigma.tot <- c(mcmc.array[, , "sigma.tot"])
} else {
n.s <- prod(dim(mcmc.array)[1:2])
rho.tot <- rep(winbugs.data$rho.tot0, n.s)
sigma.tot <- rep(winbugs.data$sigma.tot0, n.s)
}
if(!ModelFunctionRateModel(write.model.fun)) {
## ---------- LEVEL MODEL >>>>>>>>>>
eps.str <- InternalGetARTrajectories(rho.s = rho.tot,
sigma.s = sigma.tot,
eps.is = eps.is, years.i = years.i,
start.year = start.year, end.year = end.year,
nrepeatARsampling = nrepeatARsampling,
seed.country = seed.country) # change JR, 20140317
#print(dim(eps.str))
pstar.str <- array(rep(pstar.st, nrepeatARsampling), c(dim(pstar.st), nrepeatARsampling)) # change JR, 20140317
logitp.str <- logit(pstar.str) + eps.str
p.str <- 1/(1+exp(-logitp.str))
##value<< matrix with trajectories, dimension (no of posterior samples, length estimation period)
return(p.str)
## <<<<<<<<<< LEVEL MODEL ----------
} else {
## ---------- RATE MODEL >>>>>>>>>>
##Change NC, 20160810
##Need to ensure that 1990 is in the estimation period because
##that is the year in which we fix the level
start.year.temp <- min(1985.5,start.year)
end.year.temp <- max(1995.5,end.year)
years.s<-seq(start.year.temp,end.year.temp)
##Function Change NC, 20160807
eps.str <- InternalGetTotCPARTrajectories(rho.s = rho.tot,
sigma.s = sigma.tot,
eps.is = eps.is, years.i = years.i,
start.year = start.year.temp, end.year = end.year.temp,
nrepeatARsampling = nrepeatARsampling,
seed.country = seed.country) # change JR, 20140317
nyears<-length(years.s)
year.start<-which(years.s==1990.5)
omega.s <- c(mcmc.array[, ,paste0("omega.c[", c, "]")])
setlevel.s <- c(mcmc.array[, , paste0("setlevel.c[", c, "]")])
pmax.s <- c(mcmc.array[, ,paste0("pmax.c[", c, "]")])
nsample<-length(pmax.s)
p.str<-logitp.str<-ls.str<-rate.str<- array(NA, c(nsample, nyears))# Change NC, 20160807
logitp.str[,year.start]<-setlevel.s
p.str[,year.start]<-1/(1+exp(-logitp.str[,year.start]))
for(j in 1:nsample){
for(k in (year.start-1):1)
{
ls.str[j,k]<-logitp.str[j,k+1]-eps.str[j,k,nrepeatARsampling]
if(invlogit(ls.str[j,k])<pmax.s[j])
{
p.str[j,k]<-pmax.s[j]*(invlogit((logit(invlogit(ls.str[j,k])/pmax.s[j])-omega.s[j])))
}
else
{
p.str[j,k]=invlogit(ls.str[j,k])
}
logitp.str[j,k]<-logit(p.str[j,k])
}
for(k in (year.start+1):nyears)
{
if(p.str[j,k-1]<pmax.s[j])
{
logitp.str[j,k]<-logit(pmax.s[j]/(1+exp(-(logit(p.str[j,k-1]/pmax.s[j])+omega.s[j]))))+eps.str[j,k-1,nrepeatARsampling]
}
else
{
logitp.str[j,k]<-logit(p.str[j,k-1])+eps.str[j,k-1,nrepeatARsampling]
}
p.str[j,k]<-1/(1+exp(-logitp.str[j,k]))
}
rate.str[j,1]<-0 #Dummy, removed later
for(k in 2:nyears)
{
rate.str[j,k]<-(logitp.str[j,k]-logitp.str[j,k-1])-eps.str[j,k-1,nrepeatARsampling]
}
}
select <- is.element(seq(start.year.temp, end.year.temp), seq(start.year, end.year))
p.str.final <- p.str[,select]
rate.str.final<-rate.str[,select][,-1]
##value<< matrix with trajectories, dimension (no of posterior samples, length estimation period)
return(list(p.str.final=p.str.final,rate.str.final=rate.str.final))
}
## <<<<<<<<<< RATE MODEL ----------
}
##----------------------------------------------------------------------------------------------
InternalGetTrajectoriesCountryRat <- function(# Get trajectories for modern/total
### Get trajectories for modern/total by adding AR(1) to main trend
### using posterior samples of \code{eta.ci, rho.rat} and \code{sigma.rat}.
c, ##<< Country index
years.i,##<< Observation years in country
start.year, ##<< First year estimation period
end.year, ##<< Last year estimation period
mcmc.array, ##<< Object
do.country.specific.run = FALSE, ##<< Logical: Do country-specific run?
winbugs.data = NULL, ##<< Object
Rstar.st, ##<< Main trend in modern/total for estimation period
nrepeatARsampling,
seed.country ##<< Seed used for country
){
eta.is <- matrix(NA, length(years.i), length(c(mcmc.array[,,1])))
for (i in 1:length(years.i)){
eta.is[i,] <- c(mcmc.array[, , paste0("eta.ci[", c, ",", i, "]")])
}
if (!do.country.specific.run) { # change JR, 20131104
rho.rat <- c(mcmc.array[, ,"rho.rat"])
sigma.rat <- c(mcmc.array[, ,"sigma.rat"])
} else {
n.s <- prod(dim(mcmc.array)[1:2])
rho.rat <- rep(winbugs.data$rho.rat0, n.s)
sigma.rat <- rep(winbugs.data$sigma.rat0, n.s)
}
eta.str <- InternalGetARTrajectories(rho.s = rho.rat,
sigma.s = sigma.rat,
eps.is = eta.is,
years.i = years.i, start.year = start.year, end.year = end.year,
nrepeatARsampling = nrepeatARsampling,
seed.country = seed.country) # change JR, 20140317
Rstar.str <- array(rep(Rstar.st, nrepeatARsampling), c(dim(Rstar.st), nrepeatARsampling)) # change JR, 20140317
logitR.str <- logit(Rstar.str) + eta.str
R.str <- 1/(1+exp(-logitR.str))
##value<< matrix with trajectories, dimension (no of posterior samples, length estimation period)
return(R.str)
}
#----------------------------------------------------------------------------------------------
InternalInternalGetTrajectoriesCountryRatStar <- function(# Get trajectories for main trend in modern/total
### Get trajectories for main trend in modern/total
c, ##<< Country index
years.i,##<< Observation years in country
start.year, ##<< First year estimation period
end.year, ##<< Last year estimation period
mcmc.array ##<< Object
){
# Note: mcmc.array has to be 3D
Romega.s <- c(mcmc.array[, ,paste0("Romega.c[", c, "]")])
RT.s <- c(mcmc.array[, ,paste0("RT.c[", c, "]")])
Rmax.s <- c(mcmc.array[, ,paste0("Rmax.c[", c, "]")])
Rstar.st <- Rmax.s/(1+exp(-Romega.s*(start.year - RT.s)))
for (year in (start.year+1):end.year){
Rstar.st <- cbind(Rstar.st, Rmax.s/(1+exp(-Romega.s*(year - RT.s))))
}
##value<< matrix with trajectories, dimension (no of posterior samples, length estimation period)
return(Rstar.st)
}
#----------------------------------------------------------------------------------
InternalInternalGetTrajectoriesCountryTotStar <-
function(# Get trajectories for main trend in total
### Get trajectories for main trend in total
c, ##<< Country index
years.i,##<< Observation years in country
start.year, ##<< First year estimation period
end.year, ##<< Last year estimation period
mcmc.array ##<< Object
,write.model.fun
){
if(ModelFunctionRateModel(write.model.fun)) {
## >>>>> RATE MODEL [MCW-2018-01-03] Copied from Niamh's version
## Need to ensure that 1990 is in the estimation period because that is the year in which we fix the level
start.year.temp <- min(1985.5,start.year)
end.year.temp <- max(1995.5,end.year)
years.s<-seq(start.year.temp,end.year.temp)
nyears<-length(years.s)
year.start<-which(years.s==1990.5)
omega.s <- c(mcmc.array[, ,paste0("omega.c[", c, "]")])
setlevel.s <- c(mcmc.array[, , paste0("setlevel.c[", c, "]")])
pmax.s <- c(mcmc.array[, ,paste0("pmax.c[", c, "]")])
nsample<-length(pmax.s)
pstar.st<-logitpstar.st<-lsstar.st<- array(NA, c(nsample, nyears)) # change JR, 20140317
logitpstar.st[,year.start]<-setlevel.s
pstar.st[,year.start]<-1/(1+exp(-logitpstar.st[,year.start]))
for(j in 1:nsample){
for(k in (year.start-1):1)
{
lsstar.st[j,k]<-logitpstar.st[j,k+1]
if(invlogit(lsstar.st[j,k])<pmax.s[j])
{
pstar.st[j,k]<-pmax.s[j]*(invlogit((logit(invlogit(lsstar.st[j,k])/pmax.s[j])-omega.s[j])))
}
else
{
pstar.st[j,k]=invlogit(lsstar.st[j,k])
}
logitpstar.st[j,k]<-logit(pstar.st[j,k])
}
for(k in (year.start+1):nyears)
{
if(pstar.st[j,k-1]<pmax.s[j])
{
logitpstar.st[j,k]<-logit(pmax.s[j]/(1+exp(-(logit(pstar.st[j,k-1]/pmax.s[j])+omega.s[j]))))
}
else
{
logitpstar.st[j,k]<-logit(pstar.st[j,k-1])
}
pstar.st[j,k]<-1/(1+exp(-logitpstar.st[j,k]))
}
}
select <- is.element(seq(start.year.temp, end.year.temp), seq(start.year, end.year))
pstar.st.final <- pstar.st[,select]
##value<< matrix with trajectories, dimension (no of posterior samples, length estimation period)
return(pstar.st.final)
## <<<<< RATE MODEL
} else {
## ====> LEVEL MODEL [MCW-2018-01-03] Copied from Niamh's version
omega.s <- c(mcmc.array[, ,paste0("omega.c[", c, "]")])
T.s <- c(mcmc.array[, , paste0("T.c[", c, "]")])
pmax.s <- c(mcmc.array[, ,paste0("pmax.c[", c, "]")])
pstar.st <- pmax.s/(1+exp(-omega.s*(start.year - T.s)))
for (year in (start.year+1):end.year){
pstar.st <- cbind(pstar.st, pmax.s/(1+exp(-omega.s*(year - T.s))))
}
##value<< matrix with trajectories, dimension (no of posterior samples, length estimation period)
return(pstar.st)
}
## ====< LEVEL MODEL
}
#----------------------------------------------------------------------------------------------
InternalGetARTrajectories <- function( # Construct AR(1) trajectories
### Construct posterior sample of AR(1) trajectories, given samples at (unequally spaced) time points
rho.s, ##<< Posterior sample of autoregressive parameter
sigma.s, ##<< Posterior sample of autoregressive sd
eps.is, ##<< Posterior sample of AR(1) for obs years i=1,..., I
years.i, ##<< Obs years i=1,..., I
start.year, ##<< First year where posterior sample is needed
end.year,##<< Last year where posterior sample is needed
nrepeatARsampling, ##<< How many AR-trajectories to sample?
seed.country ##<< Seed used for country
){
### Note: years.i and start/end year are centered at midpoint calendar year
nsample <- length(rho.s)
# Note: some obs years could be before start year or after end year
# Don't throw them out because they inform the eps in start/end year
# Inefficient but simple coding:
# first construct eps from min(years.i,start year) to max(years.i, end year)
# then select the years we need
start.year.temp <- min(years.i,start.year)
end.year.temp <- max(years.i,end.year)
nyears <- end.year.temp - start.year.temp + 1
#eps.st <- matrix(NA, nsample, nyears)
obs.years.indices <- years.i - start.year.temp + 1
n <- length(obs.years.indices)
# create nrepeatARsampling trajectories for each posterior sample
eps.str <- array(NA, c(nsample, nyears, nrepeatARsampling))
# add posterior samples from MCMC
for (i in 1:n){
for (r in 1:nrepeatARsampling){
eps.str[,obs.years.indices[i],r] <- eps.is[i,]
}
}
# SAMPLING STARTS
# create nrepeatARsampling trajectories for each posterior sample
# speed all this up!?
set.seed(seed.country*100) # change JR, 20140317
if (n > 1){ # is there more than 1 obs?
for (j in 1:(n-1)){
if ((obs.years.indices[j+1] - obs.years.indices[j]) > 1){
# are there are eps's missing between the two observed eps's?
for (t in (obs.years.indices[j]+1):(obs.years.indices[j+1]-1)){
A <- rho.s^(2*(obs.years.indices[j+1] - t + 1))
varZ.s <- sigma.s^2/(1-rho.s^2)*(
1 - 1/(1-A)*(rho.s^2 - 2*A + rho.s^(2*(obs.years.indices[j+1]-t)))
)
for (r in 1:nrepeatARsampling){
Zhat.s <- 1/(1-A)*(
eps.str[,t-1,r]*rho.s*(1 - rho.s^(2*(obs.years.indices[j+1]-t))) +
eps.str[,obs.years.indices[j+1],r]*rho.s^(obs.years.indices[j+1]-t)*(1 - rho.s^2))
eps.str[,t,r] <- rnorm(nsample, Zhat.s, sd = sqrt(varZ.s))
}
}
}
}
}
set.seed(seed.country*200) # change JR, 20140317
# add samples at start
if (obs.years.indices[1] > 1){
for (k in seq(obs.years.indices[1]-1,1,-1)){
for (r in 1:nrepeatARsampling){
eps.str[,k,r] <- rnorm(nsample,rho.s*eps.str[,k+1,r], sigma.s)
}
}
}
set.seed(seed.country*300) # change JR, 20140317
# add samples at end
if (obs.years.indices[n] < nyears){
for (k in (obs.years.indices[n]+1):nyears){
for (r in 1:nrepeatARsampling){
eps.str[,k,r] <- rnorm(nsample,rho.s*eps.str[,k-1,r], sigma.s)
}
}
}
# select the corresponding years
# note that 3rd dimension drops out if it's 1
#A <- array(seq(1,12), c(3,4,1))
#A
#array(A[,-1,], dim(A[,-1,]))
#array(A[,-1,], c(dim(A[,-1,]),1))
select <- is.element(seq(start.year.temp, end.year.temp), seq(start.year, end.year))
if (nrepeatARsampling!=1){
eps.str.final <- eps.str[,select,]
} else {
eps.str.final <- array(eps.str[,select,], c(dim(eps.str[,select,]),1))
}
#print(dim(eps.str.final))
# note: the 3rd dimension is still lost when repeat=1
return(eps.str.final)
##value<<
## matrix of size $s$ times $t$ for years (start.year:end.year) time $r$
## where r is the number of repeated AR trajectories for the same posterior sample
}
# eps <- InternalGetARTrajectories(
# rho.s = c(0.5,0.5),
# sigma.s= c(0.5,0.5),
# eps.is = matrix(c(1,1), 1,2),
# years.i = 2,
# start.year = 0,
# end.year = 3,
# nrepeatARsampling=1)
# eps[1,1,1]
##------------------------------------------------------------------------------
####Function added NC, 20160810
InternalGetTotCPARTrajectories <- function( # Construct AR(1) trajectories
### Construct posterior sample of AR(1) trajectories, given samples at (unequally spaced) time points
rho.s, ##<< Posterior sample of autoregressive parameter
sigma.s, ##<< Posterior sample of autoregressive sd
eps.is, ##<< Posterior sample of AR(1) for obs years i=1,..., I
years.i, ##<< Obs years i=1,..., I
start.year, ##<< First year where posterior sample is needed
end.year,##<< Last year where posterior sample is needed
nrepeatARsampling, ##<< How many AR-trajectories to sample?
seed.country ##<< Seed used for country
){ ### Note: years.i and start/end year are centered at midpoint calendar year
nsample <- length(rho.s) # Note: some obs years could be before start year or after end year
# Don't throw them out because they inform the eps in start/end year
# Inefficient but simple coding:
# first construct eps from min(years.i,start year) to max(years.i, end year)
# then select the years we need
start.year.temp <- min(years.i,start.year)
end.year.temp <- max(years.i,end.year)
nyears <- end.year.temp - start.year.temp + 1 #eps.st <- matrix(NA, nsample, nyears)
obs.years.indices <- years.i - start.year.temp + 1
n <- length(obs.years.indices) # create nrepeatARsampling trajectories for each posterior sample
eps.str <- array(NA, c(nsample, nyears, nrepeatARsampling))
# add posterior samples from MCMC.
## (NB: 'nrepeatARsampling' is always '1' so ignore it)
## 'eps.str' is a matrix (essentially) with one row per trajectory
## and one column per year in the estimation period (e.g,. 1970 --
## 2030). The columns which match years at which there were
## observations are filled with the posterior estimates of epsilon
## that JAGS produced. The remaining columns are 'NA' at this
## point.
for (i in 1:n){
for (r in 1:nrepeatARsampling){
eps.str[,obs.years.indices[i],r] <- eps.is[i,]
}
}
# SAMPLING STARTS
# create nrepeatARsampling trajectories for each posterior sample
# speed all this up!?
## This part fills in the first block of 'NA' columns of
## 'eps.str'. These columns are just iid normal samples from N(mu,
## s), where mu is rho.s*[prev. column 'eps.str'] and s is
## 'sigma.s'.
set.seed(seed.country*200) # change JR, 20140317
# add samples at start
if (obs.years.indices[1] > 1){
for (k in seq(obs.years.indices[1]-1,1,-1)){
for (r in 1:nrepeatARsampling){
eps.str[,k,r] <- rnorm(nsample,rho.s*eps.str[,k+1,r], sigma.s)
}
}
}
## This part fills in the last block of 'NA' columns of
## 'eps.str', just like the above.
set.seed(seed.country*300) # change JR, 20140317
# add samples at end
if (obs.years.indices[n] < nyears){
for (k in (obs.years.indices[n]+1):nyears){
for (r in 1:nrepeatARsampling){
eps.str[,k,r] <- rnorm(nsample,rho.s*eps.str[,k-1,r], sigma.s)
}
}
}
select <- is.element(seq(start.year.temp, end.year.temp), seq(start.year, end.year))
if (nrepeatARsampling!=1){
eps.str.final <- eps.str[,select,]
} else {
eps.str.final <- array(eps.str[,select,], c(dim(eps.str[,select,]),1))
}
#print(dim(eps.str.final))
# note: the 3rd dimension is still lost when repeat=1
return(eps.str.final)
##value<<
## matrix of size $s$ times $t$ for years (start.year:end.year) time $r$
## where r is the number of repeated AR trajectories for the same posterior sample
}
#----------------------------------------------------------------------------------
GetParInfo <- function(# Get percentiles of parameters of logistics for total and ratio modern/total
### Get (2.5%, 50%, 97.5%) percentiles of parameters of logistics for total and ratio modern/total
mcmc.array,##<< Object of class \code{\link{mcmc.array}}
parnames.list, ##<< nn
winbugs.data, ##<< Object of class \code{\link{winbugs.data}}
country.info ##<< Object of class \code{\link{country.info}}
){
percentiles = c(0.025,0.5,0.975)
percentiles.names = c("2.5%", "50%", "97.5%")
## [MCW-2016-08-26-7] Take number of countries from 'country.info' as this now might include countries with no data.
par.ciq <- array(NA, c(nrow(country.info), length(parnames.list$parnames.c), 3))
for (c in 1:nrow(country.info)){
#[MCW-2016-08-26-8] Again, take number of countries (upper limit of loop) from 'country.info' as this now might include countries with no data.
i <- 0
for (parname in paste0(parnames.list$parnames.c, "[", c, "]")){
if(parname %in% dimnames(mcmc.array)[[3]]) { #Extra check [MCW-2018-01-03]
i <- i+1
par.ciq[c,i,] <- quantile(c(mcmc.array[,,parname]), percentiles)
}}
}
dimnames(par.ciq) <- list(country.info$name.c, parnames.list$parnames.c, percentiles.names)
par.ciq[,"RT.c",] <- par.ciq[,"RT.c",]
## >>>>> LEVEL MODEL [MCW-2018-01-03]
if(isTRUE("T.c" %in% parnames.list$parnames.c)) {
par.ciq[,"T.c",] <- par.ciq[,"T.c",]
}
## <<<<< LEVEL MODEL
##value<< 3-dimensional array with entries (no of countries, 6 logistic parameters, percentiles)
## (with names for each dimension)
return(par.ciq)
}
#----------------------------------------------------------------------
# The End!
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.