diff --git a/DESCRIPTION b/DESCRIPTION index 1e057f2..a71245b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,10 +1,10 @@ -Package: eppspectrum +Package: eppasm Title: Age-structured EPP Model for HIV Epidemic Estimates -Version: 0.1.1 +Version: 0.4.0 Authors@R: person("Jeff", "Eaton", email = "jeffrey.eaton@imperial.ac.uk", role = c("aut", "cre")) Description: What the package does (one paragraph). -Depends: R (>= 3.1.0), epp (>= 0.3), -Imports: fastmatch (>= 1.1), abind (>= 1.4) +Depends: R (>= 3.1.0), +Imports: epp (>= 0.3.3), fastmatch (>= 1.1), abind (>= 1.4), mgcv (>= 1.8), mvtnorm LinkingTo: BH License: GPL-3 Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index 6c62efe..a7b603d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,3 +1,3 @@ # Generated by roxygen2: fake comment so roxygen2 overwrites silently. exportPattern("^[^\\.]") -useDynLib(eppspectrum, checkBoostAsserts, spectrumC) +useDynLib(eppasm, checkBoostAsserts, spectrumC) diff --git a/NEWS.md b/NEWS.md index a15d42d..27e2d72 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,70 @@ - Update to interface with `epp v0.3` which implements ANC routine testing (ANC-RT) likelihood in EPP 2017. + # eppspectrum 0.1.1 - Add option to use .ep5 file inputs instead of .DP file when preparing fit from PJNZ file. (use_ep5=FALSE by default.) -- update prepare_spec_fit() to not use popadjust if EPP projection has a single population. \ No newline at end of file +- update prepare_spec_fit() to not use popadjust if EPP projection has a single population. + +# eppspectrum 0.1.3 + +- EPP model setup occurs in fitmod() +- Allow order of spline model penalty to vary (fp$rtpenord) +- Allow number of knots to vary (fp$numKnots) +- Return spline coefficients in fnCreateParam() + +# eppspectrum 0.1.5 + +- Implemented O-spline model (penalized B-spline) using mgcv to construct +- Added `r0logiotaratio` option to estimate ratio of r(t0) and log of initial seed, reduces correation. Not set as default. + +# eppspectrum 0.1.6 + +- Bug fix: add check in ll_hhage_binom() that ldbinom() does not return NaN. +- Bug fix: in create_spectrum_fixpar(), handle case where ART initiation starts in different years for men and women. + + +# eppasm 0.3.0 + +- Rename package `eppasm`. +- Add IMIS function to eppasm package. In this version of IMIS, at each iteration a new mixture component is constructed either centered on input with greatest weight or based on optimizer. Allows optimizers to be run at arbitrary iterations, but doesn't implment multiple optimizers which might still be usful. Covariance for optimizer mixture component when Hessian is degenerate still needs further work. + +- Change from dependency to imports epp package. +- Add ANC-RT data to aggregate national fits (prepare_national_fit() and create_aggr_input()). + +- Implement dsamp() to calculate density for initial IMIS samples. This allows different initial sampling density from prior distribution. + +- Specify knot locations for o-spline model +- Estimate HIV+:HIV- FRR adjustment. +- Specify knot locations for o-spline model + +- Add functions to read country and subnational region from Spectrum PJN file. + +# eppasm 0.3.2 + +- Integrate random effects variance parameter out of likelihood. +- Implement hybrid r-spline and RW model for r(t). +- Implement logistic model for log r(t) (rlogistic), and version with random walk (rlogistic_rw). +- Add optimization option to fitmod(). + +- Add option to fit without site-level ANC data. + +# eppasm 0.3.3 + +- Modularize code for calculating new infections. + +- Implement age 15 entrant prevalence and ART coverage inputs. +- Implement logit transformation for sampling from uniform logiota prior distribution. +- Set age IRR penalty variance at a fixed constant value (9003) + +- Implement piecewise-linear time-varying M:F incidence/transmission ratio + and 15-24 incidence rate ratio. Knots fixed at 2002, 2007, and 2012. +- Modularize code for incidence rate ratio parameterization, now in infections.R. + +- Updated default IRR priors to informative priors based on fits countries with several surveys. +- Add function to generate summary model outputs + + +# eppasm 0.4.0 +- Add annual direct incidence input option. \ No newline at end of file diff --git a/R/aggregate-fits.R b/R/aggregate-fits.R new file mode 100644 index 0000000..8d639a6 --- /dev/null +++ b/R/aggregate-fits.R @@ -0,0 +1,59 @@ +create_aggr_input <- function(inputlist){ + + val <- inputlist[[1]] + + eppdlist <- lapply(inputlist, attr, "eppd") + + ## Only keep intersecting years + anc.prev.list <- lapply(eppdlist, "[[", "anc.prev") + anc.prev.list <- lapply(anc.prev.list, function(x) x[,Reduce(intersect, lapply(anc.prev.list, colnames))]) + + anc.n.list <- lapply(eppdlist, "[[", "anc.n") + anc.n.list <- lapply(anc.n.list, function(x) x[,Reduce(intersect, lapply(anc.n.list, colnames))]) + + ancrtsite.prev.list <- lapply(eppdlist, "[[", "ancrtsite.prev") + ancrtsite.prev.list <- lapply(ancrtsite.prev.list, function(x) x[,Reduce(intersect, lapply(ancrtsite.prev.list, colnames))]) + + ancrtsite.n.list <- lapply(eppdlist, "[[", "ancrtsite.n") + ancrtsite.n.list <- lapply(ancrtsite.n.list, function(x) x[,Reduce(intersect, lapply(ancrtsite.n.list, colnames))]) + + + ## aggregate census data across regions + ancrtcens <- do.call(rbind, lapply(eppdlist, "[[", "ancrtcens")) + if(!is.null(ancrtcens) && nrow(ancrtcens)){ + ancrtcens$x <- ancrtcens$prev * ancrtcens$n + ancrtcens <- aggregate(cbind(x,n) ~ year, ancrtcens, sum) + ancrtcens$prev <- ancrtcens$x / ancrtcens$n + ancrtcens <- ancrtcens[c("year", "prev", "n")] + } + + attr(val, "eppd") <- list(anc.used = do.call(c, lapply(eppdlist, "[[", "anc.used")), + anc.prev = do.call(rbind, anc.prev.list), + anc.n = do.call(rbind, anc.n.list), + ancrtsite.prev = do.call(rbind, ancrtsite.prev.list), + ancrtsite.n = do.call(rbind, ancrtsite.n.list), + ancrtcens = ancrtcens) + + artnumperc <- !attr(inputlist[[1]], "specfp")$art15plus_isperc + artnumlist <- lapply(lapply(inputlist, attr, "specfp"), "[[", "art15plus_num") + + art15plus_num <- artnumlist[[1]] + art15plus_num[artnumperc] <- Reduce("+", lapply(artnumlist, "[", artnumperc)) + + attr(val, "specfp")$art15plus_num <- art15plus_num + + return(val) +} + + +fnAddHHSLikDat <- function(obj){ + objcountry <- attr(obj, "country") + fp <- attr(obj, "specfp") + anchor.year <- as.integer(floor(min(fp$proj.steps))) + + attr(obj, "eppd")$hhs <- subset(prev.15to49.nat, country==objcountry) + attr(obj, "eppd")$hhsage <- subset(prev.agesex.nat, country==objcountry) + ## attr(obj, "eppd")$sibmx <- subset(sib.mx.tips, country==objcountry) + + return(obj) +} diff --git a/R/cluster-functions.R b/R/cluster-functions.R new file mode 100644 index 0000000..d3ef832 --- /dev/null +++ b/R/cluster-functions.R @@ -0,0 +1,5 @@ + +pick_maxlpd <- function(set){set <- set[!sapply(set, is.null)]; set[[which.max(sapply(set, function(x) tail(x$stat,1)[1]))]]} +get_imisiter <- function(x) nrow(x$stat) +get_logmargpost <- function(x) tail(x$stat, 1)[1] +get_nunique <- function(x) tail(x$stat, 1)[2] diff --git a/R/directincid.R b/R/directincid.R new file mode 100644 index 0000000..cf92ec1 --- /dev/null +++ b/R/directincid.R @@ -0,0 +1,48 @@ +calc_entrantprev <- function(specres){ + ageprev1 <- function(specres, str){colSums(specres$hivpop[str,,,drop=FALSE],,2) / colSums(specres$totpop[str,,,drop=FALSE],,2)} + prev14 <- ageprev1(specres, "14") + prev13 <- ageprev1(specres, "13") + Sx <- c(0, prev14[-1] / prev13[-length(prev13)]) # assume that survival from age 14 to 15 is the same as 13 to 14 + Sx <- ifelse(is.na(Sx), 0, Sx) + return(Sx*prev14) +} + +calc_entrantartcov <- function(specres){ + ## Assume uniform ART coverage among age 10-14 + artcov <- with(specres, ((artnum.f+artnum.m)/(hivnum.f+hivnum.m))["10-15",]) + artcov <- ifelse(is.nan(artcov), 0, artcov) + artcov +} + +create_specfp <- function(pjnz, upd.path=NULL, hiv_steps_per_year = 10L, use_ep5=FALSE){ + + ## demographic inputs + if(!is.null(upd.path)) + demp <- read_demog_param(upd.path) # from UPD file + else + demp <- read_specdp_demog_param(pjnz, use_ep5=use_ep5) # from DP file or ep5 file + + ## HIV projection parameters (most AIM adult parameters) + projp <- read_hivproj_param(pjnz, use_ep5=use_ep5) + + ## HIV projection results + specres <- read_hivproj_output(pjnz) + + specfp <- create_spectrum_fixpar(projp, demp, hiv_steps_per_year= hiv_steps_per_year) + specfp$entrantprev <- calc_entrantprev(specres) + specfp$entrantartcov <- calc_entrantartcov(specres) + + attr(specfp, "country") <- read_country(pjnz) + attr(specfp, "country") <- read_country(pjnz) + attr(specfp, "region") <- read_region(pjnz) + + return(specfp) +} + +prepare_directincid <- function(pjnz){ + specfp <- create_specfp(pjnz) + specfp$eppmod <- "directincid" + specfp$incidinput <- read_incid_input(pjnz) + specfp$incidpopage <- attr(specfp$incidinput, "incidpopage") + return(specfp) +} diff --git a/R/fit-model.R b/R/fit-model.R index dbeabca..4b092cf 100644 --- a/R/fit-model.R +++ b/R/fit-model.R @@ -7,11 +7,11 @@ prepare_spec_fit <- function(pjnz, proj.end=2016.5, popadjust = NULL, popupdate=TRUE, use_ep5=FALSE){ ## epp - eppd <- read_epp_data(pjnz) - epp.subp <- read_epp_subpops(pjnz) - epp.input <- read_epp_input(pjnz) + eppd <- epp::read_epp_data(pjnz) + epp.subp <- epp::read_epp_subpops(pjnz) + epp.input <- epp::read_epp_input(pjnz) - epp.subp.input <- fnCreateEPPSubpops(epp.input, epp.subp, eppd) + epp.subp.input <- epp::fnCreateEPPSubpops(epp.input, epp.subp, eppd) ## spectrum demp <- read_specdp_demog_param(pjnz, use_ep5=use_ep5) @@ -39,11 +39,14 @@ prepare_spec_fit <- function(pjnz, proj.end=2016.5, popadjust = NULL, popupdate= mapply(function(set, value){ attributes(set)[[attrib]] <- value; set}, obj, value.lst) val <- set.list.attr(val, "eppd", eppd) - val <- set.list.attr(val, "eppfp", lapply(epp.subp.input, fnCreateEPPFixPar, proj.end = proj.end)) + val <- set.list.attr(val, "eppfp", lapply(epp.subp.input, epp::fnCreateEPPFixPar, proj.end = proj.end)) val <- set.list.attr(val, "specfp", specfp.subp) val <- set.list.attr(val, "country", attr(eppd, "country")) val <- set.list.attr(val, "region", names(eppd)) + attr(val, "country") <- read_country(pjnz) + attr(val, "region") <- read_region(pjnz) + return(val) } @@ -93,7 +96,7 @@ create_subpop_specfp <- function(projp, demp, eppd, epp_t0=setNames(rep(1975, le agesexpop <- demp$basepop ## Iteratively rescale population until difference < 0.1% - while(any(abs(rowSums(subpops,,3) / agesexpop - 1.0) > 0.001)){ + while(any(abs(rowSums(subpops,,3) / agesexpop - 1.0) > 0.001, na.rm=TRUE)){ ## Scale supopulation size to match national population by age/sex subpops <- subpops <- sweep(subpops, 1:3, agesexpop / rowSums(subpops,,3), "*") @@ -139,7 +142,7 @@ create_subpop_specfp <- function(projp, demp, eppd, epp_t0=setNames(rep(1975, le ## Prepare national fit. Aggregates ANC data from regional EPP files. -prepare_national_fit <- function(pjnz, upd.path=NULL, proj.end=2013.5, hiv_steps_per_year = 10L, use_ep5=use_ep5){ +prepare_national_fit <- function(pjnz, upd.path=NULL, proj.end=2013.5, hiv_steps_per_year = 10L, use_ep5=FALSE){ ## spectrum if(!is.null(upd.path)) @@ -152,34 +155,43 @@ prepare_national_fit <- function(pjnz, upd.path=NULL, proj.end=2013.5, hiv_steps specfp <- create_spectrum_fixpar(projp, demp, proj_end = as.integer(proj.end), time_epi_start = epp_t0[1], hiv_steps_per_year= hiv_steps_per_year) # Set time_epi_start to match first EPP population ## epp - eppd <- read_epp_data(pjnz) - epp.subp <- read_epp_subpops(pjnz) - epp.input <- read_epp_input(pjnz) + eppd <- epp::read_epp_data(pjnz) + epp.subp <- epp::read_epp_subpops(pjnz) + epp.input <- epp::read_epp_input(pjnz) ## output val <- setNames(vector("list", length(eppd)), names(eppd)) val <- list() + ## aggregate census data across regions + ancrtcens <- do.call(rbind, lapply(eppd, "[[", "ancrtcens")) + if(!is.null(ancrtcens) && nrow(ancrtcens)){ + ancrtcens$x <- ancrtcens$prev * ancrtcens$n + ancrtcens <- aggregate(cbind(x,n) ~ year, ancrtcens, sum) + ancrtcens$prev <- ancrtcens$x / ancrtcens$n + ancrtcens <- ancrtcens[c("year", "prev", "n")] + } + attr(val, "eppd") <- list(anc.used = do.call(c, lapply(eppd, "[[", "anc.used")), anc.prev = do.call(rbind, lapply(eppd, "[[", "anc.prev")), - anc.n = do.call(rbind, lapply(eppd, "[[", "anc.n"))) - attr(val, "likdat") <- list(anclik.dat = with(attr(val, "eppd"), anclik::fnPrepareANCLikelihoodData(anc.prev, anc.n, anc.used, projp$yr_start))) - attr(val, "likdat")$lastdata.idx <- max(unlist(attr(val, "likdat")$anclik.dat$anc.idx.lst), - unlist(lapply(lapply(lapply(eppd, "[[", "hhs"), epp:::fnPrepareHHSLikData, projp$yr_start), "[[", "idx"))) - attr(val, "likdat")$firstdata.idx <- min(unlist(attr(val, "likdat")$anclik.dat$anc.idx.lst), - unlist(lapply(lapply(lapply(eppd, "[[", "hhs"), epp:::fnPrepareHHSLikData, projp$yr_start), "[[", "idx"))) + anc.n = do.call(rbind, lapply(eppd, "[[", "anc.n")), + ancrtsite.prev = do.call(rbind, lapply(eppd, "[[", "ancrtsite.prev")), + ancrtsite.n = do.call(rbind, lapply(eppd, "[[", "ancrtsite.n")), + ancrtcens = ancrtcens) + attr(val, "specfp") <- specfp - attr(val, "eppfp") <- fnCreateEPPFixPar(epp.input, proj.end = proj.end) + attr(val, "eppfp") <- epp::fnCreateEPPFixPar(epp.input, proj.end = proj.end) attr(val, "country") <- attr(eppd, "country") return(val) } -fitmod <- function(obj, ..., epp=FALSE, B0 = 1e5, B = 1e4, B.re = 3000, number_k = 500, D=0, opt_iter=0, - sample.prior=epp:::sample.prior, - prior=epp:::prior, - likelihood=epp:::likelihood){ +fitmod <- function(obj, ..., epp=FALSE, B0 = 1e5, B = 1e4, B.re = 3000, number_k = 500, opt_iter=0, + sample_prior=eppasm:::sample.prior, + prior=eppasm:::prior, + likelihood=eppasm:::likelihood, + optfit=FALSE, opt_method="BFGS", opt_init=NULL, opt_maxit=1000, opt_diffstep=1e-3){ ## ... : updates to fixed parameters (fp) object to specify fitting options @@ -205,21 +217,98 @@ fitmod <- function(obj, ..., epp=FALSE, B0 = 1e5, B = 1e4, B.re = 3000, number_k } else if(!is.null(eppd$ancrtcens) && is.null(eppd$ancrtsite.prev)){ fp$ancrt <- "census" fp$ancrtsite.beta <- 0 - } else if(!is.null(eppd$ancrtcens) && is.null(eppd$ancrtsite.prev)) + } else if(is.null(eppd$ancrtcens) && !is.null(eppd$ancrtsite.prev)) fp$ancrt <- "site" else fp$ancrt <- "both" - likdat <- fnCreateLikDat(eppd, floor(fp$proj.steps[1])) - + if(epp) + eppd$hhsage <- eppd$sibmx <- NULL + + likdat <- prepare_likdat(eppd, fp) + fp$ancsitedata <- as.logical(length(likdat$anclik.dat$W.lst)) + + if(fp$eppmod %in% c("rhybrid", "logrw", "rlogistic_rw")){ # THIS IS REALLY MESSY, NEED TO REFACTOR CODE + fp$SIM_YEARS <- as.integer(likdat$lastdata.idx) + fp$proj.steps <- seq(fp$ss$proj_start+0.5, fp$ss$proj_start-1+fp$SIM_YEARS+0.5, by=1/fp$ss$hiv_steps_per_year) + } else + fp$SIM_YEARS <- fp$ss$PROJ_YEARS + + + ## Prepare the EPP model + tsEpidemicStart <- if(epp) fp$tsEpidemicStart else fp$ss$time_epi_start+0.5 + if(!exists("eppmod", fp) || fp$eppmod %in% c("rspline", "logrspline")) + fp <- prepare_rspline_model(fp, tsEpidemicStart=tsEpidemicStart) + else if(fp$eppmod %in% c("ospline", "logospline")) + fp <- prepare_ospline_model(fp, tsEpidemicStart=tsEpidemicStart) + else if(fp$eppmod == "rtrend") + fp <- prepare_rtrend_model(fp) + else if(fp$eppmod == "rhybrid") + fp <- prepare_hybrid_r(fp) + else if(fp$eppmod == "logrw") + fp <- prepare_logrw(fp) + else if(fp$eppmod == "rlogistic_rw") + fp <- prepare_rlogistic_rw(fp) + + fp$logitiota = TRUE + + ## Prepare the incidence model + if(exists("incidmod", where=fp) && fp$incidmod == "transm"){ + if(!exists("relsexact_cd4cat", where=fp)) + fp$relsexact_cd4cat <- c(1.0, 0.92, 0.76, 0.76, 0.55, 0.55, 0.55) + } else + fp$incidmod <- "eppspectrum" + + fp <- prepare_irr_model(fp) + + ## Fit using optimization + if(optfit){ + optfn <- function(theta, fp, likdat) lprior(theta, fp) + ll(theta, fp, likdat) + if(is.null(opt_init)){ + X0 <- sample_prior(B0, fp) + lpost0 <- likelihood(X0, fp, likdat, log=TRUE) + prior(X0, fp, log=TRUE) + opt_init <- X0[which.max(lpost0)[1],] + } + opt <- optim(opt_init, optfn, fp=fp, likdat=likdat, method=opt_method, control=list(fnscale=-1, trace=4, maxit=opt_maxit, ndeps=rep(opt_diffstep, length(opt_init)))) + opt$fp <- fp + opt$likdat <- likdat + opt$param <- fnCreateParam(opt$par, fp) + opt$mod <- simmod(update(fp, list=opt$param)) + if(epp) + class(opt) <- "eppopt" + else + class(opt) <- "specopt" + + return(opt) + } + ## Fit using optimization + if(optfit){ + optfn <- function(theta, fp, likdat) lprior(theta, fp) + ll(theta, fp, likdat) + if(is.null(opt_init)){ + X0 <- sample_prior(B0, fp) + lpost0 <- likelihood(X0, fp, likdat, log=TRUE) + prior(X0, fp, log=TRUE) + opt_init <- X0[which.max(lpost0)[1],] + } + opt <- optim(opt_init, optfn, fp=fp, likdat=likdat, method=opt_method, control=list(fnscale=-1, trace=4, maxit=1e3)) + opt$fp <- fp + opt$likdat <- likdat + opt$param <- fnCreateParam(opt$par, fp) + opt$mod <- simmod(update(fp, list=opt$param)) + if(epp) + class(opt) <- "eppopt" + else + class(opt) <- "specopt" + + return(opt) + } ## If IMIS fails, start again fit <- try(stop(""), TRUE) while(inherits(fit, "try-error")){ start.time <- proc.time() - fit <- try(IMIS(B0, B, B.re, number_k, D, opt_iter, fp=fp, likdat=likdat, - sample.prior=sample.prior, prior=prior, likelihood=likelihood)) + fit <- try(imis(B0, B, B.re, number_k, opt_iter, fp=fp, likdat=likdat, + sample_prior=sample.prior, prior=prior, likelihood=likelihood)) fit.time <- proc.time() - start.time } fit$fp <- fp @@ -237,24 +326,29 @@ fitmod <- function(obj, ..., epp=FALSE, B0 = 1e5, B = 1e4, B.re = 3000, number_k ## simulate incidence and prevalence -simfit.specfit <- function(fit, rwproj=fit$fp$eppmod == "rspline", ageprevdat=FALSE, agegr3=FALSE, aidsdeaths=FALSE, pregprev=TRUE, entrantprev=TRUE){ - fit$param <- lapply(seq_len(nrow(fit$resample)), function(ii) fnCreateParam(fit$resample[ii,], fit$fp)) +simfit.specfit <- function(fit, rwproj=fit$fp$eppmod == "rspline", ageprevdat=FALSE, agegr3=FALSE, mxoutputs=FALSE, aidsdeaths=FALSE, pregprev=TRUE, entrantprev=TRUE, mod.list=NULL){ - if(rwproj){ - if(exists("eppmod", where=fit$fp) && fit$fp$eppmod == "rtrend") - stop("Random-walk projection is only used with r-spline model") + if(is.null(mod.list)){ + fit$param <- lapply(seq_len(nrow(fit$resample)), function(ii) fnCreateParam(fit$resample[ii,], fit$fp)) + + if(rwproj){ + if(exists("eppmod", where=fit$fp) && fit$fp$eppmod == "rtrend") + stop("Random-walk projection is only used with r-spline model") - ## fit$rvec.spline <- sapply(fit$param, "[[", "rvec") - firstidx <- which(fit$fp$proj.steps == fit$fp$tsEpidemicStart) - lastidx <- (fit$likdat$lastdata.idx-1)*fit$fp$ss$hiv_steps_per_year+1 + ## fit$rvec.spline <- sapply(fit$param, "[[", "rvec") + firstidx <- which(fit$fp$proj.steps == fit$fp$tsEpidemicStart) + lastidx <- (fit$likdat$lastdata.idx-1)*fit$fp$ss$hiv_steps_per_year+1 + + ## replace rvec with random-walk simulated rvec + fit$param <- lapply(fit$param, function(par){par$rvec <- epp:::sim_rvec_rwproj(par$rvec, firstidx, lastidx, 1/fit$fp$ss$hiv_steps_per_year); par}) + } - ## replace rvec with random-walk simulated rvec - fit$param <- lapply(fit$param, function(par){par$rvec <- epp:::sim_rvec_rwproj(par$rvec, firstidx, lastidx, 1/fit$fp$ss$hiv_steps_per_year); par}) + fp.list <- lapply(fit$param, function(par) update(fit$fp, list=par)) + mod.list <- lapply(fp.list, simmod) + } else { + fp.list <- rep(fit$fp, length(mod.list)) } - fp.list <- lapply(fit$param, function(par) update(fit$fp, list=par)) - mod.list <- lapply(fp.list, simmod) - fit$rvec <- sapply(mod.list, attr, "rvec_ts") fit$prev <- sapply(mod.list, prev) fit$incid <- mapply(incid, mod = mod.list, fp = fp.list) @@ -278,11 +372,60 @@ simfit.specfit <- function(fit, rwproj=fit$fp$eppmod == "rspline", ageprevdat=FA if(aidsdeaths) fit$aidsdeaths <- sapply(lapply(mod.list, attr, "hivdeaths"), colSums, dims=2) - + + if(mxoutputs){ + fit$agemx <- abind::abind(lapply(mod.list, agemx), rev.along=0) + dimnames(fit$agemx) <- with(fit$fp$ss, list(age=with(fit$fp$ss, AGE_START+0:(pAG-1)), sex=c("male", "female"), proj_start + 0:(PROJ_YEARS-1), NULL)) + + fit$natagemx <- abind::abind(lapply(mod.list, agemx, nonhiv=TRUE), rev.along=0) + dimnames(fit$natagemx) <- with(fit$fp$ss, list(age=with(fit$fp$ss, AGE_START+0:(pAG-1)), sex=c("male", "female"), proj_start + 0:(PROJ_YEARS-1), NULL)) + + fit$q4515 <- abind::abind(lapply(mod.list, calc_nqx, fp=fit$fp, n=45, x=15), rev.along=0) + dimnames(fit$q4515) <- with(fit$fp$ss, list(sex=c("male", "female"), proj_start + 0:(PROJ_YEARS-1), NULL)) + + fit$q3515 <- abind::abind(lapply(mod.list, calc_nqx, fp=fit$fp, n=35, x=15), rev.along=0) + dimnames(fit$q3515) <- with(fit$fp$ss, list(sex=c("male", "female"), proj_start + 0:(PROJ_YEARS-1), NULL)) + + fit$natq4515 <- abind::abind(lapply(mod.list, calc_nqx, fp=fit$fp, n=45, x=15, nonhiv=TRUE), rev.along=0) + dimnames(fit$natq4515) <- with(fit$fp$ss, list(sex=c("male", "female"), proj_start + 0:(PROJ_YEARS-1), NULL)) + + fit$natq3515 <- abind::abind(lapply(mod.list, calc_nqx, fp=fit$fp, n=35, x=15, nonhiv=TRUE), rev.along=0) + dimnames(fit$natq3515) <- with(fit$fp$ss, list(sex=c("male", "female"), proj_start + 0:(PROJ_YEARS-1), NULL)) + } return(fit) } +simfit.eppfit <- function(fit, rwproj=fit$fp$eppmod == "rspline", pregprev=TRUE){ + + fit$param <- lapply(seq_len(nrow(fit$resample)), function(ii) fnCreateParam(fit$resample[ii,], fit$fp)) + + if(rwproj){ + if(exists("eppmod", where=fit$fp) && fit$fp$eppmod == "rtrend") + stop("Random-walk projection is only used with r-spline model") + + fit$rvec.spline <- sapply(fit$param, "[[", "rvec") + firstidx <- which(fit$fp$proj.steps == fit$fp$tsEpidemicStart) + lastidx <- (fit$likdat$lastdata.idx-1)/fit$fp$dt+1 + + ## replace rvec with random-walk simulated rvec + fit$param <- lapply(fit$param, function(par){par$rvec <- sim_rvec_rwproj(par$rvec, firstidx, lastidx, fit$fp$dt); par}) + } + + fp.list <- lapply(fit$param, function(par) update(fit$fp, list=par)) + mod.list <- lapply(fp.list, simmod) + + fit$rvec <- sapply(mod.list, attr, "rvec") + fit$prev <- sapply(mod.list, prev) + fit$incid <- mapply(incid, mod = mod.list, fp = fp.list) + fit$popsize <- sapply(mod.list, pop15to49) + + if(pregprev) + fit$pregprev <- mapply(fnPregPrev, mod.list, fp.list) + + return(fit) +} + sim_mod_list <- function(fit, rwproj=fit$fp$eppmod == "rspline"){ @@ -306,24 +449,30 @@ sim_mod_list <- function(fit, rwproj=fit$fp$eppmod == "rspline"){ mod.list <- lapply(fp.list, simmod) ## strip unneeded attributes to preserve memory - mod.list <- lapply(mod.list, function(mod){ attributes(mod)[!names(attributes(mod)) %in% c("class", "dim", "infections", "hivdeaths", "natdeaths", "rvec", "popadjust")] <- NULL; mod}) + + keep <- c("class", "dim", "infections", "hivdeaths", "natdeaths", "hivpop", "artpop", "rvec", "popadjust") + mod.list <- lapply(mod.list, function(mod){ attributes(mod)[!names(attributes(mod)) %in% keep] <- NULL; mod}) return(mod.list) } ## ' aggregate lists of model fits aggr_specfit <- function(fitlist, rwproj=sapply(fitlist, function(x) x$fp$eppmod) == "rspline"){ - allmod <- parallel::mcmapply(sim_mod_list, fitlist, rwproj, SIMPLIFY=FALSE) + allmod <- mapply(sim_mod_list, fitlist, rwproj, SIMPLIFY=FALSE) modaggr <- lapply(do.call(mapply, c(FUN=list, allmod, SIMPLIFY=FALSE)), Reduce, f="+") ## infectionsaggr <- lapply(do.call(mapply, c(FUN=list, lapply(allmod, lapply, attr, "infections"), SIMPLIFY=FALSE)), Reduce, f="+") hivdeathsaggr <- lapply(do.call(mapply, c(FUN=list, lapply(allmod, lapply, attr, "hivdeaths"), SIMPLIFY=FALSE)), Reduce, f="+") natdeathsaggr <- lapply(do.call(mapply, c(FUN=list, lapply(allmod, lapply, attr, "natdeaths"), SIMPLIFY=FALSE)), Reduce, f="+") + hivpopaggr <- lapply(do.call(mapply, c(FUN=list, lapply(allmod, lapply, attr, "hivpop"), SIMPLIFY=FALSE)), Reduce, f="+") + artpopaggr <- lapply(do.call(mapply, c(FUN=list, lapply(allmod, lapply, attr, "artpop"), SIMPLIFY=FALSE)), Reduce, f="+") ## modaggr <- mapply("attr<-", modaggr, "infections", infectionsaggr, SIMPLIFY=FALSE) modaggr <- mapply("attr<-", modaggr, "hivdeaths", hivdeathsaggr, SIMPLIFY=FALSE) modaggr <- mapply("attr<-", modaggr, "natdeaths", natdeathsaggr, SIMPLIFY=FALSE) + modaggr <- mapply("attr<-", modaggr, "hivpop", hivpopaggr, SIMPLIFY=FALSE) + modaggr <- mapply("attr<-", modaggr, "artpop", artpopaggr, SIMPLIFY=FALSE) ## modaggr <- mapply("attr<-", modaggr, "prev15to49", lapply(modaggr, calc_prev15to49, fitlist[[1]]$fp), SIMPLIFY=FALSE) modaggr <- mapply("attr<-", modaggr, "incid15to49", lapply(modaggr, calc_incid15to49, fitlist[[1]]$fp), SIMPLIFY=FALSE) @@ -332,14 +481,36 @@ aggr_specfit <- function(fitlist, rwproj=sapply(fitlist, function(x) x$fp$eppmod return(modaggr) } -calc_prev15to49 <- function(mod, fp){ - colSums(mod[fp$ss$p.age15to49.idx,,2,],,2)/colSums(mod[fp$ss$p.age15to49.idx,,,],,3) -} -calc_incid15to49 <- function(mod, fp){ - c(0, colSums(attr(mod, "infections")[fp$ss$p.age15to49.idx,,-1],,2)/colSums(mod[fp$ss$p.age15to49.idx,,1,-fp$ss$PROJ_YEARS],,2)) -} +#### Parameters #### -calc_pregprev <- function(mod, fp){ - warning("not yet implemented") -} +frr_cd4_stage <- rbind(c(2.2092601, 1.0498458, 0.7909242, 0.7457322, 0.6370297, 0.5784465, 0.5784465, 0.5784465), +c(1.9957325, 0.9476719, 0.7137200, 0.6728340, 0.5747181, 0.5218241, 0.5218241, 0.5218241), +c(1.6978419, 0.8060810, 0.6068454, 0.5719130, 0.4884228, 0.4435285, 0.4435285, 0.4435285), +c(1.2546568, 0.5960523, 0.4484867, 0.4226725, 0.3609799, 0.3276454, 0.3276454, 0.3276454), +c(0.8321120, 0.3955791, 0.2974010, 0.2802773, 0.2391743, 0.2170073, 0.2170073, 0.2170073), +c(0.6498167, 0.3092457, 0.2323928, 0.2188925, 0.1869424, 0.1695819, 0.1695819, 0.1695819), +c(0.6196790, 0.2947683, 0.2214894, 0.2086464, 0.1781029, 0.1616417, 0.1616417, 0.1616417)) + +frr_art_stage <- array(0, c(3,7,8)) +frr_art_stage[1,,] <- frr_cd4_stage +frr_art_stage[2,,] <- frr_cd4_stage +frr_art_stage[3,,] <- 0.8 + + +frr_cd4_stage1 <- frr_cd4_stage +frr_art_stage1 <- frr_art_stage +frr_art_stage1[3,,] <- 1.0 + +frr_cd4_default <- rbind(c(1.2, 1.2, 0.76, 0.71, 0.65, 0.59, 0.53, 0.47), + c(1.2, 1.2, 0.76, 0.71, 0.65, 0.59, 0.53, 0.47), + c(1.2, 1.2, 0.76, 0.71, 0.65, 0.59, 0.53, 0.47), + c(1.2, 1.2, 0.76, 0.71, 0.65, 0.59, 0.53, 0.47), + c(1.2, 1.2, 0.76, 0.71, 0.65, 0.59, 0.53, 0.47), + c(1.2, 1.2, 0.76, 0.71, 0.65, 0.59, 0.53, 0.47), + c(1.2, 1.2, 0.76, 0.71, 0.65, 0.59, 0.53, 0.47)) + +frr_art_default <- array(0, c(3,7,8)) +frr_art_default[1,,] <- frr_cd4_default +frr_art_default[2,,] <- frr_cd4_default +frr_art_default[3,,] <- 1.0 diff --git a/R/generics.R b/R/generics.R new file mode 100644 index 0000000..bc48010 --- /dev/null +++ b/R/generics.R @@ -0,0 +1,19 @@ +simmod <- function(fp, ...) UseMethod("simmod") +simfit <- function(fit, ...) UseMethod("simfit") + +prev <- function(mod, ...) UseMethod("prev") +fnPregPrev <- function(mod, fp, ...) UseMethod("fnPregPrev") +incid <- function(mod, ...) UseMethod("incid") + +incid_sexratio <- function(mod, ...) UseMethod("incid_sexratio") + +agemx <- function(mod, ...) UseMethod("agemx") +natagemx <- function(mod, ...) UseMethod("natagemx") +calc_nqx <- function(mod, ...) UseMethod("calc_nqx") + +pop15to49 <- function(mod, ...) UseMethod("pop15to49") +artpop15to49 <- function(mod, ...) UseMethod("artpop15to49") +artpop15plus <- function(mod, ...) UseMethod("artpop15plus") +artcov15to49 <- function(mod, ...) UseMethod("artcov15to49") +artcov15plus <- function(mod, ...) UseMethod("artcov15plus") +age15pop <- function(mod, ...) UseMethod("age15pop") diff --git a/R/imis.R b/R/imis.R new file mode 100644 index 0000000..77a9e47 --- /dev/null +++ b/R/imis.R @@ -0,0 +1,193 @@ +## Modified from IMIS package by Le Bao (http://cran.r-project.org/web/packages/IMIS/) + +#' Incremental Mixture Importance Sampling (IMIS) +#' +#' Implements IMIS algorithm with optional optimization step (Raftery and Bao 2010). +#' +#' @param B0 number of initial samples to draw +#' @param B number of samples at each IMIS iteration +#' @param B_re number of resamples +#' @param number_k maximum number of iterations +#' @param opt_k vector of iterations at which to use optimization step to identify new mixture component +#' @param fp fixed model parameters +#' @param likdat likeihood data +#' @param prior function to calculate prior density for matrix of parameter inputs +#' @param likelihood function to calculate likelihood for matrix of parameter inputs +#' @param sample_prior function to draw an initial sample of parameter inputs +#' @param dsamp function to calculate density for initial sampling distribution (may be equal to prior) +#' @param save_all logical whether to save all sampled parameters +#' +#' @return list with items resample, stat, and center +imis <- function(B0, B, B_re, number_k, opt_k=NULL, fp, likdat, + prior=eppasm::prior, + likelihood=eppasm::likelihood, + sample_prior=eppasm::sample.prior, + dsamp = eppasm::dsamp, save_all=FALSE){ + + ## Draw initial samples from prior distribution + X_k <- sample_prior(B0, fp) # Draw initial samples from the prior distribution + cov_prior = cov(X_k) # estimate of the prior covariance + + ## Locations and covariance of mixture components + center_all <- list() + sigma_all <- list() + + ll_all <- numeric() + lprior_all <- numeric() + mix_all <- numeric() + n_k <- integer() + + X_all <- matrix(0, B0+B*number_k, ncol(X_k)) + n_all <- 0 + stat <- matrix(NA, number_k, 7) + + idx_exclude <- integer() ## inputs to exclude from initial points for optimization step + + + iter_start_time <- proc.time() + for(k in 1:number_k){ + + ## Calculate log-likelihood for new inputs + ll_k <- likelihood(X_k, fp, likdat, log=TRUE) + + ## Keep only inputs with non-zero likelihood, calculate importance weights + which_k <- which(ll_k > -Inf) + + n_k[k] <- length(which_k) + idx_k <- n_all + seq_len(n_k[k]) + n_all <- n_all+n_k[k] + + X_k <- X_k[which_k,] + ll_k <- ll_k[which_k] + lprior_k <- log(prior(X_k, fp)) + + ## calculate mixture weights for new inputs + mix_k <- dsamp(X_k, fp) * B0 / B + if(k > 1) + mix_k <- mix_k + rowSums(mapply(mvtnorm::dmvnorm, mean=center_all, sigma=sigma_all, MoreArgs=list(x=X_k))) + + X_all[idx_k,] <- X_k + ll_all[idx_k] <- ll_k + lprior_all[idx_k] <- lprior_k + mix_all[idx_k] <- mix_k + + offset <- max(ll_all) - 400 + weights <- exp(ll_all + lprior_all - log(mix_all) - offset) + lmarg_post <- log(sum(weights)) - log(B0+B*(k-1)) + offset + log(B0/B+(k-1)) # log marginal posterior + weights <- weights / sum(weights) + + ## Store convergence monitoring criteria + iter_stop_time <- proc.time() + stat[k,] <- c(lmarg_post, # log marginal posterior + sum(1-(1-weights)^B_re), # the expected number of unique points + max(weights), # the maximum weight + 1/sum(weights^2), # the effictive sample size + -sum(weights*log(weights), na.rm = TRUE) / log(length(weights)), # the entropy relative to uniform !!! NEEDS UDPATING FOR OMITTED SAMPLES !!! + var(weights/mean(weights)), # the variance of scaled weights !!! NEEDS UDPATING FOR OMITTED SAMPLES !!! + as.numeric(iter_stop_time - iter_start_time)[3]) + iter_start_time <- iter_stop_time + + if (k==1) + print("Stage MargLike UniquePoint MaxWeight ESS IterTime") + print(sprintf("%5d %9.3f %12.2f %11.2f %8.2f %10.2f", k, stat[k,1], stat[k,2], stat[k,3], stat[k,4], stat[k,7])) + + + ## Check for convergence + if(stat[k,2] > (1 - exp(-1))*B_re || k == number_k) + break; + + ## ## Identify new mixture component + + if(k %in% opt_k){ + + idx_remain <- setdiff(seq_len(n_all), idx_exclude) + idx_init <- idx_remain[which.max(weights[idx_remain])] + idx_exclude <- c(idx_exclude, idx_init) + theta_init <- X_all[idx_init,] + + nlposterior <- function(theta){-prior(theta, fp, log=TRUE)-likelihood(theta, fp, likdat, log=TRUE)} + + ## opt <- optimization_step(theta_init, nlposterior, cov_prior) # Version by Bao uses prior covariance to parscale optimizer + opt <- optimization_step(theta_init, nlposterior, cov(X_all)) + center_all[[k]] <- opt$mu + sigma_all[[k]] <- opt$sigma + + ## exclude the neighborhood of the local optima + distance_remain <- mahalanobis(X_all[seq_len(n_all),], center_all[[k]], diag(diag(sigma_all[[k]]))) + idx_exclude <- union(idx_exclude, order(distance_remain)[seq_len(n_all/length(opt_k))]) + + } else { + + ## choose mixture component centered at input with current maximum weight + center_all[[k]] <- X_all[which.max(weights),] + distance_all <- mahalanobis(X_all[1:n_all,], center_all[[k]], diag(diag(cov_prior))) # Raftery & Bao version + ## distance_all <- mahalanobis(X_all[1:n_all,], center_all[[k]], cov(X_all)) # Suggested by Fasiolo et al. + which_close <- order(distance_all)[seq_len(min(n_all, B))] # Choose B nearest inputs (use n_all if n_all < B) + sigma_all[[k]] <- cov.wt(X_all[which_close,], wt = weights[which_close]+1/n_all, center = center_all[[k]])$cov # Raftery & Bao version + ## sigma_all[[k]] <- cov.wt(X_all[which_close,], center = center_all[[k]])$cov # Suggested by Fasiolo et al. + } + + ## Update mixture weights according with new mixture component + mix_all <- mix_all + mvtnorm::dmvnorm(X_all[1:n_all,], center_all[[k]], sigma_all[[k]]) + + ## Sample B inputs from new mixture component + X_k <- mvtnorm::rmvnorm(B, center_all[[k]], sigma_all[[k]]) + + } # end of iteration k + + resample <- X_all[sample(seq_len(n_all), B_re, replace = TRUE, prob = weights),] + + if(save_all){ + mix_all_k <- cbind(dsamp(X_all[1:n_all,], fp) * B0 / B, mapply(mvtnorm::dmvnorm, mean=center_all, sigma=sigma_all, MoreArgs=list(x=X_all[1:n_all,]))) + return(list(stat=stat[1:k,], resample=resample, center=center_all, sigma_all=sigma_all, + ll_all=ll_all, lprior_all=lprior_all, mix_all=mix_all, mix_all_k = mix_all_k, n_k=n_k)) + } + return(list(stat=stat[1:k,], resample=resample, center=center_all)) +} + + +optimization_step <- function(theta, fn, cov){ + + ## The rough optimizer uses the Nelder-Mead algorithm. + ptm.opt = proc.time() + optNM <- optim(theta, fn, method="Nelder-Mead", + control=list(maxit=5000, parscale=sqrt(diag(cov)))) + + ## The more efficient optimizer uses the BFGS algorithm + optBFGS <- try(stop(""), TRUE) + step_expon <- 0.2 + while(inherits(optBFGS, "try-error") && step_expon <= 0.8){ + optBFGS <- try(optim(optNM$par, fn, method="BFGS", hessian=TRUE, + control=list(parscale=sqrt(diag(cov)), ndeps=rep(.Machine$double.eps^step_expon, length(optNM$par)), maxit=1000)), + silent=TRUE) + step_expon <- step_expon + 0.05 + } + ptm.use = (proc.time() - ptm.opt)[3] + if(inherits(optBFGS, "try-error")){ + print(paste0("D = ", i, "; BFGS optimization failed.")) + print(paste("maximum log posterior=", round(-optNM$value,2), + ## ", likelihood=", round(likelihood(optNM$par, fp, likdat, log=TRUE),2), + ## ", prior=", round(log(prior(optNM$par, fp)),2), + ", time used=", round(ptm.use/60,2), + "minutes, convergence=", optNM$convergence)) + mu <- optNM$par + sigma <- cov + } else { + print(paste("maximum log posterior=", round(-optBFGS$value,2), + ## ", likelihood=", round(likelihood(optBFGS$par, fp, likdat, log=TRUE),2), + ## ", prior=", round(log(prior(optBFGS$par, fp)),2), + ", time used=", round(ptm.use/60,2), + "minutes, convergence=", optBFGS$convergence)) + mu <- optBFGS$par + eig <- eigen(optBFGS$hessian) + if (all(eig$values>0)){ + sigma <- chol2inv(chol(optBFGS$hessian)) # the covariance of new samples + } else { # If the hessian matrix is not positive definite, we define the covariance as following + + ## !!! NOTE: This isn't working very well. Would be good to improve... + eigval <- replace(eig$values, eig$values < 0, 0) + sigma <- chol2inv(chol(eig$vectors %*% diag(eigval) %*% t(eig$vectors) + diag(1/diag(cov)))) + } + } + return(list(mu=mu, sigma=sigma)) +} diff --git a/R/infections.R b/R/infections.R new file mode 100644 index 0000000..ad652dd --- /dev/null +++ b/R/infections.R @@ -0,0 +1,311 @@ +#' Annualized number of new infections +#' +calc_infections_eppspectrum <- function(fp, pop, hivpop, i, ii, r_ts){ + + ## Attach state space variables + invisible(list2env(fp$ss, environment())) # put ss variables in environment for convenience + + ## HIV population size at ts + ts <- (i-2)/DT + ii + + hivn.ii <- sum(pop[p.age15to49.idx,,hivn.idx,i]) + hivn.ii <- hivn.ii - sum(pop[p.age15to49.idx[1],,hivn.idx,i])*(1-DT*(ii-1)) + hivn.ii <- hivn.ii + sum(pop[tail(p.age15to49.idx,1)+1,,hivn.idx,i])*(1-DT*(ii-1)) + + hivp.ii <- sum(pop[p.age15to49.idx,,hivp.idx,i]) + hivp.ii <- hivp.ii - sum(pop[p.age15to49.idx[1],,hivp.idx,i])*(1-DT*(ii-1)) + hivp.ii <- hivp.ii + sum(pop[tail(p.age15to49.idx,1)+1,,hivp.idx,i])*(1-DT*(ii-1)) + + art.ii <- sum(hivpop[-1,,h.age15to49.idx,,i]) + if(sum(hivpop[,,h.age15to49.idx[1],,i]) > 0) + art.ii <- art.ii - sum(pop[p.age15to49.idx[1],,hivp.idx,i] * colSums(hivpop[-1,,h.age15to49.idx[1],,i],,2) / colSums(hivpop[,,h.age15to49.idx[1],,i],,2)) * (1-DT*(ii-1)) + if(sum(hivpop[,,tail(h.age15to49.idx, 1)+1,,i]) > 0) + art.ii <- art.ii + sum(pop[tail(p.age15to49.idx,1)+1,,hivp.idx,i] * colSums(hivpop[-1,,tail(h.age15to49.idx, 1)+1,,i],,2) / colSums(hivpop[,,tail(h.age15to49.idx, 1)+1,,i],,2)) * (1-DT*(ii-1)) + + transm_prev <- (hivp.ii - art.ii + fp$relinfectART*art.ii) / (hivn.ii+hivp.ii) + + incrate15to49.ts <- r_ts * transm_prev + fp$iota * (fp$proj.steps[ts] == fp$tsEpidemicStart) + sexinc15to49.ts <- incrate15to49.ts*c(1, fp$incrr_sex[i])*sum(pop[p.age15to49.idx,,hivn.idx,i])/(sum(pop[p.age15to49.idx,m.idx,hivn.idx,i]) + fp$incrr_sex[i]*sum(pop[p.age15to49.idx, f.idx,hivn.idx,i])) + agesex.inc <- sweep(fp$incrr_age[,,i], 2, sexinc15to49.ts/(colSums(pop[p.age15to49.idx,,hivn.idx,i] * fp$incrr_age[p.age15to49.idx,,i])/colSums(pop[p.age15to49.idx,,hivn.idx,i])), "*") + infections.ts <- agesex.inc * pop[,,hivn.idx,i] + + ## distribute new infections according to Beer's coefficients + if(exists("irr", fp) && exists("Amat", fp$irr)){ + infections.ts <- fp$irr$Amat %*% apply(infections.ts, 2, fastmatch::ctapply, ceiling(seq_len(fp$ss$pAG)/5), sum) + infections.ts <- pmax(infections.ts, 0) + } + + attr(infections.ts, "incrate15to49.ts") <- incrate15to49.ts + attr(infections.ts, "prevcurr") <- hivp.ii / (hivn.ii+hivp.ii) + + return(infections.ts) +} + +calc_infections_simpletransm <- function(fp, pop, hivpop, i, ii, r_ts){ + + ## Attach state space variables + invisible(list2env(fp$ss, environment())) # put ss variables in environment for convenience + + ts <- (i-2)/DT + ii + + ## Calculate prevalence of unsuppressed viral load among sexually active population + hivn.ii <- colSums(pop[p.age15to49.idx,,hivn.idx,i]) + hivn.ii <- hivn.ii - pop[p.age15to49.idx[1],,hivn.idx,i]*(1-DT*(ii-1)) + hivn.ii <- hivn.ii + pop[tail(p.age15to49.idx,1)+1,,hivn.idx,i]*(1-DT*(ii-1)) + + ## Calculate proportion in each HIV age group who are in 15 to 49 population, accounting for partial year time step + ha1 <- h.age15to49.idx[1] + haM <- h.age15to49.idx[length(h.age15to49.idx)]+1 # age group one above 15 to 49 + prop_include <- rbind(ifelse(pop[agfirst.idx[ha1],,hivp.idx,i] > 0, + 1 - pop[agfirst.idx[ha1],,hivp.idx,i] / colSums(pop[agfirst.idx[ha1]+1:h.ag.span[ha1]-1,,hivp.idx,i]) * (1-DT*(ii-1)), + c(1.0, 1.0)), + matrix(1, length(h.age15to49.idx)-1, NG), + ifelse(pop[agfirst.idx[haM],,hivp.idx,i] > 0, + pop[agfirst.idx[haM],,hivp.idx,i] / colSums(pop[agfirst.idx[haM]+1:h.ag.span[haM]-1,,hivp.idx,i]) * (1-DT*(ii-1)), + c(0, 0))) + + + hivp_noart.ii <- colSums(colSums(sweep(hivpop[1,,c(h.age15to49.idx, haM),,i], 1, fp$relsexact_cd4cat, "*")) * prop_include) + art.ii <- colSums(colSums(hivpop[-1,,c(h.age15to49.idx, haM),,i],,2) * prop_include) + + ## Prevalence of unsuppressed viral load among sexually active population + hivtransm_prev <- (hivp_noart.ii + fp$relinfectART * art.ii) / (hivn.ii+hivp_noart.ii+art.ii) + + ## r_sex[1:2] is the transmission rate by (Men, Women) + r_sex <- c(sqrt(fp$mf_transm_rr[i]), 1/sqrt(fp$mf_transm_rr[i])) * r_ts + + sexinc15to49.ts <- (r_sex * hivtransm_prev)[2:1] + fp$mf_transm_rr[i]^c(-0.25, 0.25) * fp$iota * (fp$proj.steps[ts] == fp$tsEpidemicStart) + agesex.inc <- sweep(fp$incrr_age[,,i], 2, sexinc15to49.ts/(colSums(pop[p.age15to49.idx,,hivn.idx,i] * fp$incrr_age[p.age15to49.idx,,i])/colSums(pop[p.age15to49.idx,,hivn.idx,i])), "*") + infections.ts <- agesex.inc * pop[,,hivn.idx,i] + + attr(infections.ts, "incrate15to49.ts") <- sum(infections.ts[p.age15to49.idx,]) / sum(hivn.ii) + attr(infections.ts, "prevcurr") <- sum(hivp_noart.ii+art.ii) / sum(hivn.ii+hivp_noart.ii+art.ii) + + return(infections.ts) +} + +## Beers coefficients to distribute infections from 5-year age groups to single-year of age +create_beers <- function(n5yr){ + + ## Beer's coefficients for disaggregating 5 year age groups into + ## single-year age groups (from John Stover) + Afirst <- rbind(c(0.3333, -0.1636, -0.0210, 0.0796, -0.0283), + c(0.2595, -0.0780, 0.0130, 0.0100, -0.0045), + c(0.1924, 0.0064, 0.0184, -0.0256, 0.0084), + c(0.1329, 0.0844, 0.0054, -0.0356, 0.0129), + c(0.0819, 0.1508, -0.0158, -0.0284, 0.0115)) + Asecond <- rbind(c( 0.0404, 0.2000, -0.0344, -0.0128, 0.0068), + c( 0.0093, 0.2268, -0.0402, 0.0028, 0.0013), + c(-0.0108, 0.2272, -0.0248, 0.0112, -0.0028), + c(-0.0198, 0.1992, 0.0172, 0.0072, -0.0038), + c(-0.0191, 0.1468, 0.0822, -0.0084, -0.0015)) + Amid <- rbind(c(-0.0117, 0.0804, 0.1570, -0.0284, 0.0027), + c(-0.0020, 0.0160, 0.2200, -0.0400, 0.0060), + c( 0.0050, -0.0280, 0.2460, -0.0280, 0.0050), + c( 0.0060, -0.0400, 0.2200, 0.0160, -0.0020), + c( 0.0027, -0.0284, 0.1570, 0.0804, -0.0117)) + Apenult <- rbind(c(-0.0015, -0.0084, 0.0822, 0.1468, -0.0191), + c(-0.0038, 0.0072, 0.0172, 0.1992, -0.0198), + c(-0.0028, 0.0112, -0.0248, 0.2272, -0.0108), + c( 0.0013, 0.0028, -0.0402, 0.2268, 0.0093), + c( 0.0068, -0.0128, -0.0344, 0.2000, 0.0404)) + Aultim <- rbind(c( 0.0115, -0.0284, -0.0158, 0.1508, 0.0819), + c( 0.0129, -0.0356, 0.0054, 0.0844, 0.1329), + c( 0.0084, -0.0256, 0.0184, 0.0064, 0.1924), + c(-0.0045, 0.0100, 0.0130, -0.0780, 0.2595), + c(-0.0283, 0.0796, -0.0210, -0.1636, 0.3333)) + + A <- do.call(rbind, + c(list(cbind(Afirst, matrix(0, 5, n5yr-5)), + cbind(Asecond, matrix(0, 5, n5yr-5))), + lapply(0:(n5yr-6), function(i) cbind(matrix(0, 5, i), Amid, matrix(0, 5, (n5yr-5)-i))), + list(cbind(matrix(0, 5, n5yr-6), Apenult, matrix(0, 5, 1)), + cbind(matrix(0, 5, n5yr-6), Aultim, matrix(0, 5, 1)), + c(rep(0, n5yr-1), 1)))) + return(round(A, 4)) +} + +prepare_irr_model <- function(fp){ + irr <- list() + return(fp) +} + + +################################################ +#### Prior for incidence rate ratio model #### +################################################ + +## RW2 model +NPARAM_RW2 <- 13 + +sexincrr.pr.mean <- log(1.38) +sexincrr.pr.sd <- 0.2 + +mf_transm_rr.pr.mean <- log(1.9) +mf_transm_rr.pr.sd <- 0.3 # change default to 0.3 + +## ageincrr.pr.mean <- c(-1.40707274, -0.23518703, 0.69314718, 0.78845736, -0.39975544, -0.70620810, -0.84054571, -0.02101324, -0.16382449, -0.37914407, -0.59639985, -0.82038300) +## ageincrr.pr.sd <- 0.5 + +## Informative priors based on estimates for 11 countries with 3+ surveys +ageincrr.pr.mean <- c(-1.4, -0.28, 0.3, 0.3, -0.3, -0.6, -0.2, 0.05, -0.4, -0.45, -0.6, -0.7) +ageincrr.pr.sd <- c(0.5, 0.4, 0.23, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.2, 0.2) + +NPARAM_LININCRR <- 6 +## incrr_trend_mean <- c(0, 0, 0, 0, 0, 0) +## incrr_trend_sd <- c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5) + +## Informative priors based on estimates for 11 countries with 3+ surveys +incrr_trend_mean <- c(0.0, 0.035, -0.02, -0.09, -0.016, -0.06) +incrr_trend_sd <- c(0.07, 0.07, 0.1, 0.1, 0.08, 0.08) + +getnparam_incrr <- function(fp){ + switch(fp$fitincrr, + "TRUE"=NPARAM_RW2, + linincrr=NPARAM_RW2+NPARAM_LININCRR, + lognorm=7, + relbehav=NPAR_RELBEHAV, 0) +} + +transf_incrr <- function(theta_incrr, param, fp){ + + incrr_nparam <- getnparam_incrr(fp) + + if(fp$incidmod == "eppspectrum"){ + param$incrr_sex <- fp$incrr_sex + param$incrr_sex[] <- exp(theta_incrr[1]) + } else if(fp$incidmod == "transm") { + param$mf_transm_rr <- rep(exp(theta_incrr[1]), fp$ss$PROJ_YEARS) + } + + if(fp$fitincrr %in% c(TRUE ,"linincrr")){ + + ## param$sigma_agepen <- exp(theta_incrr[incrr_nparam]) + param$sigma_agepen <- 0.4 + + param$logincrr_age <- array(0, c(7, 2)) + param$logincrr_age[-3,] <- theta_incrr[2:13] + + param$incrr_age <- fp$incrr_age + param$incrr_age[fp$ss$p.age15to49.idx,,] <- apply(exp(param$logincrr_age), 2, rep, each=5) + param$incrr_age[36:66,,] <- sweep(fp$incrr_age[36:66,,fp$ss$PROJ_YEARS], 2, + param$incrr_age[35,,fp$ss$PROJ_YEARS]/fp$incrr_age[35,,fp$ss$PROJ_YEARS], "*") + + years <- with(fp$ss, proj_start+1:PROJ_YEARS-1) + if(fp$fitincrr == "linincrr"){ + par <- theta_incrr[NPARAM_RW2+1:NPARAM_LININCRR] + param$logincrr_trend <- par + sexadjust <- approx(c(2002, 2007, 2012), c(-5, 0, 5)*c(par[1], 0, par[2]), years, rule=2)$y + if(fp$incidmod == "eppspectrum") + param$incrr_sex <- param$incrr_sex * exp(sexadjust) + else if(fp$incidmod == "transm") + param$mf_transm_rr <- param$mf_transm_rr * exp(sexadjust) + + ## adjustment to age IRRs among 15-24 + m15to24_adjust <- approx(c(2002, 2007, 2012), c(-5, 0, 5)*c(par[3], 0, par[4]), years, rule=2)$y + f15to24_adjust <- approx(c(2002, 2007, 2012), c(-5, 0, 5)*c(par[5], 0, par[6]), years, rule=2)$y + param$incrr_age[1:10,,] <- sweep(param$incrr_age[1:10,,,drop=FALSE], 2:3, exp(rbind(m15to24_adjust, f15to24_adjust)), "*") + } + ## cubic spline interpolation of age IRRs + ## note: this is really slow and not very good. Need to figure out something better + if(exists("smoothirr", fp) && fp$smoothirr){ + smooth_irr <- function(y){ + yval <- c(-5, log(y[0:12*5+1])) + yval <- pmax(yval, -8) + exp(spline(2:15*5+2, yval, xout=15:80)$y) + } + idx <- approx(c(2002, 2012), c(1,11), years, rule=2)$y + param$incrr_age <- apply(param$incrr_age[,,2002-fp$ss$proj_start + 1:11], 2:3, smooth_irr)[,,idx] + } + + } else if(fp$fitincrr=="lognorm"){ + param$logincrr_age <- cbind(calc_lognorm_logagerr(theta_incrr[2:4]), + calc_lognorm_logagerr(theta_incrr[5:7])) + param$incrr_age <- fp$incrr_age + param$incrr_age[,,] <- apply(exp(param$logincrr_age), 2, rep, c(rep(5, 13), 1)) + + } else if(fp$fitincrr == "relbehav"){ + + par <- theta_incrr[2:incrr_nparam] + param$adjustpar <- par + logadjust1 <- cbind(approx(c(17, 27, 38, 49), c(par[1], 0, cumsum(par[2:3])), xout=15:80, rule=2)$y, + approx(c(17, 27, 38, 49), c(par[4], 0, cumsum(par[5:6])), xout=15:80, rule=2)$y) + + logadjust2 <- cbind(approx(c(17, 27, 38, 49), c(par[1]+par[7], 0, cumsum(par[2:3])), xout=15:80, rule=2)$y, + approx(c(17, 27, 38, 49), c(par[4]+par[8], 0, cumsum(par[5:6])), xout=15:80, rule=2)$y) + + BREAK_YEAR <- 36 + param$incrr_age <- fp$logrelbehav + param$incrr_age[,,1:(BREAK_YEAR-1)] <- exp(sweep(fp$logrelbehav[,,1:(BREAK_YEAR-1)], 1:2, logadjust1, "+")) + param$incrr_age[,,BREAK_YEAR:fp$SIM_YEARS] <- exp(sweep(fp$logrelbehav[,,BREAK_YEAR:fp$SIM_YEARS], 1:2, logadjust2, "+")) + } + + return(param) +} + +lprior_incrr <- function(theta_incrr, fp){ + + if(exists("prior_args", where = fp)){ + for(i in seq_along(fp$prior_args)) + assign(names(fp$prior_args)[i], fp$prior_args[[i]]) + } + + lpr <- 0 + + if(fp$incidmod == "eppspectrum") + lpr <- lpr + dnorm(theta_incrr[1], sexincrr.pr.mean, sexincrr.pr.sd, log=TRUE) + else if(fp$incidmod == "transm") + lpr <- lpr + dnorm(theta_incrr[1], mf_transm_rr.pr.mean, mf_transm_rr.pr.sd, log=TRUE) + + if(fp$fitincrr %in% c(TRUE, "linincrr")){ + lpr <- lpr + sum(dnorm(theta_incrr[2:13], ageincrr.pr.mean, ageincrr.pr.sd, log=TRUE)) + ## dnorm(theta_incrr[14], -1, 0.7, log=TRUE) + + if(fp$fitincrr == "linincrr"){ + lpr <- lpr+sum(dnorm(theta_incrr[NPARAM_RW2+1:NPARAM_LININCRR], incrr_trend_mean, incrr_trend_sd, log=TRUE)) + } + + } else if(fp$fitincrr=="lognorm"){ + lpr <- lpr + + sum(dnorm(theta_incrr[c(2,5)], lognorm.a0.pr.mean, lognorm.a0.pr.sd, log=TRUE)) + + sum(dnorm(theta_incrr[c(3,6)], lognorm.meanlog.pr.mean, lognorm.meanlog.pr.sd, log=TRUE)) + + sum(dnorm(theta_incrr[c(4,7)], lognorm.logsdlog.pr.mean, lognorm.logsdlog.pr.sd, log=TRUE)) + } else if(fp$fitincrr=="relbehav"){ + lpr <- lpr + sum(dnorm(theta_incrr[2:NPAR_RELBEHAV], 0, relbehav_adjust_sd, log=TRUE)); + } + + return(lpr) +} + +sample_incrr <- function(n, fp){ + if(exists("prior_args", where = fp)){ + for(i in seq_along(fp$prior_args)) + assign(names(fp$prior_args)[i], fp$prior_args[[i]]) + } + + incrr_nparam <- getnparam_incrr(fp) + mat <- matrix(NA, n, incrr_nparam) + + if(fp$incidmod == "eppspectrum") + mat[,1] <- rnorm(n, sexincrr.pr.mean, sexincrr.pr.sd) + else if(fp$incidmod == "transm") + mat[,1] <- rnorm(n, mf_transm_rr.pr.mean, mf_transm_rr.pr.sd) + + if(fp$fitincrr %in% c(TRUE, "linincrr")){ + mat[,2:13] <- t(matrix(rnorm(n*12, ageincrr.pr.mean, ageincrr.pr.sd), nrow=12)) + ## mat[,14] <- rnorm(n, -1, 0.7) # log variance of ageincrr difference penalty + if(fp$fitincrr == "linincrr") + mat[,NPARAM_RW2+1:NPARAM_LININCRR] <- t(matrix(rnorm(n*NPARAM_LININCRR, incrr_trend_mean, incrr_trend_sd), nrow=NPARAM_LININCRR)) + } else if(fp$fitincrr=="lognorm"){ + mat[,c(2,5)] <- t(matrix(rnorm(n*2, lognorm.a0.pr.mean, lognorm.a0.pr.sd), nrow=2)) + mat[,c(3,6)] <- t(matrix(rnorm(n*2, lognorm.meanlog.pr.mean, lognorm.meanlog.pr.sd), nrow=2)) + mat[,c(4,7)] <- t(matrix(rnorm(n*2, lognorm.logsdlog.pr.mean, lognorm.logsdlog.pr.sd), nrow=2)) + } else if(fp$fitincrr=="relbehav"){ + incrr_nparam <- NPAR_RELBEHAV + mat[,2:NPAR_RELBEHAV] <- rnorm(n*(NPAR_RELBEHAV-1), 0, relbehav_adjust_sd) + } + + return(mat) +} + +ldsamp_incrr <- lprior_incrr diff --git a/R/likelihood.R b/R/likelihood.R new file mode 100644 index 0000000..148502d --- /dev/null +++ b/R/likelihood.R @@ -0,0 +1,941 @@ +########################### +#### EPP model prior #### +########################### + +ldinvgamma <- function(x, alpha, beta){ + log.density <- alpha * log(beta) - lgamma(alpha) - (alpha + 1) * log(x) - (beta/x) + return(log.density) +} + +bayes_lmvt <- function(x, shape, rate){ + mvtnorm::dmvt(x, sigma=diag(length(x)) / (shape / rate), df=2*shape, log=TRUE) +} + +bayes_rmvt <- function(n, d, shape, rate){ + mvtnorm::rmvt(n, sigma=diag(d) / (shape / rate), df=2*shape) +} + +## Binomial distribution log-density permitting non-integer counts +ldbinom <- function(x, size, prob){ + lgamma(size+1) - lgamma(x+1) - lgamma(size-x+1) + x*log(prob) + (size-x)*log(1-prob) +} + +## r-spline prior parameters + +## tau2.prior.rate <- 0.5 # initial sampling distribution for tau2 parameter +tau2_init_shape <- 3 +tau2_init_rate <- 4 + +tau2_prior_shape <- 0.001 # Inverse gamma parameter for tau^2 prior for spline +tau2_prior_rate <- 0.001 +muSS <- 1/11.5 #1/duration for r steady state prior + +rw_prior_shape <- 300 +rw_prior_rate <- 1.0 + + +## r-trend prior parameters +t0.unif.prior <- c(1970, 1990) +## t1.unif.prior <- c(10, 30) +## logr0.unif.prior <- c(1/11.5, 10) +t1.pr.mean <- 20.0 +t1.pr.sd <- 4.5 +logr0.pr.mean <- 0.42 +logr0.pr.sd <- 0.23 +## rtrend.beta.pr.mean <- 0.0 +## rtrend.beta.pr.sd <- 0.2 +rtrend.beta.pr.mean <- c(0.46, 0.17, -0.68, -0.038) +rtrend.beta.pr.sd <- c(0.12, 0.07, 0.24, 0.009) + + +########################################### +#### #### +#### Site level ANC data (SS and RT) #### +#### #### +########################################### + +ancbias.pr.mean <- 0.15 +ancbias.pr.sd <- 1.0 +vinfl.prior.rate <- 1/0.015 + +ancrtsite.beta.pr.mean <- 0 +## ancrtsite.beta.pr.sd <- 1.0 +ancrtsite.beta.pr.sd <- 0.05 +## ancrtsite.vinfl.pr.rate <- 1/0.015 + + +#' Prepare site-level ANC prevalence data for EPP random-effects likelihood +#' +#' @param eppd EPP data object +#' @param anchor.year year in which EPP data inputs start +#' NOTE: requires year to be stored in column names of anc.prev +prepare_ancsite_likdat <- function(eppd, anchor.year=1970L){ + + anc.prev <- eppd$anc.prev + anc.n <- eppd$anc.n + anc.used <- eppd$anc.used + + anc.prev <- anc.prev[anc.used,,drop=FALSE] # keep only used sites + anc.n <- anc.n[anc.used,,drop=FALSE] # keep only used sites + + ancobs.idx <- mapply(intersect, lapply(as.data.frame(t(!is.na(anc.prev))), which), + lapply(as.data.frame(t(!is.na(anc.n))), which), SIMPLIFY=FALSE) + ## limit to years with both prevalence and N observations (likely input errors in EPP if not) + + nobs <- sapply(ancobs.idx, length) + + anc.years.lst <- lapply(ancobs.idx, function(i) as.integer(colnames(anc.prev)[i])) + anc.prev.lst <- setNames(lapply(seq_along(ancobs.idx), function(i) as.numeric(anc.prev[i, ancobs.idx[[i]]])), rownames(anc.prev)) + anc.n.lst <- setNames(lapply(seq_along(ancobs.idx), function(i) as.numeric(anc.n[i, ancobs.idx[[i]]])), rownames(anc.n)) + + X.lst <- mapply(cbind, Intercept=lapply(nobs, rep, x=1), ancrt=lapply(nobs, rep, x=0), SIMPLIFY=FALSE) + + if(exists("ancrtsite.prev", where=eppd) && !is.null(eppd$ancrtsite.prev)){ + ancrtsite.prev <- eppd$ancrtsite.prev + ancrtsite.n <- eppd$ancrtsite.n + + ancrtsite.prev <- ancrtsite.prev[anc.used,,drop=FALSE] # keep only used sites + ancrtsite.n <- ancrtsite.n[anc.used,,drop=FALSE] # keep only used sites + + ancrtsiteobs.idx <- mapply(intersect, lapply(as.data.frame(t(!is.na(ancrtsite.prev))), which), + lapply(as.data.frame(t(!is.na(ancrtsite.n))), which), SIMPLIFY=FALSE) + ## limit to years with both prevalence and N observations (likely input errors in EPP if not) + + nobs <- sapply(ancrtsiteobs.idx, length) + + ancrtsite.years.lst <- lapply(ancrtsiteobs.idx, function(i) as.integer(colnames(ancrtsite.prev)[i])) + ancrtsite.prev.lst <- setNames(lapply(seq_along(ancrtsiteobs.idx), function(i) as.numeric(ancrtsite.prev[i, ancrtsiteobs.idx[[i]]])), rownames(ancrtsite.prev)) + ancrtsite.n.lst <- setNames(lapply(seq_along(ancrtsiteobs.idx), function(i) as.numeric(ancrtsite.n[i, ancrtsiteobs.idx[[i]]])), rownames(ancrtsite.n)) + + ancrtsite.X.lst <- mapply(cbind, Intercept=lapply(nobs, rep, x=1), ancrt=lapply(nobs, rep, x=1), SIMPLIFY=FALSE) + + ## Combine SS and RT data + anc.years.lst <- mapply(c, anc.years.lst, ancrtsite.years.lst, SIMPLIFY=FALSE) + anc.prev.lst <- mapply(c, anc.prev.lst, ancrtsite.prev.lst, SIMPLIFY=FALSE) + anc.n.lst <- mapply(c, anc.n.lst, ancrtsite.n.lst, SIMPLIFY=FALSE) + X.lst <- mapply(rbind, X.lst, ancrtsite.X.lst, SIMPLIFY=FALSE) + } + + ## eliminate records with no observations + anc.years.lst <- anc.years.lst[sapply(anc.years.lst, length) > 0] + anc.prev.lst <- anc.prev.lst[sapply(anc.years.lst, length) > 0] + anc.n.lst <- anc.n.lst[sapply(anc.years.lst, length) > 0] + X.lst <- X.lst[sapply(anc.years.lst, length) > 0] + + x.lst <- mapply(function(p, n) (p*n+0.5)/(n+1), anc.prev.lst, anc.n.lst, SIMPLIFY=FALSE) + W.lst <- lapply(x.lst, qnorm) + v.lst <- mapply(function(W, x, n) 2*pi*exp(W^2)*x*(1-x)/n, W.lst, x.lst, anc.n.lst, SIMPLIFY=FALSE) + anc.idx.lst <- lapply(anc.years.lst, "-", anchor.year-1) ## index of observations relative to output prevalence vector + + + anclik.dat <- list(W.lst = W.lst, + v.lst = v.lst, + n.lst = anc.n.lst, + X.lst = X.lst, + anc.idx.lst = anc.idx.lst) + + return(anclik.dat) +} + +ll_anc <- function(qM, coef=c(0, 0), vinfl=0, anclik.dat){ + + ## linear model offset + mu <- lapply(lapply(anclik.dat$X.lst, "%*%", coef), c) + + d.lst <- mapply(function(w, mu, idx) w - (qM[idx]+mu), anclik.dat$W.lst, mu, anclik.dat$anc.idx.lst, SIMPLIFY=FALSE) + v.lst <- lapply(anclik.dat$v.lst, "+", vinfl) + + return(log(anclik::anc_resid_lik(d.lst, v.lst))) +} + + + +############################################# +#### #### +#### ANCRT census likelihood functions #### +#### #### +############################################# + +## prior parameters for ANCRT census +log_frr_adjust.pr.mean <- 0 +## ancrtcens.bias.pr.sd <- 1.0 +log_frr_adjust.pr.sd <- 0.2 +ancrtcens.vinfl.pr.rate <- 1/0.015 + +prepare_ancrtcens_likdat <- function(dat, anchor.year){ + + x.ancrt <- (dat$prev*dat$n+0.5)/(dat$n+1) + dat$W.ancrt <- qnorm(x.ancrt) + dat$v.ancrt <- 2*pi*exp(dat$W.ancrt^2)*x.ancrt*(1-x.ancrt)/dat$n + dat$idx <- dat$year - anchor.year+1 + + return(dat) +} + +ll_ancrtcens <- function(qM.preg, ancrtcens.dat, fp){ + sum(dnorm(ancrtcens.dat$W.ancrt, qM.preg[ancrtcens.dat$idx], sqrt(ancrtcens.dat$v.ancrt + fp$ancrtcens.vinfl), log=TRUE)) +} + + + +################################### +#### Age/sex incidence model #### +################################### + +## log-normal age incrr prior parameters +lognorm.a0.pr.mean <- 10 +lognorm.a0.pr.sd <- 5 + +lognorm.meanlog.pr.mean <- 3 +lognorm.meanlog.pr.sd <- 2 + +lognorm.logsdlog.pr.mean <- 0 +lognorm.logsdlog.pr.sd <- 1 + +relbehav_adjust_sd <- 0.25 +NPAR_RELBEHAV <- 9 + +calc_lognorm_logagerr <- function(par, a=2.5+5*3:16, b=27.5){ + dlnorm(a-par[1], par[2], exp(par[3]), log=TRUE) - dlnorm(b-par[1], par[2], exp(par[3]), log=TRUE) +} + + + +fnCreateLogAgeSexIncrr <- function(logrr, fp){ + + + logincrr.theta.idx <- c(7:10, 12:20) + logincrr.fixed.idx <- 11 + + lastidx <- length(fp$proj.steps) + fixed.age50p.logincrr <- log(fp$agesex.incrr.ts[,age50plus.idx,lastidx]) - log(fp$agesex.incrr.ts[,age45.idx,lastidx]) + + logincrr.theta <- tail(theta, length(logincrr.theta.idx)) + logincrr.agesex <- array(-Inf, c(NG, AG)) + logincrr.agesex[logincrr.fixed.idx] <- 0 + logincrr.agesex[logincrr.theta.idx] <- logincrr.theta + logincrr.agesex[,age50plus.idx] <- logincrr.agesex[,age45.idx] + fixed.age50p.logincrr + + return(logincrr.agesex) +} + +create_natmx_param <- function(theta_natmx, fp){ + + ## linear trend in logmx + par <- list(natmx_b0 = theta_natmx[1], + natmx_b1 = theta_natmx[2]) + par$Sx <- with(fp$natmx, exp(-exp(outer(logmx0, par$natmx_b0 + natmx_b1*x, "+")))) + return(par) +} + + +fnCreateParam <- function(theta, fp){ + + if(exists("prior_args", where = fp)){ + for(i in seq_along(fp$prior_args)) + assign(names(fp$prior_args)[i], fp$prior_args[[i]]) + } + + if(!exists("eppmod", where = fp)) # backward compatibility + fp$eppmod <- "rspline" + + if(fp$eppmod %in% c("rspline", "logrspline", "ospline", "logospline", "logrw")){ + + epp_nparam <- fp$numKnots+1 + + if(fp$eppmod %in% c("rspline", "logrspline")){ + u <- theta[1:fp$numKnots] + if(fp$rtpenord == 2){ + beta <- numeric(fp$numKnots) + beta[1] <- u[1] + beta[2] <- u[1]+u[2] + for(i in 3:fp$numKnots) + beta[i] <- -beta[i-2] + 2*beta[i-1] + u[i] + } else # first order penalty + beta <- cumsum(u) + } else if(fp$eppmod %in% c("ospline", "logospline", "logrw")) + beta <- theta[1:fp$numKnots] + + param <- list(beta = beta, + rvec = as.vector(fp$rvec.spldes %*% beta)) + + if(fp$eppmod %in% c("logrspline", "logospline", "logrw")) + + param$rvec <- exp(param$rvec) + + if(exists("r0logiotaratio", fp) && fp$r0logiotaratio) + param$iota <- exp(param$rvec[fp$proj.steps == fp$tsEpidemicStart] * theta[fp$numKnots+1]) + else + param$iota <- transf_iota(theta[fp$numKnots+1], fp) + + } else if(fp$eppmod == "rlogistic") { + epp_nparam <- 5 + par <- theta[1:4] + par[3] <- exp(theta[3]) + ## par[1:3] <- exp(par[1:3]) + param <- list() + param$rvec <- exp(rlogistic(fp$proj.steps, par)) + ## param$rvec <- rlogistic(fp$proj.steps, par) + param$iota <- transf_iota(theta[5], fp) + } else if(fp$eppmod == "rtrend"){ # rtrend + epp_nparam <- 7 + param <- list(tsEpidemicStart = fp$proj.steps[which.min(abs(fp$proj.steps - (round(theta[1]-0.5)+0.5)))], # t0 + rtrend = list(tStabilize = round(theta[1]-0.5)+0.5+round(theta[2]), # t0 + t1 + r0 = exp(theta[3]), # r0 + beta = theta[4:7])) + } else { + epp_nparam <- fp$rt$n_param+1 + param <- list() + param$rvec <- create_rvec(theta[1:fp$rt$n_param], fp$rt) + param$iota <- transf_iota(theta[fp$rt$n_param+1], fp) + } + + if(fp$ancsitedata){ + param$ancbias <- theta[epp_nparam+1] + if(!exists("v.infl", where=fp)){ + anclik_nparam <- 2 + param$v.infl <- exp(theta[epp_nparam+2]) + } else + anclik_nparam <- 1 + } + else + anclik_nparam <- 0 + + + paramcurr <- epp_nparam+anclik_nparam + if(exists("ancrt", fp) && fp$ancrt %in% c("census", "both")){ + param$log_frr_adjust <- theta[paramcurr+1] + param$frr_cd4 <- fp$frr_cd4 * exp(param$log_frr_adjust) + param$frr_art <- fp$frr_art + param$frr_art[1:2,,,] <- param$frr_art[1:2,,,] * exp(param$log_frr_adjust) + + if(!exists("ancrtcens.vinfl", fp)){ + param$ancrtcens.vinfl <- exp(theta[paramcurr+2]) + paramcurr <- paramcurr+2 + } else + paramcurr <- paramcurr+1 + } + if(exists("ancrt", fp) && fp$ancrt %in% c("site", "both")){ + param$ancrtsite.beta <- theta[paramcurr+1] + paramcurr <- paramcurr+1 + ## param$ancrtsite.vinfl <- exp(theta[length(theta)]) + } + + if(inherits(fp, "specfp")){ + if(exists("fitincrr", where=fp)){ + incrr_nparam <- getnparam_incrr(fp) + if(incrr_nparam) + param <- transf_incrr(theta[paramcurr+1:incrr_nparam], param, fp) + paramcurr <- paramcurr+incrr_nparam + } + } + + if(exists("natmx", where=fp) && fp$fitmx==TRUE){ + natmx_nparam <- 3 + theta_natmx <- theta[paramcurr+1:natmx_nparam] + paramcurr <- paramcurr+natmx_nparam + + b0 <- theta_natmx[1] + b1 <- theta_natmx[2]/10 + mx_lsexrat <- theta_natmx[3] + + param$natmx_par <- list(b0=b0, b1=b1, mx_lsexrat=mx_lsexrat) + param$Sx <- with(fp$natmx, exp(-exp(outer(sweep(logmx0, 2, c(0, mx_lsexrat), "+"), b0 + b1*x, "+")))) + } + + return(param) +} + + + +######################################################## +#### Age specific prevalence likelihood functions #### +######################################################## + + +#' Prepare age-specific HH survey prevalence likelihood data +prepare_hhsageprev_likdat <- function(hhsage, fp){ + anchor.year <- floor(min(fp$proj.steps)) + + hhsage$W.hhs <- qnorm(hhsage$prev) + hhsage$v.hhs <- 2*pi*exp(hhsage$W.hhs^2)*hhsage$se^2 + hhsage$sd.W.hhs <- sqrt(hhsage$v.hhs) + + if(exists("deff_approx", hhsage)) + hhsage$n_eff <- hhsage$n/hhsage$deff_approx + else + hhsage$n_eff <- hhsage$n/hhsage$deff + hhsage$x_eff <- hhsage$n_eff * hhsage$prev + + hhsage$sidx <- match(hhsage$sex, c("male", "female")) + hhsage$aidx <- as.integer(substr(hhsage$agegr, 1, 2)) - fp$ss$AGE_START+1L + hhsage$yidx <- hhsage$year - (anchor.year - 1) + + hhsage$arridx <- hhsage$aidx + (hhsage$sidx-1)*fp$ss$pAG + (hhsage$yidx-1)*fp$ss$NG*fp$ss$pAG + + return(subset(hhsage, aidx > 0)) +} + + +#' Log likelihood for age 15-49 household survey prevalence +ll_hhs <- function(qM, hhslik.dat){ + return(sum(dnorm(hhslik.dat$W.hhs, qM[hhslik.dat$idx], hhslik.dat$sd.W.hhs, log=TRUE))) +} + +#' Log likelihood for age-specific household survey prevalence +ll_hhsage <- function(mod, hhsage.dat){ + qM.age <- suppressWarnings(qnorm(ageprev(mod, arridx=hhsage.dat$arridx, agspan=5))) + if(any(is.na(qM.age))) return(-Inf) + sum(dnorm(hhsage.dat$W.hhs, qM.age, hhsage.dat$sd.W.hhs, log=TRUE)) +} + + +#' Log likelihood for age-specific household survey prevalence using binomial approximation +ll_hhsage_binom <- function(mod, hhsage.dat){ + prevM.age <- suppressWarnings(ageprev(mod, arridx=hhsage.dat$arridx, agspan=5)) + if(any(is.na(prevM.age)) || any(prevM.age >= 1)) return(-Inf) + ll <- sum(ldbinom(hhsage.dat$x_eff, hhsage.dat$n_eff, prevM.age)) + if(is.na(ll)) + return(-Inf) + return(ll) +} + + + +########################################## +#### Mortality likelihood functions #### +########################################## + +#' Prepare sibling history mortality likelihood data +#' +prepare_sibmx_likdat <- function(sibmxdat, fp){ + anchor.year <- floor(min(fp$proj.steps)) + nyears <- fp$ss$PROJ_YEARS + NG <- fp$ss$NG + AG <- fp$ss$pAG + + sibmxdat$sidx <- as.integer(sibmxdat$sex) + sibmxdat$aidx <- sibmxdat$agegr - (fp$ss$AGE_START-1) + sibmxdat$yidx <- sibmxdat$period - (anchor.year - 1) + sibmxdat$tipsidx <- sibmxdat$tips+1L + + sibmxdat <- subset(sibmxdat, aidx > 0) + + sibmxdat$arridx <- sibmxdat$aidx + (sibmxdat$sidx-1)*AG + (sibmxdat$yidx-1)*NG*AG + + return(sibmxdat) +} + +#' Log negative binomial density +#' +#' Log negative binomial density, mu parameterization +#' +#' Log-density of negative binomial distribution. Parameter names and +#' parameterization matches the 'mu' parameterization of \code{\link{dnbinom}}. +#' +#' @param x vector of number of events. +#' @param size dispersion parameter. +#' @param mu mean expected number of events. +ldnbinom <- function(x, size, mu){ + prob <- size/(size+mu) + lgamma(x+size) - lgamma(size) - lgamma(x+1) + size*log(prob) + x*log(1-prob) +} + + + +#' Log-likelihood for sibling history mortality data +#' +#' Calculate the log-likelihood for sibling history mortality data +#' +#' !!! NOTE: does not account for complex survey design +#' +#' @param mx Array of age/sex-specific mortality rates for each year, output +#' from function \code{\link{agemx}}. +#' @param tipscoef Vector of TIPS (time preceding survey) coefficients for +#' relative risk of underreporting deceased siblings. +#' @param theta Overdispersion of negative binomial distribution. +#' @param sibmx.dat Data frame consisting of sibling history mortality data. +ll_sibmx <- function(mx, tipscoef, theta, sibmx.dat){ + + ## predicted deaths: product of predicted mortality, tips coefficient, and person-years + mu.pred <- mx[sibmx.dat$arridx] * tipscoef[sibmx.dat$tipsidx] * sibmx.dat$pys + + return(sum(ldnbinom(sibmx.dat$deaths, theta, mu.pred))) +} + + +######################################### +#### Incidence likelihood function #### +######################################### + +#' Prepare household survey incidence likelihood data +prepare_hhsincid_likdat <- function(hhsincid, fp){ + anchor.year <- floor(min(fp$proj.steps)) + + hhsincid$idx <- hhsincid$year - (anchor.year - 1) + hhsincid$log_incid <- log(hhsincid$incid) + hhsincid$log_incid.se <- hhsincid$se/hhsincid$incid + + return(hhsincid) +} + +#' Log-likelhood for direct incidence estimate from household survey +#' +#' Calculate log-likelihood for nationally representative incidence +#' estimates from a household survey. Currently implements likelihood +#' for a log-transformed direct incidence estimate and standard error. +#' Needs to be updated to handle incidence assay outputs. +#' +#' @param mod model output, object of class `spec`. +#' @param hhsincid.dat prepared houshold survey incidence estimates (see perp +ll_hhsincid <- function(mod, hhsincid.dat){ + logincid <- log(incid(mod, fp)) + ll.incid <- sum(dnorm(hhsincid.dat$log_incid, logincid[hhsincid.dat$idx], hhsincid.dat$log_incid.se, TRUE)) + return(ll.incid) +} + + +############################### +#### Likelihood function #### +############################### + +prepare_likdat <- function(eppd, fp){ + + anchor_year <- floor(fp$proj.steps[1]) + + likdat <- list(anclik.dat = prepare_ancsite_likdat(eppd, anchor.year=anchor_year), + hhslik.dat = epp::fnPrepareHHSLikData(eppd$hhs, anchor.year=anchor_year)) + if(exists("ancrtcens", where=eppd)) + likdat$ancrtcens.dat <- prepare_ancrtcens_likdat(eppd$ancrtcens, anchor.year=anchor_year) + if(exists("hhsage", where=eppd)) + likdat$hhsage.dat <- prepare_hhsageprev_likdat(eppd$hhsage, fp) + if(exists("hhsincid", where=eppd)) + likdat$hhsincid.dat <- prepare_hhsincid_likdat(eppd$hhsincid, fp) + if(exists("sibmx", where=eppd)) + likdat$sibmx.dat <- prepare_sibmx_likdat(eppd$sibmx, fp) + + likdat$lastdata.idx <- max(unlist(likdat$anclik.dat$anc.idx.lst), + likdat$hhslik.dat$idx, + likdat$ancrtcens.dat$idx, + likdat$hhsage.dat$idx, + likdat$hhsincid.dat$idx, + likdat$sibmx.dat$idx) + likdat$firstdata.idx <- min(unlist(likdat$anclik.dat$anc.idx.lst), + likdat$hhslik.dat$idx, + likdat$ancrtcens.dat$idx, + likdat$ancrtcens.dat$idx, + likdat$hhsage.dat$idx, + likdat$hhsincid.dat$idx, + likdat$sibmx.dat$idx) + + return(likdat) +} + + + + +lprior <- function(theta, fp){ + + if(!exists("eppmod", where = fp)) # backward compatibility + fp$eppmod <- "rspline" + + if(exists("prior_args", where = fp)){ + for(i in seq_along(fp$prior_args)) + assign(names(fp$prior_args)[i], fp$prior_args[[i]]) + } + + if(fp$eppmod %in% c("rspline", "logrspline", "ospline", "logospline", "rhybrid", "logrw")){ + epp_nparam <- fp$numKnots+1 + + nk <- fp$numKnots + + if(fp$eppmod == "rhybrid") + lpr <- bayes_lmvt(theta[(1+fp$rt$spline_penord):fp$rt$n_splines], tau2_prior_shape, tau2_prior_rate) + + bayes_lmvt(theta[fp$rt$n_splines + 1:fp$rt$n_rw], rw_prior_shape, rw_prior_rate) + else if(fp$eppmod == "logrw") + lpr <- bayes_lmvt(theta[2:fp$numKnots], rw_prior_shape, rw_prior_rate) + else + lpr <- bayes_lmvt(theta[(1+fp$rtpenord):nk], tau2_prior_shape, tau2_prior_rate) + + if(exists("r0logiotaratio", fp) && fp$r0logiotaratio) + lpr <- lpr + dunif(theta[nk+1], r0logiotaratio.unif.prior[1], r0logiotaratio.unif.prior[2], log=TRUE) + else + lpr <- lpr + lprior_iota(theta[nk+1], fp) + + } else if(fp$eppmod == "rlogistic") { + epp_nparam <- 5 + lpr <- sum(dnorm(theta[1:4], rlog_pr_mean, rlog_pr_sd, log=TRUE)) + lpr <- lpr + lprior_iota(theta[5], fp) + } else if(fp$eppmod == "rtrend"){ # rtrend + + epp_nparam <- 7 + + lpr <- dunif(round(theta[1]), t0.unif.prior[1], t0.unif.prior[2], log=TRUE) + + ## dunif(theta[2], t1.unif.prior[1], t1.unif.prior[2], log=TRUE) + + dnorm(round(theta[2]), t1.pr.mean, t1.pr.sd, log=TRUE) + + ## dunif(theta[3], logr0.unif.prior[1], logr0.unif.prior[2], log=TRUE) + + dnorm(theta[3], logr0.pr.mean, logr0.pr.sd, log=TRUE) + + sum(dnorm(theta[4:7], rtrend.beta.pr.mean, rtrend.beta.pr.sd, log=TRUE)) + } else if(fp$eppmod == "rlogistic_rw"){ + epp_nparam <- fp$rt$n_param+1 + lpr <- sum(dnorm(theta[1:4], rlog_pr_mean, rlog_pr_sd, log=TRUE)) + + bayes_lmvt(theta[4+1:fp$rt$n_rw], rw_prior_shape, rw_prior_rate) + lpr <- lpr + lprior_iota(theta[fp$rt$n_param+1], fp) + } + + if(fp$ancsitedata){ + lpr <- lpr + dnorm(theta[epp_nparam+1], ancbias.pr.mean, ancbias.pr.sd, log=TRUE) + if(!exists("v.infl", where=fp)){ + anclik_nparam <- 2 + lpr <- lpr + dexp(exp(theta[epp_nparam+2]), vinfl.prior.rate, TRUE) + theta[epp_nparam+2] # additional ANC variance + } else + anclik_nparam <- 1 + } else + anclik_nparam <- 0 + + paramcurr <- epp_nparam+anclik_nparam + if(exists("ancrt", fp) && fp$ancrt %in% c("census", "both")){ + lpr <- lpr + dnorm(theta[paramcurr+1], log_frr_adjust.pr.mean, log_frr_adjust.pr.sd, log=TRUE) + if(!exists("ancrtcens.vinfl", fp)){ + lpr <- lpr + dexp(exp(theta[paramcurr+2]), ancrtcens.vinfl.pr.rate, TRUE) + theta[paramcurr+2] + paramcurr <- paramcurr+2 + } else + paramcurr <- paramcurr+1 + } + if(exists("ancrt", fp) && fp$ancrt %in% c("site", "both")){ + lpr <- lpr + dnorm(theta[paramcurr+1], ancrtsite.beta.pr.mean, ancrtsite.beta.pr.sd, log=TRUE) ## + + ## dexp(exp(theta[np]), ancrtsite.vinfl.pr.rate, TRUE) + theta[np] + paramcurr <- paramcurr+1 + } + + if(exists("fitincrr", where=fp)){ + incrr_nparam <- getnparam_incrr(fp) + if(incrr_nparam){ + lpr <- lpr + lprior_incrr(theta[paramcurr+1:incrr_nparam], fp) + paramcurr <- paramcurr+incrr_nparam + } + } + + return(lpr) +} + + +ll <- function(theta, fp, likdat){ + theta.last <<- theta + fp <- update(fp, list=fnCreateParam(theta, fp)) + + if(exists("fitincrr", where=fp) && fp$fitincrr==TRUE){ + ll.incpen <- sum(dnorm(diff(fp$logincrr_age, differences=2), sd=fp$sigma_agepen, log=TRUE)) + } else + ll.incpen <- 0 + + if (!exists("eppmod", where = fp) || fp$eppmod %in% c("rspline", "logrspline", "ospline", "logospline", "rhybrid")) + if (any(is.na(fp$rvec)) || min(fp$rvec) < 0 || max(fp$rvec) > 20) + return(-Inf) + + mod <- simmod(fp) + + qM.all <- suppressWarnings(qnorm(prev(mod))) + qM.preg <- if(exists("pregprev", where=fp) && !fp$pregprev) qM.all else suppressWarnings(qnorm(fnPregPrev(mod, fp))) + + if(any(is.na(qM.preg[likdat$firstdata.idx:likdat$lastdata.idx])) || + any(is.na(qM.all[likdat$firstdata.idx:likdat$lastdata.idx])) || + any(qM.preg[likdat$firstdata.idx:likdat$lastdata.idx] == -Inf) || + any(qM.preg[likdat$firstdata.idx:likdat$lastdata.idx] > 2)) # prevalence not greater than pnorm(2) = 0.977 + return(-Inf) + + ## ANC likelihood + if(fp$ancsitedata) + ll.anc <- ll_anc(qM.preg, coef=c(fp$ancbias, fp$ancrtsite.beta), vinfl=fp$v.infl, likdat$anclik.dat) + else + ll.anc <- 0 + + if(exists("ancrt", fp) && fp$ancrt %in% c("census", "both")) + ll.ancrt <- ll_ancrtcens(qM.preg, likdat$ancrtcens.dat, fp) + else + ll.ancrt <- 0 + + + ## Household survey likelihood + if(exists("ageprev", where=fp) && fp$ageprev=="binom") + ll.hhs <- ll_hhsage_binom(mod, likdat$hhsage.dat) + else if(exists("ageprev", where=fp) && (fp$ageprev==TRUE | fp$ageprev == "probit")) # ==TRUE for backward compatibility + ll.hhs <- ll_hhsage(mod, likdat$hhsage.dat) # probit-transformed model + else + ll.hhs <- ll_hhs(qM.all, likdat$hhslik.dat) + + if(!is.null(likdat$hhsincid.dat)) + ll.incid <- ll_hhsincid(mod, likdat$hhsincid.dat) + else + ll.incid <- 0 + + + if(exists("sibmx", where=fp) && fp$sibmx){ + M.agemx <- agemx(mod) + ll.sibmx <- ll_sibmx(M.agemx, fp$tipscoef, fp$sibmx.theta, likdat$sibmx.dat) + } else + ll.sibmx <- 0 + + if(exists("equil.rprior", where=fp) && fp$equil.rprior){ + rvec.ann <- fp$rvec[fp$proj.steps %% 1 == 0.5] + equil.rprior.mean <- epp:::muSS/(1-pnorm(qM.all[likdat$lastdata.idx])) + equil.rprior.sd <- sqrt(mean((epp:::muSS/(1-pnorm(qM.all[likdat$lastdata.idx - 9:0])) - rvec.ann[likdat$lastdata.idx - 9:0])^2)) # empirical sd based on 10 previous years + ll.rprior <- sum(dnorm(rvec.ann[(likdat$lastdata.idx+1L):length(qM.all)], equil.rprior.mean, equil.rprior.sd, log=TRUE)) # prior starts year after last data + } else + ll.rprior <- 0 + + ## return(ll.anc+ll.hhs+ll.incpen+ll.rprior) + return(ll.anc + ll.ancrt + ll.hhs + ll.incid + ll.sibmx + ll.rprior + ll.incpen) +} + + +########################## +#### IMIS functions #### +########################## + +sample.prior <- function(n, fp){ + + if(!exists("eppmod", where = fp)) # backward compatibility + fp$eppmod <- "rspline" + + if(exists("prior_args", where = fp)){ + for(i in seq_along(fp$prior_args)) + assign(names(fp$prior_args)[i], fp$prior_args[[i]]) + } + + ## Calculate number of parameters + if(fp$eppmod %in% c("rspline", "logrspline", "ospline", "logospline", "rhybrid", "logrw")) + epp_nparam <- fp$numKnots+1L + else if(fp$eppmod == "rlogistic") + epp_nparam <- 5 + else if(fp$eppmod == "rtrend") + epp_nparam <- 7 + else if(fp$eppmod == "rlogistic_rw") + epp_nparam <- fp$rt$n_param+1 + + if(fp$ancsitedata) + if(!exists("v.infl", fp)) + anclik_nparam <- 2 + else + anclik_nparam <- 1 + else + anclik_nparam <- 0 + + if(exists("ancrt", fp) && fp$ancrt == "both") + ancrt_nparam <- 2 + else if(exists("ancrt", fp) && fp$ancrt == "census") + ancrt_nparam <- 1 + else if(exists("ancrt", fp) && fp$ancrt == "site") + ancrt_nparam <- 1 + else + ancrt_nparam <- 0 + + if(exists("ancrt", fp) && fp$ancrt %in% c("census", "both") && !exists("ancrtcens.vinfl", fp)) + ancrt_nparam <- ancrt_nparam+1 + + nparam <- epp_nparam+anclik_nparam+ancrt_nparam + + if(exists("fitincrr", where=fp)) nparam <- nparam+getnparam_incrr(fp) + + + ## Create matrix for storing samples + mat <- matrix(NA, n, nparam) + + if(fp$eppmod %in% c("rspline", "logrspline", "ospline", "logospline", "rhybrid", "logrw")){ + epp_nparam <- fp$numKnots+1 + + if(fp$eppmod == "rspline") + mat[,1] <- rnorm(n, 1.5, 1) # u[1] + if(fp$eppmod == "ospline") + mat[,1] <- rnorm(n, 0.5, 1) + else # logrspline, logospline, logrw + mat[,1] <- rnorm(n, 0.2, 1) # u[1] + if(fp$eppmod == "rhybrid"){ + mat[,2:fp$rt$n_splines] <- bayes_rmvt(n, fp$rt$n_splines-1,tau2_init_shape, tau2_init_rate) + mat[,fp$rt$n_splines+1:fp$rt$n_rw] <- bayes_rmvt(n, fp$rt$n_rw, rw_prior_shape, rw_prior_rate) # u[2:numKnots] + } else if(fp$eppmod == "logrw"){ + mat[,2:fp$rt$n_rw] <- bayes_rmvt(n, fp$rt$n_rw-1, rw_prior_shape, rw_prior_rate) # u[2:numKnots] + } else { + mat[,2:fp$numKnots] <- bayes_rmvt(n, fp$numKnots-1,tau2_init_shape, tau2_init_rate) # u[2:numKnots] + } + + if(exists("r0logiotaratio", fp) && fp$r0logiotaratio) + mat[,fp$numKnots+1] <- runif(n, r0logiotaratio.unif.prior[1], r0logiotaratio.unif.prior[2]) # ratio r0 / log(iota) + else + mat[,fp$numKnots+1] <- sample_iota(n, fp) + } else if(fp$eppmod == "rlogistic"){ + mat[,1:4] <- t(matrix(rnorm(4*n, rlog_pr_mean, rlog_pr_sd), 4)) + mat[,5] <- sample_iota(n, fp) + } else if(fp$eppmod == "rtrend"){ # r-trend + + mat[,1] <- runif(n, t0.unif.prior[1], t0.unif.prior[2]) # t0 + ## mat[,2] <- runif(n, t1.unif.prior[1], t1.unif.prior[2]) # t1 + mat[,2] <- rnorm(n, t1.pr.mean, t1.pr.sd) + ## mat[,3] <- runif(n, logr0.unif.prior[1], logr0.unif.prior[2]) # r0 + mat[,3] <- rnorm(n, logr0.pr.mean, logr0.pr.sd) # r0 + mat[,4:7] <- t(matrix(rnorm(4*n, rtrend.beta.pr.mean, rtrend.beta.pr.sd), 4, n)) # beta + } else if(fp$eppmod == "rlogistic_rw") { + mat[,1:4] <- t(matrix(rnorm(4*n, rlog_pr_mean, rlog_pr_sd), 4)) + mat[,4+1:fp$rt$n_rw] <- bayes_rmvt(n, fp$rt$n_rw, rw_prior_shape, rw_prior_rate) # u[2:numKnots] + mat[,fp$rt$n_param+1] <- sample_iota(n, fp) + } + + ## sample ANC bias paramters + if(fp$ancsitedata){ + mat[,epp_nparam+1] <- rnorm(n, ancbias.pr.mean, ancbias.pr.sd) # ancbias parameter + if(!exists("v.infl", where=fp)) + mat[,epp_nparam+2] <- log(rexp(n, vinfl.prior.rate)) + } + + ## sample ANCRT parameters + paramcurr <- epp_nparam+anclik_nparam + if(exists("ancrt", where=fp) && fp$ancrt %in% c("census", "both")){ + mat[,paramcurr+1] <- rnorm(n, log_frr_adjust.pr.mean, log_frr_adjust.pr.sd) + if(!exists("ancrtcens.vinfl", fp)){ + mat[,paramcurr+2] <- log(rexp(n, ancrtcens.vinfl.pr.rate)) + paramcurr <- paramcurr+2 + } else + paramcurr <- paramcurr+1 + } + if(exists("ancrt", where=fp) && fp$ancrt %in% c("site", "both")){ + mat[,paramcurr+1] <- rnorm(n, ancrtsite.beta.pr.mean, ancrtsite.beta.pr.sd) + ## mat[,nparam] <- log(rexp(n, ancrtsite.vinfl.pr.rate)) + paramcurr <- paramcurr+1 + } + + if(exists("fitincrr", where=fp)){ + incrr_nparam <- getnparam_incrr(fp) + if(incrr_nparam) + mat[,paramcurr+1:incrr_nparam] <- sample_incrr(n, fp) + paramcurr <- paramcurr+incrr_nparam + } + + return(mat) +} + +ldsamp <- function(theta, fp){ + + if(!exists("eppmod", where = fp)) # backward compatibility + fp$eppmod <- "rspline" + + if(exists("prior_args", where = fp)){ + for(i in seq_along(fp$prior_args)) + assign(names(fp$prior_args)[i], fp$prior_args[[i]]) + } + + if(fp$eppmod %in% c("rspline", "logrspline", "ospline", "logospline", "rhybrid", "logrw")){ + epp_nparam <- fp$numKnots+1 + + nk <- fp$numKnots + + if(fp$eppmod == "rspline") # u[1] + lpr <- dnorm(theta[1], 1.5, 1, log=TRUE) + if(fp$eppmod == "ospline") + lpr <- dnorm(theta[1], 0.5, 1, log=TRUE) + else # logrspline, logospline, logrw + lpr <- dnorm(theta[1], 0.2, 1, log=TRUE) + + if(fp$eppmod == "rhybrid") + lpr <- bayes_lmvt(theta[2:fp$rt$n_splines], tau2_init_shape, tau2_init_rate) + + bayes_lmvt(theta[fp$rt$n_splines + 1:fp$rt$n_rw], rw_prior_shape, rw_prior_rate) + else if(fp$eppmod == "logrw") + bayes_lmvt(theta[2:fp$rt$n_rw], rw_prior_shape, rw_prior_rate) + else + lpr <- bayes_lmvt(theta[2:nk], tau2_prior_shape, tau2_prior_rate) + + + if(exists("r0logiotaratio", fp) && fp$r0logiotaratio) + lpr <- lpr + dunif(theta[nk+1], r0logiotaratio.unif.prior[1], r0logiotaratio.unif.prior[2], log=TRUE) + else + lpr <- lpr + ldsamp_iota(theta[nk+1], fp) + + } else if(fp$eppmod == "rlogistic") { + epp_nparam <- 5 + lpr <- sum(dnorm(theta[1:4], rlog_pr_mean, rlog_pr_sd, log=TRUE)) + lpr <- lpr + ldsamp_iota(theta[5], fp) + } else if(fp$eppmod == "rtrend"){ # rtrend + + epp_nparam <- 7 + + lpr <- dunif(round(theta[1]), t0.unif.prior[1], t0.unif.prior[2], log=TRUE) + + ## dunif(theta[2], t1.unif.prior[1], t1.unif.prior[2], log=TRUE) + + dnorm(round(theta[2]), t1.pr.mean, t1.pr.sd, log=TRUE) + + ## dunif(theta[3], logr0.unif.prior[1], logr0.unif.prior[2], log=TRUE) + + dnorm(theta[3], logr0.pr.mean, logr0.pr.sd, log=TRUE) + + sum(dnorm(theta[4:7], rtrend.beta.pr.mean, rtrend.beta.pr.sd, log=TRUE)) + } else if(fp$eppmod == "rlogistic_rw"){ + epp_nparam <- fp$rt$n_param+1 + lpr <- sum(dnorm(theta[1:4], rlog_pr_mean, rlog_pr_sd, log=TRUE)) + + bayes_lmvt(theta[4+1:fp$rt$n_rw], rw_prior_shape, rw_prior_rate) + lpr <- lpr + ldsamp_iota(theta[fp$rt$n_param+1], fp) + } + + if(fp$ancsitedata){ + lpr <- lpr + dnorm(theta[epp_nparam+1], ancbias.pr.mean, ancbias.pr.sd, log=TRUE) + if(!exists("v.infl", where=fp)){ + anclik_nparam <- 2 + lpr <- lpr + dexp(exp(theta[epp_nparam+2]), vinfl.prior.rate, TRUE) + theta[epp_nparam+2] # additional ANC variance + } else + anclik_nparam <- 1 + } else + anclik_nparam <- 0 + + paramcurr <- epp_nparam+anclik_nparam + if(exists("ancrt", fp) && fp$ancrt %in% c("census", "both")){ + lpr <- lpr + dnorm(theta[paramcurr+1], log_frr_adjust.pr.mean, log_frr_adjust.pr.sd, log=TRUE) + if(!exists("ancrtcens.vinfl", fp)){ + lpr <- lpr + dexp(exp(theta[paramcurr+2]), ancrtcens.vinfl.pr.rate, TRUE) + theta[paramcurr+2] + paramcurr <- paramcurr+2 + } else + paramcurr <- paramcurr+1 + } + if(exists("ancrt", fp) && fp$ancrt %in% c("site", "both")){ + lpr <- lpr + dnorm(theta[paramcurr+1], ancrtsite.beta.pr.mean, ancrtsite.beta.pr.sd, log=TRUE) ## + + ## dexp(exp(theta[np]), ancrtsite.vinfl.pr.rate, TRUE) + theta[np] + paramcurr <- paramcurr+1 + } + + if(exists("fitincrr", where=fp)){ + incrr_nparam <- getnparam_incrr(fp) + if(incrr_nparam){ + lpr <- lpr + ldsamp_incrr(theta[paramcurr+1:incrr_nparam], fp) + paramcurr <- paramcurr+incrr_nparam + } + } + + return(lpr) +} + + +prior <- function(theta, fp, log=FALSE){ + if(is.vector(theta)) + lval <- lprior(theta, fp) + else + lval <- unlist(lapply(seq_len(nrow(theta)), function(i) (lprior(theta[i,], fp)))) + if(log) + return(lval) + else + return(exp(lval)) +} + +likelihood <- function(theta, fp, likdat, log=FALSE){ + if(is.vector(theta)) + lval <- ll(theta, fp, likdat) + else + lval <- unlist(lapply(seq_len(nrow(theta)), function(i) ll(theta[i,], fp, likdat))) + if(log) + return(lval) + else + return(exp(lval)) +} + +dsamp <- function(theta, fp, log=FALSE){ + if(is.vector(theta)) + lval <- ldsamp(theta, fp) + else + lval <- unlist(lapply(seq_len(nrow(theta)), function(i) (ldsamp(theta[i,], fp)))) + if(log) + return(lval) + else + return(exp(lval)) +} diff --git a/R/model-outputs.R b/R/model-outputs.R new file mode 100644 index 0000000..42ce516 --- /dev/null +++ b/R/model-outputs.R @@ -0,0 +1,122 @@ +estci2 <- function(x){ + if(is.vector(x)) x <- matrix(x, 1) + nd <- length(dim(x)) + val <- apply(x, seq_len(nd-1), function(y) c(mean(y), sd(y), quantile(y, c(0.5, 0.025, 0.975)))) + val <- aperm(val, c(2:nd, 1)) + dimnames(val)[[nd]] <- c("mean", "se", "median", "lower", "upper") + val +} + +sub_na <- function(x, v=0){x[is.na(x)] <- v; x} + +summary_outputs <- function(fit, modlist){ + out <- list() + + startyr <- fit$fp$ss$proj_start + endyr <- fit$fp$ss$proj_start + fit$fp$ss$PROJ_YEARS-1L + + out$prev <- sapply(modlist, prev) + out$incid <- sapply(modlist, incid) + out$incid[min(which(out$incid[,1] > 0)),] <- 0 # remove initial seed incidence + out$transmrate <- estci2(sub_na(out$incid / out$prev)) + out$prev <- estci2(out$prev) + out$incid <- estci2(out$incid) + if(!is.null(attr(modlist[[1]], "pregprev"))) + out$pregprev <- estci2(sapply(modlist, fnPregPrev)) + + out$artcov15plus <- estci2(sub_na(sapply(modlist, artcov15plus))) + out$artcov15to49 <- estci2(sub_na(sapply(modlist, artcov15to49))) + + ## Sex ratio of incidence 14-49 + out$incidsexratio <- lapply(modlist, ageincid, aidx=15-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=startyr:endyr - startyr+1L, agspan=35) + out$incidsexratio <- estci2(sub_na(sapply(out$incidsexratio, function(x) x[,2,] / x[,1,]))) + + + ann <- c("prev", "incid", "artcov15plus", "artcov15to49", "transmrate", "incidsexratio") + if(exists("pregprev", out)) ann <- c(ann, "pregprev") + out[ann] <- lapply(out[ann], function(x){dimnames(x)[[1]] <- startyr:endyr; x}) + + + ## Prevalence, incidence, and ART coverage by age categories and sex + agegr3 <- lapply(modlist, ageprev, aidx=c(15, 25, 35, 50)-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=1999:endyr - startyr+1L, agspan=c(10, 10, 15, 31)) + age15to49 <- lapply(modlist, ageprev, aidx=15-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=1999:endyr - startyr+1L, agspan=35) + age15plus <- lapply(modlist, ageprev, aidx=15-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=1999:endyr - startyr+1L, agspan=66) + agegr3 <- estci2(abind::abind(agegr3, rev.along=0)) + age15to49 <- estci2(abind::abind(age15to49, rev.along=0)) + age15plus <- estci2(abind::abind(age15plus, rev.along=0)) + out$agegr3prev <- abind::abind(agegr3, age15to49, age15plus, along=1) + + agegr3 <- lapply(modlist, ageincid, aidx=c(15, 25, 35, 50)-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=1999:endyr - startyr+1L, agspan=c(10, 10, 15, 31)) + age15to49 <- lapply(modlist, ageincid, aidx=15-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=1999:endyr - startyr+1L, agspan=35) + age15plus <- lapply(modlist, ageincid, aidx=15-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=1999:endyr - startyr+1L, agspan=66) + agegr3 <- estci2(abind::abind(agegr3, rev.along=0)) + age15to49 <- estci2(abind::abind(age15to49, rev.along=0)) + age15plus <- estci2(abind::abind(age15plus, rev.along=0)) + out$agegr3incid <- abind::abind(agegr3, age15to49, age15plus, along=1) + + agegr3 <- lapply(modlist, ageinfections, aidx=c(15, 25, 35, 50)-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=1999:endyr - startyr+1L, agspan=c(10, 10, 15, 31)) + age15to49 <- lapply(modlist, ageinfections, aidx=15-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=1999:endyr - startyr+1L, agspan=35) + age15plus <- lapply(modlist, ageinfections, aidx=15-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=1999:endyr - startyr+1L, agspan=66) + agegr3 <- estci2(abind::abind(agegr3, rev.along=0)) + age15to49 <- estci2(abind::abind(age15to49, rev.along=0)) + age15plus <- estci2(abind::abind(age15plus, rev.along=0)) + out$agegr3infections <- abind::abind(agegr3, age15to49, age15plus, along=1) + + dimnames(out$agegr3prev)[1:3] <- dimnames(out$agegr3incid)[1:3] <- dimnames(out$agegr3infections)[1:3] <- + list(agegr=c("15-24", "25-34", "35-49", "50+", "15-49", "15+"), sex=c("Male", "Female"), year=1999:endyr) + + + agegr3 <- lapply(modlist, ageartcov, aidx=c(15, 25, 35, 50)-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=2005:endyr - startyr+1L, agspan=c(10, 10, 15, 31)) + age15to49 <- lapply(modlist, ageartcov, aidx=15-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=2005:endyr - startyr+1L, agspan=35) + age15plus <- lapply(modlist, ageartcov, aidx=15-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=2005:endyr - startyr+1L, agspan=66) + agegr3 <- estci2(abind::abind(agegr3, rev.along=0)) + age15to49 <- estci2(abind::abind(age15to49, rev.along=0)) + age15plus <- estci2(abind::abind(age15plus, rev.along=0)) + out$agegr3artcov <- abind::abind(agegr3, age15to49, age15plus, along=1) + dimnames(out$agegr3artcov)[1:3] <- list(agegr=c("15-24", "25-34", "35-49", "50+", "15-49", "15+"), sex=c("Male", "Female"), year=2005:endyr) + + + ## Age-specific prevalence in survey years + out$ageprevdat <- data.frame(fit$likdat$hhsage.dat[c("survyear", "year", "sex", "agegr")], + estci2(sapply(modlist, ageprev, arridx=fit$likdat$hhsage.dat$arridx, agspan=5))) + + ## Incidence relative to 25-29y + out$relincid <- lapply(modlist, ageincid, aidx=3:9*5-fit$fp$ss$AGE_START+1L, sidx=1:2, + yidx=c(2001, 2006, 2011, 2016)- startyr+1L, agspan=5) + out$relincid <- estci2(abind::abind(lapply(out$relincid, function(x) sweep(x, 2:3, x[3,,], "/")), rev.along=0)) + dimnames(out$relincid)[1:3] <- list(agegr=paste0(3:9*5, "-", 3:9*5+4), sex=c("Male", "Female"), year=2001+0:3*5) + + return(out) +} + + +create_outputs <- function(fit){ + paramlist <- lapply(seq_len(nrow(fit$resample)), function(ii) fnCreateParam(fit$resample[ii,], fit$fp)) + fplist <- lapply(paramlist, function(par) update(fit$fp, list=par)) + modlist <- lapply(fplist, simmod) + + out <- summary_outputs(fit, modlist) + out +} + +#' @param fitlist list of model fits to aggregate. +#' @param fitnat single fit to use as the base fit with aggregation. +#' @param both flag indicating whether to return outputs for both aggregated fit and individual fits (default TRUE). +create_aggr_outputs <- function(fitlist, fitnat, both=TRUE){ + + modlist <- aggr_specfit(fitlist) + summary_outputs(fitnat, modlist) +} diff --git a/R/plot.R b/R/plot.R index de274f2..a1fdf7b 100644 --- a/R/plot.R +++ b/R/plot.R @@ -1,28 +1,34 @@ -cred.region <- function(x, y, ...) +cred.region <- function(x, y, ...){ + if(nrow(y) != 2) y <- t(y) polygon(c(x, rev(x)), c(y[1,], rev(y[2,])), border=NA, ...) +} -transp <- function(col, alpha=0.5) - return(apply(col2rgb(col), 2, function(c) rgb(c[1]/255, c[2]/255, c[3]/255, alpha))) +transp <- function(col, alpha=0.5) adjustcolor(col, alpha) -estci <- function(x){val <- cbind(rowMeans(x), t(apply(x, 1, quantile, c(0.5, 0.025, 0.975)))); colnames(val) <- c("mean", "median", "lower", "upper"); val} +estci <- function(x){ + if(is.vector(x)) x <- matrix(x, 1) + val <- cbind(rowMeans(x), t(apply(x, 1, quantile, c(0.5, 0.025, 0.975)))); colnames(val) <- c("mean", "median", "lower", "upper"); + val +} -plot_compare_ageprev <- function(fit, fit2=NULL, fit3=NULL, ylim=NULL, col=c("grey30", "darkred", "forestgreen")){ +plot_compare_ageprev <- function(fit, fit2=NULL, fit3=NULL, specres=NULL, ylim=NULL, col=c("grey30", "darkred", "forestgreen")){ if(is.null(ylim)) - ylim <- c(0, 0.05*ceiling(max(fit$likdat$hhsage.dat$ci_u)/0.05)) + ylim <- c(0, 0.05*ceiling(max(1.3*fit$likdat$hhsage.dat$prev)/0.05)) #### survprev <- data.frame(fit$likdat$hhsage.dat, estci(fit$ageprevdat)) - survprev <- split(survprev, factor(survprev$year)) + survprev$survyear <- with(survprev, factor(survyear, levels(survyear)[order(as.integer(substr(levels(survyear), 1, 4)))])) + survprev <- split(survprev, factor(survprev$survyear)) ## if(!is.null(fit2)){ survprev2 <- data.frame(fit2$likdat$hhsage.dat, estci(fit2$ageprevdat)) - survprev2 <- split(survprev2, factor(survprev2$year)) + survprev2 <- split(survprev2, factor(survprev2$survyear)) } if(!is.null(fit3)){ survprev3 <- data.frame(fit3$likdat$hhsage.dat, estci(fit3$ageprevdat)) - survprev3 <- split(survprev3, factor(survprev3$year)) + survprev3 <- split(survprev3, factor(survprev3$survyear)) } ## par(mfrow=c(4,2), mar=c(2, 3, 2, 1), tcl=-0.25, mgp=c(2, 0.5, 0), las=1, cex=1) @@ -35,9 +41,12 @@ plot_compare_ageprev <- function(fit, fit2=NULL, fit3=NULL, ylim=NULL, col=c("gr sp3 <- subset(survprev3[[isurv]], sex==isex & as.integer(agegr) %in% 3:11) ## xx <- as.integer(sp$agegr) + main <- if(!is.null(sp$region)) + paste0(sp$country[1], " ", gsub("(\\w)(\\w*)", "\\U\\1\\L\\2", sp$region[1], perl=TRUE), " ", survprev[[isurv]]$survyear[1], ", ", isex) + else + paste0(sp$country[1], " ", survprev[[isurv]]$survyear[1], ", ", isex) plot(xx+0.5, sp$prev, type="n", xlim=c(4, 12), ylim=ylim, xaxt="n", - main=paste0(sp$country[1], " ", survprev[[isurv]]$survyear[1], ", ", isex), - xlab="", ylab="") + main=main, xlab="", ylab="") axis(1, xx+0.5, sp$agegr) ## rect(xx+0.05, sp$lower, xx+0.95, sp$upper, @@ -55,6 +64,12 @@ plot_compare_ageprev <- function(fit, fit2=NULL, fit3=NULL, ylim=NULL, col=c("gr segments(xx+0.05, sp3$mean, xx+0.95, col=col[3], lwd=2) } ## + if(!is.null(specres)){ + csex <- sub("(\\b[a-z]{1})", "\\U\\1" , isex, perl=TRUE) + stryear <- as.character(survprev[[isurv]]$year[1]) + specres.prev <- tapply(specres$hivpop[as.character(15:54), csex, stryear], rep(3:10, each=5), sum) / tapply(specres$totpop[as.character(15:54), csex, stryear], rep(3:10, each=5), sum) + segments(4:11+0.1, specres.prev, 4:11+0.9, lty=3, col="grey10", lwd=2) + } points(xx+0.5, sp$prev, pch=19) segments(x0=xx+0.5, y0=sp$ci_l, y1=sp$ci_u) } @@ -64,14 +79,20 @@ plot_compare_ageprev <- function(fit, fit2=NULL, fit3=NULL, ylim=NULL, col=c("gr -plot_prev <- function(fit, ..., ylim=NULL, xlim=c(1980, 2016), col="blue", main=""){ +plot_prev <- function(fit, ..., ylim=NULL, xlim=c(1980, with(fit$fp$ss, proj_start+PROJ_YEARS-1)), col="blue", main="", ylab="prevalence", plotancdata=FALSE, plotprevdat=TRUE){ if(is.null(ylim)) ylim <- c(0, 1.1*max(apply(fit$prev, 1, quantile, 0.975))) xx <- fit$fp$ss$proj_start-1+1:fit$fp$ss$PROJ_YEARS - plot(xx, rowMeans(fit$prev), type="n", ylim=ylim, xlim=xlim, ylab="prevalence", xlab="", yaxt="n", xaxt="n", main=main) + plot(xx, rowMeans(fit$prev), type="n", ylim=ylim, xlim=xlim, ylab=ylab, xlab="", yaxt="n", xaxt="n", main=main) axis(1, labels=TRUE) axis(2, labels=TRUE) dots <- list(...) + + if(plotancdata){ + with(fit$likdat$anclik.dat, mapply(function(idx, W) points(idx+1970-1, pnorm(W), col=adjustcolor("grey", 0.5), pch=15), anc.idx.lst, W.lst)) + with(fit$likdat$anclik.dat, mapply(function(idx, W) lines(idx+1970-1, pnorm(W), col=adjustcolor("grey", 0.5), pch=15), anc.idx.lst, W.lst)) + } + for(ii in seq_along(dots)) cred.region(xx, apply(dots[[ii]]$prev, 1, quantile, c(0.025, 0.975)), col=transp(col[1+ii], 0.3)) cred.region(xx, apply(fit$prev, 1, quantile, c(0.025, 0.975)), col=transp(col[1], 0.3)) @@ -79,18 +100,20 @@ plot_prev <- function(fit, ..., ylim=NULL, xlim=c(1980, 2016), col="blue", main= lines(xx, rowMeans(dots[[ii]]$prev), col=col[1+ii], lwd=1.5) lines(xx, rowMeans(fit$prev), col=col[1], lwd=1.5) ## - points(fit$likdat$hhslik.dat$year, fit$likdat$hhslik.dat$prev, pch=20) - segments(fit$likdat$hhslik.dat$year, - y0=pnorm(fit$likdat$hhslik.dat$W.hhs - qnorm(0.975)*fit$likdat$hhslik.dat$sd.W.hhs), - y1=pnorm(fit$likdat$hhslik.dat$W.hhs + qnorm(0.975)*fit$likdat$hhslik.dat$sd.W.hhs)) + if(plotprevdat){ + points(fit$likdat$hhslik.dat$year, fit$likdat$hhslik.dat$prev, pch=20) + segments(fit$likdat$hhslik.dat$year, + y0=pnorm(fit$likdat$hhslik.dat$W.hhs - qnorm(0.975)*fit$likdat$hhslik.dat$sd.W.hhs), + y1=pnorm(fit$likdat$hhslik.dat$W.hhs + qnorm(0.975)*fit$likdat$hhslik.dat$sd.W.hhs)) + } } -plot_incid <- function(fit, ..., ylim=NULL, xlim=c(1980, 2016), col="blue", main=""){ +plot_incid <- function(fit, ..., ylim=NULL, xlim=c(1980, with(fit$fp$ss, proj_start+PROJ_YEARS-1)), col="blue", main="", ylab="incidence rate"){ if(is.null(ylim)) ylim <- c(0, 1.1*max(apply(fit$incid, 1, quantile, 0.975))) xx <- fit$fp$ss$proj_start-1+1:fit$fp$ss$PROJ_YEARS plot(xx, rowMeans(fit$incid), type="n", ylim=ylim, xlim=xlim, - ylab="incidence rate", xlab="", yaxt="n", xaxt="n", main=main) + ylab=ylab, xlab="", yaxt="n", xaxt="n", main=main) axis(1, labels=TRUE) axis(2, labels=TRUE) dots <- list(...) @@ -100,9 +123,13 @@ plot_incid <- function(fit, ..., ylim=NULL, xlim=c(1980, 2016), col="blue", main for(ii in seq_along(dots)) lines(xx, rowMeans(dots[[ii]]$incid), col=col[1+ii],lwd=1.5) lines(xx, rowMeans(fit$incid), col=col, lwd=1.5) + ## + if(exists("hhsincid.dat", where=fit$likdat)) + with(fit$likdat$hhsincid.dat,{ points(year, incid, pch=20); + segments(year, y0=exp(log_incid-qnorm(0.975)*log_incid.se), y1=exp(log_incid+qnorm(0.975)*log_incid.se))}) } -plot_rvec <- function(fit, ..., ylim=NULL, xlim=c(1980, 2016), col="blue"){ +plot_rvec <- function(fit, ..., ylim=NULL, xlim=c(1980, with(fit$fp$ss, proj_start+PROJ_YEARS-1)), col="blue"){ dots <- list(...) fit$rvec <- sapply(seq_len(ncol(fit$rvec)), function(i) replace(fit$rvec[,i], fit$fp$proj.steps < fit$param[[i]]$tsEpidemicStart, NA)) idx <- seq_len(length(fit$fp$proj.steps)-1) @@ -122,3 +149,65 @@ plot_rvec <- function(fit, ..., ylim=NULL, xlim=c(1980, 2016), col="blue"){ lines(xx, rowMeans(fit$rvec[idx,], na.rm=TRUE)[idx], col=col[1]) return(invisible()) } + +plot_ancprev <- function(fit, ..., data=fit$likdat, ylim=NULL, xlim=c(1980, with(fit$fp$ss, proj_start+PROJ_YEARS-1)), col="blue", main="", ylab="ANC prevalence"){ + + ## Calculate parameters for bias term + param <- apply(fit$resample, 1, fnCreateParam, fit$fp) + ## ancrtcens.bias <- sapply(param, "[[", "ancrtcens.bias") + ancrtcens.vinfl <- sapply(param, "[[", "ancrtcens.vinfl") + ancrt.prev <- fit$pregprev + + dots <- list(...) + dots_param <- lapply(dots, function(fit) apply(fit$resample, 1, fnCreateParam, fit$fp)) + ## dots_ancrtcens.bias <- lapply(dots_param, sapply, "[[", "ancrtcens.bias") + dots_ancrtcens.vinfl <- lapply(dots_param, sapply, "[[", "ancrtcens.vinfl") + dots_ancrt.prev <- lapply(dots, "[[", "pregprev") + + if(is.null(ylim)) + ylim <- c(0, 1.1*max(apply(ancrt.prev, 1, quantile, 0.975))) + xx <- fit$fp$ss$proj_start-1+1:fit$fp$ss$PROJ_YEARS + plot(xx, rowMeans(fit$pregprev), type="n", ylim=ylim, xlim=xlim, ylab=ylab, xlab="", yaxt="n", xaxt="n", main=main) + axis(1, labels=TRUE) + axis(2, labels=TRUE) + for(ii in seq_along(dots)) + cred.region(xx, apply(dots_ancrt.prev[[ii]], 1, quantile, c(0.025, 0.975)), col=transp(col[1+ii], 0.3)) + cred.region(xx, apply(ancrt.prev, 1, quantile, c(0.025, 0.975)), col=transp(col[1], 0.3)) + for(ii in seq_along(dots)) + lines(xx, rowMeans(dots_ancrt.prev[[ii]]), col=col[1+ii], lwd=1.5) + lines(xx, rowMeans(ancrt.prev), col=col[1], lwd=1.5) + ## + if(!is.null(data$ancrtcens.dat)){ + vinfl <- if(!is.null(fit$fp$ancrtcens.vinfl)) fit$fp$ancrtcens.vinfl else mean(ancrtcens.vinfl) + with(data$ancrtcens.dat, segments(x0=year, col="grey50", + y0=pnorm(qnorm(prev) - qnorm(0.975)*sqrt(v.ancrt+vinfl)), + y1=pnorm(qnorm(prev) + qnorm(0.975)*sqrt(v.ancrt+vinfl)))) + with(data$ancrtcens.dat, segments(year, + y0=pnorm(qnorm(prev) - qnorm(0.975)*sqrt(v.ancrt)), + y1=pnorm(qnorm(prev) + qnorm(0.975)*sqrt(v.ancrt)))) + with(data$ancrtcens.dat, points(year, prev, pch=20)) + } +} + + +plot_log_rvec <- function(fit, ..., ylim=NULL, xlim=c(1980, with(fit$fp$ss, proj_start+PROJ_YEARS-1)), col="blue"){ + dots <- list(...) + fit$rvec <- sapply(seq_len(ncol(fit$rvec)), function(i) replace(fit$rvec[,i], fit$fp$proj.steps < fit$param[[i]]$tsEpidemicStart, NA)) + idx <- seq_len(length(fit$fp$proj.steps)-1) + xx <- fit$fp$proj.steps[idx] + for(ii in seq_along(dots)) + dots[[ii]]$rvec <- sapply(seq_len(ncol(dots[[ii]]$rvec)), function(i) replace(dots[[ii]]$rvec[,i], dots[[ii]]$fp$proj.steps < dots[[ii]]$param[[i]]$tsEpidemicStart, NA)) + if(is.null(ylim)) + ylim <- c(max(quantile(apply(log(fit$rvec), 1, quantile, 0.025, na.rm=TRUE), 0.025, na.rm=TRUE), -6), + min(quantile(apply(log(fit$rvec), 1, quantile, 0.975, na.rm=TRUE), 0.975, na.rm=TRUE), 5)) + plot(xx, rowMeans(log(fit$rvec), na.rm=TRUE)[idx], type="n", ylim=ylim, xlim=xlim, ylab="log r(t)", yaxt="n", xlab="") + axis(1, labels=TRUE) + axis(2, labels=TRUE) + for(ii in seq_along(dots)) + cred.region(xx, apply(log(dots[[ii]]$rvec[idx,]), 1, quantile, c(0.025, 0.975), na.rm=TRUE), col=transp(col[1+ii], 0.3)) + cred.region(xx, apply(log(fit$rvec[idx,]), 1, quantile, c(0.025, 0.975), na.rm=TRUE), col=transp(col[1], 0.3)) + for(ii in seq_along(dots)) + lines(xx, rowMeans(log(dots[[ii]]$rvec[idx,]), na.rm=TRUE)[idx], col=col[1+ii]) + lines(xx, rowMeans(log(fit$rvec[idx,]), na.rm=TRUE)[idx], col=col[1]) + return(invisible()) +} diff --git a/R/plot2.R b/R/plot2.R new file mode 100644 index 0000000..0bb6e0a --- /dev/null +++ b/R/plot2.R @@ -0,0 +1,216 @@ +plot_prev2 <- function(fit, ..., ylim=NULL, xlim=c(1980, max(as.integer(dimnames(fit$prev)[[1]]))), + col="blue", main="", ylab="prevalence"){ + if(is.null(ylim)) + ylim <- c(0, 1.1*max(fit$prev[,"upper"])) + xx <- as.integer(dimnames(fit$prev)[[1]]) + plot(xx, fit$prev[,"mean"], type="n", ylim=ylim, xlim=xlim, ylab=ylab, xlab="", yaxt="n", xaxt="n", main=main) + axis(1, labels=TRUE) + axis(2, labels=TRUE) + dots <- list(...) + dots <- dots[!sapply(dots, is.null)] + + for(ii in seq_along(dots)) + cred.region(xx, dots[[ii]]$prev[,c("lower", "upper")], col=transp(col[1+ii], 0.3)) + cred.region(xx, fit$prev[,c("lower", "upper")], col=transp(col[1], 0.3)) + for(ii in seq_along(dots)) + lines(xx, dots[[ii]]$prev[,"mean"], col=col[1+ii], lwd=1.5) + lines(xx, fit$prev[,"mean"], col=col[1], lwd=1.5) +} + + +plot_incid2 <- function(fit, ..., ylim=NULL, xlim=c(1980, max(as.integer(dimnames(fit$incid)[[1]]))), + col="blue", main="", ylab="incidence rate"){ + if(is.null(ylim)) + ylim <- c(0, 1.1*max(fit$incid[,"upper"])) + xx <- as.integer(dimnames(fit$incid)[[1]]) + plot(xx, fit$incid[,"mean"], type="n", ylim=ylim, xlim=xlim, ylab=ylab, xlab="", yaxt="n", xaxt="n", main=main) + axis(1, labels=TRUE) + axis(2, labels=TRUE) + dots <- list(...) + dots <- dots[!sapply(dots, is.null)] + + for(ii in seq_along(dots)) + cred.region(xx, dots[[ii]]$incid[,c("lower", "upper")], col=transp(col[1+ii], 0.3)) + cred.region(xx, fit$incid[,c("lower", "upper")], col=transp(col[1], 0.3)) + for(ii in seq_along(dots)) + lines(xx, dots[[ii]]$incid[,"mean"], col=col[1+ii], lwd=1.5) + lines(xx, fit$incid[,"mean"], col=col[1], lwd=1.5) +} + + +plot_log_transmrate <- function(fit, ..., ylim=NULL, xlim=c(1980, max(as.integer(dimnames(fit$transmrate)[[1]]))), + col="blue", main="", ylab="log transmission rate"){ + if(is.null(ylim)) + ylim <- c(min(log(fit$transmrate[fit$transmrate[,"lower"] > 0, "lower"]))-0.2, + max(log(fit$transmrate[,"upper"])) + 0.2) + xx <- as.integer(dimnames(fit$transmrate)[[1]]) + plot(xx, fit$transmrate[,"mean"], type="n", ylim=ylim, xlim=xlim, ylab=ylab, xlab="", yaxt="n", xaxt="n", main=main) + axis(1, labels=TRUE) + axis(2, labels=TRUE) + dots <- list(...) + dots <- dots[!sapply(dots, is.null)] + + for(ii in seq_along(dots)) + cred.region(xx, log(dots[[ii]]$transmrate[,c("lower", "upper")]), col=transp(col[1+ii], 0.3)) + cred.region(xx, log(fit$transmrate[,c("lower", "upper")]), col=transp(col[1], 0.3)) + for(ii in seq_along(dots)) + lines(xx, log(dots[[ii]]$transmrate[,"mean"]), col=col[1+ii], lwd=1.5) + lines(xx, log(fit$transmrate[,"mean"]), col=col[1], lwd=1.5) +} + + +plot_incidsexratio <- function(fit, ..., ylim=NULL, xlim=c(1999, max(as.integer(dimnames(fit$incidsexratio)[[1]]))), + col="blue", main="", ylab="F:M incidence ratio"){ + if(is.null(ylim)) + ylim <- c(0, max(2.5, 1.1*max(fit$incidsexratio[,"upper"]))) + xx <- as.integer(dimnames(fit$incidsexratio)[[1]]) + plot(xx, fit$incidsexratio[,"mean"], type="n", ylim=ylim, xlim=xlim, ylab=ylab, xlab="", yaxt="n", xaxt="n", main=main) + axis(1, labels=TRUE) + axis(2, labels=TRUE) + dots <- list(...) + dots <- dots[!sapply(dots, is.null)] + + for(ii in seq_along(dots)) + cred.region(xx, dots[[ii]]$incidsexratio[,c("lower", "upper")], col=transp(col[1+ii], 0.3)) + cred.region(xx, fit$incidsexratio[,c("lower", "upper")], col=transp(col[1], 0.3)) + for(ii in seq_along(dots)) + lines(xx, dots[[ii]]$incidsexratio[,"mean"], col=col[1+ii], lwd=1.5) + lines(xx, fit$incidsexratio[,"mean"], col=col[1], lwd=1.5) +} + + + +plot_pregprev <- function(fit, ..., likdat=NULL, ylim=NULL, xlim=c(1988, max(as.integer(dimnames(fit$pregprev)[[1]]))), + col="blue", main="", ylab="Preg. prevalence"){ + + dots <- list(...) + dots <- dots[!sapply(dots, is.null)] + + if(is.null(ylim)){ + maxest <- max(fit$pregprev[,"upper"]) + if(!is.null(likdat) && !is.null(likdat$anclik.dat) && length(likdat$anclik.dat$W.lst)) + maxdata <- max(pnorm(unlist(likdat$anclik.dat$W.lst))) + else + maxdata <- 0 + ylim <- c(0, 1.1*max(maxest, min(maxdata, 2*maxest))) + } + xx <- as.integer(dimnames(fit$incidsexratio)[[1]]) + + plot(xx, fit$pregprev[,"mean"], type="n", ylim=ylim, xlim=xlim, ylab=ylab, xlab="", yaxt="n", xaxt="n", main=main) + axis(1, labels=TRUE) + axis(2, labels=TRUE) + ## + if(!is.null(likdat)){ + if(!is.null(likdat$anclik.dat) && length(likdat$anclik.dat$W.lst)){ + with(likdat$anclik.dat, mapply(function(idx, W) points(idx+1970-1, pnorm(W), col=adjustcolor("grey", 0.5), pch=15), anc.idx.lst, W.lst)) + with(likdat$anclik.dat, mapply(function(idx, W) lines(idx+1970-1, pnorm(W), col=adjustcolor("grey", 0.5)), anc.idx.lst, W.lst)) + } + } + ## + for(ii in seq_along(dots)) + cred.region(xx, dots[[ii]]$pregprev[,c("lower", "upper")], col=transp(col[1+ii], 0.3)) + cred.region(xx, fit$pregprev[,c("lower", "upper")], col=transp(col[1], 0.3)) + for(ii in seq_along(dots)) + lines(xx, dots[[ii]]$pregprev[,"mean"], col=col[1+ii], lwd=1.5) + lines(xx, fit$pregprev[,"mean"], col=col[1], lwd=1.5) + ## + if(!is.null(likdat$ancrtcens.dat) && length(likdat$ancrtcens.dat$W.ancrt)){ + with(likdat$ancrtcens.dat, + segments(year, y0=pnorm(qnorm(prev) - qnorm(0.975)*sqrt(v.ancrt)), + y1=pnorm(qnorm(prev) + qnorm(0.975)*sqrt(v.ancrt)))) + with(likdat$ancrtcens.dat, points(year, prev, pch=15)) + } +} + + +plot_artcov15plus <- function(fit, ..., ylim=NULL, xlim=c(2003, max(as.integer(dimnames(fit$artcov15plus)[[1]]))), + col="blue", main="", ylab="ART coverage"){ + if(is.null(ylim)) + ylim <- c(0, 1) + xx <- as.integer(dimnames(fit$artcov15plus)[[1]]) + plot(xx, fit$artcov15plus[,"mean"], type="n", ylim=ylim, xlim=xlim, ylab=ylab, xlab="", yaxt="n", xaxt="n", main=main) + axis(1, labels=TRUE) + axis(2, labels=TRUE) + dots <- list(...) + dots <- dots[!sapply(dots, is.null)] + + for(ii in seq_along(dots)) + cred.region(xx, dots[[ii]]$artcov15plus[,c("lower", "upper")], col=transp(col[1+ii], 0.3)) + cred.region(xx, fit$artcov15plus[,c("lower", "upper")], col=transp(col[1], 0.3)) + for(ii in seq_along(dots)) + lines(xx, dots[[ii]]$artcov15plus[,"mean"], col=col[1+ii], lwd=1.5) + lines(xx, fit$artcov15plus[,"mean"], col=col[1], lwd=1.5) +} + + + +plot_compare_ageprev2 <- function(fit, fit2=NULL, fit3=NULL, specres=NULL, likdat=NULL, ylim=NULL, col=c("navy", "darkred", "forestgreen"), exact_ci=TRUE){ + if(is.null(ylim)){ + if(!is.null(likdat)) + maxdata <- likdat$hhsage.dat$prev + else + maxdata <- 0 + ylim <- c(0, 0.05*ceiling(max(c(fit$ageprevdat$upper, 1.3*maxdata))/0.05)) + } + #### + survprev <- fit$ageprevdat + if(!is.null(likdat)){ + survprev <- merge(likdat$hhsage.dat, fit$ageprevdat, by=c("year", "survyear", "sex", "agegr"), all.x=TRUE) + if(exact_ci) + survprev[c("ci_l", "ci_u")] <- with(survprev, binom::binom.exact(x_eff, n_eff))[c("lower", "upper")] + } + survprev$survyear <- with(survprev, factor(survyear, levels(survyear)[order(as.integer(substr(levels(survyear), 1, 4)))])) + survprev <- split(survprev, factor(survprev$survyear)) + ## + if(!is.null(fit2)) + survprev2 <- split(fit2$ageprevdat, factor(fit2$ageprevdat$survyear)) + if(!is.null(fit3)) + survprev3 <- split(fit3$ageprevdat, factor(fit3$ageprevdat$survyear)) + ## + par(mfrow=c(4,2), mar=c(2, 3, 2, 1), tcl=-0.25, mgp=c(2, 0.5, 0), las=1, cex=1) + for(isurv in names(survprev)) + for(isex in c("male", "female")){ + sp <- subset(survprev[[isurv]], sex==isex & as.integer(agegr) %in% 3:11) + if(!is.null(fit2)) + sp2 <- subset(survprev2[[isurv]], sex==isex & as.integer(agegr) %in% 3:11) + if(!is.null(fit3)) + sp3 <- subset(survprev3[[isurv]], sex==isex & as.integer(agegr) %in% 3:11) + ## + xx <- as.integer(sp$agegr) + main <- if(!is.null(sp$eppregion)) + paste0(sp$country[1], " ", gsub("(\\w)(\\w*)", "\\U\\1\\L\\2", sp$eppregion[1], perl=TRUE), " ", survprev[[isurv]]$survyear[1], ", ", isex) + else + paste0(sp$country[1], " ", survprev[[isurv]]$survyear[1], ", ", isex) + plot(xx+0.5, sp$prev, type="n", xlim=c(4, 12), ylim=ylim, xaxt="n", + main=main, xlab="", ylab="") + axis(1, xx+0.5, sp$agegr) + ## + rect(xx+0.05, sp$lower, xx+0.95, sp$upper, + col=transp(col[1]), border=NA) + segments(xx+0.05, sp$mean, xx+0.95, col=col[1], lwd=2) + ## + if(!is.null(fit2)){ + rect(xx+0.05, sp2$lower, xx+0.95, sp2$upper, + col=transp(col[2]), border=NA) + segments(xx+0.05, sp2$mean, xx+0.95, col=col[2], lwd=2) + } + if(!is.null(fit3)){ + rect(xx+0.05, sp3$lower, xx+0.95, sp3$upper, + col=transp(col[3]), border=NA) + segments(xx+0.05, sp3$mean, xx+0.95, col=col[3], lwd=2) + } + ## + if(!is.null(specres)){ + csex <- sub("(\\b[a-z]{1})", "\\U\\1" , isex, perl=TRUE) + stryear <- as.character(survprev[[isurv]]$year[1]) + specres.prev <- tapply(specres$hivpop[as.character(15:54), csex, stryear], rep(3:10, each=5), sum) / tapply(specres$totpop[as.character(15:54), csex, stryear], rep(3:10, each=5), sum) + segments(4:11+0.1, specres.prev, 4:11+0.9, lty=3, col="grey10", lwd=2) + } + if(exists("prev", sp)){ + points(xx+0.5, sp$prev, pch=19) + segments(x0=xx+0.5, y0=sp$ci_l, y1=sp$ci_u) + } + } + ## + return(invisible()) +} diff --git a/R/plot_agefit.R b/R/plot_agefit.R index c7a28b4..c1f1325 100644 --- a/R/plot_agefit.R +++ b/R/plot_agefit.R @@ -1,145 +1,185 @@ -plot_agefit <- function(icountry, eppmod, fitaggr, fitincrr, fit3=NULL, cols=c("grey30", "darkred", "darkgreen")){ - par(oma=c(1, 1, 2.5, 1), mfrow=c(3, 2), mar=c(3.5, 3.5, 3, 1), tcl=-0.25, mgp=c(2.5, 0.5, 0), cex=1, las=1) - ## - ## prevalence trend - if(!is.null(fit3)) - plot_prev(fitaggr, fitincrr, fit3, col=cols) - else - plot_prev(fitaggr, fitincrr, col=cols) - mtext("HIV prevalence, age 15-49y", 3, 0.5, font=2, cex=1.2) - ## - ## incidence trend - if(!is.null(fit3)) - plot_incid(fitaggr, fitincrr, fit3, col=cols) - else - plot_incid(fitaggr, fitincrr, col=cols) - mtext("HIV incidence rate, age 15-49y", 3, 0.5, font=2, cex=1.2) - ## - ## r-trend - if(!is.null(fit3)) - plot_rvec(fitaggr, fitincrr, fit3, col=cols) - else - plot_rvec(fitaggr, fitincrr, col=cols) - mtext("r(t)", 3, 0.5, font=2, cex=1.2) - ## - ## vinfl - ## - ## sex incrr - logincrrsex <- log(sapply(fitincrr$param, "[[", "incrr_sex")[1,]) - dens <- density(logincrrsex) - densCI <- which(dens$x >= quantile(logincrrsex, 0.025) & - dens$x <= quantile(logincrrsex, 0.975)) - if(!is.null(fit3)){ - logincrrsex3 <- log(sapply(fit3$param, "[[", "incrr_sex")[1,]) - dens3 <- density(logincrrsex3) - dens3CI <- which(dens3$x >= quantile(logincrrsex3, 0.025) & - dens3$x <= quantile(logincrrsex3, 0.975)) - } - plot(dens, xlim=c(-0.1, 0.75), col=cols[2], - main="F:M incidence rate ratio, posterior density", xlab="log F:M IRR") - polygon(dens$x[c(min(densCI), densCI, max(densCI))], c(0, dens$y[densCI], 0), - col=transp(cols[2]), border=NA) - if(!is.null(fit3)){ - lines(dens3, col=cols[3]) - polygon(dens3$x[c(min(dens3CI), dens3CI, max(dens3CI))], c(0, dens3$y[dens3CI], 0), - col=transp(cols[3]), border=NA) - } - segments(x0=mean(log(sapply(fitincrr$param, "[[", "incrr_sex")[1,])), y0=0, y1=6, col=cols[2], lwd=2) - if(!is.null(fit3)) - segments(x0=mean(log(sapply(fit3$param, "[[", "incrr_sex")[1,])), y0=0, y1=6, col=cols[3], lwd=2) - segments(x0=log(tail(fitaggr$fp$incrr_sex, 1)), y0=0, y1=6, col=cols[1], lwd=2) - lines(seq(-0.1, 0.75, 0.01), dnorm(seq(-0.1, 0.75, 0.01), eppspectrum:::sexincrr.pr.mean, eppspectrum:::sexincrr.pr.sd), col="darkblue", lty=2) - segments(x0=eppspectrum:::sexincrr.pr.mean, y0=0, y1=2, col="darkblue", lwd=2, lty=2) - ## - ## age incrr - xx <- c(1:2, 4:7) - logincrrage <- estci(sapply(fitincrr$param, "[[", "logincrr_age")) - if(!is.null(fit3)) - logincrrage3 <- estci(sapply(fit3$param, "[[", "logincrr_age")) - ## plot men - plot(1:7+0.5, 1:7, type="n", xlim=c(1, 8), ylim=c(-2.5, 2), - xlab="Age group", ylab="log IRR", main = "Male incidence rate ratios (log)", xaxt="n") - axis(1, 1:7+0.5, paste0(3:9*5, "-", 3:9*5+4)) - abline(h=0, col="grey") - points(3.5, 0, pch=4, lwd=2.5, col=1, cex=1.2) - rect(xx+0.1, - eppspectrum:::ageincrr.pr.mean[1:6]-qnorm(0.975)*eppspectrum:::ageincrr.pr.sd, - xx+0.9, - eppspectrum:::ageincrr.pr.mean[1:6]+qnorm(0.975)*eppspectrum:::ageincrr.pr.sd, - col=transp("darkblue", 0.1), border=transp("darkblue", 0.5), lty=2) - ## - rect(xx+0.1, logincrrage[xx,3], xx+0.9, logincrrage[xx,4], col=transp(cols[2]), border=NA) - if(!is.null(fit3)) - rect(xx+0.1, logincrrage3[xx,3], xx+0.9, logincrrage3[xx,4], col=transp(cols[3]), border=NA) - defaultincrr <- log(fitaggr$fp$incrr_age[(xx-1)*5+1,1,fitaggr$fp$ss$PROJ_YEARS]) - segments(xx+0.1, defaultincrr, xx+0.9, col=cols[1], lwd=2) - segments(xx+0.1, eppspectrum:::ageincrr.pr.mean[1:6], xx+0.9, col=transp("darkblue", 0.5), lwd=1.5, lty=2) - segments(xx+0.1, logincrrage[xx,1], xx+0.9, col=cols[2], lwd=2) - if(!is.null(fit3)) - segments(xx+0.1, logincrrage3[xx,1], xx+0.9, col=cols[3], lwd=2) - ## plot women - plot(1:7+0.5, 1:7, type="n", xlim=c(1, 8), ylim=c(-2.5, 2), - xlab="Age group", ylab="log IRR", main = "Female incidence rate ratios (log)", xaxt="n") - axis(1, 1:7+0.5, paste0(3:9*5, "-", 3:9*5+4)) - abline(h=0, col="grey") - points(3.5, 0, pch=4, lwd=2.5, col=1, cex=1.2) - rect(xx+0.1, - eppspectrum:::ageincrr.pr.mean[7:12]-qnorm(0.975)*eppspectrum:::ageincrr.pr.sd, - xx+0.9, - eppspectrum:::ageincrr.pr.mean[7:12]+qnorm(0.975)*eppspectrum:::ageincrr.pr.sd, - col=transp("darkblue", 0.1), border=transp("darkblue", 0.5), lty=2) - ## - offset <- nrow(logincrrage)/2 - rect(xx+0.1, logincrrage[xx+offset,3], xx+0.9, logincrrage[xx++offset,4], col=transp(cols[2]), border=NA) - if(!is.null(fit3)){ - offset3 <- nrow(logincrrage3)/2 - rect(xx+0.1, logincrrage3[xx+offset3,3], xx+0.9, logincrrage3[xx++offset3,4], col=transp(cols[3]), border=NA) +plot_agefit <- function(icountry, eppmod, fitaggr, fitincrr, fit3=NULL, specres=NULL, cols=c("grey30", "darkred", "darkgreen"), pages=1:3, + agegr3dat = subset(prev_agegr3sex_nat, country==icountry), age15to49dat=NULL){ + if(1 %in% pages){ + par(oma=c(1, 1, 2.5, 1), mfrow=c(3, 2), mar=c(3.5, 3.5, 3, 1), tcl=-0.25, mgp=c(2.5, 0.5, 0), cex=1, las=1) + ## + ## prevalence trend + if(!is.null(fit3)) + plot_prev(fitaggr, fitincrr, fit3, col=cols, plotprevdat=is.null(age15to49dat)) + else + plot_prev(fitaggr, fitincrr, col=cols, plotprevdat=is.null(age15to49dat)) + if(!is.null(specres)) + lines(as.numeric(names(prev(specres))), prev(specres), lty=2, lwd=2, col="grey10") + if(!is.null(age15to49dat)){ + if(!is.null(age15to49dat$prev_spec17)){ + points(age15to49dat$year, age15to49dat$prev, pch=15, col="grey40") + points(age15to49dat$year, age15to49dat$prev_spec17, pch=19) + segments(age15to49dat$year, y0=age15to49dat$ci_l_spec17, y1=age15to49dat$ci_u_spec17) + } else { + points(age15to49dat$year, age15to49dat$prev, pch=19) + segments(age15to49dat$year, y0=age15to49dat$ci_l, y1=age15to49dat$ci_u) + } + } + mtext("HIV prevalence, age 15-49y", 3, 0.5, font=2, cex=1.2) + ## + ## incidence trend + if(!is.null(fit3)) + plot_incid(fitaggr, fitincrr, fit3, col=cols) + else + plot_incid(fitaggr, fitincrr, col=cols) + if(!is.null(specres)) + lines(as.numeric(names(incid(specres))), incid(specres), lty=2, lwd=2, col="grey10") + mtext("HIV incidence rate, age 15-49y", 3, 0.5, font=2, cex=1.2) + ## + ## r-trend + if(!is.null(fitaggr$rvec[[1]])){ + if(!is.null(fit3)) + plot_log_rvec(fitaggr, fitincrr, fit3, col=cols) + else + plot_log_rvec(fitaggr, fitincrr, col=cols) + mtext("log r(t)", 3, 0.5, font=2, cex=1.2) + } + ## + ## vinfl + ## + ## sex incrr + if(!is.null(fitincrr$param)){ + yidx <- 2010-fitincrr$fp$ss$proj_start+1 + logincrrsex <- log(sapply(fitincrr$param, "[[", "incrr_sex")[yidx,]) # year 2010 + dens <- density(logincrrsex) + densCI <- which(dens$x >= quantile(logincrrsex, 0.025) & + dens$x <= quantile(logincrrsex, 0.975)) + if(!is.null(fit3)){ + logincrrsex3 <- log(sapply(fit3$param, "[[", "incrr_sex")[yidx,]) + dens3 <- density(logincrrsex3) + dens3CI <- which(dens3$x >= quantile(logincrrsex3, 0.025) & + dens3$x <= quantile(logincrrsex3, 0.975)) + } + plot(dens, xlim=c(-0.1, 0.75), col=cols[2], + main="F:M incidence RR (2010), posterior density", xlab="log F:M IRR") + polygon(dens$x[c(min(densCI), densCI, max(densCI))], c(0, dens$y[densCI], 0), + col=transp(cols[2]), border=NA) + if(!is.null(fit3)){ + lines(dens3, col=cols[3]) + polygon(dens3$x[c(min(dens3CI), dens3CI, max(dens3CI))], c(0, dens3$y[dens3CI], 0), + col=transp(cols[3]), border=NA) + } + segments(x0=mean(log(sapply(fitincrr$param, "[[", "incrr_sex")[yidx,])), y0=0, y1=6, col=cols[2], lwd=2) + if(!is.null(fit3)) + segments(x0=mean(log(sapply(fit3$param, "[[", "incrr_sex")[yidx,])), y0=0, y1=6, col=cols[3], lwd=2) + segments(x0=log(tail(fitaggr$fp$incrr_sex, 1)), y0=0, y1=6, col=cols[1], lwd=2) + lines(seq(-0.1, 0.75, 0.01), dnorm(seq(-0.1, 0.75, 0.01), eppasm:::sexincrr.pr.mean, eppasm:::sexincrr.pr.sd), col="darkblue", lty=2) + segments(x0=eppasm:::sexincrr.pr.mean, y0=0, y1=2, col="darkblue", lwd=2, lty=2) + + ## + ## age incrr + xx <- c(1:2, 4:7) + logincrrage <- estci(sapply(fitincrr$param, "[[", "logincrr_age")) + if(!is.null(fit3)) + logincrrage3 <- estci(sapply(fit3$param, "[[", "logincrr_age")) + ## plot men + plot(1:7+0.5, 1:7, type="n", xlim=c(1, 8), ylim=c(-2.5, 2), + xlab="Age group", ylab="log IRR", main = "Male incidence RR (log), 2007", xaxt="n") + axis(1, 1:7+0.5, paste0(3:9*5, "-", 3:9*5+4)) + abline(h=0, col="grey") + points(3.5, 0, pch=4, lwd=2.5, col=1, cex=1.2) + rect(xx+0.1, + eppasm:::ageincrr.pr.mean[1:6]-qnorm(0.975)*eppasm:::ageincrr.pr.sd, + xx+0.9, + eppasm:::ageincrr.pr.mean[1:6]+qnorm(0.975)*eppasm:::ageincrr.pr.sd, + col=transp("darkblue", 0.1), border=transp("darkblue", 0.5), lty=2) + ## + rect(xx+0.1, logincrrage[xx,3], xx+0.9, logincrrage[xx,4], col=transp(cols[2]), border=NA) + if(!is.null(fit3)) + rect(xx+0.1, logincrrage3[xx,3], xx+0.9, logincrrage3[xx,4], col=transp(cols[3]), border=NA) + defaultincrr <- log(fitaggr$fp$incrr_age[(xx-1)*5+1,1,yidx]) + segments(xx+0.1, defaultincrr, xx+0.9, col=cols[1], lwd=2) + segments(xx+0.1, eppasm:::ageincrr.pr.mean[1:6], xx+0.9, col=transp("darkblue", 0.5), lwd=1.5, lty=2) + segments(xx+0.1, logincrrage[xx,1], xx+0.9, col=cols[2], lwd=2) + if(!is.null(fit3)) + segments(xx+0.1, logincrrage3[xx,1], xx+0.9, col=cols[3], lwd=2) + ## plot women + plot(1:7+0.5, 1:7, type="n", xlim=c(1, 8), ylim=c(-2.5, 2), + xlab="Age group", ylab="log IRR", main = "Female incidence RR (log), 2007", xaxt="n") + axis(1, 1:7+0.5, paste0(3:9*5, "-", 3:9*5+4)) + abline(h=0, col="grey") + points(3.5, 0, pch=4, lwd=2.5, col=1, cex=1.2) + rect(xx+0.1, + eppasm:::ageincrr.pr.mean[7:12]-qnorm(0.975)*eppasm:::ageincrr.pr.sd, + xx+0.9, + eppasm:::ageincrr.pr.mean[7:12]+qnorm(0.975)*eppasm:::ageincrr.pr.sd, + col=transp("darkblue", 0.1), border=transp("darkblue", 0.5), lty=2) + ## + offset <- nrow(logincrrage)/2 + rect(xx+0.1, logincrrage[xx+offset,3], xx+0.9, logincrrage[xx++offset,4], col=transp(cols[2]), border=NA) + if(!is.null(fit3)){ + offset3 <- nrow(logincrrage3)/2 + rect(xx+0.1, logincrrage3[xx+offset3,3], xx+0.9, logincrrage3[xx++offset3,4], col=transp(cols[3]), border=NA) + } + defaultincrr <- log(fitaggr$fp$incrr_age[(xx-1)*5+1,2,yidx]) + segments(xx+0.1, defaultincrr, xx+0.9, col=cols[1], lwd=2) + segments(xx+0.1, eppasm:::ageincrr.pr.mean[7:12], xx+0.9, col=transp("darkblue", 0.5), lwd=1.5, lty=2) + segments(xx+0.1, logincrrage[xx+offset,1], xx+0.9, col=cols[2], lwd=2) + if(!is.null(fit3)) + segments(xx+0.1, logincrrage3[xx+offset3,1], xx+0.9, col=cols[3], lwd=2) + ## + } + mtext(paste0(icountry, ", ", eppmod, "; posterior distribution"), 3, 0.5, outer=TRUE, font=2, cex=1.3) } - defaultincrr <- log(fitaggr$fp$incrr_age[(xx-1)*5+1,2,fitaggr$fp$ss$PROJ_YEARS]) - segments(xx+0.1, defaultincrr, xx+0.9, col=cols[1], lwd=2) - segments(xx+0.1, eppspectrum:::ageincrr.pr.mean[7:12], xx+0.9, col=transp("darkblue", 0.5), lwd=1.5, lty=2) - segments(xx+0.1, logincrrage[xx+offset,1], xx+0.9, col=cols[2], lwd=2) - if(!is.null(fit3)) - segments(xx+0.1, logincrrage3[xx+offset3,1], xx+0.9, col=cols[3], lwd=2) - ## - mtext(paste0(icountry, ", ", eppmod, " model; posterior distribution"), 3, 0.5, outer=TRUE, font=2, cex=1.3) ## ## Age specific prevalence compared to survey ## - plot_compare_ageprev(fitaggr, fitincrr, fit3, col=cols) - mtext(paste0(icountry, ", ", eppmod, " model; Age-specific prevalence"), 3, 0.5, outer=TRUE, font=2, cex=1.3) + if(2 %in% pages){ + plot_compare_ageprev(fitaggr, fitincrr, fit3, specres, col=cols) + mtext(paste0(icountry, ", ", eppmod, "; Age-specific prevalence"), 3, 0.5, outer=TRUE, font=2, cex=1.3) + } ## ## ## Age prevalence trend by age group ## - par(oma=c(1, 1, 2.5, 1), mfrow=c(3, 2), mar=c(3.5, 3.5, 3, 1), tcl=-0.25, mgp=c(2.5, 0.5, 0), cex=1, las=1) - ## - for(iagegr in 1:3){ - for(isex in 1:2){ - strsex <- c("male", "female")[isex] - stragegr <- c("15-24", "25-34", "35-49")[iagegr] - aggr.yprev <- estci(fitaggr$agegr3prev[iagegr,isex,,]) - fit.yprev <- estci(fitincrr$agegr3prev[iagegr,isex,,]) - if(!is.null(fit3)) - fit3.yprev <- estci(fit3$agegr3prev[iagegr,isex,,]) - survdat <- subset(prev.agegr3sex.nat, country==icountry & sex == strsex & agegr3==stragegr) - ## - plot(1999:2016, fit.yprev[,1], type="n", ylim=c(0, 0.05*ceiling(max(survdat$ci_u, aggr.yprev[,1], fit.yprev[,1])/0.05)), - ylab="", xlab="", main=paste(strsex, stragegr)) - cred.region(1999:2016, t(aggr.yprev[,3:4]), col=transp(cols[1], 0.4)) - cred.region(1999:2016, t(fit.yprev[,3:4]), col=transp(cols[2], 0.4)) - if(!is.null(fit3)) - cred.region(1999:2016, t(fit3.yprev[,3:4]), col=transp(cols[3], 0.4)) - lines(1999:2016, aggr.yprev[,1], col=cols[1], lwd=2) - lines(1999:2016, fit.yprev[,1], col=cols[2], lwd=2) - if(!is.null(fit3)) - lines(1999:2016, fit3.yprev[,1], col=cols[3], lwd=2) - ## - points(survdat$year, survdat$prev, pch=19) - segments(survdat$year, y0=survdat$ci_l, y1=survdat$ci_u) + if(3 %in% pages){ + par(oma=c(1, 1, 2.5, 1), mfrow=c(3, 2), mar=c(3.5, 3.5, 3, 1), tcl=-0.25, mgp=c(2.5, 0.5, 0), cex=1, las=1) + ## + for(iagegr in 1:3){ + for(isex in 1:2){ + strsex <- c("male", "female")[isex] + stragegr <- c("15-24", "25-34", "35-49")[iagegr] + aggr.yprev <- estci(fitaggr$agegr3prev[iagegr,isex,,]) + fit.yprev <- estci(fitincrr$agegr3prev[iagegr,isex,,]) + if(!is.null(fit3)) + fit3.yprev <- estci(fit3$agegr3prev[iagegr,isex,,]) + survdat <- subset(agegr3dat, sex == strsex & agegr3==stragegr) + ## + xx <- 1998+seq_len(nrow(fit.yprev)) + plot(xx, fit.yprev[,1], type="n", ylim=c(0, 0.05*ceiling(max(survdat$ci_u, aggr.yprev[,1], fit.yprev[,1])/0.05)), + ylab="", xlab="", main=paste(strsex, stragegr)) + cred.region(xx, t(aggr.yprev[,3:4]), col=transp(cols[1], 0.4)) + cred.region(xx, t(fit.yprev[,3:4]), col=transp(cols[2], 0.4)) + if(!is.null(fit3)) + cred.region(xx, t(fit3.yprev[,3:4]), col=transp(cols[3], 0.4)) + lines(xx, aggr.yprev[,1], col=cols[1], lwd=2) + lines(xx, fit.yprev[,1], col=cols[2], lwd=2) + if(!is.null(fit3)) + lines(xx, fit3.yprev[,1], col=cols[3], lwd=2) + ## + if(!is.null(specres)){ + ages <- as.character(c(15, 25, 35)[iagegr] + 0:(c(10, 10, 15)[iagegr]-1)) + specres.prev <- colSums(specres$hivpop[ages,isex,as.character(xx)]) / colSums(specres$totpop[ages,isex,as.character(xx)]) + lines(xx, specres.prev, lty=2, lwd=2, col="grey10") + } + ## + if(!is.null(survdat$prev_spec17)){ + points(survdat$year, survdat$prev, pch=15, col="grey40") + points(survdat$year, survdat$prev_spec17, pch=19) + segments(survdat$year, y0=survdat$ci_l_spec17, y1=survdat$ci_u_spec17) + } else { + points(survdat$year, survdat$prev, pch=19) + segments(survdat$year, y0=survdat$ci_l, y1=survdat$ci_u) + } + } } + mtext(paste0(icountry, ", ", eppmod, "\nPrevalence trend by age group"), 3, 0, outer=TRUE, font=2, cex=1.3) } - mtext(paste0(icountry, ", ", eppmod, " model; Prevalence trend by age group"), 3, 0.5, outer=TRUE, font=2, cex=1.3) ## ## return(invisible()) diff --git a/R/plot_output.R b/R/plot_output.R new file mode 100644 index 0000000..2b764be --- /dev/null +++ b/R/plot_output.R @@ -0,0 +1,129 @@ + + +plot_output <- function(fit, fit2=NULL, fit3=NULL, specres=NULL, cols=c("navy", "darkred", "darkgreen"), pages=1:3, likdat=NULL, + title="", + agegr3dat=NULL, age15to49dat=NULL){ + if(1 %in% pages){ + par(oma=c(1, 1, 2.5, 1), mfrow=c(3, 2), mar=c(3.5, 3.5, 3, 1), tcl=-0.25, mgp=c(2.5, 0.5, 0), cex=1, las=1) + ## + ## prevalence trend + plot_prev2(fit, fit2, fit3, col=cols) + if(!is.null(specres)) + lines(as.numeric(names(prev(specres))), prev(specres), lty=2, lwd=2, col="grey10") + if(!is.null(age15to49dat)){ + if(!is.null(age15to49dat$prev_spec17)){ + points(age15to49dat$year, age15to49dat$prev, pch=15, col="grey40") + points(age15to49dat$year, age15to49dat$prev_spec17, pch=19) + segments(age15to49dat$year, y0=age15to49dat$ci_l_spec17, y1=age15to49dat$ci_u_spec17) + } else { + points(age15to49dat$year, age15to49dat$prev, pch=19) + segments(age15to49dat$year, y0=age15to49dat$ci_l, y1=age15to49dat$ci_u) + } + } + mtext("HIV prevalence, age 15-49y", 3, 0.5, font=2, cex=1.1) + ## + ## incidence trend + plot_incid2(fit, fit2, fit3, col=cols) + if(!is.null(specres)) + lines(as.numeric(names(incid(specres))), incid(specres), lty=2, lwd=2, col="grey10") + mtext("HIV incidence rate, age 15-49y", 3, 0.5, font=2, cex=1.1) + ## + ## tranmission rate + plot_log_transmrate(fit, fit2, fit3, col=cols) + if(!is.null(specres)) + lines(as.numeric(names(incid(specres))), log(incid(specres) / prev(specres)), lty=2, lwd=2, col="grey10") + mtext("Log transmission rate", 3, 0.5, font=2, cex=1.1) + ## + ## Sex ratio of incidence + plot_incidsexratio(fit, fit2, fit3, col=cols) + if(!is.null(specres)) + lines(as.numeric(names(incid_sexratio(specres))), incid_sexratio(specres), lty=2, lwd=2, col="grey10") + mtext("Incidence sex ratio (F:M, 15-49y)", 3, 0.5, font=2, cex=1.1) + ## + ## ART coverage age 15+ + plot_artcov15plus(fit, fit2, fit3, col=cols) + if(!is.null(specres) && exists("artnum.m", specres)) + lines(as.numeric(names(artcov15plus(specres))), artcov15plus(specres), lty=2, lwd=2, col="grey10") + mtext("ART coverage, age 15+", 3, 0.5, font=2, cex=1.1) + mtext(paste0(title, "; posterior distribution"), 3, 0.5, outer=TRUE, font=2, cex=1.3) + ## + ## Pregnant women prevalence + if(!is.null(fit$pregprev)){ + plot_pregprev(fit, fit2, fit3, col=cols, likdat=likdat) + if(!is.null(specres)) + lines(as.numeric(names(fnPregPrev(specres))), fnPregPrev(specres), lty=2, lwd=2, col="grey10") + mtext("Prevalence among pregnant women", 3, 0.5, font=2, cex=1.1) + } + } + ## + ## Age specific prevalence compared to survey + ## + if(2 %in% pages){ + plot_compare_ageprev2(fit, fit2, fit3, specres, col=cols, likdat=likdat) + mtext(paste0(title, "; Age-specific prevalence"), 3, 0.5, outer=TRUE, font=2, cex=1.3) + } + ## + ## + ## Age prevalence trend by age group + ## + if(3 %in% pages){ + par(oma=c(1, 1, 2.5, 1), mfrow=c(3, 2), mar=c(3.5, 3.5, 3, 1), tcl=-0.25, mgp=c(2.5, 0.5, 0), cex=1, las=1) + ## + for(iagegr in 1:3){ + for(isex in 1:2){ + strsex <- c("Male", "Female")[isex] + stragegr <- c("15-24", "25-34", "35-49")[iagegr] + fit.yprev <- fit$agegr3prev[stragegr,strsex,,] + if(!is.null(fit2)) + fit2.yprev <- fit2$agegr3prev[stragegr,strsex,,] + else + fit2.yprev <- NULL + if(!is.null(fit3)) + fit3.yprev <- fit3$agegr3prev[stragegr,strsex,,] + else + fit3.yprev <- NULL + if(!is.null(agegr3dat)) + survdat <- subset(agegr3dat, sex == tolower(strsex) & agegr3==stragegr) + else + survdat <- NULL + ## + xx <- as.integer(rownames(fit.yprev)) + maxprev <- max(survdat$ci_u, fit.yprev[,"upper"], fit2.yprev[,"upper"], fit3.yprev[,"upper"], na.rm=TRUE) + plot(xx, fit.yprev[,"mean"], type="n", + ylim=c(0, 0.05*ceiling(maxprev/0.05)), + ylab="", xlab="", main=paste(strsex, stragegr)) + cred.region(xx, t(fit.yprev[,c("lower", "upper")]), col=transp(cols[1], 0.4)) + if(!is.null(fit2)) + cred.region(xx, t(fit2.yprev[,c("lower", "upper")]), col=transp(cols[2], 0.4)) + if(!is.null(fit3)) + cred.region(xx, t(fit3.yprev[,c("lower", "upper")]), col=transp(cols[3], 0.4)) + lines(xx, fit.yprev[,"mean"], col=cols[1], lwd=2) + if(!is.null(fit2)) + lines(xx, fit2.yprev[,"mean"], col=cols[2], lwd=2) + if(!is.null(fit3)) + lines(xx, fit3.yprev[,"mean"], col=cols[3], lwd=2) + ## + if(!is.null(specres)){ + ages <- as.character(c(15, 25, 35)[iagegr] + 0:(c(10, 10, 15)[iagegr]-1)) + specres.prev <- colSums(specres$hivpop[ages,isex,as.character(xx)]) / colSums(specres$totpop[ages,isex,as.character(xx)]) + lines(xx, specres.prev, lty=2, lwd=2, col="grey10") + } + ## + if(!is.null(survdat)){ + if(!is.null(survdat$prev_spec17)){ + points(survdat$year, survdat$prev, pch=15, col="grey40") + points(survdat$year, survdat$prev_spec17, pch=19) + segments(survdat$year, y0=survdat$ci_l_spec17, y1=survdat$ci_u_spec17) + } else { + points(survdat$year, survdat$prev, pch=19) + segments(survdat$year, y0=survdat$ci_l, y1=survdat$ci_u) + } + } + } + } + mtext(paste0(title, "\nPrevalence trend by age group"), 3, 0, outer=TRUE, font=2, cex=1.3) + } + ## + ## + return(invisible()) +} diff --git a/R/read-spectrum-files.R b/R/read-spectrum-files.R index 5613dce..9684113 100644 --- a/R/read-spectrum-files.R +++ b/R/read-spectrum-files.R @@ -9,7 +9,34 @@ get_dp_version <- function(dp){ stop("Spectrum DP file version not recognized. Package probably needs to be updated to most recent Spectrum version.") return(dp.vers) } - + +read_dp <- function(pjnz){ + dpfile <- grep(".DP$", unzip(pjnz, list=TRUE)$Name, value=TRUE) + dp <- read.csv(unz(pjnz, dpfile), as.is=TRUE) + return(dp) +} + +read_pjn <- function(pjnz){ + dpfile <- grep(".PJN$", unzip(pjnz, list=TRUE)$Name, value=TRUE) + dp <- read.csv(unz(pjnz, dpfile), as.is=TRUE) + return(dp) +} + + +read_region <- function(pjnz){ + pjn <- read_pjn(pjnz) + region <- pjn[which(pjn[,1] == "")+2, 4] + if(region == "") + return(NULL) + else + return(region) +} + +read_country <- function(pjnz){ + pjn <- read_pjn(pjnz) + cc <- as.integer(pjn[which(pjn[,1] == "")+2, 4]) + return(with(spectrum5_countrylist, Country[Code == cc])) +} ################################################### #### function to read HIV projection outputs #### @@ -18,8 +45,7 @@ get_dp_version <- function(dp){ read_hivproj_output <- function(pjnz, single.age=TRUE){ ## read .DP file - dpfile <- grep(".DP$", unzip(pjnz, list=TRUE)$Name, value=TRUE) - dp <- read.csv(unz(pjnz, dpfile), as.is=TRUE) + dp <- read_dp(pjnz) dp.vers <- get_dp_version(dp) @@ -101,9 +127,12 @@ read_hivproj_output <- function(pjnz, single.age=TRUE){ } else if(exists_dptag("")){ totpop.m <- sapply(lapply(dpsub("", 3:83, timedat.idx), as.numeric), tapply, c(rep(1:16, each=5), 17), sum) totpop.f <- sapply(lapply(dpsub("", 81+3:83, timedat.idx), as.numeric), tapply, c(rep(1:16, each=5), 17), sum) - } else { + } else if(exists_dptag("")){ totpop.m <- sapply(lapply(dpsub("", 3:83, timedat.idx), as.numeric), tapply, c(rep(1:16, each=5), 17), sum) totpop.f <- sapply(lapply(dpsub("", 243+3:83, timedat.idx), as.numeric), tapply, c(rep(1:16, each=5), 17), sum) + } else if(exists_dptag("")){ + totpop.m <- sapply(lapply(dpsub("", 3:83, timedat.idx), as.numeric), tapply, c(rep(1:16, each=5), 17), sum) + totpop.f <- sapply(lapply(dpsub("", 84:164, timedat.idx), as.numeric), tapply, c(rep(1:16, each=5), 17), sum) } dimnames(totpop.m) <- dimnames(totpop.f) <- list(agegr.lab, proj.years) @@ -173,6 +202,8 @@ read_hivproj_output <- function(pjnz, single.age=TRUE){ totpop <- sapply(dpsub("", 3:164, timedat.idx), as.numeric) else if(exists_dptag("")) totpop <- sapply(dpsub("", c(3+0:80, 246+0:80), timedat.idx), as.numeric) + else if(exists_dptag("")) + totpop <- sapply(dpsub("", 3:164, timedat.idx), as.numeric) totpop <- array(totpop, c(81, 2, length(proj.years)), list(0:80, c("Male", "Female"), proj.years)) if(exists_dptag("")) @@ -202,8 +233,15 @@ read_hivproj_output <- function(pjnz, single.age=TRUE){ specres[c("totpop", "hivpop", "natdeaths", "hivdeaths")] <- list(totpop, hivpop, natdeaths, hivdeaths) } - + + specres$births <- setNames(as.numeric(dpsub("", 2, timedat.idx)), proj.years) + specres$hivpregwomen <- setNames(as.numeric(dpsub("", 2, timedat.idx)), proj.years) + specres$hivpregwomen <- setNames(as.numeric(dpsub("", 2, timedat.idx)), proj.years) + specres$receivepmtct <- setNames(as.numeric(dpsub("", 2, timedat.idx)), proj.years) + class(specres) <- "specres" + attr(specres, "country") <- read_country(pjnz) + attr(specres, "region") <- read_region(pjnz) return(specres) } @@ -216,6 +254,7 @@ read_hivproj_output <- function(pjnz, single.age=TRUE){ read_hivproj_param <- function(pjnz, use_ep5=FALSE){ ## read .DP file + if(use_ep5) dpfile <- grep(".ep5$", unzip(pjnz, list=TRUE)$Name, value=TRUE) else @@ -298,17 +337,20 @@ read_hivproj_param <- function(pjnz, use_ep5=FALSE){ if(dp.vers == ""){ fert_rat <- as.numeric(dp[which(dp[,1] == "")+185, 4+0:6]) fert_rat <- array(rep(fert_rat, length(proj.years)), c(7, length(proj.years))) + dimnames(fert_rat) <- list(agegr=seq(15, 45, 5), year=proj.years) } else if(dp.vers == "") { fert_rat <- sapply(dp[hivtfr.tidx+2:8, 3+seq_along(proj.years)], as.numeric) + dimnames(fert_rat) <- list(agegr=seq(15, 45, 5), year=proj.years) } else if(dp.vers == "Spectrum2016") { fert_rat <- sapply(dpsub("", 2:8, timedat.idx), as.numeric) - } else if(dp.vers == "Spectrum2017") { - fert_rat <- sapply(dpsub("", 2:8, timedat.idx), as.numeric) + dimnames(fert_rat) <- list(agegr=seq(15, 45, 5), year=proj.years) + } else if(exists_dptag("")) { + fert_rat <- sapply(dpsub("", 2:7, timedat.idx), as.numeric) + dimnames(fert_rat) <- list(agegr=c(15, 18, seq(20, 35, 5)), year=proj.years) # this version of Spectrum stratified fertility reduction by 15-17, 18-19, 20-24, ... + } else if(exists_dptag("")){ + fert_rat <- sapply(dpsub("", 2:8, timedat.idx), as.numeric) + dimnames(fert_rat) <- list(agegr=seq(15, 45, 5), year=proj.years) } - if(dp.vers == "Spectrum2017") - dimnames(fert_rat) <- list(c(15, 18, seq(20, 40, 5)), proj.years) - else - dimnames(fert_rat) <- list(seq(15, 45, 5), proj.years) if(dp.vers == "Spectrum2017") cd4fert_rat <- as.numeric(dpsub("", 2, 4+1:DS)) @@ -338,10 +380,10 @@ read_hivproj_param <- function(pjnz, use_ep5=FALSE){ ## hiv natural history - cd4_initdist <- array(NA, c(DS, 4, NG), list(1:DS, c("15-24", "25-34", "35-44", "45+"), c("Male", "Female"))) - cd4_prog <- array(NA, c(DS-1, 4, NG), list(1:(DS-1), c("15-24", "25-34", "35-44", "45+"), c("Male", "Female"))) - cd4_mort <- array(NA, c(DS, 4, NG), list(1:DS, c("15-24", "25-34", "35-44", "45+"), c("Male", "Female"))) - art_mort <- array(NA, c(TS, DS, 4, NG), list(c("ART0MOS", "ART6MOS", "ART1YR"), 1:DS, c("15-24", "25-34", "35-44", "45+"), c("Male", "Female"))) + cd4_initdist <- array(NA, c(DS, 4, NG), list(cd4stage=1:DS, agecat=c("15-24", "25-34", "35-44", "45+"), sex=c("Male", "Female"))) + cd4_prog <- array(NA, c(DS-1, 4, NG), list(cd4stage=1:(DS-1), agecat=c("15-24", "25-34", "35-44", "45+"), sex=c("Male", "Female"))) + cd4_mort <- array(NA, c(DS, 4, NG), list(cd4stage=1:DS, agecat=c("15-24", "25-34", "35-44", "45+"), sex=c("Male", "Female"))) + art_mort <- array(NA, c(TS, DS, 4, NG), list(artdur=c("ART0MOS", "ART6MOS", "ART1YR"), cd4stage=1:DS, agecat=c("15-24", "25-34", "35-44", "45+"), sex=c("Male", "Female"))) if(dp.vers %in% c("", "")){ cd4_initdist[,,"Male"] <- array(as.numeric(dp[cd4initdist.tidx+2, 4:31])/100, c(DS, 4)) @@ -402,8 +444,8 @@ read_hivproj_param <- function(pjnz, use_ep5=FALSE){ artelig_specpop <- setNames(dpsub("", 3:9, 2:6), c("description", "pop", "elig", "percent", "year")) } - dimnames(art15plus_numperc) <- list(c("Male", "Female"), proj.years) - dimnames(art15plus_num) <- list(c("Male", "Female"), proj.years) + dimnames(art15plus_numperc) <- list(sex=c("Male", "Female"), year=proj.years) + dimnames(art15plus_num) <- list(sex=c("Male", "Female"), year=proj.years) artelig_specpop$pop <- c("PW", "TBHIV", "DC", "FSW", "MSM", "IDU", "OTHER") artelig_specpop$elig <- as.logical(as.integer(artelig_specpop$elig)) @@ -524,7 +566,7 @@ read_demog_param <- function(upd.file, age.intervals = 1){ ## population size basepop <- array(as.numeric(bp$value), c(length(unique(bp$age)), length(unique(bp$sex)), length(unique(bp$year)))) - dimnames(basepop) <- list(unique(bp$age), c("Male", "Female"), unique(bp$year)) + dimnames(basepop) <- list(age=unique(bp$age), sex=c("Male", "Female"), year=unique(bp$year)) basepop <- apply(basepop, 2:3, tapply, age.groups, sum) ## mx @@ -532,13 +574,13 @@ read_demog_param <- function(upd.file, age.intervals = 1){ nyears <- length(years) Sx <- as.numeric(lt$Sx[-(1:(2*nyears)*82-1)]) # 80+ age group given twice dim(Sx) <- c(81, 2, nyears) - dimnames(Sx) <- list(0:80, c("Male", "Female"), years) + dimnames(Sx) <- list(age=0:80, sex=c("Male", "Female"), year=years) Sx <- apply(Sx, 2:3, tapply, age.groups, prod) mx <- -sweep(log(Sx), 1, age.intervals, "/") ## asfr asfd <- array(as.numeric(pasfrs$value), c(35, nyears)) - dimnames(asfd) <- list(15:49, years) + dimnames(asfd) <- list(age=15:49, year=years) asfr <- sweep(asfd, 2, tfr, "*") asfr <- apply(asfr, 2, tapply, age.groups[16:50], mean) @@ -546,7 +588,7 @@ read_demog_param <- function(upd.file, age.intervals = 1){ ## migration netmigr <- array(as.numeric(migration$value), c(81, 2, nyears)) - dimnames(netmigr) <- list(0:80, c("Male", "Female"), years) + dimnames(netmigr) <- list(age=0:80, sex=c("Male", "Female"), year=years) netmigr <- apply(netmigr, 2:3, tapply, age.groups, sum) demp <- list("basepop"=basepop, "mx"=mx, "Sx"=Sx, "asfr"=asfr, "tfr"=tfr, "asfd"=asfd, "srb"=srb, "netmigr"=netmigr) @@ -602,10 +644,16 @@ read_specdp_demog_param <- function(pjnz, use_ep5=FALSE){ if(exists_dptag("")) basepop <- array(sapply(dpsub("", 3:164, timedat.idx), as.numeric), c(81, 2, length(proj.years)), list(0:80, c("Male", "Female"), proj.years)) - else + else if(exists_dptag("")) basepop <- array(sapply(dpsub("", c(3+0:80, 246+0:80), timedat.idx), as.numeric), - c(81, 2, length(proj.years)), list(0:80, c("Male", "Female"), proj.years)) - + c(81, 2, length(proj.years)), list(0:80, c("Male", "Female"), proj.years)) + else if(exists_dptag("")) + basepop <- array(sapply(dpsub("", 3+0:161, timedat.idx), as.numeric), + c(81, 2, length(proj.years)), list(0:80, c("Male", "Female"), proj.years)) + else + stop("No recognized tag, basepop not found.") + + ## mx if(dp.vers == "Spectrum2016"){ sx.tidx <- which(dp[,1] == "") @@ -613,7 +661,7 @@ read_specdp_demog_param <- function(pjnz, use_ep5=FALSE){ } else if(dp.vers == "Spectrum2017") Sx <- dpsub("", 3+c(0:79, 81, 82+0:79, 82+81), timedat.idx) Sx <- array(as.numeric(unlist(Sx)), c(81, 2, length(proj.years))) - dimnames(Sx) <- list(0:80, c("Male", "Female"), proj.years) + dimnames(Sx) <- list(age=0:80, sex=c("Male", "Female"), year=proj.years) mx <- -log(Sx) @@ -624,7 +672,7 @@ read_specdp_demog_param <- function(pjnz, use_ep5=FALSE){ tfr <- setNames(as.numeric(dp[tfr.tidx + 2, timedat.idx]), proj.years) asfd <- sapply(dp[asfd.tidx + 3:9, timedat.idx], as.numeric)/100 asfd <- apply(asfd / 5, 2, rep, each=5) - dimnames(asfd) <- list(15:49, proj.years) + dimnames(asfd) <- list(age=15:49, year=proj.years) asfr <- sweep(asfd, 2, tfr, "*") ## srb @@ -686,7 +734,7 @@ read_specdp_demog_param <- function(pjnz, use_ep5=FALSE){ c(rep(0, 16), 1)))) netmigr <- apply(netmigr, 2:3, function(x) A %*% x) - dimnames(netmigr) <- list(0:80, c("Male", "Female"), proj.years) + dimnames(netmigr) <- list(age=0:80, sex=c("Male", "Female"), year=proj.years) demp <- list("basepop"=basepop, "mx"=mx, "Sx"=Sx, "asfr"=asfr, "tfr"=tfr, "asfd"=asfd, "srb"=srb, "netmigr"=netmigr) @@ -784,3 +832,68 @@ read_subp_file <- function(filepath){ return(data) } + + +#' Read CSAVR input data +#' +#' @param pjnz file path to Spectrum PJNZ file. +read_csavr_data <- function(pjnz){ + + dpfile <- grep(".DP$", unzip(pjnz, list=TRUE)$Name, value=TRUE) + dp <- read.csv(unz(pjnz, dpfile), as.is=TRUE) + + exists_dptag <- function(tag, tagcol=1){tag %in% dp[,tagcol]} + dpsub <- function(tag, rows, cols, tagcol=1){ + dp[which(dp[,tagcol]==tag)+rows, cols] + } + + yr_start <- as.integer(dpsub("",2,4)) + yr_end <- as.integer(dpsub("",2,4)) + proj_years <- yr_start:yr_end + + + if(exists_dptag("")){ + val <- data.frame(year = proj_years, + t(sapply(dpsub("", 2:10, 3+seq_along(proj_years)), as.numeric)), + row.names=proj_years) + names(val) <- c("year", "plhiv", "plhiv_undercount", "new_cases", "new_cases_undercount", "new_cases_lag", + "aids_deaths", "aids_deaths_undercount", "deaths_hivp", "deaths_hivp_undercount") + + attr(val, "agegroup") <- c("All ages", "Adults 15-49", "Adults 15+")[as.integer(dpsub("", 2, 4))+1L] + } else + val <- NULL + + return(val) +} + + + +#' Read annual incidence input +#' +#' @param pjnz file path to Spectrum PJNZ file. +read_incid_input <- function(pjnz){ + + dpfile <- grep(".DP$", unzip(pjnz, list=TRUE)$Name, value=TRUE) + dp <- read.csv(unz(pjnz, dpfile), as.is=TRUE) + + exists_dptag <- function(tag, tagcol=1){tag %in% dp[,tagcol]} + dpsub <- function(tag, rows, cols, tagcol=1){ + dp[which(dp[,tagcol]==tag)+rows, cols] + } + + yr_start <- as.integer(dpsub("",2,4)) + yr_end <- as.integer(dpsub("",2,4)) + proj_years <- yr_start:yr_end + + if(exists_dptag("")){ + val <- as.numeric(dpsub("", 2, 3+seq_along(proj_years))) + val <- setNames(val, proj_years) + attr(val, "incidpopage") <- as.integer(dpsub("", 2, 4)) # Adults 15-49 = 0; Adults 15+ = 1 + return(val / 100) + } else { + warning(paste0(" not found for ", basename(pjnz), ".")) + val <- NULL + } + + return(val) +} diff --git a/R/rt-models.R b/R/rt-models.R new file mode 100644 index 0000000..775374e --- /dev/null +++ b/R/rt-models.R @@ -0,0 +1,307 @@ +prepare_hybrid_r <- function(fp, tsEpidemicStart=fp$ss$time_epi_start+0.5, rw_start=fp$rw_start, rw_dk=NULL){ + + if(!exists("rtpenord", fp)) + fp$rtpenord <- 2L + + if(is.null(rw_start)) + rw_start <- max(fp$proj.steps) + + ## if(exists("knots", fp)) + ## fp$numKnots <- length(fp$knots) - 4 + + fp$tsEpidemicStart <- fp$proj.steps[which.min(abs(fp$proj.steps - tsEpidemicStart))] + + rt <- list() + rt$spline_steps <- fp$proj.steps[fp$proj.steps >= fp$tsEpidemicStart & fp$proj.steps <= rw_start] + rt$rw_steps <- fp$proj.steps[fp$proj.steps > rw_start & fp$proj.steps <= max(fp$proj.steps)] + + rt$nsteps_preepi <- length(fp$proj.steps[fp$proj.steps < tsEpidemicStart]) + + if(!exists("n_splines", fp)) + n_splines <- 7 + else + n_splines <- fp$n_splines + + if(!exists("n_rw", fp)) + n_rw <- ceiling(diff(range(rt$rw_steps))) ## + else + n_rw <- fp$n_rw + + + rt$n_splines <- n_splines + rt$n_rw <- n_rw + rt$n_param <- rt$n_splines+rt$n_rw + + fp$numKnots <- rt$n_splines+rt$n_rw + + if(rt$n_splines > 0){ + rt$spline_penord <- fp$rtpenord + proj.dur <- diff(range(rt$spline_steps)) + rvec.knots <- seq(min(rt$spline_steps) - 3*proj.dur/(rt$n_splines-3), max(rt$spline_steps) + 3*proj.dur/(rt$n_splines-3), proj.dur/(rt$n_splines-3)) + + fp$splineX <- splines::splineDesign(rvec.knots, rt$spline_steps) + + m <- matrix(0, rt$n_splines, rt$n_splines) + m[,1] <- 1 + for(i in 2:rt$n_splines) + m[i:rt$n_splines,i] <- 1:(rt$n_splines-i+1) + + rt$splineX <- fp$splineX %*% m + } + + ## Random walk design matrix + if(!is.null(rw_dk)) + rt$rw_knots <- seq(min(rt$rw_steps), max(rt$rw_steps)+rw_dk, by=rw_dk) + else + rt$rw_knots <- seq(min(rt$rw_steps), max(rt$rw_steps), length.out=n_rw+1) + rt$rwX <- outer(rt$rw_steps, rt$rw_knots[1:n_rw], ">=") + class(rt$rwX) <- "integer" + + rt$eppmod <- "rhybrid" + fp$rt <- rt + + fp$rvec.spldes <- rbind(matrix(0, rt$nsteps_preepi, fp$numKnots), + cbind(rt$splineX, matrix(0, length(rt$spline_steps), n_rw)), + cbind(matrix(tail(rt$splineX, 1), nrow=length(rt$rw_steps), ncol=n_splines, byrow=TRUE), rt$rwX)) + + if(!exists("eppmod", fp)) + fp$eppmod <- "rhybrid" + fp$iota <- NULL + + return(fp) +} + + +prepare_logrw <- function(fp, tsEpidemicStart=fp$ss$time_epi_start+0.5){ + + fp$tsEpidemicStart <- fp$proj.steps[which.min(abs(fp$proj.steps - tsEpidemicStart))] + rw_steps <- fp$proj.steps[fp$proj.steps >= fp$tsEpidemicStart] + + rt <- list() + rt$nsteps_preepi <- length(fp$proj.steps[fp$proj.steps < tsEpidemicStart]) + + if(!exists("n_rw", fp)) + rt$n_rw <- ceiling(diff(range(rw_steps))) ## + else + rt$n_rw <- fp$n_rw + + fp$numKnots <- rt$n_rw + + ## Random walk design matrix + rt$rw_knots <- seq(min(rw_steps), max(rw_steps), length.out=rt$n_rw+1) + rt$rwX <- outer(rw_steps, rt$rw_knots[1:rt$n_rw], ">=") + class(rt$rwX) <- "integer" + + fp$rt <- rt + + fp$rvec.spldes <- rbind(matrix(0, rt$nsteps_preepi, fp$numKnots), rt$rwX) + + if(!exists("eppmod", fp)) + fp$eppmod <- "logrw" + fp$iota <- NULL + + return(fp) +} + + +rlog_pr_mean <- c(log(0.35), log(0.09), log(0.2), 1993) +rlog_pr_sd <- c(0.5, 0.3, 0.5, 5) + +rlogistic <- function(t, p){ + ## p[1] = log r(0) : log r(t) at the start of the epidemic (exponential growth) + ## p[2] = log r(Inf) : endemic value for log r(t) + ## p[3] = alpha : rate of change in log r(t) + ## p[4] = t_mid : inflection point for logistic curve + + p[1] - (p[1] - p[2]) / (1 + exp(-p[3] * (t - p[4]))) +} + + +prepare_rlogistic_rw <- function(fp, tsEpidemicStart=fp$ss$time_epi_start+0.5, rw_start=fp$rw_start, rw_dk=NULL){ + + if(is.null(rw_start)) + rw_start <- max(fp$proj.steps) + + fp$tsEpidemicStart <- fp$proj.steps[which.min(abs(fp$proj.steps - tsEpidemicStart))] + + rt <- list() + rt$rlogistic_steps <- fp$proj.steps[fp$proj.steps <= rw_start] + rt$rw_steps <- fp$proj.steps[fp$proj.steps > rw_start & fp$proj.steps <= max(fp$proj.steps)] + + if(!exists("n_rw", fp)) + n_rw <- ceiling(diff(range(rt$rw_steps))) ## + else + n_rw <- fp$n_rw + + rt$n_rw <- n_rw + rt$n_param <- 4+rt$n_rw # 4 parameters for rlogistic + + ## Random walk design matrix + if(!is.null(rw_dk)) + rt$rw_knots <- seq(min(rt$rw_steps), max(rt$rw_steps)+rw_dk, by=rw_dk) + else + rt$rw_knots <- seq(min(rt$rw_steps), max(rt$rw_steps), length.out=n_rw+1) + rt$rwX <- pmin(pmax(outer(rt$rw_steps, rt$rw_knots[1:n_rw], "-"), 0), 1) # piecewise linear interpolation + + rt$eppmod <- "rlogistic_rw" + fp$rt <- rt + + if(!exists("eppmod", fp)) + fp$eppmod <- "rlogistic_rw" + fp$iota <- NULL + + return(fp) +} + + +create_rvec <- function(theta, rt){ + if(rt$eppmod == "rlogistic_rw"){ + par <- theta[1:4] + par[3] <- exp(par[3]) + rvec <- rlogistic(rt$rlogistic_steps, par) + rvec <- c(rvec, rvec[length(rt$rlogistic_steps)] + rt$rwX %*% theta[4+1:rt$n_rw]) + return(exp(rvec)) + } + if(rt$eppmod == "rhybrid"){ + u <- theta[1:rt$n_splines] + rvec <- log(rt$splineX %*% u) + rvec <- c(rep(0, rt$nsteps_preepi), rvec, rvec[length(rvec)] + rt$rwX %*% theta[rt$n_splines+1:rt$n_rw]) + return(exp(rvec)) + } +} + + +#' Sample from conditional posterior distribution for variance parameter +sample_invgamma_post <- function(x, prior_shape, prior_rate){ + ## x: n_samples, n_knots + if(is.vector(x)) x <- matrix(x, 1) + 1/rgamma(nrow(x), shape=prior_shape + ncol(x)/2, + rate=prior_rate + 0.5*rowSums(x^2)) +} + +extend_projection <- function(fit, proj_years){ + + + if(proj_years > fit$fp$ss$PROJ_YEARS) + stop("Cannot extend projection beyond duration of projection file") + + fp <- fit$fp + fpnew <- fp + + fpnew$SIM_YEARS <- as.integer(proj_years) + fpnew$proj.steps <- with(fpnew$ss, seq(proj_start+0.5, proj_start-1+fpnew$SIM_YEARS+0.5, by=1/hiv_steps_per_year)) + + if(fp$eppmod == "rlogistic_rw"){ + idx1 <- 5 # start of random walk parameters + idx2 <- 4+fp$rt$n_rw + fpnew <- prepare_rlogistic_rw(fpnew, rw_dk=diff(fp$rt$rw_knots[1:2])) + } else if(fp$eppmod == "rhybrid"){ + idx1 <- fp$rt$n_splines+1L # start of random walk parameters + idx2 <- fp$rt$n_splines+fp$rt$n_rw + fpnew <- prepare_hybrid_r(fpnew, rw_dk=diff(fp$rt$rw_knots[1:2])) + } + + if(exists("prior_args", fp) && exists("rw_prior_shape", fp$prior_args)) + sh <- fp$prior_args$rw_prior_shape + else + sh <- eppasm::rw_prior_shape + + if(exists("prior_args", fp) && exists("rw_prior_scale", fp$prior_args)) + rate <- fp$prior_args$rw_prior_rate + else + rate <- eppasm::rw_prior_rate + + theta <- fit$resample[,idx1:idx2, drop=FALSE] + rw_sigma <- sqrt(sample_invgamma_post(theta, sh, rate)) + + nsteps <- fpnew$rt$n_rw - fp$rt$n_rw + + thetanew <- matrix(nrow=nrow(theta), ncol=fpnew$rt$n_rw) + thetanew[,1:ncol(theta)] <- theta + thetanew[,ncol(theta)+1:nsteps] <- rnorm(nrow(theta)*nsteps, sd=rw_sigma) + + fit$resample <- cbind(fit$resample[,1:(idx1-1), drop=FALSE], thetanew, fit$resample[,(idx2+1):ncol(fit$resample), drop=FALSE]) + fit$fp <- fpnew + + return(fit) +} + + + + +calc_rtrend_rt <- function(t, fp, rveclast, prevlast, pop, i, ii){ + + ## Attach state space variables + invisible(list2env(fp$ss, environment())) # put ss variables in environment for convenience + + hivn.ii <- sum(pop[p.age15to49.idx,,hivn.idx,i]) + hivn.ii <- hivn.ii - sum(pop[p.age15to49.idx[1],,hivn.idx,i])*(1-DT*(ii-1)) + hivn.ii <- hivn.ii + sum(pop[tail(p.age15to49.idx,1)+1,,hivn.idx,i])*(1-DT*(ii-1)) + + hivp.ii <- sum(pop[p.age15to49.idx,,hivp.idx,i]) + hivp.ii <- hivp.ii - sum(pop[p.age15to49.idx[1],,hivp.idx,i])*(1-DT*(ii-1)) + hivp.ii <- hivp.ii + sum(pop[tail(p.age15to49.idx,1)+1,,hivp.idx,i])*(1-DT*(ii-1)) + + prevcurr <- hivp.ii / (hivn.ii + hivp.ii) + + + if(t > fp$tsEpidemicStart){ + par <- fp$rtrend + gamma.t <- if(t < par$tStabilize) 0 else (prevcurr-prevlast)*(t - par$tStabilize) / (fp$ss$DT*prevlast) + logr.diff <- par$beta[2]*(par$beta[1] - rveclast) + par$beta[3]*prevlast + par$beta[4]*gamma.t + return(exp(log(rveclast) + logr.diff)) + } else + return(fp$rtrend$r0) +} + + + + +#### Model for iota #### + + +logiota.unif.prior <- c(log(1e-14), 0) +r0logiotaratio.unif.prior <- c(-25, -5) + +logit <- function(p) log(p/(1-p)) +invlogit <- function(x) 1/(1+exp(-x)) +ldinvlogit <- function(x){v <- invlogit(x); log(v) + log(1-v)} + +transf_iota <- function(par, fp){ + + if(exists("prior_args", where = fp)){ + for(i in seq_along(fp$prior_args)) + assign(names(fp$prior_args)[i], fp$prior_args[[i]]) + } + + if(exists("logitiota", fp) && fp$logitiota) + exp(invlogit(par)*diff(logiota.unif.prior) + logiota.unif.prior[1]) + else + exp(par) +} + +lprior_iota <- function(par, fp){ + ## !!! CHECK THIS FUNCTION IS DOING THE RIGHT THING + if(exists("prior_args", where = fp)){ + for(i in seq_along(fp$prior_args)) + assign(names(fp$prior_args)[i], fp$prior_args[[i]]) + } + + if(exists("logitiota", fp) && fp$logitiota) + ldinvlogit(par) + else + dunif(par, logiota.unif.prior[1], logiota.unif.prior[2], log=TRUE) +} + +sample_iota <- function(n, fp){ + if(exists("prior_args", where = fp)){ + for(i in seq_along(fp$prior_args)) + assign(names(fp$prior_args)[i], fp$prior_args[[i]]) + } + if(exists("logitiota", fp) && fp$logitiota) + return(logit(runif(n))) + else + runif(n, logiota.unif.prior[1], logiota.unif.prior[2]) +} + +ldsamp_iota <- lprior_iota diff --git a/R/specres-functions.R b/R/specres-functions.R index 4511f75..278ca51 100644 --- a/R/specres-functions.R +++ b/R/specres-functions.R @@ -1,5 +1,96 @@ -incid.specres <- function(x) colSums(x$newinf.m[4:10,]+x$newinf.f[4:10,]) / colSums(x$totpop.m[4:10,]+x$totpop.f[4:10,]-(x$hivnum.m[4:10,]+x$hivnum.f[4:10,])) +incid.specres <- function(x){ + nyr <- ncol(x$newinf.m) + infections <- colSums(x$newinf.m[4:10,-1]+x$newinf.f[4:10,-1]) + hivn <- colSums(x$totpop.m[4:10,-nyr]+x$totpop.f[4:10,-nyr]-(x$hivnum.m[4:10,-nyr]+x$hivnum.f[4:10,-nyr])) + c(0, infections / hivn) +} + prev.specres <- function(x) colSums(x$hivnum.m[4:10,]+x$hivnum.f[4:10,])/colSums(x$totpop.m[4:10,]+x$totpop.f[4:10,]) aidsdeaths.specres <- function(x) colSums(x$aidsdeaths.m[-(1:3),]+x$aidsdeaths.f[-(1:3),]) + +agemx.specres <- function(specres, nonhiv=FALSE){ + + if(nonhiv) + deaths <- specres$natdeaths + else + deaths <- with(specres, natdeaths+hivdeaths) + pop <- with(specres, (totpop[,,-1]+totpop[,,-dim(totpop)[3]])/2) + + mx <- array(0, dim=dim(deaths), dimnames(deaths)) + mx[,,-1] <- deaths[,,-1] / pop + + return(mx) +} + +natagemx.specres <- function(specres){ + + deaths <- specres$natdeaths + pop <- with(specres, (totpop[,,-1]+totpop[,,-dim(totpop)[3]])/2) + + mx <- array(0, dim=dim(deaths), dimnames(deaths)) + mx[,,-1] <- deaths[,,-1] / pop + + return(mx) +} + +calc_nqx.specres <- function(specres, n=45, x=15, nonhiv=FALSE){ + if(nonhiv) + mx <- natagemx(specres) + else + mx <- agemx(specres) + 1-exp(-colSums(mx[as.character(x+0:(n-1)),,])) +} + + +aggr_specres <- function(specreslist){ + out <- lapply(do.call(mapply, c(FUN=list, specreslist, SIMPLIFY=FALSE)), Reduce, f="+") + class(out) <- "specres" + return(out) +} + +pop15to49.specres <- function(specres){colSums(specres$totpop[as.character(15:49),,],,2)} +artpop15to49.specres <- function(specres){colSums(specres$artnum.m[4:10,]+specres$artnum.f[4:10,])} +artpop15plus.specres <- function(specres){colSums(specres$artnum.m[4:17,]+specres$artnum.f[4:17,])} +artcov15to49.specres <- function(specres){colSums(specres$artnum.m[4:10,]+specres$artnum.f[4:10,]) / colSums(specres$hivnum.m[4:10,]+specres$hivnum.f[4:10,])} +artcov15plus.specres <- function(specres){colSums(specres$artnum.m[4:17,]+specres$artnum.f[4:17,]) / colSums(specres$hivnum.m[4:17,]+specres$hivnum.f[4:17,])} +age15pop.specres <- function(specres){colSums(specres$totpop["15",,])} + +ageprev.specres <- function(specres, aidx=NULL, sidx=NULL, yidx=NULL, agspan=5, arridx=NULL){ + + if(is.null(arridx)){ + if(length(agspan)==1) + agspan <- rep(agspan, length(aidx)) + + dims <- dim(mod) + idx <- expand.grid(aidx=aidx, sidx=sidx, yidx=yidx) + arridx <- idx$aidx + (idx$sidx-1)*dims[1] + (idx$yidx-1)*dims[1]*dims[2] + agspan <- rep(agspan, times=length(sidx)*length(yidx)) + } else if(length(agspan)==1) + agspan <- rep(agspan, length(arridx)) + + agidx <- rep(arridx, agspan) + allidx <- agidx + unlist(sapply(agspan, seq_len))-1 + + hivn <- fastmatch::ctapply(mod[,,1,][allidx], agidx, sum) + hivp <- fastmatch::ctapply(mod[,,2,][allidx], agidx, sum) + + prev <- hivp/(hivn+hivp) + if(!is.null(aidx)) + prev <- array(prev, c(length(aidx), length(sidx), length(yidx))) + return(prev) +} + + +## MAYBE NEED TO CORRECT THIS FUNCTION FOR SUSCEPTIBLES YEAR EARLIER +incid_sexratio.specres <- function(x){ + incid.m <- colSums(x$newinf.m[4:10,]) / colSums(x$totpop.m[4:10,] - x$hivnum.m[4:10,]) + incid.f <- colSums(x$newinf.f[4:10,]) / colSums(x$totpop.f[4:10,] - x$hivnum.f[4:10,]) + return(incid.f / incid.m) +} + + +fnPregPrev.specres <- function(specres){ + specres$hivpregwomen / specres$births +} diff --git a/R/spectrum.R b/R/spectrum.R index 9502d8d..2a2945c 100644 --- a/R/spectrum.R +++ b/R/spectrum.R @@ -29,7 +29,7 @@ create_spectrum_fixpar <- function(projp, demp, hiv_steps_per_year = 10L, proj_s ss$ag.rate <- 1 ss$p.fert.idx <- 16:50 - AGE_START ss$p.age15to49.idx <- 16:50 - AGE_START - ss$p.age15plus.idx <- 16:ss$pAG - AGE_START + ss$p.age15plus.idx <- (16-AGE_START):ss$pAG ## HIV model state-space @@ -39,8 +39,10 @@ create_spectrum_fixpar <- function(projp, demp, hiv_steps_per_year = 10L, proj_s ss$hTS <- 3 # number of treatment stages (including untreated) ss$ag.idx <- rep(1:ss$hAG, ss$h.ag.span) + ss$agfirst.idx <- which(!duplicated(ss$ag.idx)) ss$aglast.idx <- which(!duplicated(ss$ag.idx, fromLast=TRUE)) + ss$h.fert.idx <- which((AGE_START-1 + cumsum(ss$h.ag.span)) %in% 15:49) ss$h.age15to49.idx <- which((AGE_START-1 + cumsum(ss$h.ag.span)) %in% 15:49) ss$h.age15plus.idx <- which((AGE_START-1 + cumsum(ss$h.ag.span)) >= 15) @@ -48,7 +50,8 @@ create_spectrum_fixpar <- function(projp, demp, hiv_steps_per_year = 10L, proj_s invisible(list2env(ss, environment())) # put ss variables in environment for convenience fp <- list(ss=ss) - fp$proj.steps <- proj_start + 0.5 + 0:(ss$hiv_steps_per_year * (ss$PROJ_YEARS-1)) / ss$hiv_steps_per_year + fp$SIM_YEARS <- ss$PROJ_YEARS + fp$proj.steps <- proj_start + 0.5 + 0:(ss$hiv_steps_per_year * (fp$SIM_YEARS-1)) / ss$hiv_steps_per_year ## ######################## ## ## Demographic parameters ## @@ -181,7 +184,7 @@ create_spectrum_fixpar <- function(projp, demp, hiv_steps_per_year = 10L, proj_s fp$med_cd4init_cat <- replace(findInterval(-fp$median_cd4init, - c(1000, 500, 350, 250, 200, 100, 50)), !fp$med_cd4init_input, 0L) - fp$tARTstart <- min(apply(fp$art15plus_num > 0, 1, which)) + fp$tARTstart <- min(unlist(apply(fp$art15plus_num > 0, 1, which))) ## Vertical transmission and survival to AGE_START for lagged births @@ -204,26 +207,12 @@ create_spectrum_fixpar <- function(projp, demp, hiv_steps_per_year = 10L, proj_s ## fp$paedsurv_lag[i+AGE_START] <- fp$paedsurv_lag[i+AGE_START] * (1 - hivqx[j, i+j-1]) - fp$paedsurv_cd4dist <- c(0.056,0.112,0.112,0.07,0.14,0.23,0.28) + ## fp$paedsurv_cd4dist <- c(0.056,0.112,0.112,0.07,0.14,0.23,0.28) + fp$paedsurv_cd4dist <- c(0.25, 0.25, 0.25, 0.12, 0.08, 0.03, 0.02) # distribution to give ~0.05 mortality rate among those entering 15+ age group + fp$paedsurv_artcd4dist <- c(0, 0, 0, 0, 1.0, 0.0, 0.0) # put them all at CD4 100-200...to avoid mucking up the summation code fp$netmig_hivprob <- 0.4*0.22 fp$netmighivsurv <- 0.25/0.22 - - - ## ######################### ## - ## Prepare EPP r(t) models ## - ## ######################### ## - - fp$iota <- 0.0025 - fp$tsEpidemicStart <- fp$proj.steps[which.min(abs(fp$proj.steps - (fp$ss$time_epi_start+0.5)))] - fp$numKnots <- 7 - epi_steps <- fp$proj.steps[fp$proj.steps >= fp$tsEpidemicStart] - proj.dur <- diff(range(epi_steps)) - rvec.knots <- seq(min(epi_steps) - 3*proj.dur/(fp$numKnots-3), max(epi_steps) + 3*proj.dur/(fp$numKnots-3), proj.dur/(fp$numKnots-3)) - fp$rvec.spldes <- rbind(matrix(0, length(fp$proj.steps) - length(epi_steps), fp$numKnots), - splines::splineDesign(rvec.knots, epi_steps)) - - fp$eppmod <- "rspline" # default to r-spline model class(fp) <- "specfp" @@ -239,17 +228,49 @@ prepare_rtrend_model <- function(fp, iota=0.0025){ } -prepare_rspline_model <- function(fp, numKnots=7, tsEpidemicStart=fp$ss$time_epi_start+0.5){ +prepare_rspline_model <- function(fp, numKnots=NULL, tsEpidemicStart=fp$ss$time_epi_start+0.5){ + + if(!exists("numKnots", fp)) + fp$numKnots <- 7 fp$tsEpidemicStart <- fp$proj.steps[which.min(abs(fp$proj.steps - tsEpidemicStart))] - fp$numKnots <- numKnots epi_steps <- fp$proj.steps[fp$proj.steps >= fp$tsEpidemicStart] proj.dur <- diff(range(epi_steps)) rvec.knots <- seq(min(epi_steps) - 3*proj.dur/(fp$numKnots-3), max(epi_steps) + 3*proj.dur/(fp$numKnots-3), proj.dur/(fp$numKnots-3)) fp$rvec.spldes <- rbind(matrix(0, length(fp$proj.steps) - length(epi_steps), fp$numKnots), splines::splineDesign(rvec.knots, epi_steps)) - fp$eppmod <- "rspline" + if(!exists("rtpenord", fp)) + fp$rtpenord <- 2L + if(!exists("eppmod", fp)) + fp$eppmod <- "rspline" + fp$iota <- NULL + + return(fp) +} + +prepare_ospline_model <- function(fp, numKnots=NULL, tsEpidemicStart=fp$ss$time_epi_start+0.5){ + + if(!exists("numKnots", fp)) + fp$numKnots <- 7 + + if(!exists("rtpenord", fp)) + fp$rtpenord <- 2L + + if(exists("knots", fp)) + fp$numKnots <- length(fp$knots) - 4 + + fp$tsEpidemicStart <- fp$proj.steps[which.min(abs(fp$proj.steps - tsEpidemicStart))] + epi_steps <- fp$proj.steps[fp$proj.steps >= fp$tsEpidemicStart] + + ## Use mgcv to setup cubic B-spline basis and design matrix with penalty absorbed + sm <- mgcv::smoothCon(mgcv::s(epi_steps, bs="bs", k=fp$numKnots, m=c(3, fp$rtpenord)), + data.frame(epi_steps=epi_steps), knots=list(epi_steps=fp$knots), absorb.cons=TRUE, diagonal.penalty=TRUE)[[1]] + fp$rvec.spldes <- rbind(matrix(0, length(fp$proj.steps) - length(epi_steps), fp$numKnots), + cbind(1, sm$X[,c(ncol(sm$X), 1:(ncol(sm$X)-1))])) + + if(!exists("eppmod", fp)) + fp$eppmod <- "ospline" fp$iota <- NULL return(fp) @@ -259,10 +280,15 @@ prepare_rspline_model <- function(fp, numKnots=7, tsEpidemicStart=fp$ss$time_epi simmod.specfp <- function(fp, VERSION="C"){ + if(!exists("popadjust", where=fp)) + fp$popadjust <- FALSE + + if(!exists("incidmod", where=fp)) + fp$incidmod <- "eppspectrum" + if(VERSION != "R"){ - fp$eppmodInt <- as.integer(fp$eppmod == "rtrend") # 0: r-spline; 1: r-trend - if(!exists("popadjust", where=fp)) - fp$popadjust <- FALSE + fp$eppmodInt <- match(fp$eppmod, c("rtrend", "directincid"), nomatch=0) # 0: r-spline; + fp$incidmodInt <- match(fp$incidmod, c("eppspectrum", "transm"))-1L # -1 for 0-based indexing mod <- .Call(spectrumC, fp) class(mod) <- "spec" return(mod) @@ -300,19 +326,22 @@ simmod.specfp <- function(fp, VERSION="C"){ popadj.prob <- array(0, c(pAG, NG, PROJ_YEARS)) - incrate15to49.ts.out <- rep(NA, length(fp$rvec)) - rvec <- if(fp$eppmod == "rtrend") rep(NA, length(fp$proj.steps)) else fp$rvec - - prev15to49.ts.out <- rep(NA, length(fp$rvec)) - entrant_prev_out <- numeric(PROJ_YEARS) hivp_entrants_out <- array(0, c(NG, PROJ_YEARS)) + if(fp$eppmod != "directincid"){ + ## outputs by timestep + incrate15to49.ts.out <- rep(NA, length(fp$rvec)) + rvec <- if(fp$eppmod == "rtrend") rep(NA, length(fp$proj.steps)) else fp$rvec + + prev15to49.ts.out <- rep(NA, length(fp$rvec)) + } + ## store last prevalence value (for r-trend model) - prevlast <- prevcurr <- 0 + prevlast <- 0 - for(i in 2:PROJ_YEARS){ + for(i in 2:fp$SIM_YEARS){ ## ################################### ## ## Single-year population projection ## @@ -323,17 +352,21 @@ simmod.specfp <- function(fp, VERSION="C"){ pop[pAG,,,i] <- pop[pAG,,,i-1] + pop[pAG-1,,,i-1] # open age group ## Add lagged births into youngest age group + if(exists("entrantprev", where=fp)) + entrant_prev <- fp$entrantprev[i] + else + entrant_prev <- pregprevlag[i-1]*fp$verttrans_lag[i-1]*fp$paedsurv_lag[i-1] + if(exists("popadjust", where=fp) & fp$popadjust){ - entrant_prev <- pregprevlag[i-1]*fp$verttrans_lag[i-1]*fp$paedsurv_lag[i-1] hivn_entrants <- fp$entrantpop[,i-1]*(1-entrant_prev) hivp_entrants <- fp$entrantpop[,i-1]*entrant_prev } else { if(exists("age15pop", where=fp)){ - hivn_entrants <- fp$age15pop[1]*c(1.03, 1)/2.03*(1-pregprevlag[i-1]*fp$verttrans_lag[i-1]) - hivp_entrants <- fp$age15pop[1]*c(1.03, 1)/2.03*pregprevlag[i-1]*fp$verttrans_lag[i-1]*fp$paedsurv_lag[i-1] + hivn_entrants <- fp$age15pop[1]*c(1.03, 1)/2.03*(1-entrant_prev / fp$paedsurv_lag[i-1]) + hivp_entrants <- fp$age15pop[1]*c(1.03, 1)/2.03*entrant_prev } else { - hivn_entrants <- birthslag[,i-1]*fp$cumsurv[,i-1]*(1-pregprevlag[i-1]*fp$verttrans_lag[i-1]) + fp$cumnetmigr[,i-1]*(1-pregprevlag[i-1]*fp$netmig_hivprob) - hivp_entrants <- birthslag[,i-1]*fp$cumsurv[,i-1]*pregprevlag[i-1]*fp$verttrans_lag[i-1]*fp$paedsurv_lag[i-1] + fp$cumnetmigr[,i-1]*pregprevlag[i-1]*fp$netmig_hivprob*fp$netmighivsurv + hivn_entrants <- birthslag[,i-1]*fp$cumsurv[,i-1]*(1-entrant_prev / fp$paedsurv_lag[i-1]) + fp$cumnetmigr[,i-1]*(1-pregprevlag[i-1]*fp$netmig_hivprob) + hivp_entrants <- birthslag[,i-1]*fp$cumsurv[,i-1]*entrant_prev + fp$cumnetmigr[,i-1]*entrant_prev } entrant_prev <- sum(hivp_entrants) / sum(hivn_entrants+hivp_entrants) } @@ -350,7 +383,8 @@ simmod.specfp <- function(fp, VERSION="C"){ hivpop[,,,,i] <- hivpop[,,,,i-1] hivpop[,,-hAG,,i] <- hivpop[,,-hAG,,i] - sweep(hivpop[,,-hAG,,i-1], 3:4, hiv.ag.prob[-hAG,], "*") hivpop[,,-1,,i] <- hivpop[,,-1,,i] + sweep(hivpop[,,-hAG,,i-1], 3:4, hiv.ag.prob[-hAG,], "*") - hivpop[1,,1,,i] <- hivpop[1,,1,,i] + fp$paedsurv_cd4dist %o% hivp_entrants + hivpop[1,,1,,i] <- hivpop[1,,1,,i] + fp$paedsurv_cd4dist %o% hivp_entrants * (1-fp$entrantartcov[i]) + hivpop[4,,1,,i] <- hivpop[4,,1,,i] + fp$paedsurv_artcd4dist %o% hivp_entrants * fp$entrantartcov[i] # assume all are 1+ years on ART ## survive the population deaths <- sweep(pop[,,,i], 1:2, (1-fp$Sx[,,i]), "*") @@ -384,44 +418,37 @@ simmod.specfp <- function(fp, VERSION="C"){ ## events at dt timestep for(ii in seq_len(hiv_steps_per_year)){ - grad <- array(0, c(hTS+1L, hDS, hAG, NG)) - ## HIV population size at ts ts <- (i-2)/DT + ii - hivn.ii <- sum(pop[p.age15to49.idx,,hivn.idx,i]) - hivn.ii <- hivn.ii - sum(pop[p.age15to49.idx[1],,hivn.idx,i])*(1-DT*(ii-1)) - hivn.ii <- hivn.ii + sum(pop[tail(p.age15to49.idx,1)+1,,hivn.idx,i])*(1-DT*(ii-1)) - - hivp.ii <- sum(pop[p.age15to49.idx,,hivp.idx,i]) - hivp.ii <- hivp.ii - sum(pop[p.age15to49.idx[1],,hivp.idx,i])*(1-DT*(ii-1)) - hivp.ii <- hivp.ii + sum(pop[tail(p.age15to49.idx,1)+1,,hivp.idx,i])*(1-DT*(ii-1)) - - ## there is an approximation here since this is the 15-49 pop (doesn't account for the slight offset in age group) - propart.ii <- ifelse(hivp.ii > 0, sum(hivpop[-1,,h.age15to49.idx,,i])/sum(hivpop[,,h.age15to49.idx,,i]), 0) - - - ## incidence - - ## calculate r(t) - prevlast <- prevcurr - prev15to49.ts.out[ts] <- prevcurr <- hivp.ii / (hivn.ii+hivp.ii) - if(fp$eppmod=="rtrend") - rvec[ts] <- calc.rt(fp$proj.steps[ts], fp, rvec[ts-1L], prevlast, prevcurr) - - incrate15to49.ts <- rvec[ts] * hivp.ii * (1 - (1-fp$relinfectART)*propart.ii) / (hivn.ii+hivp.ii) + fp$iota * (fp$proj.steps[ts] == fp$tsEpidemicStart) - sexinc15to49.ts <- incrate15to49.ts*c(1, fp$incrr_sex[i])*sum(pop[p.age15to49.idx,,hivn.idx,i])/(sum(pop[p.age15to49.idx,m.idx,hivn.idx,i]) + fp$incrr_sex[i]*sum(pop[p.age15to49.idx, f.idx,hivn.idx,i])) - agesex.inc <- sweep(fp$incrr_age[,,i], 2, sexinc15to49.ts/(colSums(pop[p.age15to49.idx,,hivn.idx,i] * fp$incrr_age[p.age15to49.idx,,i])/colSums(pop[p.age15to49.idx,,hivn.idx,i])), "*") - infections.ts <- agesex.inc * pop[,,hivn.idx,i] - - incrate15to49.ts.out[ts] <- incrate15to49.ts - - pop[,,hivn.idx,i] <- pop[,,hivn.idx,i] - DT*infections.ts - pop[,,hivp.idx,i] <- pop[,,hivp.idx,i] + DT*infections.ts - infections[,,i] <- infections[,,i] + DT*infections.ts + grad <- array(0, c(hTS+1L, hDS, hAG, NG)) - grad[1,,,] <- grad[1,,,] + sweep(fp$cd4_initdist, 2:3, apply(infections.ts, 2, ctapply, ag.idx, sum), "*") - incid15to49[i] <- incid15to49[i] + sum(DT*infections.ts[p.age15to49.idx,]) + if(fp$eppmod != "directincid"){ + ## incidence + + ## calculate r(t) + if(fp$eppmod %in% c("rtrend", "rtrend_rw")) + rvec[ts] <- calc_rtrend_rt(fp$proj.steps[ts], fp, rvec[ts-1], prevlast, pop, i, ii) + else + rvec[ts] <- fp$rvec[ts] + + ## number of infections by age / sex + if(exists("incidmod", where=fp) && fp$incidmod == "transm") + infections.ts <- calc_infections_simpletransm(fp, pop, hivpop, i, ii, rvec[ts]) + else + infections.ts <- calc_infections_eppspectrum(fp, pop, hivpop, i, ii, rvec[ts]) + + incrate15to49.ts.out[ts] <- attr(infections.ts, "incrate15to49.ts") + prev15to49.ts.out[ts] <- attr(infections.ts, "prevcurr") + prevlast <- attr(infections.ts, "prevcurr") + + pop[,,hivn.idx,i] <- pop[,,hivn.idx,i] - DT*infections.ts + pop[,,hivp.idx,i] <- pop[,,hivp.idx,i] + DT*infections.ts + infections[,,i] <- infections[,,i] + DT*infections.ts + + grad[1,,,] <- grad[1,,,] + sweep(fp$cd4_initdist, 2:3, apply(infections.ts, 2, ctapply, ag.idx, sum), "*") + incid15to49[i] <- incid15to49[i] + sum(DT*infections.ts[p.age15to49.idx,]) + } ## disease progression and mortality grad[1,-hDS,,] <- grad[1,-hDS,,] - fp$cd4_prog * hivpop[1,-hDS,,,i] # remove cd4 stage progression (untreated) @@ -521,8 +548,8 @@ simmod.specfp <- function(fp, VERSION="C"){ if(medcd4_idx > 1) elig_above <- elig_above + colSums(art15plus.elig[1:(medcd4_idx-1),,,drop=FALSE],,2) - initprob_below <- pmin(art15plus.inits * 0.5 / elig_below, 1.0) - initprob_above <- pmin(art15plus.inits * 0.5 / elig_above, 1.0) + initprob_below <- pmin(art15plus.inits * 0.5 / elig_below, 1.0, na.rm=TRUE) + initprob_above <- pmin(art15plus.inits * 0.5 / elig_above, 1.0, na.rm=TRUE) initprob_medcat <- initprob_below * medcat_propbelow + initprob_above * (1-medcat_propbelow) artinit <- array(0, dim=c(hDS, hAG, NG)) @@ -539,22 +566,29 @@ simmod.specfp <- function(fp, VERSION="C"){ } } - ## ## Code for calculating new infections once per year to match prevalence (like Spectrum) ## ## incidence ## prev.i <- sum(pop[p.age15to49.idx,,2,i]) / sum(pop[p.age15to49.idx,,,i]) # prevalence age 15 to 49 ## incrate15to49.i <- (fp$prev15to49[i] - prev.i)/(1-prev.i) - ## sexinc15to49 <- incrate15to49.i*c(1, fp$inc.sexratio[i])*sum(pop[p.age15to49.idx,,hivn.idx,i])/(sum(pop[p.age15to49.idx,m.idx,hivn.idx,i]) + fp$inc.sexratio[i]*sum(pop[p.age15to49.idx, f.idx,hivn.idx,i])) - - ## agesex.inc <- sweep(fp$inc.agerr[,,i], 2, sexinc15to49/(colSums(pop[p.age15to49.idx,,hivn.idx,i] * fp$inc.agerr[p.age15to49.idx,,i])/colSums(pop[p.age15to49.idx,,hivn.idx,i])), "*") - ## infections <- agesex.inc * pop[,,hivn.idx,i] - - ## pop[,,hivn.idx,i] <- pop[,,hivn.idx,i] - infections - ## pop[,,hivp.idx,i] <- pop[,,hivp.idx,i] + infections - - ## hivpop[1,,,,i] <- hivpop[1,,,,i] + sweep(fp$cd4.initdist, 2:3, apply(infections, 2, ctapply, ag.idx, sum), "*") - + ## Direct incidence input + if(fp$eppmod == "directincid"){ + if(specfp$incidpopage == 0L) # incidence for 15-49 population + p.incidpop.idx <- p.age15to49.idx + else if(specfp$incidpopage == 1L) # incidence for 15+ population + p.incidpop.idx <- p.age15plus.idx + incrate.i <- fp$incidinput[i] + sexinc <- incrate.i*c(1, fp$incrr_sex[i])*sum(pop[p.incidpop.idx,,hivn.idx,i-1])/(sum(pop[p.incidpop.idx,m.idx,hivn.idx,i-1]) + fp$incrr_sex[i]*sum(pop[p.incidpop.idx, f.idx,hivn.idx,i-1])) + agesex.inc <- sweep(fp$incrr_age[,,i], 2, sexinc/(colSums(pop[p.incidpop.idx,,hivn.idx,i-1] * fp$incrr_age[p.incidpop.idx,,i])/colSums(pop[p.incidpop.idx,,hivn.idx,i-1])), "*") + infections[,,i] <- agesex.inc * pop[,,hivn.idx,i-1] + + pop[,,hivn.idx,i] <- pop[,,hivn.idx,i] - infections[,,i] + pop[,,hivp.idx,i] <- pop[,,hivp.idx,i] + infections[,,i] + + hivpop[1,,,,i] <- hivpop[1,,,,i] + sweep(fp$cd4_initdist, 2:3, apply(infections[,,i], 2, ctapply, ag.idx, sum), "*") + incid15to49[i] <- sum(infections[p.age15to49.idx,,i]) + } + ## adjust population to match target population size if(exists("popadjust", where=fp) & fp$popadjust){ popadj.prob[,,i] <- fp$targetpop[,,i] / rowSums(pop[,,,i],,2) @@ -590,8 +624,11 @@ simmod.specfp <- function(fp, VERSION="C"){ attr(pop, "popadjust") <- popadj.prob attr(pop, "pregprevlag") <- pregprevlag - attr(pop, "incrate15to49_ts") <- incrate15to49.ts.out - attr(pop, "prev15to49_ts") <- prev15to49.ts.out + + if(fp$eppmod != "directincid"){ + attr(pop, "incrate15to49_ts") <- incrate15to49.ts.out + attr(pop, "prev15to49_ts") <- prev15to49.ts.out + } attr(pop, "entrant_prev") <- entrant_prev_out attr(pop, "hivp_entrants") <- hivp_entrants_out @@ -599,16 +636,6 @@ simmod.specfp <- function(fp, VERSION="C"){ return(pop) } -calc.rt <- function(t, fp, rveclast, prevlast, prevcurr){ - if(t > fp$tsEpidemicStart){ - par <- fp$rtrend - gamma.t <- if(t < par$tStabilize) 0 else (prevcurr-prevlast)*(t - par$tStabilize) / (fp$ss$DT*prevlast) - logr.diff <- par$beta[2]*(par$beta[1] - rveclast) + par$beta[3]*prevlast + par$beta[4]*gamma.t - return(exp(log(rveclast) + logr.diff)) - } else - return(fp$rtrend$r0) -} - update.specfp <- epp::update.eppfp @@ -620,3 +647,239 @@ update.specfp <- epp::update.eppfp prev.spec <- function(mod, fp){ attr(mod, "prev15to49") } incid.spec <- function(mod, fp){ attr(mod, "incid15to49") } fnPregPrev.spec <- function(mod, fp) { attr(mod, "pregprev") } + +calc_prev15to49 <- function(mod, fp){ + colSums(mod[fp$ss$p.age15to49.idx,,2,],,2)/colSums(mod[fp$ss$p.age15to49.idx,,,],,3) +} + +calc_incid15to49 <- function(mod, fp){ + c(0, colSums(attr(mod, "infections")[fp$ss$p.age15to49.idx,,-1],,2)/colSums(mod[fp$ss$p.age15to49.idx,,1,-fp$ss$PROJ_YEARS],,2)) +} + +calc_pregprev <- function(mod, fp){ + warning("not yet implemented") +} + + + +#' Age-specific mortality +#' +#' Calculate all-cause mortality rate by single year of age and sex from a +#' \code{spec} object. +#' +#' Mortality in year Y is calculated as the number of deaths occurring from the +#' mid-year of year Y-1 to mid-year Y, divided by the population size at the +#' mid-year of year Y-1. +#' !!! NOTE: This might be different from the calculation in Spectrum. Should +#' confirm this with John Stover. +#' +#' @param mod output of simmod of class \code{\link{spec}}. +#' @return 3-dimensional array of mortality by age, sex, and year. +agemx.spec <- function(mod, nonhiv=FALSE){ + if(nonhiv) + deaths <- attr(mod, "natdeaths") + else + deaths <- attr(mod, "natdeaths") + attr(mod, "hivdeaths") + pop <- mod[,,1,]+ mod[,,2,] + + mx <- array(0, dim=dim(pop)) + mx[,,-1] <-deaths[,,-1] / pop[,,-dim(pop)[3]] + + return(mx) +} + + +#' Non-HIV age-specific mortality +#' +#' Calculate all-cause mortality rate by single year of age and sex from a +#' \code{spec} object. +#' +#' Mortality in year Y is calculated as the number of non-HIV deaths occurring +#' from the mid-year of year Y-1 to mid-year Y, divided by the population size +#' at the mid-year of year Y-1. +#' !!! NOTE: This might be different from the calculation in Spectrum. Should +#' confirm this with John Stover. +#' +#' @param mod output of simmod of class \code{\link{spec}}. +#' @return 3-dimensional array of mortality by age, sex, and year. +natagemx.spec <- function(mod){ + deaths <- attr(mod, "natdeaths") + pop <- mod[,,1,]+ mod[,,2,] + + mx <- array(0, dim=dim(pop)) + mx[,,-1] <-deaths[,,-1] / pop[,,-dim(pop)[3]] + + return(mx) +} + +hivagemx.spec <- function(mod){ + deaths <- attr(mod, "natdeaths") + pop <- mod[,,1,]+ mod[,,2,] + + mx <- array(0, dim=dim(pop)) + mx[,,-1] <-deaths[,,-1] / pop[,,-dim(pop)[3]] + + return(mx) +} + + + +#' Age-specific prevalence by 5-year age groups +#' +#' Age specific HIV prevalene by 5-year age groups from age 15 to 59 +#' +#' Notes: Assumes that AGE_START is 15 and single year of age. +ageprev <- function(mod, aidx=NULL, sidx=NULL, yidx=NULL, agspan=5, arridx=NULL){ + + if(is.null(arridx)){ + if(length(agspan)==1) + agspan <- rep(agspan, length(aidx)) + + dims <- dim(mod) + idx <- expand.grid(aidx=aidx, sidx=sidx, yidx=yidx) + arridx <- idx$aidx + (idx$sidx-1)*dims[1] + (idx$yidx-1)*dims[1]*dims[2] + agspan <- rep(agspan, times=length(sidx)*length(yidx)) + } else if(length(agspan)==1) + agspan <- rep(agspan, length(arridx)) + + agidx <- rep(arridx, agspan) + allidx <- agidx + unlist(sapply(agspan, seq_len))-1 + + hivn <- fastmatch::ctapply(mod[,,1,][allidx], agidx, sum) + hivp <- fastmatch::ctapply(mod[,,2,][allidx], agidx, sum) + + prev <- hivp/(hivn+hivp) + if(!is.null(aidx)) + prev <- array(prev, c(length(aidx), length(sidx), length(yidx))) + return(prev) +} + + +ageincid <- function(mod, aidx=NULL, sidx=NULL, yidx=NULL, agspan=5, arridx=NULL){ + + if(is.null(arridx)){ + if(length(agspan)==1) + agspan <- rep(agspan, length(aidx)) + + dims <- dim(mod) + idx <- expand.grid(aidx=aidx, sidx=sidx, yidx=yidx) + arridx_inf <- idx$aidx + (idx$sidx-1)*dims[1] + (idx$yidx-1)*dims[1]*dims[2] + arridx_hivn <- idx$aidx + (idx$sidx-1)*dims[1] + (pmax(idx$yidx-2, 0))*dims[1]*dims[2] + agspan <- rep(agspan, times=length(sidx)*length(yidx)) + } else if(length(agspan)==1){ + ## arridx_hivn NEED ADJUST arridx FOR PREVIOUS YEAR + agspan <- rep(agspan, length(arridx)) + } + + agidx_inf <- rep(arridx_inf, agspan) + agidx_hivn <- rep(arridx_hivn, agspan) + allidx_inf <- agidx_inf + unlist(sapply(agspan, seq_len))-1 + allidx_hivn <- agidx_hivn + unlist(sapply(agspan, seq_len))-1 + + inf <- fastmatch::ctapply(attr(mod, "infections")[allidx_inf], agidx_inf, sum) + hivn <- fastmatch::ctapply(mod[,,1,][allidx_hivn], agidx_hivn, sum) + + incid <- inf/hivn + if(!is.null(aidx)) + incid <- array(incid, c(length(aidx), length(sidx), length(yidx))) + return(incid) +} + + +ageinfections <- function(mod, aidx=NULL, sidx=NULL, yidx=NULL, agspan=5, arridx=NULL){ + + if(is.null(arridx)){ + if(length(agspan)==1) + agspan <- rep(agspan, length(aidx)) + + dims <- dim(mod) + idx <- expand.grid(aidx=aidx, sidx=sidx, yidx=yidx) + arridx_inf <- idx$aidx + (idx$sidx-1)*dims[1] + (idx$yidx-1)*dims[1]*dims[2] + arridx_hivn <- idx$aidx + (idx$sidx-1)*dims[1] + (pmax(idx$yidx-2, 0))*dims[1]*dims[2] + agspan <- rep(agspan, times=length(sidx)*length(yidx)) + } else if(length(agspan)==1){ + ## arridx_hivn NEED ADJUST arridx FOR PREVIOUS YEAR + agspan <- rep(agspan, length(arridx)) + } + + agidx_inf <- rep(arridx_inf, agspan) + allidx_inf <- agidx_inf + unlist(sapply(agspan, seq_len))-1 + + inf <- fastmatch::ctapply(attr(mod, "infections")[allidx_inf], agidx_inf, sum) + + if(!is.null(aidx)) + inf <- array(inf, c(length(aidx), length(sidx), length(yidx))) + return(inf) +} + +ageartcov <- function(mod, aidx=NULL, sidx=NULL, yidx=NULL, agspan=5, arridx=NULL, + h.ag.span=c(2, 3, 5, 5, 5, 5, 5, 5, 31)){ + + if(is.null(arridx)){ + if(length(agspan)==1) + agspan <- rep(agspan, length(aidx)) + + dims <- dim(mod) + idx <- expand.grid(aidx=aidx, sidx=sidx, yidx=yidx) + arridx <- idx$aidx + (idx$sidx-1)*dims[1] + (idx$yidx-1)*dims[1]*dims[2] + agspan <- rep(agspan, times=length(sidx)*length(yidx)) + } else { + stop("NOT YET IMPLEMENTED FOR arridx inputs") + if(length(agspan)==1) + agspan <- rep(agspan, length(arridx)) + } + + agidx <- rep(arridx, agspan) + sidx.ag <- rep(idx$sidx, agspan) + yidx.ag <- rep(idx$yidx, agspan) + allidx <- agidx + unlist(sapply(agspan, seq_len))-1 + + h.ag.idx <- rep(seq_along(h.ag.span), h.ag.span) + haidx <- h.ag.idx[rep(idx$aidx, agspan) + unlist(sapply(agspan, seq_len))-1] + + ## ART coverage with HA age groups + artpop <- colSums(attr(mod, "artpop"),,2) + artcov <- artpop / (artpop + colSums(attr(mod, "hivpop"),,1)) + + hdim <- dim(artcov) + hallidx <- haidx + (sidx.ag-1)*hdim[1] + (yidx.ag-1)*hdim[1]*hdim[2] + + artp <- fastmatch::ctapply(mod[,,2,][allidx]*artcov[hallidx], agidx, sum) # number on ART + hivp <- fastmatch::ctapply(mod[,,2,][allidx], agidx, sum) + + artcov <- artp/hivp + if(!is.null(aidx)) + artcov <- array(artcov, c(length(aidx), length(sidx), length(yidx))) + return(artcov) +} + + +incid_sexratio.spec <- function(mod){ + inc <- ageincid(mod, 1, 1:2, seq_len(dim(mod)[4]), 35)[,,] + inc[2,] / inc[1,] +} + + +calc_nqx.spec <- function(mod, fp, n=45, x=15, nonhiv=FALSE){ + mx <- agemx(mod, nonhiv) + return(1-exp(-colSums(mx[x+1:n-fp$ss$AGE_START,,]))) +} + + +pop15to49.spec <- function(mod){colSums(mod[1:35,,,],,3)} +artpop15to49.spec <- function(mod){colSums(attr(mod, "artpop")[,,1:8,,],,4)} +artpop15plus.spec <- function(mod){colSums(attr(mod, "artpop"),,4)} + +artcov15to49.spec <- function(mod, sex=1:2){ + n_art <- colSums(attr(mod, "artpop")[,,1:8,sex,,drop=FALSE],,4) + n_hiv <- colSums(attr(mod, "hivpop")[,1:8,sex,,drop=FALSE],,3) + return(n_art / (n_hiv+n_art)) +} + +artcov15plus.spec <- function(mod, sex=1:2){ + n_art <- colSums(attr(mod, "artpop")[,,,sex,,drop=FALSE],,4) + n_hiv <- colSums(attr(mod, "hivpop")[,,sex,,drop=FALSE],,3) + return(n_art / (n_hiv+n_art)) +} + +age15pop.spec <- function(mod){colSums(mod[1,,,],,2)} diff --git a/R/sysdata.rda b/R/sysdata.rda index 766b50f..0c74164 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/data-raw/CountryListMaster.csv b/data-raw/CountryListMaster.csv new file mode 100755 index 0000000..a7ade4c --- /dev/null +++ b/data-raw/CountryListMaster.csv @@ -0,0 +1,238 @@ +Code,Country,Currency,ExchangeRate,Currency Name,AM,FP,CS,HV,RN,TB,UPD Filename +4,Afghanistan,AFN,3.83,$ argentinos,0,1,1,0,0,1,Afghanistan_4.upd +903,AFRICA,,,,0,0,0,0,0,0,AFRICA_903.upd +8,Albania,ALL,,,0,1,1,0,0,0,Albania_8.upd +12,Algeria,DZD,,,1,1,1,0,0,1,Algeria_12.upd +24,Angola,AOA,,,1,1,1,0,0,1,Angola_24.upd +28,Antigua and Barbuda,XCD,,,0,0,0,0,0,0,Antigua and Barbuda_28.upd +32,Argentina,ARS,,,1,1,1,0,1,1,Argentina_32.upd +51,Armenia,AMD,,,1,1,1,0,0,1,Armenia_51.upd +533,Aruba,AWG,,,0,0,0,0,0,0,Aruba_533.upd +935,ASIA,,,,0,0,0,0,0,0,ASIA_935.upd +36,Australia,AUD,,,1,0,0,0,0,1,Australia_36.upd +927,Australia and New Zealand,NZD,,,0,0,0,0,0,0,Australia and New Zealand_927.upd +40,Austria,EUR,,,1,0,0,0,0,1,Austria_40.upd +31,Azerbaijan,AZN,,,1,1,1,0,0,1,Azerbaijan_31.upd +44,Bahamas,BSD,,,1,1,1,0,0,1,Bahamas_44.upd +48,Bahrain,BHD,,,0,1,1,0,0,0,Bahrain_48.upd +50,Bangladesh,BDT,,,1,1,1,0,0,1,Bangladesh_50.upd +52,Barbados,BBD,,,1,1,1,0,0,1,Barbados_52.upd +112,Belarus,BYR,,,1,1,1,0,0,1,Belarus_112.upd +56,Belgium,EUR,,,1,0,0,0,0,1,Belgium_56.upd +84,Belize,BZD,,,1,1,1,0,0,1,Belize_84.upd +204,Benin,XOF,450,FCFA,1,1,1,0,1,1,Benin_204.upd +64,Bhutan,BTN,,,1,1,1,0,0,1,Bhutan_64.upd +68,Bolivia,BOB,1,BOB,1,1,1,0,1,0,Bolivia_68.upd +70,Bosnia and Herzegovina,BAM,,,0,1,1,0,0,0,Bosnia and Herzegovina_70.upd +72,Botswana,BWP,6.5,Pula,1,1,1,1,1,1,Botswana_72.upd +76,Brazil,BRL,1.71,BRL,1,1,1,1,1,1,Brazil_76.upd +96,Brunei Darussalam,BND,,,0,1,1,0,0,0,Brunei Darussalam_96.upd +100,Bulgaria,BGN,,,1,1,1,0,0,1,Bulgaria_100.upd +854,Burkina Faso,XOF,475,FCFA,1,1,1,0,1,1,Burkina Faso_854.upd +108,Burundi,BIF,,,1,1,1,0,0,1,Burundi_108.upd +116,Cambodia,KHR,1,KHR,1,1,1,1,1,1,Cambodia_116.upd +120,Cameroon,XAF,1,XAF,1,1,1,1,1,1,Cameroon_120.upd +124,Canada,CAD,,,1,0,0,0,0,1,Canada_124.upd +132,Cape Verde,CVE,,,1,1,1,0,0,0,Cape Verde_132.upd +915,Caribbean,XCD,,,0,0,0,0,0,0,Caribbean_915.upd +140,Central African Republic,XAF,1,CFA,1,1,1,0,1,0,Central African Republic_140.upd +916,Central America,,,,0,0,0,0,0,0,Central America_916.upd +5500,Central Asia,,,,0,0,0,0,0,0,Central Asia_5500.upd +148,Chad,XAF,1,XAF,1,1,1,0,1,1,Chad_148.upd +830,Channel Islands,GBP,,,0,0,0,0,0,0,Channel Islands_830.upd +152,Chile,CLP,1,US$,1,1,1,0,1,1,Chile_152.upd +156,China,CNY,1,CNY,1,1,1,1,1,1,China_156.upd +344,China Hong Kong SAR,HKD,,,0,0,0,0,0,0,China Hong Kong SAR_344.upd +446,China Macao SAR,MOP,,,0,0,0,0,0,0,China Macao SAR_446.upd +158,China Taiwan Province,TWD,,,0,0,0,0,0,0,China Taiwan Province_158.upd +170,Colombia,COP,,,1,1,1,0,0,1,Colombia_170.upd +174,Comoros,KMF,,,1,1,1,0,0,1,Comoros_174.upd +178,Congo,XAF,1,FCFA Afrique Centrale,1,1,1,0,1,1,Congo_178.upd +188,Costa Rica,CRC,,,1,1,1,0,0,1,Costa Rica_188.upd +384,Côte d'Ivoire,XOF,450,FCFA,1,1,1,1,1,0,Côte d'Ivoire_384.upd +191,Croatia,HRK,,,1,1,1,0,0,1,Croatia_191.upd +192,Cuba,CUP,,,1,1,1,0,0,1,Cuba_192.upd +531,Curacao,ANG,,,0,0,0,0,0,0,Curacao_531.upd +196,Cyprus,EUR,,,0,0,0,0,0,0,Cyprus_196.upd +203,Czech Republic,CZK,,,1,1,1,0,0,1,Czech Republic_203.upd +408,Dem. People's Republic of Korea,KPW,,,1,1,1,0,0,0,Dem. People's Republic of Korea_408.upd +180,Democratic Republic of the Congo,CDF,1,CDF,1,1,1,0,1,0,Democratic Republic of the Congo_180.upd +208,Denmark,DKK,,,1,0,0,0,0,1,Denmark_208.upd +262,Djibouti,DJF,,,1,1,1,0,0,1,Djibouti_262.upd +214,Dominican Republic,DOP,1,DOP,1,1,1,0,1,1,Dominican Republic_214.upd +910,Eastern Africa,,,,0,0,0,0,0,0,Eastern Africa_910.upd +906,Eastern Asia,,,,0,0,0,0,0,0,Eastern Asia_906.upd +923,Eastern Europe,,,,0,0,0,0,0,0,Eastern Europe_923.upd +218,Ecuador,ECS,1,ECS,1,1,1,0,1,1,Ecuador_218.upd +818,Egypt,EGP,,,1,1,1,0,0,1,Egypt_818.upd +222,El Salvador,SVC,1,US$,1,1,1,0,1,1,El Salvador_222.upd +226,Equatorial Guinea,XAF,,,1,1,1,0,0,1,Equatorial Guinea_226.upd +232,Eritrea,ERN,,,1,1,1,0,0,1,Eritrea_232.upd +233,Estonia,EEK,,,1,1,1,0,0,1,Estonia_233.upd +231,Ethiopia,ETB,1,ETB,1,1,1,1,1,1,Ethiopia_231.upd +908,EUROPE,,,,0,0,0,0,0,0,EUROPE_908.upd +242,Fiji,FJD,,,1,1,1,0,0,1,Fiji_242.upd +246,Finland,EUR,,,1,0,0,0,0,1,Finland_246.upd +250,France,EUR,,,1,0,0,0,0,1,France_250.upd +254,French Guiana,EUR,,,0,1,0,0,0,0,French Guiana_254.upd +258,French Polynesia,XPF,,,0,1,0,0,0,0,French Polynesia_258.upd +266,Gabon,XAF,1,CFA,1,1,1,0,1,1,Gabon_266.upd +270,Gambia,GMD,,,1,1,1,0,0,1,Gambia_270.upd +268,Georgia,GEL,,,1,1,1,0,0,1,Georgia_268.upd +276,Germany,EUR,,,1,0,0,0,0,1,Germany_276.upd +288,Ghana,GHS,1.65,GHC,1,1,1,0,1,1,Ghana_288.upd +300,Greece,EUR,,,1,0,0,0,0,1,Greece_300.upd +308,Grenada,XCD,,,0,1,1,0,0,0,Grenada_308.upd +312,Guadeloupe,EUR,,,0,1,0,0,0,0,Guadeloupe_312.upd +316,Guam,USD,,,0,1,0,0,0,0,Guam_316.upd +320,Guatemala,GTQ,1,GTQ,1,1,1,0,1,1,Guatemala_320.upd +324,Guinea,GNF,1,GNF,1,1,1,0,1,1,Guinea_324.upd +624,Guinea-Bissau,XOF,,,1,1,1,0,0,1,Guinea-Bissau_624.upd +328,Guyana,GYD,,,1,1,1,0,0,1,Guyana_328.upd +332,Haiti,HTG,,,1,1,1,0,0,1,Haiti_332.upd +340,Honduras,HNL,,,1,1,1,0,0,1,Honduras_340.upd +348,Hungary,HUF,,,1,1,1,0,0,1,Hungary_348.upd +352,Iceland,ISK,,,1,0,0,0,0,1,Iceland_352.upd +356,India,INR,46,INR,1,1,1,1,1,1,India_356.upd +360,Indonesia,IDR,9300,IDR,1,1,1,1,1,1,Indonesia_360.upd +364,Iran (Islamic Republic of),IRR,,,1,1,1,0,0,0,Iran (Islamic Republic of)_364.upd +368,Iraq,IQR,,,0,1,1,0,0,0,Iraq_368.upd +372,Ireland,EUR,,,1,0,0,0,0,1,Ireland_372.upd +376,Israel,ILS,,,1,0,0,0,0,1,Israel_376.upd +380,Italy,EUR,,,1,0,0,0,0,1,Italy_380.upd +388,Jamaica,JMD,,,1,1,1,1,1,1,Jamaica_388.upd +392,Japan,JPY,,,1,0,0,0,0,1,Japan_392.upd +400,Jordan,JOD,,,0,1,1,0,0,0,Jordan_400.upd +398,Kazakhstan,KZT,,,1,1,1,0,0,1,Kazakhstan_398.upd +404,Kenya,KES,74.8,Shillings,1,1,1,1,1,1,Kenya_404.upd +296,Kiribati,AUD,,,0,0,0,0,0,0,Kiribati_296.upd +414,Kuwait,KWD,,,0,1,1,0,0,0,Kuwait_414.upd +417,Kyrgyzstan,KGS,,,1,1,1,0,0,1,Kyrgyzstan_417.upd +418,Lao People's Democratic Republic,LAK,,,1,1,1,0,0,0,Lao People's Democratic Republic_418.upd +904,LATIN AMERICA AND THE CARIBBEAN,,,,0,0,0,0,0,0,LATIN AMERICA AND THE CARIBBEAN_904.upd +428,Latvia,LVL,,,1,1,1,0,0,1,Latvia_428.upd +941,Least developed countries,,,,0,0,0,0,0,0,Least developed countries_941.upd +422,Lebanon,LBP,,,1,1,1,0,0,1,Lebanon_422.upd +426,Lesotho,LSL,7,Maloti,1,1,1,1,1,1,Lesotho_426.upd +902,Less developed regions,,,,0,0,0,0,0,0,Less developed regions_902.upd +948,Less developed regions excluding China,,,,0,0,0,0,0,0,Less developed regions excluding China_948.upd +934,Less developed regions excluding least developed,,,,0,0,0,0,0,0,Less developed regions excluding least developed_934.upd +430,Liberia,LRD,,,1,1,1,0,0,1,Liberia_430.upd +434,Libyan Arab Jamahiriya,LYD,,,0,1,1,0,0,0,Libyan Arab Jamahiriya_434.upd +440,Lithuania,LTL,,,1,1,1,0,0,1,Lithuania_440.upd +442,Luxembourg,EUR,,,1,0,0,0,0,1,Luxembourg_442.upd +450,Madagascar,MGA,2000,Ariary,1,1,1,0,1,1,Madagascar_450.upd +454,Malawi,MWK,140,Malawi Kwacha,1,1,1,1,1,1,Malawi_454.upd +458,Malaysia,MYR,1,MYR,1,1,1,0,1,1,Malaysia_458.upd +462,Maldives,MVR,,,1,1,1,0,0,1,Maldives_462.upd +466,Mali,XOF,500,XOF,1,1,1,0,1,1,Mali_466.upd +470,Malta,EUR,,,1,0,0,0,0,1,Malta_470.upd +474,Martinique,EUR,,,0,1,0,0,0,0,Martinique_474.upd +478,Mauritania,MRO,,,1,1,1,0,0,1,Mauritania_478.upd +480,Mauritius,MUR,,,1,1,1,0,0,1,Mauritius_480.upd +175,Mayotte,EUR,,,0,0,0,0,0,0,Mayotte_175.upd +928,Melanesia,,,,0,0,0,0,0,0,Melanesia_928.upd +484,Mexico,MXN,13.2325,Peso,1,1,1,1,1,1,Mexico_484.upd +954,Micronesia,USD,,,0,0,0,0,0,0,Micronesia_954.upd +583,Micronesia (Fed. States of),USD,,,0,1,1,0,0,0,Micronesia (Fed. States of)_583.upd +911,Middle Africa,,,,0,0,0,0,0,0,Middle Africa_911.upd +496,Mongolia,MNT,1,MNT,1,1,1,0,1,1,Mongolia_496.upd +499,Montenegro,EUR,,,0,1,0,0,0,0,Montenegro_499.upd +901,More developed regions,,,,0,0,0,0,0,0,More developed regions_901.upd +504,Morocco,MAD,,,1,1,1,0,0,1,Morocco_504.upd +508,Mozambique,MZN,1,MZN,1,1,1,0,1,1,Mozambique_508.upd +104,Myanmar,MMK,1,Kyats,1,1,1,0,1,1,Myanmar_104.upd +516,Namibia,NAD,7.4,NAD,1,1,1,0,1,1,Namibia_516.upd +524,Nepal,NPR,1,NPR,1,1,1,0,1,1,Nepal_524.upd +528,Netherlands,EUR,,,1,0,0,0,0,1,Netherlands_528.upd +540,New Caledonia,XPF,,,0,1,0,0,0,0,New Caledonia_540.upd +554,New Zealand,NZD,,,1,0,0,0,0,1,New Zealand_554.upd +558,Nicaragua,NIO,,,1,1,1,0,0,1,Nicaragua_558.upd +562,Niger,XOF,450,FCFA,1,1,1,0,1,1,Niger_562.upd +566,Nigeria,NGN,150,NAIRA,1,1,1,1,1,1,Nigeria_566.upd +912,Northern Africa,,,,0,0,0,0,0,0,Northern Africa_912.upd +905,NORTHERN AMERICA,,,,0,0,0,0,0,0,NORTHERN AMERICA_905.upd +924,Northern Europe,,,,0,0,0,0,0,0,Northern Europe_924.upd +578,Norway,NOK,,,1,0,0,0,0,1,Norway_578.upd +275,Occupied Palestinian Territory,ILS,,,0,1,1,0,0,0,Occupied Palestinian Territory_275.upd +909,OCEANIA,,,,0,0,0,0,0,0,OCEANIA_909.upd +512,Oman,OMR,,,1,1,1,0,0,1,Oman_512.upd +586,Pakistan,PKR,84,Rs,1,1,1,0,1,1,Pakistan_586.upd +591,Panama,PAB,1,Dolares,1,1,1,0,1,1,Panama_591.upd +598,Papua New Guinea,PGK,2.6,PGK,1,1,1,0,1,1,Papua New Guinea_598.upd +600,Paraguay,PYG,4890,Guananies,1,1,1,0,1,1,Paraguay_600.upd +604,Peru,PEN,0.341296928,PEN,1,1,1,0,1,1,Peru_604.upd +608,Philippines,PHP,1,PHP,1,1,1,0,1,1,Philippines_608.upd +616,Poland,PLN,,,1,1,1,0,0,1,Poland_616.upd +957,Polynesia,XPF,,,0,0,0,0,0,0,Polynesia_957.upd +620,Portugal,EUR,,,1,0,0,0,0,1,Portugal_620.upd +630,Puerto Rico,USD,,,0,1,0,0,0,0,Puerto Rico_630.upd +634,Qatar,QAR,,,0,1,1,0,0,0,Qatar_634.upd +410,Republic of Korea,KRW,,,1,1,1,0,0,1,Republic of Korea_410.upd +498,Republic of Moldova,MDL,,,1,1,1,0,0,1,Republic of Moldova_498.upd +638,Réunion,EUR,,,0,1,0,0,0,0,Réunion_638.upd +642,Romania,RON,,,1,1,1,0,0,1,Romania_642.upd +643,Russian Federation,RUB,,,1,1,1,1,1,1,Russian Federation_643.upd +646,Rwanda,RWF,1,RWF,1,1,1,1,1,1,Rwanda_646.upd +662,Saint Lucia,XCD,,,0,1,1,0,0,0,Saint Lucia_662.upd +670,Saint Vincent and the Grenadines,XCD,,,0,1,1,0,0,0,Saint Vincent and the Grenadines_670.upd +882,Samoa,WST,,,0,1,1,0,0,0,Samoa_882.upd +5733,Sample country,USD,1,USD,1,1,1,1,1,1,Sample country_5733.upd +678,São Tomé and Príncipe,STD,,,1,1,1,0,0,0,Sao Tomé and Príncipe_678.upd +682,Saudi Arabia,SAR,,,0,1,1,0,0,0,Saudi Arabia_682.upd +686,Senegal,XOF,1,XOF,1,1,1,0,1,1,Senegal_686.upd +688,Serbia,RSD,,,1,1,1,0,0,1,Serbia_688.upd +690,Seychelles,SCR,,,0,0,0,0,0,0,Seychelles_690.upd +694,Sierra Leone,SLL,3650,Leone ,1,1,1,0,1,1,Sierra Leone_694.upd +702,Singapore,SGD,,,1,1,1,0,0,1,Singapore_702.upd +703,Slovakia,SKK,,,1,1,1,0,0,1,Slovakia_703.upd +705,Slovenia,SIT,,,1,1,1,0,0,1,Slovenia_705.upd +90,Solomon Islands,SBD,,,0,1,1,0,0,0,Solomon Islands_90.upd +706,Somalia,SOS,,,1,1,1,0,0,1,Somalia_706.upd +710,South Africa,ZAR,7.5,South African Rand (ZAR),1,1,1,1,1,1,South Africa_710.upd +931,South America,,,,0,0,0,0,0,0,South America_931.upd +5501,Southern Asia,,,,0,0,0,0,0,0,Southern Asia_5501.upd +728,South Sudan,SDG,,,1,1,1,0,0,0,South Sudan_728.upd +921,South-central Asia,,,,0,0,0,0,0,0,South-central Asia_921.upd +920,South-eastern Asia,,,,0,0,0,0,0,0,South-eastern Asia_920.upd +913,Southern Africa,,,,0,0,0,0,0,0,Southern Africa_913.upd +925,Southern Europe,,,,0,0,0,0,0,0,Southern Europe_925.upd +724,Spain,EUR,,,1,0,0,0,0,1,Spain_724.upd +144,Sri Lanka,LKR,,,1,1,1,0,0,1,Sri Lanka_144.upd +947,Sub-Saharan Africa,,,,0,0,0,0,0,0,Sub-Saharan Africa_947.upd +729,Sudan,SDG,,,1,1,1,0,0,1,Sudan_729.upd +740,Suriname,SRD,,,1,1,1,0,0,1,Suriname_740.upd +748,Swaziland,SZL,7,SZL,1,1,1,0,1,1,Swaziland_748.upd +752,Sweden,SEK,,,1,0,0,0,0,1,Sweden_752.upd +756,Switzerland,CHF,,,1,0,0,0,0,1,Switzerland_756.upd +760,Syrian Arab Republic,SYP,,,0,1,1,0,0,0,Syrian Arab Republic_760.upd +762,Tajikistan,TJS,,,1,1,1,0,0,1,Tajikistan_762.upd +807,TFYR Macedonia,MKD,,,0,1,1,0,0,0,TFYR Macedonia_807.upd +764,Thailand,THB,33.13,Thai Baht,1,1,1,0,1,1,Thailand_764.upd +626,Timor-Leste,IDR,,,0,1,1,0,0,0,Timor-Leste_626.upd +768,Togo,XOF,1,FCFA,1,1,1,0,1,1,Togo_768.upd +776,Tonga,TOP,,,0,1,1,0,0,0,Tonga_776.upd +780,Trinidad and Tobago,TTD,,,1,1,1,0,0,1,Trinidad and Tobago_780.upd +788,Tunisia,TND,,,1,1,1,0,0,1,Tunisia_788.upd +792,Turkey,TRY,,,1,1,1,0,0,1,Turkey_792.upd +795,Turkmenistan,TMM,,,0,1,1,0,0,0,Turkmenistan_795.upd +800,Uganda,UGX,2137,Ug Shilling,1,1,1,1,1,1,Uganda_800.upd +804,Ukraine,UAH,,,1,1,1,1,1,1,Ukraine_804.upd +784,United Arab Emirates,AED,,,0,1,1,0,0,0,United Arab Emirates_784.upd +826,United Kingdom,GBP,,,1,0,0,0,0,0,United Kingdom_826.upd +834,United Republic of Tanzania,TZS,1320,Tshs,1,1,1,1,1,0,United Republic of Tanzania_834.upd +840,United States of America,USD,,,1,0,0,0,0,0,United States of America_840.upd +850,United States Virgin Islands,USD,,,0,1,0,0,0,0,United States Virgin Islands_850.upd +858,Uruguay,UYU,,,1,1,1,0,0,1,Uruguay_858.upd +860,Uzbekistan,UZS,,,1,1,1,0,0,1,Uzbekistan_860.upd +548,Vanuatu,VUV,,,0,1,1,0,0,0,Vanuatu_548.upd +862,Venezuela,VEF,,,1,1,1,0,0,0,Venezuela_862.upd +704,Viet Nam,VND,16850,Dong,1,1,1,1,1,1,Viet Nam_704.upd +914,Western Africa,,,,0,0,0,0,0,0,Western Africa_914.upd +922,Western Asia,,,,0,0,0,0,0,0,Western Asia_922.upd +926,Western Europe,,,,0,0,0,0,0,0,Western Europe_926.upd +732,Western Sahara,MAD,,,0,1,0,0,0,0,Western Sahara_732.upd +900,WORLD,,,,0,0,0,0,0,0,WORLD_900.upd +887,Yemen,YER,,,1,1,1,0,0,1,Yemen_887.upd +894,Zambia,ZMK,5000,ZMK,1,1,1,1,1,1,Zambia_894.upd +716,Zimbabwe,ZWD,1,ZWD,1,1,1,1,1,1,Zimbabwe_716.upd diff --git a/data-raw/spectrum-country-list.R b/data-raw/spectrum-country-list.R new file mode 100644 index 0000000..d550f20 --- /dev/null +++ b/data-raw/spectrum-country-list.R @@ -0,0 +1,9 @@ + +## Country list taken from Spectrum 5.62beta15 +## C:\Program Files (x86)\Spectrum5\DP\ModData\CountryListMaster.csv + +load("../R/sysdata.rda") + +spectrum5_countrylist <- read.csv("CountryListMaster.csv", as.is=TRUE, encoding = "UTF-8") +spectrum5_countrylist$Country[spectrum5_countrylist$Code == 384] <- "Côte d'Ivoire" +devtools::use_data(spectrum5_countrylist, subp, internal = TRUE, overwrite=TRUE) diff --git a/dev/#dev-artpercentage.R# b/dev/#dev-artpercentage.R# deleted file mode 100644 index e07fb5a..0000000 --- a/dev/#dev-artpercentage.R# +++ /dev/null @@ -1,71 +0,0 @@ -devtools::load_all("~/Dropbox/Documents/Code/R/eppspectrum/", export_all=FALSE) - -upd.path <- "~/Documents/Data/Spectrum files/2014, final (downloaded 8 October 2014)/unpop/Botswana_72.upd" -spec.path <- "~/Documents/Data/Spectrum files/2015 final/SSA/Botswana 2015 upd/Botswana 2015 upd" - -demp <- read_demog_param(upd.path) -projp <- read_hivproj_param(paste(spec.path, ".DP", sep="")) - -fp <- create_spectrum_fixpar(projp, demp, proj_end = 2020, time_epi_start = 1970, hiv_steps_per_year= 10L) # Set time_epi_start tomatch EPP - - -theta.rspline <- c(1.31820011, -0.09884313, -0.40054248, 0.06277183, 0.16923859, 0.41277390, -0.17640756, -14.13863910, 0.09765759, -3.73232668, -5.12046650) - -param <- fnCreateParam(theta.rspline, fp) -fp.rspline <- update(fp, list=param) -mod.rspline <- simmod(fp.rspline) - -round(prev(mod.rspline), 3) # prevalence -round(incid(mod.rspline, fp.rspline), 4) # incidence - - - - -############################## -############################## - -devtools::load_all("~/Documents/Code/R/eppspectrum/") - -modR <- simmod(fp.rspline, VERSION="R") -modC <- simmod(fp.rspline, VERSION="C") - -cbind(round(incid(modR), 4), - round(incid(modC), 4)) - -cbind(round(prev(modR), 4), - round(prev(modC), 4)) - - -dim(modR) - - -prevR <- function(mod){colSums(mod[fp$ss$p.age15to49.idx,,2,],,2) / colSums(mod[fp$ss$p.age15to49.idx,,,],,3)} -##artnumR <- function - -cbind(prevR(modRbak), - prevR(modCbak), - fp$art15plus_numperc, - colSums(fp$art15plus_num), - - cbind(colSums(attr(modRbak, "hivpop")[-1,,,,],,4), - colSums(attr(modCbak, "artpop"),,4), - colSums(attr(mod, "hivpop")[-1,,,,],,4)) - - - - -devtools::load_all("~/Dropbox/Documents/Code/R/eppspectrum/", export_all=FALSE) - -## mod <- simmod(fp.rspline, VERSION="R") - -mod2R <- simmod(fp.rspline, VERSION="R") -mod2C <- simmod(fp.rspline) - -cbind(prevR(mod2R), - prevR(mod2C)) -prevR(modRbak) - - - -cbind(t(colSums(attr(mod2C, "artpop"),,3)[,33:51]), - t(colSums(attr(mod2R, "artpop"),,3)[,33:51])) diff --git a/dev/.#dev-artpercentage.R b/dev/.#dev-artpercentage.R deleted file mode 120000 index bee7f3a..0000000 --- a/dev/.#dev-artpercentage.R +++ /dev/null @@ -1 +0,0 @@ -jeff@jeff-mb.local.1684 \ No newline at end of file diff --git a/src/spectrum.cpp b/src/spectrum.cpp index 59a2691..e5e2e18 100644 --- a/src/spectrum.cpp +++ b/src/spectrum.cpp @@ -46,9 +46,36 @@ #define EPP_RSPLINE 0 #define EPP_RTREND 1 +#define EPP_DIRECTINCID 2 // annual direct incidence inputs (as Spectrum) +#define INCIDMOD_EPPSPEC 0 +#define INCIDMOD_TRANSM 1 +#define INCIDPOP_15TO49 0 // age range corresponding to incidence input +#define INCIDPOP_15PLUS 1 + +using namespace boost; + + +// Function declarations SEXP getListElement(SEXP list, const char *str); +int checkListElement(SEXP list, const char *str); + +double calc_rtrend_rt(const multi_array_ref pop, double rtrend_tstab, const double *rtrend_beta, double rtrend_r0, + double projstep, double tsEpidemicStart, double DT, int t, int hts, double rveclast, + double *prevlast, double *prevcurr); + +void calc_infections_eppspectrum(const multi_array_ref pop, const multi_array_ref hivpop, const multi_array_ref artpop, + double r_ts, double relinfectART, double iota, + double *incrr_sex, const multi_array_ref incrr_age, + int t_ART_start, double DT, int t, int hts, int *hAG_START, int *hAG_SPAN, + double *prevcurr, double *incrate15to49_ts, double infections_ts[NG][pAG]); + +void calc_infections_simpletransm(const multi_array_ref pop, const multi_array_ref hivpop, const multi_array_ref artpop, + double r_ts, double relinfectART, double iota, + const double *mf_transm_rr, const double *relsexact_cd4cat, const multi_array_ref incrr_age, + int t_ART_start, double DT, int t, int hts, int *hAG_START, int *hAG_SPAN, + double *prevcurr, double *incrate15to49_ts, double infections_ts[NG][pAG]); extern "C" { @@ -79,6 +106,7 @@ extern "C" { for(int ha = 1; ha < hAG; ha++) hAG_START[ha] = hAG_START[ha-1] + hAG_SPAN[ha-1]; + int SIM_YEARS = *INTEGER(getListElement(s_fp, "SIM_YEARS")); double *projsteps = REAL(getListElement(s_fp, "proj.steps")); // demographic projection @@ -126,30 +154,52 @@ extern "C" { int *med_cd4init_cat = INTEGER(getListElement(s_fp, "med_cd4init_cat")); int *med_cd4init_input = INTEGER(getListElement(s_fp, "med_cd4init_input")); - + // incidence model // double *prev15to49 = REAL(getListElement(s_fp, "prev15to49")); - double *incrr_sex = REAL(getListElement(s_fp, "incrr_sex")); - multi_array_ref incrr_age(REAL(getListElement(s_fp, "incrr_age")), extents[PROJ_YEARS][NG][pAG]); + int incidmod = *INTEGER(getListElement(s_fp, "incidmodInt")); + double *incrr_sex; + double *mf_transm_rr; + double *relsexact_cd4cat; + if(incidmod == INCIDMOD_EPPSPEC) + incrr_sex = REAL(getListElement(s_fp, "incrr_sex")); + else { + mf_transm_rr = REAL(getListElement(s_fp, "mf_transm_rr")); + relsexact_cd4cat = REAL(getListElement(s_fp, "relsexact_cd4cat")); + } - double relinfectART = *REAL(getListElement(s_fp, "relinfectART")); - // double ts_epidemic_start = *INTEGER(getListElement(s_fp, "ts_epi_start")) - 1; // -1 for 0-based indexing in C vs. 1-based in R - double tsEpidemicStart = *REAL(getListElement(s_fp, "tsEpidemicStart")); // -1 for 0-based indexing in C vs. 1-based in R - double iota = *REAL(getListElement(s_fp, "iota")); + multi_array_ref incrr_age(REAL(getListElement(s_fp, "incrr_age")), extents[PROJ_YEARS][NG][pAG]); int eppmod = *INTEGER(getListElement(s_fp, "eppmodInt")); + + double *incidinput; + int pIDX_INCIDPOP, pAG_INCIDPOP; + double tsEpidemicStart, iota, relinfectART; double *rspline_rvec; double *rtrend_beta, rtrend_tstab, rtrend_r0; - if(eppmod == EPP_RSPLINE) - rspline_rvec = REAL(getListElement(s_fp, "rvec")); - else { - SEXP s_rtrend = getListElement(s_fp, "rtrend"); - rtrend_beta = REAL(getListElement(s_rtrend, "beta")); - rtrend_tstab = *REAL(getListElement(s_rtrend, "tStabilize")); - rtrend_r0 = *REAL(getListElement(s_rtrend, "r0")); + if(eppmod == EPP_DIRECTINCID){ + incidinput = REAL(getListElement(s_fp, "incidinput")); + pIDX_INCIDPOP = 0; + if(*INTEGER(getListElement(s_fp, "incidpopage")) == INCIDPOP_15TO49) + pAG_INCIDPOP = pAG_15TO49; + else + pAG_INCIDPOP = pAG_15PLUS; + } else { + relinfectART = *REAL(getListElement(s_fp, "relinfectART")); + tsEpidemicStart = *REAL(getListElement(s_fp, "tsEpidemicStart")); + iota = *REAL(getListElement(s_fp, "iota")); + + if(eppmod == EPP_RSPLINE) + rspline_rvec = REAL(getListElement(s_fp, "rvec")); + else if(eppmod == EPP_RTREND){ + SEXP s_rtrend = getListElement(s_fp, "rtrend"); + rtrend_beta = REAL(getListElement(s_rtrend, "beta")); + rtrend_tstab = *REAL(getListElement(s_rtrend, "tStabilize")); + rtrend_r0 = *REAL(getListElement(s_rtrend, "r0")); + } } - + // vertical transmission and survival double *verttrans_lag = REAL(getListElement(s_fp, "verttrans_lag")); @@ -158,6 +208,27 @@ extern "C" { double netmighivsurv = *REAL(getListElement(s_fp, "netmighivsurv")); double *paedsurv_cd4dist = REAL(getListElement(s_fp, "paedsurv_cd4dist")); + double *entrantprev; + int use_entrantprev = checkListElement(s_fp, "entrantprev"); + if(use_entrantprev) + entrantprev = REAL(getListElement(s_fp, "entrantprev")); + + double *entrantartcov; + if(checkListElement(s_fp, "entrantartcov")) + entrantartcov = REAL(getListElement(s_fp, "entrantartcov")); + else { + entrantartcov = (double*) R_alloc(PROJ_YEARS, sizeof(double)); + memset(entrantartcov, 0, PROJ_YEARS*sizeof(double)); + } + + double *paedsurv_artcd4dist; + if(checkListElement(s_fp, "paedsurv_artcd4dist")) + paedsurv_artcd4dist = REAL(getListElement(s_fp, "paedsurv_artcd4dist")); + else { + paedsurv_artcd4dist = (double*) R_alloc(hDS, sizeof(double)); + memset(paedsurv_artcd4dist, 0, hDS*sizeof(double)); + } + // initialize output SEXP s_pop = PROTECT(allocVector(REALSXP, pAG * NG * pDS * PROJ_YEARS)); SEXP s_pop_dim = PROTECT(allocVector(INTSXP, 4)); @@ -175,7 +246,7 @@ extern "C" { INTEGER(s_hivpop_dim)[3] = PROJ_YEARS; setAttrib(s_hivpop, R_DimSymbol, s_hivpop_dim); setAttrib(s_pop, install("hivpop"), s_hivpop); - + SEXP s_artpop = PROTECT(allocVector(REALSXP, hTS * hDS * hAG * NG * PROJ_YEARS)); SEXP s_artpop_dim = PROTECT(allocVector(INTSXP, 5)); INTEGER(s_artpop_dim)[0] = hTS; @@ -195,7 +266,7 @@ extern "C" { setAttrib(s_pop, install("infections"), s_infections); multi_array_ref infections(REAL(s_infections), extents[PROJ_YEARS][NG][pAG]); memset(REAL(s_infections), 0, length(s_infections)*sizeof(double)); - + SEXP s_hivdeaths = PROTECT(allocVector(REALSXP, pAG * NG * PROJ_YEARS)); SEXP s_hivdeaths_dim = PROTECT(allocVector(INTSXP, 3)); INTEGER(s_hivdeaths_dim)[0] = pAG; @@ -268,7 +339,7 @@ extern "C" { memset(hivn15to49, 0, PROJ_YEARS*sizeof(double)); memset(hivp15to49, 0, PROJ_YEARS*sizeof(double)); - + // initialize population // population by single-year age @@ -278,8 +349,8 @@ extern "C" { for(int a = 0; a < pAG; a++){ pop[0][HIVN][g][a] = basepop[g][a]; pop[0][HIVP][g][a] = 0.0; - if(a >= pIDX_15TO49 & a < pIDX_15TO49+pAG_15TO49) - hivn15to49[0] += basepop[g][a]; + if(a >= pIDX_15TO49 & a < pIDX_15TO49+pAG_15TO49) + hivn15to49[0] += basepop[g][a]; } // HIV population with stage stratification @@ -296,12 +367,12 @@ extern "C" { // memset(REAL(s_artpop), 0, length(s_artpop) * sizeof(double)); // initialize artpop to 0 if(t_ART_start < PROJ_YEARS) for(int g = 0; g < NG; g++) - for(int ha = 0; ha < hAG; ha++) - for(int hm = 0; hm < hDS; hm++) - for(int hu = 0; hu < hTS; hu++) - artpop[t_ART_start][g][ha][hm][hu] = 0.0; // initialize to zero in year of ART start + for(int ha = 0; ha < hAG; ha++) + for(int hm = 0; hm < hDS; hm++) + for(int hu = 0; hu < hTS; hu++) + artpop[t_ART_start][g][ha][hm][hu] = 0.0; // initialize to zero in year of ART start + - // array to store lagged prevalence among pregnant women double *pregprevlag = REAL(s_pregprevlag); // (double*) R_alloc(PROJ_YEARS, sizeof(double)); memset(pregprevlag, 0, AGE_START*sizeof(double)); @@ -313,7 +384,7 @@ extern "C" { //// do population projection //// //////////////////////////////////// - for(int t = 1; t < PROJ_YEARS; t++){ + for(int t = 1; t < SIM_YEARS; t++){ // age the population one year for(int m = 0; m < pDS; m++) @@ -349,30 +420,36 @@ extern "C" { // add lagged births to youngest age group for(int g = 0; g < NG; g++){ - double paedsurv_g; - double entrant_prev; - if(bin_popadjust){ - entrant_prev = pregprevlag[t-1] * verttrans_lag[t-1] * paedsurv_lag[t-1]; - pop[t][HIVN][g][0] = entrantpop[t-1][g] * (1.0-entrant_prev); - paedsurv_g = entrantpop[t-1][g] * entrant_prev; - } else { - pop[t][HIVN][g][0] = birthslag[t-1][g] * cumsurv[t-1][g] * (1.0-pregprevlag[t-1] * verttrans_lag[t-1]) + cumnetmigr[t-1][g] * (1.0-pregprevlag[t-1] * netmig_hivprob); - paedsurv_g = birthslag[t-1][g] * cumsurv[t-1][g] * pregprevlag[t-1] * verttrans_lag[t-1] * paedsurv_lag[t-1] + cumnetmigr[t-1][g] * pregprevlag[t-1] * netmig_hivprob * netmighivsurv; - } + double paedsurv_g; + double entrant_prev; + + if(use_entrantprev) + entrant_prev = entrantprev[t]; + else + entrant_prev = pregprevlag[t-1] * verttrans_lag[t-1] * paedsurv_lag[t-1]; + + if(bin_popadjust){ + pop[t][HIVN][g][0] = entrantpop[t-1][g] * (1.0-entrant_prev); + paedsurv_g = entrantpop[t-1][g] * entrant_prev; + } else { + pop[t][HIVN][g][0] = birthslag[t-1][g] * cumsurv[t-1][g] * (1.0-entrant_prev / paedsurv_lag[t-1]) + cumnetmigr[t-1][g] * (1.0-pregprevlag[t-1] * netmig_hivprob); + paedsurv_g = birthslag[t-1][g] * cumsurv[t-1][g] * entrant_prev + cumnetmigr[t-1][g] * entrant_prev; + } - pop[t][HIVP][g][0] = paedsurv_g; + pop[t][HIVP][g][0] = paedsurv_g; - entrantprev_out[t] = (pop[t][HIVP][MALE][0] + pop[t][HIVP][FEMALE][0]) / (pop[t][HIVN][MALE][0] + pop[t][HIVN][FEMALE][0] + pop[t][HIVP][MALE][0] + pop[t][HIVP][FEMALE][0]); + entrantprev_out[t] = (pop[t][HIVP][MALE][0] + pop[t][HIVP][FEMALE][0]) / (pop[t][HIVN][MALE][0] + pop[t][HIVN][FEMALE][0] + pop[t][HIVP][MALE][0] + pop[t][HIVP][FEMALE][0]); for(int hm = 0; hm < hDS; hm++){ - hivpop[t][g][0][hm] = (1-hiv_ag_prob[g][0]) * hivpop[t-1][g][0][hm] + paedsurv_g * paedsurv_cd4dist[hm]; - if(t > t_ART_start) + hivpop[t][g][0][hm] = (1-hiv_ag_prob[g][0]) * hivpop[t-1][g][0][hm] + paedsurv_g * paedsurv_cd4dist[hm] * (1.0 - entrantartcov[t]); + if(t > t_ART_start){ for(int hu = 0; hu < hTS; hu++) artpop[t][g][0][hm][hu] = (1-hiv_ag_prob[g][0]) * artpop[t-1][g][0][hm][hu]; + artpop[t][g][0][hm][ART1YR] += paedsurv_g * paedsurv_artcd4dist[hm] * entrantartcov[t]; + } } } - // non-HIV mortality and netmigration for(int g = 0; g < NG; g++){ int a = 0; @@ -383,18 +460,18 @@ extern "C" { hivpop_ha += pop[t][HIVP][g][a]; // non-HIV mortality - double qx = 1.0 - Sx[t][g][a]; - double ndeaths_a = pop[t][HIVN][g][a] * qx; + double qx = 1.0 - Sx[t][g][a]; + double ndeaths_a = pop[t][HIVN][g][a] * qx; pop[t][HIVN][g][a] -= ndeaths_a; // survival HIV- population - double hdeaths_a = pop[t][HIVP][g][a] * qx; + double hdeaths_a = pop[t][HIVP][g][a] * qx; deathsmig_ha -= hdeaths_a; pop[t][HIVP][g][a] -= hdeaths_a; // survival HIV+ population - natdeaths[t][g][a] = ndeaths_a + hdeaths_a; + natdeaths[t][g][a] = ndeaths_a + hdeaths_a; // net migration double migrate_a = netmigr[t][g][a] * (1+Sx[t][g][a])/2.0 / (pop[t][HIVN][g][a] + pop[t][HIVP][g][a]); pop[t][HIVN][g][a] *= 1+migrate_a; - double hmig_a = migrate_a * pop[t][HIVP][g][a]; + double hmig_a = migrate_a * pop[t][HIVP][g][a]; deathsmig_ha += hmig_a; pop[t][HIVP][g][a] += hmig_a; @@ -427,27 +504,27 @@ extern "C" { } for(int ha = hIDX_FERT; ha < hAG_FERT; ha++) births += births_by_ha[ha-hIDX_FERT]; - + if(t + AGE_START < PROJ_YEARS) for(int g = 0; g < NG; g++) birthslag[t + AGE_START-1][g] = srb[t][g] * births; - + //////////////////////////////// //// HIV model simulation //// //////////////////////////////// - + for(int hts = 0; hts < HIVSTEPS_PER_YEAR; hts++){ - int ts = (t-1)*HIVSTEPS_PER_YEAR + hts; - - double hivdeaths_ha[NG][hAG]; - memset(hivdeaths_ha, 0, sizeof(double)*NG*hAG); + int ts = (t-1)*HIVSTEPS_PER_YEAR + hts; + + double hivdeaths_ha[NG][hAG]; + memset(hivdeaths_ha, 0, sizeof(double)*NG*hAG); - // untreated population + // untreated population - // disease progression and mortality - double grad[NG][hAG][hDS]; + // disease progression and mortality + double grad[NG][hAG][hDS]; for(int g = 0; g < NG; g++) for(int ha = 0; ha < hAG; ha++){ for(int hm = 0; hm < hDS; hm++){ @@ -458,140 +535,109 @@ extern "C" { for(int hm = 1; hm < hDS; hm++){ grad[g][ha][hm-1] -= cd4_prog[g][ha][hm-1] * hivpop[t][g][ha][hm-1]; grad[g][ha][hm] += cd4_prog[g][ha][hm-1] * hivpop[t][g][ha][hm-1]; - } - } - - // incidence + } + } - // sum population sizes - double Xhivn_g[NG], Xhivn_incagerr[NG], Xhivp_noart = 0.0, Xart = 0.0; - for(int g = 0; g < NG; g++){ - Xhivn_g[g] = 0.0; - Xhivn_incagerr[g] = 0.0; - for(int a = pIDX_15TO49; a < pIDX_15TO49+pAG_15TO49; a++){ - Xhivn_g[g] += pop[t][HIVN][g][a]; - Xhivn_incagerr[g] += incrr_age[t][g][a] * pop[t][HIVN][g][a]; - } - for(int ha = hIDX_15TO49; ha < hIDX_15TO49+hAG_15TO49; ha++) - for(int hm = 0; hm < hDS; hm++){ - Xhivp_noart += hivpop[t][g][ha][hm]; - if(t >= t_ART_start) - for(int hu = 0; hu < hTS; hu++) - Xart += artpop[t][g][ha][hm][hu]; - } - } - double Xhivn = Xhivn_g[MALE] + Xhivn_g[FEMALE]; - double Xhivp = Xhivp_noart + Xart; - double prop_art_ts = Xhivp > 0 ? Xart / Xhivp : 0.0; - - // adjust HIV population for partial year time step - for(int g = 0; g < NG; g++){ - Xhivn -= pop[t][HIVN][g][pIDX_15TO49] * (1.0 - DT*hts); - Xhivp -= pop[t][HIVP][g][pIDX_15TO49] * (1.0 - DT*hts); - Xhivn += pop[t][HIVN][g][pIDX_15TO49+pAG_15TO49] * (1.0 - DT*hts); - Xhivp += pop[t][HIVP][g][pIDX_15TO49+pAG_15TO49] * (1.0 - DT*hts); - } - - double Xtot = Xhivn + Xhivp; - - prevlast = prevcurr; - prevcurr = Xhivp / Xtot; - prev15to49_ts_out[ts] = prevcurr; - - // calculate r(t) - if(eppmod == EPP_RSPLINE) - rvec[ts] = rspline_rvec[ts]; - else { - if(projsteps[ts] > tsEpidemicStart){ - double gamma_ts = (projsteps[ts] < rtrend_tstab)?0.0:(prevcurr-prevlast) * (projsteps[ts] - rtrend_tstab) / (DT * prevlast); - double logr_diff = rtrend_beta[1]*(rtrend_beta[0] - rvec[ts-1]) + rtrend_beta[2]*prevlast + rtrend_beta[3]*gamma_ts; - rvec[ts] = exp(log(rvec[ts-1]) + logr_diff); - } else { - rvec[ts] = rtrend_r0; - } - } + if(eppmod != EPP_DIRECTINCID){ + // incidence + + // calculate r(t) + if(eppmod == EPP_RSPLINE) + rvec[ts] = rspline_rvec[ts]; + else + rvec[ts] = calc_rtrend_rt(pop, rtrend_tstab, rtrend_beta, rtrend_r0, + projsteps[ts], tsEpidemicStart, DT, t, hts, + rvec[ts-1], &prevlast, &prevcurr); + + // calculate new infections by sex and age + double infections_ts[NG][pAG]; + if(incidmod == INCIDMOD_EPPSPEC) + calc_infections_eppspectrum(pop, hivpop, artpop, + rvec[ts], relinfectART, (projsteps[ts] == tsEpidemicStart) ? iota : 0.0, + incrr_sex, incrr_age, t_ART_start, DT, t, hts, hAG_START, hAG_SPAN, + &prevcurr, &incrate15to49_ts_out[ts], infections_ts); + else + calc_infections_simpletransm(pop, hivpop, artpop, + rvec[ts], relinfectART, (projsteps[ts] == tsEpidemicStart) ? iota : 0.0, + mf_transm_rr, relsexact_cd4cat, incrr_age, t_ART_start, DT, t, hts, hAG_START, hAG_SPAN, + &prevcurr, &incrate15to49_ts_out[ts], infections_ts); + + prev15to49_ts_out[ts] = prevcurr; + + // add new infections to HIV population + for(int g = 0; g < NG; g++){ + int a = 0; + for(int ha = 0; ha < hAG; ha++){ + double infections_a, infections_ha = 0.0; + for(int i = 0; i < hAG_SPAN[ha]; i++){ + infections_ha += infections_a = infections_ts[g][a]; + infections[t][g][a] += DT*infections_a; + pop[t][HIVN][g][a] -= DT*infections_a; + pop[t][HIVP][g][a] += DT*infections_a; + a++; + } + if(ha < hIDX_15TO49+hAG_15TO49 ) + incid15to49[t] += DT*infections_ha; - double incrate15to49_ts = rvec[ts] * Xhivp * (1.0 - (1.0 - relinfectART) * prop_art_ts) / Xtot + ((projsteps[ts] == tsEpidemicStart) ? iota : 0.0); - incrate15to49_ts_out[ts] = incrate15to49_ts; + // add infections to grad hivpop + for(int hm = 0; hm < hDS; hm++) + grad[g][ha][hm] += infections_ha * cd4_initdist[g][ha][hm]; + } + } + } - // incidence by sex - double incrate15to49_g[NG]; - incrate15to49_g[MALE] = incrate15to49_ts * (Xhivn_g[MALE]+Xhivn_g[FEMALE]) / (Xhivn_g[MALE] + incrr_sex[t]*Xhivn_g[FEMALE]); - incrate15to49_g[FEMALE] = incrate15to49_ts * incrr_sex[t]*(Xhivn_g[MALE]+Xhivn_g[FEMALE]) / (Xhivn_g[MALE] + incrr_sex[t]*Xhivn_g[FEMALE]); + for(int g = 0; g < NG; g++) + for(int ha = 0; ha < hAG; ha++) + for(int hm = 0; hm < hDS; hm++) + hivpop[t][g][ha][hm] += DT*grad[g][ha][hm]; + + // ART progression, mortality, and initiation + if(t >= t_ART_start){ + int cd4elig_idx = artcd4elig_idx[t] - 1; // -1 for 0-based indexing vs. 1-based in R + int anyelig_idx = (specpop_percelig[t] > 0 | pw_artelig[t] > 0) ? 0 : (who34percelig > 0) ? hIDX_CD4_350 : cd4elig_idx; + + // progression and mortality + for(int g = 0; g < NG; g++) + for(int ha = 0; ha < hAG; ha++) + for(int hm = anyelig_idx; hm < hDS; hm++){ + double gradART[hTS]; - for(int g = 0; g < NG; g++){ - int a = 0; - for(int ha = 0; ha < hAG; ha++){ - double infections_a, infections_ha = 0.0; - for(int i = 0; i < hAG_SPAN[ha]; i++){ - infections_ha += infections_a = pop[t][HIVN][g][a] * incrate15to49_g[g] * incrr_age[t][g][a] * Xhivn_g[g] / Xhivn_incagerr[g]; - infections[t][g][a] += DT*infections_a; - pop[t][HIVN][g][a] -= DT*infections_a; - pop[t][HIVP][g][a] += DT*infections_a; - a++; - } - if(ha < hIDX_15TO49+hAG_15TO49 ) - incid15to49[t] += DT*infections_ha; - - // add infections to grad hivpop - for(int hm = 0; hm < hDS; hm++) - grad[g][ha][hm] += infections_ha * cd4_initdist[g][ha][hm]; - } - } - - - for(int g = 0; g < NG; g++) - for(int ha = 0; ha < hAG; ha++) - for(int hm = 0; hm < hDS; hm++) - hivpop[t][g][ha][hm] += DT*grad[g][ha][hm]; - - // ART progression, mortality, and initiation - if(t >= t_ART_start){ - int cd4elig_idx = artcd4elig_idx[t] - 1; // -1 for 0-based indexing vs. 1-based in R - int anyelig_idx = (specpop_percelig[t] > 0 | pw_artelig[t] > 0) ? 0 : (who34percelig > 0) ? hIDX_CD4_350 : cd4elig_idx; - - // progression and mortality - for(int g = 0; g < NG; g++) - for(int ha = 0; ha < hAG; ha++) - for(int hm = anyelig_idx; hm < hDS; hm++){ - double gradART[hTS]; - - for(int hu = 0; hu < hTS; hu++){ - double deaths = art_mort[g][ha][hm][hu] * artpop[t][g][ha][hm][hu]; - hivdeaths_ha[g][ha] += DT*deaths; - gradART[hu] = -deaths; - } - - gradART[ART0MOS] += -ART_STAGE_PROG_RATE * artpop[t][g][ha][hm][ART0MOS]; - gradART[ART6MOS] += ART_STAGE_PROG_RATE * artpop[t][g][ha][hm][ART0MOS] - ART_STAGE_PROG_RATE * artpop[t][g][ha][hm][ART6MOS]; - gradART[ART1YR] += ART_STAGE_PROG_RATE * artpop[t][g][ha][hm][ART6MOS]; - - for(int hu = 0; hu < hTS; hu++) - artpop[t][g][ha][hm][hu] += DT*gradART[hu]; - } - - // ART dropout - if(art_dropout[t] > 0){ - for(int g = 0; g < NG; g++) - for(int ha = 0; ha < hAG; ha++) - for(int hm = anyelig_idx; hm < hDS; hm++) - for(int hu = 0; hu < hTS; hu++){ - hivpop[t][g][ha][hm] += DT * art_dropout[t] * artpop[t][g][ha][hm][hu]; - artpop[t][g][ha][hm][hu] -= DT * art_dropout[t] * artpop[t][g][ha][hm][hu]; - } - } + for(int hu = 0; hu < hTS; hu++){ + double deaths = art_mort[g][ha][hm][hu] * artpop[t][g][ha][hm][hu]; + hivdeaths_ha[g][ha] += DT*deaths; + gradART[hu] = -deaths; + } + + gradART[ART0MOS] += -ART_STAGE_PROG_RATE * artpop[t][g][ha][hm][ART0MOS]; + gradART[ART6MOS] += ART_STAGE_PROG_RATE * artpop[t][g][ha][hm][ART0MOS] - ART_STAGE_PROG_RATE * artpop[t][g][ha][hm][ART6MOS]; + gradART[ART1YR] += ART_STAGE_PROG_RATE * artpop[t][g][ha][hm][ART6MOS]; - // ART initiation + for(int hu = 0; hu < hTS; hu++) + artpop[t][g][ha][hm][hu] += DT*gradART[hu]; + } + + // ART dropout + if(art_dropout[t] > 0){ + for(int g = 0; g < NG; g++) + for(int ha = 0; ha < hAG; ha++) + for(int hm = anyelig_idx; hm < hDS; hm++) + for(int hu = 0; hu < hTS; hu++){ + hivpop[t][g][ha][hm] += DT * art_dropout[t] * artpop[t][g][ha][hm][hu]; + artpop[t][g][ha][hm][hu] -= DT * art_dropout[t] * artpop[t][g][ha][hm][hu]; + } + } + + // ART initiation for(int g = 0; g < NG; g++){ - + double artelig_hahm[hAG_15PLUS][hDS], Xart_15plus = 0.0, Xartelig_15plus = 0.0, expect_mort_artelig15plus = 0.0; for(int ha = hIDX_15PLUS; ha < hAG; ha++){ for(int hm = anyelig_idx; hm < hDS; hm++){ - double prop_elig = (hm >= cd4elig_idx) ? 1.0 : (hm >= hIDX_CD4_350) ? 1.0 - (1.0-specpop_percelig[t])*(1.0-who34percelig) : specpop_percelig[t]; + double prop_elig = (hm >= cd4elig_idx) ? 1.0 : (hm >= hIDX_CD4_350) ? 1.0 - (1.0-specpop_percelig[t])*(1.0-who34percelig) : specpop_percelig[t]; Xartelig_15plus += artelig_hahm[ha-hIDX_15PLUS][hm] = prop_elig * hivpop[t][g][ha][hm] ; expect_mort_artelig15plus += cd4_mort[g][ha][hm] * artelig_hahm[ha-hIDX_15PLUS][hm]; - for(int hu = 0; hu < hTS; hu++) + for(int hu = 0; hu < hTS; hu++) Xart_15plus += artpop[t][g][ha][hm][hu]; } @@ -605,230 +651,231 @@ extern "C" { for(int hu = 0; hu < hTS; hu++) frr_pop_ha += frr_art[t][ha-hIDX_FERT][hm][hu] * artpop[t][g][ha][hm][hu]; } - for(int hm = anyelig_idx; hm < cd4elig_idx; hm++){ double pw_elig_hahm = DT * births_by_ha[ha-hIDX_FERT] * frr_cd4[t][ha-hIDX_FERT][hm] * hivpop[t][g][ha][hm] / frr_pop_ha; artelig_hahm[ha-hIDX_15PLUS][hm] += pw_elig_hahm; Xartelig_15plus += pw_elig_hahm; expect_mort_artelig15plus += cd4_mort[g][ha][hm] * pw_elig_hahm; } - } + } } // loop over ha - // calculate number on ART at end of ts, based on number or percent + // calculate number on ART at end of ts, based on number or percent double artnum_hts = 0.0; if(DT*(hts+1) < 0.5){ - if(!art15plus_isperc[t-2][g] & !art15plus_isperc[t-1][g]){ // both numbers - artnum_hts = (0.5-DT*(hts+1))*artnum15plus[t-2][g] + (DT*(hts+1)+0.5)*artnum15plus[t-1][g]; - } else if(art15plus_isperc[t-2][g] & art15plus_isperc[t-1][g]){ // both percentages - double artcov_hts = (0.5-DT*(hts+1))*artnum15plus[t-2][g] + (DT*(hts+1)+0.5)*artnum15plus[t-1][g]; - artnum_hts = artcov_hts * (Xart_15plus + Xartelig_15plus); - } else if(!art15plus_isperc[t-2][g] & art15plus_isperc[t-1][g]){ // transition from number to percentage - double curr_coverage = Xart_15plus / (Xart_15plus + Xartelig_15plus); - double artcov_hts = curr_coverage + (artnum15plus[t-1][g] - curr_coverage) * DT / (0.5-DT*hts); - artnum_hts = artcov_hts * (Xart_15plus + Xartelig_15plus); - } + if(!art15plus_isperc[t-2][g] & !art15plus_isperc[t-1][g]){ // both numbers + artnum_hts = (0.5-DT*(hts+1))*artnum15plus[t-2][g] + (DT*(hts+1)+0.5)*artnum15plus[t-1][g]; + } else if(art15plus_isperc[t-2][g] & art15plus_isperc[t-1][g]){ // both percentages + double artcov_hts = (0.5-DT*(hts+1))*artnum15plus[t-2][g] + (DT*(hts+1)+0.5)*artnum15plus[t-1][g]; + artnum_hts = artcov_hts * (Xart_15plus + Xartelig_15plus); + } else if(!art15plus_isperc[t-2][g] & art15plus_isperc[t-1][g]){ // transition from number to percentage + double curr_coverage = Xart_15plus / (Xart_15plus + Xartelig_15plus); + double artcov_hts = curr_coverage + (artnum15plus[t-1][g] - curr_coverage) * DT / (0.5-DT*hts); + artnum_hts = artcov_hts * (Xart_15plus + Xartelig_15plus); + } } else { - if(!art15plus_isperc[t-1][g] & !art15plus_isperc[t][g]){ // both numbers - artnum_hts = (1.5-DT*(hts+1))*artnum15plus[t-1][g] + (DT*(hts+1)-0.5)*artnum15plus[t][g]; - } else if(art15plus_isperc[t-1][g] & art15plus_isperc[t][g]){ // both percentages - double artcov_hts = (1.5-DT*(hts+1))*artnum15plus[t-1][g] + (DT*(hts+1)-0.5)*artnum15plus[t][g]; - artnum_hts = artcov_hts * (Xart_15plus + Xartelig_15plus); - } else if(!art15plus_isperc[t-1][g] & art15plus_isperc[t][g]){ // transition from number to percentage - double curr_coverage = Xart_15plus / (Xart_15plus + Xartelig_15plus); - double artcov_hts = curr_coverage + (artnum15plus[t][g] - curr_coverage) * DT / (1.5-DT*hts); - artnum_hts = artcov_hts * (Xart_15plus + Xartelig_15plus); - } - } + if(!art15plus_isperc[t-1][g] & !art15plus_isperc[t][g]){ // both numbers + artnum_hts = (1.5-DT*(hts+1))*artnum15plus[t-1][g] + (DT*(hts+1)-0.5)*artnum15plus[t][g]; + } else if(art15plus_isperc[t-1][g] & art15plus_isperc[t][g]){ // both percentages + double artcov_hts = (1.5-DT*(hts+1))*artnum15plus[t-1][g] + (DT*(hts+1)-0.5)*artnum15plus[t][g]; + artnum_hts = artcov_hts * (Xart_15plus + Xartelig_15plus); + } else if(!art15plus_isperc[t-1][g] & art15plus_isperc[t][g]){ // transition from number to percentage + double curr_coverage = Xart_15plus / (Xart_15plus + Xartelig_15plus); + double artcov_hts = curr_coverage + (artnum15plus[t][g] - curr_coverage) * DT / (1.5-DT*hts); + artnum_hts = artcov_hts * (Xart_15plus + Xartelig_15plus); + } + } double artinit_hts = artnum_hts > Xart_15plus ? artnum_hts - Xart_15plus : 0; - - // median CD4 at initiation inputs - if(med_cd4init_input[t]){ - - const int CD4_LOW_LIM[hDS] = {500, 350, 250, 200, 100, 50, 0}; - const int CD4_UPP_LIM[hDS] = {1000, 500, 350, 250, 200, 100, 50}; - - int medcd4_idx = med_cd4init_cat[t] - 1; // -1 for 0-based indexing vs. 1-based in R - double medcat_propbelow = (median_cd4init[t] - CD4_LOW_LIM[medcd4_idx]) / (CD4_UPP_LIM[medcd4_idx] - CD4_LOW_LIM[medcd4_idx]); - - double elig_below = 0.0, elig_above = 0.0; - for(int ha = hIDX_15PLUS; ha < hAG; ha++){ - for(int hm = anyelig_idx; hm < medcd4_idx; hm++) - elig_above += artelig_hahm[ha-hIDX_15PLUS][hm]; - elig_above += (1.0 - medcat_propbelow) * artelig_hahm[ha-hIDX_15PLUS][medcd4_idx]; - elig_below += medcat_propbelow * artelig_hahm[ha-hIDX_15PLUS][medcd4_idx]; - for(int hm = medcd4_idx+1; hm < hDS; hm++) - elig_below += artelig_hahm[ha-hIDX_15PLUS][hm]; - } - - double initprob_below = artinit_hts * 0.5 / elig_below; - double initprob_above = artinit_hts * 0.5 / elig_above; - double initprob_medcat = initprob_below * medcat_propbelow + initprob_above * (1.0-medcat_propbelow); - - for(int ha = hIDX_15PLUS; ha < hAG; ha++) - for(int hm = anyelig_idx; hm < hDS; hm++){ - double artinit_hahm; - if(hm < medcd4_idx) - artinit_hahm = artelig_hahm[ha-hIDX_15PLUS][hm] * initprob_above; - else if(hm == medcd4_idx) - artinit_hahm = artelig_hahm[ha-hIDX_15PLUS][hm] * initprob_medcat; - if(hm > medcd4_idx) - artinit_hahm = artelig_hahm[ha-hIDX_15PLUS][hm] * initprob_below; - if(artinit_hahm > hivpop[t][g][ha][hm]) artinit_hahm = hivpop[t][g][ha][hm]; - hivpop[t][g][ha][hm] -= artinit_hahm; - artpop[t][g][ha][hm][ART0MOS] += artinit_hahm; - } - - } else { // Use mixture of eligibility and expected mortality for initiation distribution - - for(int ha = hIDX_15PLUS; ha < hAG; ha++) - for(int hm = anyelig_idx; hm < hDS; hm++){ - double artinit_hahm = artinit_hts * artelig_hahm[ha-hIDX_15PLUS][hm] * 0.5 * (1.0/Xartelig_15plus + cd4_mort[g][ha][hm] / expect_mort_artelig15plus); - if(artinit_hahm > artelig_hahm[ha-hIDX_15PLUS][hm]) artinit_hahm = artelig_hahm[ha-hIDX_15PLUS][hm]; - hivpop[t][g][ha][hm] -= artinit_hahm; - artpop[t][g][ha][hm][ART0MOS] += artinit_hahm; - } - } - } - } + // median CD4 at initiation inputs + if(med_cd4init_input[t]){ + const int CD4_LOW_LIM[hDS] = {500, 350, 250, 200, 100, 50, 0}; + const int CD4_UPP_LIM[hDS] = {1000, 500, 350, 250, 200, 100, 50}; - // remove hivdeaths from pop - for(int g = 0; g < NG; g++){ - - // sum HIV+ population size in each hivpop age group - double hivpop_ha[hAG]; - int a = 0; - for(int ha = 0; ha < hAG; ha++){ - hivpop_ha[ha] = 0.0; - for(int i = 0; i < hAG_SPAN[ha]; i++){ - hivpop_ha[ha] += pop[t][HIVP][g][a]; - a++; - } - } - - // remove hivdeaths proportionally to age-distribution within each age group - a = 0; - for(int ha = 0; ha < hAG; ha++){ - if(hivpop_ha[ha] > 0){ - double hivqx_ha = hivdeaths_ha[g][ha] / hivpop_ha[ha]; - for(int i = 0; i < hAG_SPAN[ha]; i++){ - hivdeaths[t][g][a] += pop[t][HIVP][g][a] * hivqx_ha; - pop[t][HIVP][g][a] *= (1.0-hivqx_ha); - a++; - } - } // end if(pop_ha[ha] > 0) - } - } + int medcd4_idx = med_cd4init_cat[t] - 1; // -1 for 0-based indexing vs. 1-based in R + double medcat_propbelow = (median_cd4init[t] - CD4_LOW_LIM[medcd4_idx]) / (CD4_UPP_LIM[medcd4_idx] - CD4_LOW_LIM[medcd4_idx]); - } // loop HIVSTEPS_PER_YEAR + double elig_below = 0.0, elig_above = 0.0; + for(int ha = hIDX_15PLUS; ha < hAG; ha++){ + for(int hm = anyelig_idx; hm < medcd4_idx; hm++) + elig_above += artelig_hahm[ha-hIDX_15PLUS][hm]; + elig_above += (1.0 - medcat_propbelow) * artelig_hahm[ha-hIDX_15PLUS][medcd4_idx]; + elig_below += medcat_propbelow * artelig_hahm[ha-hIDX_15PLUS][medcd4_idx]; + for(int hm = medcd4_idx+1; hm < hDS; hm++) + elig_below += artelig_hahm[ha-hIDX_15PLUS][hm]; + } + double initprob_below = elig_below > 0 ? artinit_hts * 0.5 / elig_below : 1.0; + double initprob_above = elig_below > 0 ? artinit_hts * 0.5 / elig_above : 1.0; + double initprob_medcat = initprob_below * medcat_propbelow + initprob_above * (1.0-medcat_propbelow); + + for(int ha = hIDX_15PLUS; ha < hAG; ha++) + for(int hm = anyelig_idx; hm < hDS; hm++){ + double artinit_hahm; + if(hm < medcd4_idx) + artinit_hahm = artelig_hahm[ha-hIDX_15PLUS][hm] * initprob_above; + else if(hm == medcd4_idx) + artinit_hahm = artelig_hahm[ha-hIDX_15PLUS][hm] * initprob_medcat; + if(hm > medcd4_idx) + artinit_hahm = artelig_hahm[ha-hIDX_15PLUS][hm] * initprob_below; + if(artinit_hahm > hivpop[t][g][ha][hm]) artinit_hahm = hivpop[t][g][ha][hm]; + hivpop[t][g][ha][hm] -= artinit_hahm; + artpop[t][g][ha][hm][ART0MOS] += artinit_hahm; + } - /* - // Code for calculating new infections once per year to match prevalence (like Spectrum) + } else { // Use mixture of eligibility and expected mortality for initiation distribution - // (1) incidence from prevalence input - double Xhivp = 0.0, Xhivn[NG], Xhivn_incagerr[NG]; + for(int ha = hIDX_15PLUS; ha < hAG; ha++) + for(int hm = anyelig_idx; hm < hDS; hm++){ + double artinit_hahm = artinit_hts * artelig_hahm[ha-hIDX_15PLUS][hm] * 0.5 * (1.0/Xartelig_15plus + cd4_mort[g][ha][hm] / expect_mort_artelig15plus); + if(artinit_hahm > artelig_hahm[ha-hIDX_15PLUS][hm]) artinit_hahm = artelig_hahm[ha-hIDX_15PLUS][hm]; + hivpop[t][g][ha][hm] -= artinit_hahm; + artpop[t][g][ha][hm][ART0MOS] += artinit_hahm; + } + } - for(int g = 0; g < NG; g++){ - Xhivn[g] = 0.0; - Xhivn_incagerr[g] = 0.0; - for(int a = pIDX_15TO49; a < pIDX_15TO49+pAG_15TO49; a++){ - Xhivp += pop[t][HIVP][g][a]; - Xhivn[g] += pop[t][HIVN][g][a]; - Xhivn_incagerr[g] += incrr_age[t][g][a] * pop[t][HIVN][g][a]; + } } - } - double prev_i = Xhivp / (Xhivn[MALE] + Xhivn[FEMALE] + Xhivp); - double incrate15to49_i = (prev15to49[t] - prev_i)/(1.0 - prev_i); - double incrate15to49_g[NG]; - incrate15to49_g[MALE] = incrate15to49_i * (Xhivn[MALE]+Xhivn[FEMALE]) / (Xhivn[MALE] + incrr_sex[t]*Xhivn[FEMALE]); - incrate15to49_g[FEMALE] = incrate15to49_i * incrr_sex[t]*(Xhivn[MALE]+Xhivn[FEMALE]) / (Xhivn[MALE] + incrr_sex[t]*Xhivn[FEMALE]); - for(int g = 0; g < NG; g++){ - int a = 0; - for(int ha = 0; ha < hAG; ha++){ - double infections_a, infections_ha = 0.0; - for(int i = 0; i < hAG_SPAN[ha]; i++){ - infections_ha += infections_a = pop[t][HIVN][g][a] * incrate15to49_g[g] * incrr_age[t][g][a] * Xhivn[g] / Xhivn_incagerr[g]; - pop[t][HIVN][g][a] -= infections_a; - pop[t][HIVP][g][a] += infections_a; - a++; + // remove hivdeaths from pop + for(int g = 0; g < NG; g++){ + + // sum HIV+ population size in each hivpop age group + double hivpop_ha[hAG]; + int a = 0; + for(int ha = 0; ha < hAG; ha++){ + hivpop_ha[ha] = 0.0; + for(int i = 0; i < hAG_SPAN[ha]; i++){ + hivpop_ha[ha] += pop[t][HIVP][g][a]; + a++; + } } - // add infections to hivpop - for(int hm = 0; hm < hDS; hm++) - hivpop[t][g][ha][hm] += infections_ha * cd4_initdist[g][ha][hm]; + // remove hivdeaths proportionally to age-distribution within each age group + a = 0; + for(int ha = 0; ha < hAG; ha++){ + if(hivpop_ha[ha] > 0){ + double hivqx_ha = hivdeaths_ha[g][ha] / hivpop_ha[ha]; + for(int i = 0; i < hAG_SPAN[ha]; i++){ + hivdeaths[t][g][a] += pop[t][HIVP][g][a] * hivqx_ha; + pop[t][HIVP][g][a] *= (1.0-hivqx_ha); + a++; + } + } // end if(pop_ha[ha] > 0) + } } - } - */ + } // loop HIVSTEPS_PER_YEAR - // adjust population to match target population - if(bin_popadjust){ + + + if(eppmod == EPP_DIRECTINCID){ + // Calculating new infections once per year (like Spectrum) + + double Xhivp = 0.0, Xhivn[NG], Xhivn_incagerr[NG]; + + for(int g = 0; g < NG; g++){ + Xhivn[g] = 0.0; + Xhivn_incagerr[g] = 0.0; + for(int a = pIDX_INCIDPOP; a < pIDX_INCIDPOP+pAG_INCIDPOP; a++){ + Xhivp += pop[t-1][HIVP][g][a]; + Xhivn[g] += pop[t-1][HIVN][g][a]; + Xhivn_incagerr[g] += incrr_age[t][g][a] * pop[t-1][HIVN][g][a]; + } + } + // double prev_i = Xhivp / (Xhivn[MALE] + Xhivn[FEMALE] + Xhivp); + // double incrate15to49_i = (prev15to49[t] - prev_i)/(1.0 - prev_i); + double incrate_i = incidinput[t]; + double incrate_g[NG]; + incrate_g[MALE] = incrate_i * (Xhivn[MALE]+Xhivn[FEMALE]) / (Xhivn[MALE] + incrr_sex[t]*Xhivn[FEMALE]); + incrate_g[FEMALE] = incrate_i * incrr_sex[t]*(Xhivn[MALE]+Xhivn[FEMALE]) / (Xhivn[MALE] + incrr_sex[t]*Xhivn[FEMALE]); + for(int g = 0; g < NG; g++){ int a = 0; for(int ha = 0; ha < hAG; ha++){ - double popadj_ha = 0, hivpop_ha = 0; + double infections_a, infections_ha = 0.0; for(int i = 0; i < hAG_SPAN[ha]; i++){ - - hivpop_ha += pop[t][HIVP][g][a]; - - double popadjrate_a = popadjust[t][g][a] = targetpop[t][g][a] / (pop[t][HIVN][g][a] + pop[t][HIVP][g][a]); - pop[t][HIVN][g][a] *= popadjrate_a; - double hpopadj_a = (popadjrate_a-1.0) * pop[t][HIVP][g][a]; - popadj_ha += hpopadj_a; - pop[t][HIVP][g][a] += hpopadj_a; + infections_ha += infections_a = pop[t-1][HIVN][g][a] * incrate_g[g] * incrr_age[t][g][a] * Xhivn[g] / Xhivn_incagerr[g]; + infections[t][g][a] += infections_a; + pop[t][HIVN][g][a] -= infections_a; + pop[t][HIVP][g][a] += infections_a; a++; } + if(ha < hIDX_15TO49+hAG_15TO49) + incid15to49[t] += infections_ha; - // population adjustment for hivpop - double popadjrate_ha = hivpop_ha > 0 ? popadj_ha / hivpop_ha : 0.0; - for(int hm = 0; hm < hDS; hm++){ - hivpop[t][g][ha][hm] *= 1+popadjrate_ha; - if(t >= t_ART_start) - for(int hu = 0; hu < hTS; hu++) - artpop[t][g][ha][hm][hu] *= 1+popadjrate_ha; - } // loop over hm - } // loop over ha - } // loop over g + // add infections to hivpop + for(int hm = 0; hm < hDS; hm++) + hivpop[t][g][ha][hm] += infections_ha * cd4_initdist[g][ha][hm]; + } + } + } + + // adjust population to match target population + if(bin_popadjust){ + for(int g = 0; g < NG; g++){ + int a = 0; + for(int ha = 0; ha < hAG; ha++){ + double popadj_ha = 0, hivpop_ha = 0; + for(int i = 0; i < hAG_SPAN[ha]; i++){ + + hivpop_ha += pop[t][HIVP][g][a]; + + double popadjrate_a = popadjust[t][g][a] = targetpop[t][g][a] / (pop[t][HIVN][g][a] + pop[t][HIVP][g][a]); + pop[t][HIVN][g][a] *= popadjrate_a; + double hpopadj_a = (popadjrate_a-1.0) * pop[t][HIVP][g][a]; + popadj_ha += hpopadj_a; + pop[t][HIVP][g][a] += hpopadj_a; + a++; + } + + // population adjustment for hivpop + double popadjrate_ha = hivpop_ha > 0 ? popadj_ha / hivpop_ha : 0.0; + for(int hm = 0; hm < hDS; hm++){ + hivpop[t][g][ha][hm] *= 1+popadjrate_ha; + if(t >= t_ART_start) + for(int hu = 0; hu < hTS; hu++) + artpop[t][g][ha][hm][hu] *= 1+popadjrate_ha; + } // loop over hm + } // loop over ha + } // loop over g } // if(bin_popadjust) - + // prevalence among pregnant women - - double hivbirths = 0; - for(int ha = hIDX_FERT; ha < hIDX_FERT+hAG_FERT; ha++){ - double hivn_ha = 0, frr_hivpop_ha = 0; - for(int a = hAG_START[ha]; a < hAG_START[ha]+hAG_SPAN[ha]; a++) - hivn_ha += (pop[t-1][HIVN][FEMALE][a] + pop[t][HIVN][FEMALE][a])/2; - for(int hm = 0; hm < hDS; hm++){ - frr_hivpop_ha += frr_cd4[t][ha-hIDX_FERT][hm] * (hivpop[t-1][FEMALE][ha][hm]+hivpop[t][FEMALE][ha][hm])/2; - if(t == t_ART_start) - for(int hu = 0; hu < hTS; hu++) - frr_hivpop_ha += frr_art[t][ha-hIDX_FERT][hm][hu] * artpop[t][FEMALE][ha][hm][hu]/2; - else if(t > t_ART_start) - for(int hu = 0; hu < hTS; hu++) - frr_hivpop_ha += frr_art[t][ha-hIDX_FERT][hm][hu] * (artpop[t-1][FEMALE][ha][hm][hu]+artpop[t][FEMALE][ha][hm][hu])/2; - } - hivbirths += births_by_ha[ha-hIDX_FERT] * frr_hivpop_ha / (hivn_ha + frr_hivpop_ha); - } - pregprev[t] = hivbirths/births; - if(t + AGE_START < PROJ_YEARS) - pregprevlag[t + AGE_START-1] = pregprev[t]; + double hivbirths = 0; + for(int ha = hIDX_FERT; ha < hIDX_FERT+hAG_FERT; ha++){ + double hivn_ha = 0, frr_hivpop_ha = 0; + for(int a = hAG_START[ha]; a < hAG_START[ha]+hAG_SPAN[ha]; a++) + hivn_ha += (pop[t-1][HIVN][FEMALE][a] + pop[t][HIVN][FEMALE][a])/2; + for(int hm = 0; hm < hDS; hm++){ + frr_hivpop_ha += frr_cd4[t][ha-hIDX_FERT][hm] * (hivpop[t-1][FEMALE][ha][hm]+hivpop[t][FEMALE][ha][hm])/2; + if(t == t_ART_start) + for(int hu = 0; hu < hTS; hu++) + frr_hivpop_ha += frr_art[t][ha-hIDX_FERT][hm][hu] * artpop[t][FEMALE][ha][hm][hu]/2; + else if(t > t_ART_start) + for(int hu = 0; hu < hTS; hu++) + frr_hivpop_ha += frr_art[t][ha-hIDX_FERT][hm][hu] * (artpop[t-1][FEMALE][ha][hm][hu]+artpop[t][FEMALE][ha][hm][hu])/2; + } + hivbirths += births_by_ha[ha-hIDX_FERT] * frr_hivpop_ha / (hivn_ha + frr_hivpop_ha); + } + + pregprev[t] = hivbirths/births; + if(t + AGE_START < PROJ_YEARS) + pregprevlag[t + AGE_START-1] = pregprev[t]; - // prevalence 15 to 49 - for(int g = 0; g < NG; g++) - for(int a = pIDX_15TO49; a < pIDX_15TO49 + pAG_15TO49; a++){ - hivn15to49[t] += pop[t][HIVN][g][a]; - hivp15to49[t] += pop[t][HIVP][g][a]; - } - prev15to49[t] = hivp15to49[t]/(hivn15to49[t] + hivp15to49[t]); - incid15to49[t] /= hivn15to49[t-1]; + // prevalence 15 to 49 + for(int g = 0; g < NG; g++) + for(int a = pIDX_15TO49; a < pIDX_15TO49 + pAG_15TO49; a++){ + hivn15to49[t] += pop[t][HIVN][g][a]; + hivp15to49[t] += pop[t][HIVP][g][a]; + } + prev15to49[t] = hivp15to49[t]/(hivn15to49[t] + hivp15to49[t]); + incid15to49[t] /= hivn15to49[t-1]; } UNPROTECT(22); @@ -848,8 +895,210 @@ SEXP getListElement(SEXP list, const char *str) break; } - if ( elmt == R_NilValue ) + if ( elmt == R_NilValue ) error("%s missing from list", str); return elmt; } + +int checkListElement(SEXP list, const char *str) +{ + SEXP names = getAttrib(list, R_NamesSymbol); + for (int i = 0; i < length(list); i++ ) + if (strcmp(CHAR(STRING_ELT(names, i)), str) == 0 ) + return 1; + + return 0; +} + + +double calc_rtrend_rt(const multi_array_ref pop, double rtrend_tstab, const double *rtrend_beta, double rtrend_r0, + double projstep, double tsEpidemicStart, double DT, int t, int hts, double rveclast, + double *prevlast, double *prevcurr) +{ + // sum population sizes + double Xhivn = 0.0, Xhivp = 0.0; + for(int g = 0; g < NG; g++) + for(int a = pIDX_15TO49; a < pIDX_15TO49+pAG_15TO49; a++){ + Xhivn += pop[t][HIVN][g][a]; + Xhivp += pop[t][HIVP][g][a]; + } + + // adjust HIV population for partial year time step + for(int g = 0; g < NG; g++){ + Xhivn -= pop[t][HIVN][g][pIDX_15TO49] * (1.0 - DT*hts); + Xhivp -= pop[t][HIVP][g][pIDX_15TO49] * (1.0 - DT*hts); + Xhivn += pop[t][HIVN][g][pIDX_15TO49+pAG_15TO49] * (1.0 - DT*hts); + Xhivp += pop[t][HIVP][g][pIDX_15TO49+pAG_15TO49] * (1.0 - DT*hts); + } + + double Xtot = Xhivn + Xhivp; + + *prevlast = *prevcurr; + *prevcurr = Xhivp / Xtot; + + // calculate r(t) + if(projstep > tsEpidemicStart){ + double gamma_ts = (projstep < rtrend_tstab)?0.0:(*prevcurr-*prevlast) * (projstep - rtrend_tstab) / (DT * (*prevlast)); + double logr_diff = rtrend_beta[1]*(rtrend_beta[0] - rveclast) + rtrend_beta[2]*(*prevlast) + rtrend_beta[3]*gamma_ts; + return exp(log(rveclast) + logr_diff); + } else { + return rtrend_r0; + } +} + + +void calc_infections_eppspectrum(const multi_array_ref pop, const multi_array_ref hivpop, const multi_array_ref artpop, + double r_ts, double relinfectART, double iota, + double *incrr_sex, const multi_array_ref incrr_age, + int t_ART_start, double DT, int t, int hts, int *hAG_START, int *hAG_SPAN, + double *prevcurr, double *incrate15to49_ts, double infections_ts[NG][pAG]) +{ + + // sum population sizes + double Xhivn_g[NG], Xhivn_incagerr[NG], Xhivp_noart = 0.0, Xart = 0.0; + for(int g = 0; g < NG; g++){ + Xhivn_g[g] = 0.0; + Xhivn_incagerr[g] = 0.0; + for(int a = pIDX_15TO49; a < pIDX_15TO49+pAG_15TO49; a++){ + Xhivn_g[g] += pop[t][HIVN][g][a]; + Xhivn_incagerr[g] += incrr_age[t][g][a] * pop[t][HIVN][g][a]; + } + + for(int ha = hIDX_15TO49; ha < hIDX_15TO49+hAG_15TO49+1; ha++){ + + // adjustment to first and last age group for partial year time step + // calculation proportion of HIV population to include / exclude based on hivpop in single-year ages. + double prop_include; + if(ha == hIDX_15TO49){ + double hivp_ha = 0.0; + for(int a = hAG_START[ha]; a < hAG_START[ha]+hAG_SPAN[ha]; a++) + hivp_ha += pop[t][HIVP][g][a]; + prop_include = (hivp_ha > 0) ? 1.0 - pop[t][HIVP][g][hAG_START[ha]] / hivp_ha * (1.0 - DT*hts) : 1.0; + } else if(ha == hIDX_15TO49+hAG_15TO49) { + double hivp_ha = 0.0; + for(int a = hAG_START[ha]; a < hAG_START[ha]+hAG_SPAN[ha]; a++) + hivp_ha += pop[t][HIVP][g][a]; + prop_include = (hivp_ha > 0) ? pop[t][HIVP][g][hAG_START[ha]] / hivp_ha * (1.0 - DT*hts) : 1.0; + } else + prop_include = 1.0; + + for(int hm = 0; hm < hDS; hm++){ + Xhivp_noart += hivpop[t][g][ha][hm] * prop_include; + if(t >= t_ART_start) + for(int hu = 0; hu < hTS; hu++) + Xart += artpop[t][g][ha][hm][hu] * prop_include; + } + } + } // end loop over g + double Xhivn = Xhivn_g[MALE] + Xhivn_g[FEMALE]; + + // adjust HIV negative population for partial year time step + for(int g = 0; g < NG; g++){ + Xhivn -= pop[t][HIVN][g][pIDX_15TO49] * (1.0 - DT*hts); + Xhivn += pop[t][HIVN][g][pIDX_15TO49+pAG_15TO49] * (1.0 - DT*hts); + } + + double Xtot = Xhivn + Xhivp_noart + Xart; + *prevcurr = (Xhivp_noart + Xart) / Xtot; + + *incrate15to49_ts = r_ts * (Xhivp_noart + relinfectART * Xart) / Xtot + iota; + + // incidence by sex + double incrate15to49_g[NG]; + incrate15to49_g[MALE] = *incrate15to49_ts * (Xhivn_g[MALE]+Xhivn_g[FEMALE]) / (Xhivn_g[MALE] + incrr_sex[t]*Xhivn_g[FEMALE]); + incrate15to49_g[FEMALE] = *incrate15to49_ts * incrr_sex[t]*(Xhivn_g[MALE]+Xhivn_g[FEMALE]) / (Xhivn_g[MALE] + incrr_sex[t]*Xhivn_g[FEMALE]); + + + // annualized infections by age and sex + for(int g = 0; g < NG; g++) + for(int a = 0; a < pAG; a++){ + infections_ts[g][a] = pop[t][HIVN][g][a] * incrate15to49_g[g] * incrr_age[t][g][a] * Xhivn_g[g] / Xhivn_incagerr[g]; + } + + return; +} + + +void calc_infections_simpletransm(const multi_array_ref pop, const multi_array_ref hivpop, const multi_array_ref artpop, + double r_ts, double relinfectART, double iota, + const double *mf_transm_rr, const double *relsexact_cd4cat, const multi_array_ref incrr_age, + int t_ART_start, double DT, int t, int hts, int *hAG_START, int *hAG_SPAN, + double *prevcurr, double *incrate15to49_ts, double infections_ts[NG][pAG]) +{ + + // sum population size and number of contacts by status + double Xhivn[NG], Xhivn_incagerr[NG]; // population sizes by sex, not adjusted (for age incidence) + double Xhivn_adj[NG], Xhivp_noart[NG], Xart[NG], Xtot[NG]; // population sizes, adjusted for partial year timestep offset + double Chivn[NG], Chivp_noart[NG], Cart[NG], Ctot[NG]; // Number of contacts, adjusted + for(int g = 0; g < NG; g++){ + + Xhivn[g] = 0.0; + Xhivn_incagerr[g] = 0.0; + Xhivp_noart[g] = 0.0; + Xart[g] = 0.0; + Chivp_noart[g] = 0.0; + for(int a = pIDX_15TO49; a < pIDX_15TO49+pAG_15TO49; a++){ + Xhivn[g] += pop[t][HIVN][g][a]; + Xhivn_incagerr[g] += incrr_age[t][g][a] * pop[t][HIVN][g][a]; + } + + for(int ha = hIDX_15TO49; ha < hIDX_15TO49+hAG_15TO49+1; ha++){ + + // adjustment to first and last age group for partial year time step + // calculation proportion of HIV population to include / exclude based on hivpop in single-year ages. + double prop_include; + if(ha == hIDX_15TO49){ + double hivp_ha = 0.0; + for(int a = hAG_START[ha]; a < hAG_START[ha]+hAG_SPAN[ha]; a++) + hivp_ha += pop[t][HIVP][g][a]; + prop_include = (hivp_ha > 0) ? 1.0 - pop[t][HIVP][g][hAG_START[ha]] / hivp_ha * (1.0 - DT*hts) : 1.0; + } else if(ha == hIDX_15TO49+hAG_15TO49) { + double hivp_ha = 0.0; + for(int a = hAG_START[ha]; a < hAG_START[ha]+hAG_SPAN[ha]; a++) + hivp_ha += pop[t][HIVP][g][a]; + prop_include = (hivp_ha > 0) ? pop[t][HIVP][g][hAG_START[ha]] / hivp_ha * (1.0 - DT*hts) : 0.0; + } else + prop_include = 1.0; + + for(int hm = 0; hm < hDS; hm++){ + Xhivp_noart[g] += hivpop[t][g][ha][hm] * prop_include; + Chivp_noart[g] += hivpop[t][g][ha][hm] * relsexact_cd4cat[hm] * prop_include; + if(t >= t_ART_start) + for(int hu = 0; hu < hTS; hu++) + Xart[g] += artpop[t][g][ha][hm][hu] * prop_include; + } + Cart[g] = Xart[g]; + } // end loop over ha + + // adjust HIV negative population for partial year time step + Xhivn_adj[g] = Xhivn[g]; + Xhivn_adj[g] -= pop[t][HIVN][g][pIDX_15TO49] * (1.0 - DT*hts); + Xhivn_adj[g] += pop[t][HIVN][g][pIDX_15TO49+pAG_15TO49] * (1.0 - DT*hts); + + Chivn[g] = Xhivn_adj[g]; + + Xtot[g] = Xhivn_adj[g] + Xhivp_noart[g] + Xart[g]; + Ctot[g] = Chivn[g] + Chivp_noart[g] + Cart[g]; + + + } // end loop over g + + *prevcurr = 1.0 - (Xhivn_adj[MALE] + Xhivn_adj[FEMALE]) / (Xtot[MALE] + Xtot[FEMALE]); + + // incidence by sex + double incrate15to49_g[NG]; + incrate15to49_g[MALE] = r_ts * pow(mf_transm_rr[t], -0.5) * (Chivp_noart[FEMALE] + relinfectART * Cart[FEMALE]) / Ctot[FEMALE] + pow(mf_transm_rr[t], -0.25) * iota; + incrate15to49_g[FEMALE] = r_ts * pow(mf_transm_rr[t], 0.5) * (Chivp_noart[MALE] + relinfectART * Cart[MALE]) / Ctot[MALE] + pow(mf_transm_rr[t], 0.25) * iota; + + // incrate15to49_g[MALE] = r_ts * pow(mf_transm_rr, -0.5) * (Xhivp_noart[FEMALE] + relinfectART * Xart[FEMALE]) / Xtot[FEMALE] + pow(mf_transm_rr, -0.25) * iota; + // incrate15to49_g[FEMALE] = r_ts * pow(mf_transm_rr, 0.5) * (Xhivp_noart[MALE] + relinfectART * Xart[MALE]) / Xtot[MALE] + pow(mf_transm_rr, 0.25) * iota; + + // annualized infections by age and sex + for(int g = 0; g < NG; g++) + for(int a = 0; a < pAG; a++){ + infections_ts[g][a] = pop[t][HIVN][g][a] * incrate15to49_g[g] * incrr_age[t][g][a] * Xhivn[g] / Xhivn_incagerr[g]; + } + + return; +}