From 78a2366ecacd8255654fdb85bb4e853ad17c2da9 Mon Sep 17 00:00:00 2001 From: Kevin Weiss Date: Mon, 15 Jul 2019 13:20:57 -0700 Subject: [PATCH] Port over EPT analysis into public package --- .Rbuildignore | 1 - .gitignore | 1 + .travis.yml | 1 - DESCRIPTION | 20 +- NAMESPACE | 33 +- R/EpiModelHIV-package.R | 8 +- R/ErgmTerms.R | 26 +- R/estimation.R | 67 +- R/mod.acts.R | 120 +- R/mod.aging.R | 20 +- R/mod.births.R | 110 +- R/mod.cd4.R | 6 +- R/mod.condoms.R | 36 +- R/mod.death.R | 21 +- R/mod.disclose.R | 14 +- R/mod.ept.R | 796 +++++++++++++ R/mod.initialize.R | 887 ++++++++++---- R/mod.part.R | 115 ++ R/mod.position.R | 4 +- R/mod.prep.R | 198 +++- R/mod.prevalence.R | 1382 ++++++++++++++++++++-- R/mod.progress.R | 330 +++++- R/mod.riskhist.R | 94 +- R/mod.simnet.R | 192 ++- R/mod.sti.R | 1757 ++++++++++++++++++++++------ R/mod.test.R | 755 +++++++++++- R/mod.trans.R | 528 ++++++++- R/mod.tx.R | 16 +- R/mod.verbose.R | 45 +- R/mod.vl.R | 19 +- R/params.R | 716 +++++++++--- R/utilities.R | 32 - README.md | 35 +- inst/netsim.mods.R | 162 ++- man/EpiModelHIV-package.Rd | 6 +- man/InitErgmTerm.absdiffby.Rd | 9 +- man/InitErgmTerm.absdiffnodemix.Rd | 14 +- man/acts_msm.Rd | 19 +- man/aging_het.Rd | 20 + man/aging_msm.Rd | 3 - man/assign_degree.Rd | 6 +- man/base_nw_msm.Rd | 8 +- man/births_het.Rd | 20 + man/births_msm.Rd | 11 +- man/calc_nwstats_msm.Rd | 23 +- man/condoms_msm.Rd | 16 +- man/control_het.Rd | 12 +- man/control_msm.Rd | 68 +- man/deaths_het.Rd | 20 + man/deaths_msm.Rd | 3 - man/dx_het.Rd | 20 + man/edges_correct_het.Rd | 37 + man/edges_correct_msm.Rd | 3 - man/hiv_disclose_msm.Rd | 31 + man/hiv_progress_msm.Rd | 41 + man/hiv_test_msm.Rd | 29 + man/hiv_trans_msm.Rd | 40 + man/hiv_tx_msm.Rd | 35 + man/hiv_vl_msm.Rd | 37 + man/init_het.Rd | 16 +- man/init_msm.Rd | 19 +- man/init_status_hiv_msm.Rd | 19 + man/init_status_sti_msm.Rd | 23 + man/initialize_het.Rd | 30 + man/initialize_msm.Rd | 7 +- man/param_het.Rd | 25 +- man/param_msm.Rd | 530 +++++++-- man/part_msm.Rd | 31 + man/position_msm.Rd | 4 +- man/prevalence_het.Rd | 21 + man/prevalence_msm.Rd | 7 +- man/prevalence_msm_ept.Rd | 32 + man/prevalence_msm_tnt.Rd | 32 + man/reinit_het.Rd | 10 +- man/riskhist_prep_msm.Rd | 20 + man/riskhist_stitest_msm.Rd | 20 + man/setBirthAttr_het.Rd | 21 + man/simnet_het.Rd | 21 + man/simnet_msm.Rd | 7 +- man/sti_ept_msm.Rd | 23 + man/sti_recov_msm.Rd | 19 + man/sti_test_msm.Rd | 31 + man/sti_trans_msm.Rd | 20 + man/sti_tx_msm.Rd | 20 + man/syph_progress_msm.Rd | 41 + man/trans_het.Rd | 20 + man/tx_het.Rd | 20 + man/verbose_het.Rd | 32 + man/verbose_msm.Rd | 3 - man/vl_het.Rd | 20 + tests/testthat/test-aging.R | 23 + tests/testthat/test-netsim.R | 45 +- 92 files changed, 8831 insertions(+), 1459 deletions(-) create mode 100644 R/mod.ept.R create mode 100644 R/mod.part.R create mode 100644 man/aging_het.Rd create mode 100644 man/births_het.Rd create mode 100644 man/deaths_het.Rd create mode 100644 man/dx_het.Rd create mode 100644 man/edges_correct_het.Rd create mode 100644 man/hiv_disclose_msm.Rd create mode 100644 man/hiv_progress_msm.Rd create mode 100644 man/hiv_test_msm.Rd create mode 100644 man/hiv_trans_msm.Rd create mode 100644 man/hiv_tx_msm.Rd create mode 100644 man/hiv_vl_msm.Rd create mode 100644 man/init_status_hiv_msm.Rd create mode 100644 man/init_status_sti_msm.Rd create mode 100644 man/initialize_het.Rd create mode 100644 man/part_msm.Rd create mode 100644 man/prevalence_het.Rd create mode 100644 man/prevalence_msm_ept.Rd create mode 100644 man/prevalence_msm_tnt.Rd create mode 100644 man/riskhist_prep_msm.Rd create mode 100644 man/riskhist_stitest_msm.Rd create mode 100644 man/setBirthAttr_het.Rd create mode 100644 man/simnet_het.Rd create mode 100644 man/sti_ept_msm.Rd create mode 100644 man/sti_recov_msm.Rd create mode 100644 man/sti_test_msm.Rd create mode 100644 man/sti_trans_msm.Rd create mode 100644 man/sti_tx_msm.Rd create mode 100644 man/syph_progress_msm.Rd create mode 100644 man/trans_het.Rd create mode 100644 man/tx_het.Rd create mode 100644 man/verbose_het.Rd create mode 100644 man/vl_het.Rd create mode 100644 tests/testthat/test-aging.R diff --git a/.Rbuildignore b/.Rbuildignore index 9a8e9b91..b9c851b0 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,4 +1,3 @@ ^.*\.Rproj$ ^\.Rproj\.user$ .travis.yml -LICENSE.md diff --git a/.gitignore b/.gitignore index 2a83a5bb..a24098c6 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ src/*.so src/*.dll *.Rproj .DS_Store +*.rda diff --git a/.travis.yml b/.travis.yml index 462b30b1..7b2d86e8 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,4 +12,3 @@ notifications: email: on_success: never on_failure: change - slack: epimodel:ARrkdZn2p9KKRZxkcGFK9Ns0 diff --git a/DESCRIPTION b/DESCRIPTION index 22462727..4f39ecda 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,12 +1,11 @@ Package: EpiModelHIV -Version: 1.5.0 -Date: 2017-05-04 +Version: 1.0.0 +Date: 2016-06-25 Type: Package -Title: Network-Based Epidemic Modeling of HIV Transmission among MSM and Heterosexual Populations +Title: Epidemic Modeling of HIV Transmission among MSM and Heterosexual Populations Authors@R: c(person("Samuel M.", "Jenness", role = c("cre", "aut"), email = "samuel.m.jenness@emory.edu"), person("Steven M.", "Goodreau", role="aut", email="goodeau@uw.edu"), - person("Emily", "Beylerian", role = "ctb", email = "ebey@uw.edu"), - person("Kevin", "Weiss", role = "aut", email = "kevin.weiss@emory.edu")) + person("Emily", "Beylerian", role = "ctb", email = "ebey@uw.edu")) Maintainer: Samuel M. Jenness Description: EpiModelHIV provides extensions to our general EpiModel package to allow for simulating HIV transmission dynamics among two populations: men who have sex with men (MSM) in the United States and heterosexual adults in @@ -14,11 +13,11 @@ Description: EpiModelHIV provides extensions to our general EpiModel package to License: GPL-3 Depends: R (>= 3.2.0), - EpiModel (>= 1.6.5), + EpiModel (>= 1.2.7), EpiModelHPC (>= 1.3.1), - ergm (>= 3.9.4), - tergm (>= 3.5.2), - tergmLite (>= 1.1.0) + ergm (>= 3.5), + tergm, + tergmLite Imports: bindata, network, @@ -29,6 +28,5 @@ Suggests: testthat VignetteBuilder: knitr LinkingTo: ergm -RoxygenNote: 6.1.0 +RoxygenNote: 6.1.1 LazyData: true -Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index d66db3bf..35283fb1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,48 +18,56 @@ export(control_het) export(control_msm) export(deaths_het) export(deaths_msm) -export(disclose_msm) export(dx_het) export(edges_correct_het) export(edges_correct_msm) export(get_args) +export(hiv_disclose_msm) +export(hiv_progress_msm) +export(hiv_test_msm) +export(hiv_trans_msm) +export(hiv_tx_msm) +export(hiv_vl_msm) export(init_ccr5_msm) export(init_het) export(init_msm) -export(init_status_msm) +export(init_status_hiv_msm) +export(init_status_sti_msm) export(initialize_het) export(initialize_msm) export(make_nw_het) export(param_het) export(param_msm) +export(part_msm) export(position_msm) export(prep_msm) export(prevalence_het) export(prevalence_msm) -export(progress_msm) +export(prevalence_msm_ept) +export(prevalence_msm_tnt) export(reallocate_pcp) export(reinit_het) export(reinit_msm) export(remove_bad_roles_msm) -export(riskhist_msm) +export(riskhist_prep_msm) +export(riskhist_stitest_msm) +export(setBirthAttr_het) export(simnet_het) export(simnet_msm) export(sourceDir) -export(sti_recov) -export(sti_trans) -export(sti_tx) -export(test_msm) +export(sti_ept_msm) +export(sti_recov_msm) +export(sti_test_msm) +export(sti_trans_msm) +export(sti_tx_msm) +export(syph_progress_msm) export(trans_het) -export(trans_msm) -export(truncate_sim) export(tx_het) -export(tx_msm) export(update_aiclass_msm) export(update_roleclass_msm) export(verbose_het) export(verbose_msm) export(vl_het) -export(vl_msm) import(EpiModel) import(EpiModelHPC) import(bindata) @@ -70,6 +78,7 @@ import(tergm) import(tergmLite) importFrom(dplyr,group_by) importFrom(dplyr,summarise) +importFrom(stats,median) importFrom(stats,plogis) importFrom(stats,rbinom) importFrom(stats,rgeom) diff --git a/R/EpiModelHIV-package.R b/R/EpiModelHIV-package.R index 0dcf7031..6dbaab46 100644 --- a/R/EpiModelHIV-package.R +++ b/R/EpiModelHIV-package.R @@ -1,10 +1,10 @@ -#' Network-Based Epidemic Modeling of HIV Transmission among MSM and Heterosexual Populations +#' HIV Transmission Dynamics among MSM and Heterosexuals #' #' \tabular{ll}{ #' Package: \tab EpiModelHIV\cr #' Type: \tab Package\cr -#' Version: \tab 1.5.0\cr -#' Date: \tab 2017-05-04\cr +#' Version: \tab 1.0.0\cr +#' Date: \tab 2016-06-25\cr #' License: \tab GPL-3\cr #' LazyLoad: \tab yes\cr #' } @@ -19,7 +19,7 @@ #' @aliases EpiModelHIV #' #' @import EpiModel EpiModelHPC network networkDynamic tergmLite tergm ergm bindata -#' @importFrom stats rbinom rgeom rmultinom rpois runif simulate rnbinom plogis +#' @importFrom stats median rbinom rgeom rmultinom rpois runif simulate rnbinom plogis #' @importFrom dplyr group_by summarise #' #' @useDynLib EpiModelHIV, .registration = TRUE diff --git a/R/ErgmTerms.R b/R/ErgmTerms.R index 79cc9782..28724643 100644 --- a/R/ErgmTerms.R +++ b/R/ErgmTerms.R @@ -1,8 +1,8 @@ #' @title Definition for absdiffnodemix ERGM Term #' -#' @description This function defines and initialize the absdiffnodemix ERGM term -#' that allows for targeting age homophily by race. +#' @description This function defines and initialize the absdiffnodemix ERGM +#' term that allows for targeting age homophily by race. #' #' @param nw An object of class \code{network}. #' @param arglist A list of arguments as specified in the \code{ergm.userterms} @@ -11,11 +11,11 @@ #' \code{ergm.userterms} package framework. #' #' @details -#' This ERGM user term was written to allow for age-based homophily in partnership -#' formation that is heterogenous by race. The absdiff component allows targets -#' the distribution of age mixing on that continuous variable, and the nodemix -#' component differentiates this for black-black, black-white, and white-white -#' couples. +#' This ERGM user term was written to allow for age-based homophily in +#' partnership formation that is heterogenous by race. The absdiff component +#' allows targets the distribution of age mixing on that continuous variable, +#' and the nodemix component differentiates this for black-black, black-white, +#' and white-white couples. #' #' @author Steven M. Goodreau #' @@ -53,7 +53,8 @@ InitErgmTerm.absdiffnodemix <- function(nw, arglist, ...) { inputs = c(length(nodecov), length(urm), nodecov, nodecovby, urm, ucm) list(name = "absdiffnodemix", - coef.names = paste("absdiffnodemix", a$attrname, a$byattrname, uun, sep = "."), + coef.names = paste("absdiffnodemix", a$attrname, a$byattrname, uun, + sep = "."), pkgname = "EpiModelHIV", inputs = inputs, dependence = FALSE) @@ -73,10 +74,11 @@ InitErgmTerm.absdiffnodemix <- function(nw, arglist, ...) { #' \code{ergm.userterms} package framework. #' #' @details -#' This ERGM user term was written to allow for age-based homophily in partnership -#' formation that is asymetric by sex. The absdiff component targets age homophily -#' while the by component allows that to be structed by a binary attribute such -#' as "male", in order to enforce an offset in the average difference. +#' This ERGM user term was written to allow for age-based homophily in +#' partnershipformation that is asymetric by sex. The absdiff component targets +#' age homophily while the by component allows that to be structed by a binary +#' attribute suchas "male", in order to enforce an offset in the average +#' difference. #' #' @export InitErgmTerm.absdiffby <- function(nw, arglist, ...) { diff --git a/R/estimation.R b/R/estimation.R index 7118b619..1f8ce26d 100644 --- a/R/estimation.R +++ b/R/estimation.R @@ -4,12 +4,13 @@ #' @title Calculate Target Statistics for Network Model Estimation #' -#' @description Calculates the target statistics for the formation and dissolution -#' components of the network model to be estimated with \code{netest}. +#' @description Calculates the target statistics for the formation and +#' dissolution components of the network model to be estimated +#' with \code{netest}. #' #' @param time.unit Time unit relative to 1 for daily. -#' @param method Method for calculating target statistics by race, with options of -#' \code{2} for preserving race-specific statistics and \code{1} for +#' @param method Method for calculating target statistics by race, with options +#' of \code{2} for preserving race-specific statistics and \code{1} for #' averaging over the statistics and dropping the race-specific terms. #' @param num.B Population size of black MSM. #' @param num.W Population size of white MSM. @@ -25,14 +26,14 @@ #' \code{NA} to ignore these quantiles in the target statistics. #' @param qnts.W Means of one-off rates split into quintiles for black MSM. Use #' \code{NA} to ignore these quantiles in the target statistics. -#' @param prop.hom.mpi.B A vector of length 3 for the proportion of main, casual, -#' and one-off partnerships in same race for black MSM. -#' @param prop.hom.mpi.W A vector of length 3 for the proportion of main, casual, -#' and one-off partnerships in same race for white MSM. +#' @param prop.hom.mpi.B A vector of length 3 for the proportion of main, +#' casual, and one-off partnerships in same race for black MSM. +#' @param prop.hom.mpi.W A vector of length 3 for the proportion of main, +#' casual, and one-off partnerships in same race for white MSM. #' @param balance Method for balancing of edges by race for number of mixed-race -#' partnerships, with options of \code{"black"} to apply black MSM counts, -#' \code{"white"} to apply white MSM counts, and \code{"mean"} to take -#' the average of the two expectations. +#' partnerships, with options of \code{"black"} to apply black MSM +#' counts, \code{"white"} to apply white MSM counts, and \code{"mean"} to +#' take the average of the two expectations. #' @param sqrt.adiff.BB Vector of length 3 with the mean absolute differences #' in the square root of ages in main, casual, and one-off black-black #' partnerships. @@ -107,7 +108,8 @@ calc_nwstats_msm <- function(time.unit = 7, stop("deg.mp.W must sum to 1.") } if (!(method %in% 1:2)) { - stop("method must either be 1 for one-race models or 2 for two-race models", call. = FALSE) + stop("method must either be 1 for one-race models or 2 for two-race models", + call. = FALSE) } num <- num.B + num.W @@ -168,15 +170,18 @@ calc_nwstats_msm <- function(time.unit = 7, # Sqrt absdiff term for age if (method == 2) { - sqrt.adiff.m <- edges.nodemix.m * c(sqrt.adiff.BB[1], sqrt.adiff.BW[1], sqrt.adiff.WW[1]) + sqrt.adiff.m <- edges.nodemix.m * c(sqrt.adiff.BB[1], sqrt.adiff.BW[1], + sqrt.adiff.WW[1]) } if (method == 1) { - sqrt.adiff.m <- edges.m * mean(c(sqrt.adiff.BB[1], sqrt.adiff.BW[1], sqrt.adiff.WW[1])) + sqrt.adiff.m <- edges.m * mean(c(sqrt.adiff.BB[1], sqrt.adiff.BW[1], + sqrt.adiff.WW[1])) } # Compile target stats if (method == 2) { - stats.m <- c(edges.m, edges.nodemix.m[2:3], totdeg.m.by.dp[c(2:3, 5:6)], sqrt.adiff.m) + stats.m <- c(edges.m, edges.nodemix.m[2:3], totdeg.m.by.dp[c(2:3, 5:6)], + sqrt.adiff.m) } if (method == 1) { stats.m <- c(edges.m, totdeg.m.by.dp[2:3], sqrt.adiff.m) @@ -236,10 +241,12 @@ calc_nwstats_msm <- function(time.unit = 7, # Sqrt absdiff term for age if (method == 2) { - sqrt.adiff.p <- edges.nodemix.p * c(sqrt.adiff.BB[2], sqrt.adiff.BW[2], sqrt.adiff.WW[2]) + sqrt.adiff.p <- edges.nodemix.p * c(sqrt.adiff.BB[2], sqrt.adiff.BW[2], + sqrt.adiff.WW[2]) } if (method == 1) { - sqrt.adiff.p <- edges.p * mean(c(sqrt.adiff.BB[2], sqrt.adiff.BW[2], sqrt.adiff.WW[2])) + sqrt.adiff.p <- edges.p * mean(c(sqrt.adiff.BB[2], sqrt.adiff.BW[2], + sqrt.adiff.WW[2])) } # Compile target statistics @@ -310,10 +317,12 @@ calc_nwstats_msm <- function(time.unit = 7, } if (method == 2) { - sqrt.adiff.i <- edges.nodemix.i * c(sqrt.adiff.BB[3], sqrt.adiff.BW[3], sqrt.adiff.WW[3]) + sqrt.adiff.i <- edges.nodemix.i * c(sqrt.adiff.BB[3], sqrt.adiff.BW[3], + sqrt.adiff.WW[3]) } if (method == 1) { - sqrt.adiff.i <- edges.i * mean(c(sqrt.adiff.BB[3], sqrt.adiff.BW[3], sqrt.adiff.WW[3])) + sqrt.adiff.i <- edges.i * mean(c(sqrt.adiff.BB[3], sqrt.adiff.BW[3], + sqrt.adiff.WW[3])) } if (!is.na(qnts.B[1]) & !is.na(qnts.W[1])) { @@ -328,7 +337,8 @@ calc_nwstats_msm <- function(time.unit = 7, } else { if (method == 2) { - stats.i <- c(edges.i, num.inst.B[-1], num.inst.W, edges.hom.i, sqrt.adiff.i) + stats.i <- c(edges.i, num.inst.B[-1], num.inst.W, edges.hom.i, + sqrt.adiff.i) } if (method == 1) { stats.i <- c(edges.i, num.inst[-1], sqrt.adiff.i) @@ -383,10 +393,10 @@ calc_nwstats_msm <- function(time.unit = 7, #' \code{\link{calc_nwstats_msm}}. #' #' @details -#' This function takes the output of \code{\link{calc_nwstats_msm}} and constructs -#' an empty network with the necessary attributes for race, square root of age, -#' and sexual role class. This base network is used for all three network -#' estimations. +#' This function takes the output of \code{\link{calc_nwstats_msm}} and +#' constructs an empty network with the necessary attributes for race, square +#' root of age, and sexual role class. This base network is used for all three +#' network estimations. #' #' @seealso #' The final vertex attributes on the network for cross-network degree are @@ -446,9 +456,9 @@ base_nw_msm <- function(nwstats) { #' @param nwstats Object of class \code{nwstats}. #' #' @details -#' This function assigns the degree of other networks as a vertex attribute on the -#' target network given a bivariate degree mixing matrix of main, casual, and -#' one-partnerships contained in the \code{nwstats} data. +#' This function assigns the degree of other networks as a vertex attribute on +#' the target network given a bivariate degree mixing matrix of main, casual, +#' and one-partnerships contained in the \code{nwstats} data. #' #' @keywords msm #' @export @@ -546,7 +556,8 @@ make_nw_het <- function(n = 10000, # Dissolution model dissolution <- ~offset(edges) dur <- part.dur/time.unit - d.rate <- time.unit * (((1 - start.prev) * 1/(55 - 18)/365) + (start.prev * 1/12/365)) + d.rate <- time.unit * (((1 - start.prev) * 1/(55 - 18)/365) + + (start.prev * 1/12/365)) coef.diss <- dissolution_coefs(dissolution, duration = dur, d.rate = d.rate) out <- list() diff --git a/R/mod.acts.R b/R/mod.acts.R index 4ab27b41..199d2850 100644 --- a/R/mod.acts.R +++ b/R/mod.acts.R @@ -7,17 +7,18 @@ #' @inheritParams aging_msm #' #' @details -#' The number of acts at each time step is specified as a function of the race of -#' both members in a pair and the expected values within black-black, black-white, -#' and white-white combinations. For one-off partnerships, this is deterministically -#' set at 1, whereas for main and causal partnerships it is a stochastic draw -#' from a Poisson distribution. The number of total acts may further be modified -#' by the level of HIV viral suppression in an infected person. +#' The number of acts at each time step is specified as a function of the race +#' of both members in a pair and the expected values within black-black, +#' black-white,and white-white combinations. For one-off partnerships, this is +#' deterministically set at 1, whereas for main and casual partnerships it is a +#' stochastic draw from a Poisson distribution. The number of total acts may +#' further be modified by the level of HIV viral suppression in an infected +#' person. #' #' @return -#' This function returns the \code{dat} object with the updated discordant act -#' list (\code{dal}). Each element of \code{dal} is a data frame with the ids of the -#' discordant pair repeated the number of times they have AI. +#' This function returns the \code{dat} object with the updated edge +#' list (\code{el}). An additional column is added with the number of acts for +#' each partnership on the edge list (\code{el}). #' #' @keywords module msm #' @export @@ -34,6 +35,7 @@ acts_msm <- function(dat, at) { # Parameters ai.scale <- dat$param$ai.scale + ai.scale.pospos <- dat$param$ai.scale.pospos if (type == "main") { base.ai.BB.rate <- dat$param$base.ai.main.BB.rate base.ai.BW.rate <- dat$param$base.ai.main.BW.rate @@ -65,6 +67,8 @@ acts_msm <- function(dat, at) { st1 <- status[el[, 1]] st2 <- status[el[, 2]] + + # HIV discordancy disc <- abs(st1 - st2) == 1 el[which(disc == 1 & st2 == 1), ] <- el[which(disc == 1 & st2 == 1), 2:1] el <- cbind(el, status[el[, 1]], status[el[, 2]]) @@ -72,30 +76,83 @@ acts_msm <- function(dat, at) { if (nrow(el) > 0) { - # Base AI rates - ai.rate <- rep(NA, nrow(el)) - race.p1 <- race[el[, 1]] - race.p2 <- race[el[, 2]] - num.B <- (race.p1 == "B") + (race.p2 == "B") - ai.rate <- (num.B == 2) * base.ai.BB.rate + - (num.B == 1) * base.ai.BW.rate + - (num.B == 0) * base.ai.WW.rate - ai.rate <- ai.rate * ai.scale - - ## STI associated cessation of activity - idsCease <- which(dat$attr$GC.cease == 1 | dat$attr$CT.cease == 1) - noActs <- el[, "p1"] %in% idsCease | el[, "p2"] %in% idsCease - ai.rate[noActs] <- 0 - - # Final act number - if (fixed == FALSE) { - ai <- rpois(length(ai.rate), ai.rate) + el.pospos <- el[which(st1 == 1 & st2 == 1), , drop = FALSE] + + # If positive-positive, then split el into 2 + # If no positive-positive, then don't split + if (nrow(el.pospos) > 0) { + + # Separate into positive-concordant and non-positive concordant + el2 <- el[which(!(st1 == 1 & st2 == 1)), , drop = FALSE] + + # Base AI rates for positive concordant + ai.rate.pospos <- rep(NA, nrow(el.pospos)) + race.p1 <- race[el.pospos[, 1]] + race.p2 <- race[el.pospos[, 2]] + num.B <- (race.p1 == "B") + (race.p2 == "B") + ai.rate.pospos <- (num.B == 2) * base.ai.BB.rate + + (num.B == 1) * base.ai.BW.rate + + (num.B == 0) * base.ai.WW.rate + ai.rate.pospos <- ai.rate.pospos * ai.scale.pospos + + # Final act number for positive concordant + if (fixed == FALSE) { + ai.pospos <- rpois(length(ai.rate.pospos), ai.rate.pospos) + } else { + ai.pospos <- round(ai.rate.pospos) + } + + # Edge list (positive concordant) + el.pospos <- cbind(el.pospos, ptype, ai.pospos) + + # Base AI rates for non-positive concordant + ai.rate <- rep(NA, nrow(el2)) + race.p1 <- race[el2[, 1]] + race.p2 <- race[el2[, 2]] + num.B <- (race.p1 == "B") + (race.p2 == "B") + ai.rate <- (num.B == 2) * base.ai.BB.rate + + (num.B == 1) * base.ai.BW.rate + + (num.B == 0) * base.ai.WW.rate + ai.rate <- ai.rate * ai.scale + + # Final act number for non-positive concordant + if (fixed == FALSE) { + ai <- rpois(length(ai.rate), ai.rate) + } else { + ai <- round(ai.rate) + } + + # Edge list (non-positive concordant) + el2 <- cbind(el2, ptype, ai) + + # Full edge list (combine positive concordant and non-positive concordant) + el <- rbind(el2, el.pospos) + } else { - ai <- round(ai.rate) + + # Base AI rates for all + ai.rate <- rep(NA, nrow(el)) + race.p1 <- race[el[, 1]] + race.p2 <- race[el[, 2]] + num.B <- (race.p1 == "B") + (race.p2 == "B") + ai.rate <- (num.B == 2) * base.ai.BB.rate + + (num.B == 1) * base.ai.BW.rate + + (num.B == 0) * base.ai.WW.rate + ai.rate <- ai.rate * ai.scale + + + # Final act number for non-positive concordant + if (fixed == FALSE) { + ai <- rpois(length(ai.rate), ai.rate) + } else { + ai <- round(ai.rate) + } + + # Edge list (non-positive concordant) + el <- cbind(el, ptype, ai) + } - # Full edge list - el <- cbind(el, ptype, ai) colnames(el)[5:6] <- c("ptype", "ai") if (type == "main") { @@ -110,5 +167,8 @@ acts_msm <- function(dat, at) { # Remove inactive edges from el dat$temp$el <- dat$temp$el[-which(dat$temp$el[, "ai"] == 0), ] + # Update time of last sex for all those with acts at time step + dat$attr$time.last.sex[unique(c(dat$temp$el[, "p1"], dat$temp$el[, "p2"]))] <- at + return(dat) } diff --git a/R/mod.aging.R b/R/mod.aging.R index 2e3e0569..73fafdd3 100644 --- a/R/mod.aging.R +++ b/R/mod.aging.R @@ -20,9 +20,9 @@ aging_msm <- function(dat, at) { time.unit <- dat$param$time.unit age <- dat$attr$age - active <- dat$attr$active + race <- dat$attr$race - age[active == 1] <- age[active == 1] + time.unit / 365 + age[race %in% c("B", "W")] <- age[race %in% c("B", "W")] + time.unit / 365 dat$attr$age <- age dat$attr$sqrt.age <- sqrt(age) @@ -31,8 +31,18 @@ aging_msm <- function(dat, at) { } +#' @title Aging Module +#' +#' @description This module ages all active nodes in the population by one time +#' unit at each time step. +#' +#' @param dat Master data list object of class \code{dat} containing networks, +#' individual-level attributes, and summary statistics. +#' @param at Current time step. +#' +#' @keywords module het #' @export -#' @rdname aging_msm +#' aging_het <- function(dat, at) { ## Parameters @@ -40,10 +50,10 @@ aging_het <- function(dat, at) { ## Attributes age <- dat$attr$age - active <- dat$attr$active + race <- dat$attr$race ## Updates - age[active == 1] <- age[active == 1] + time.unit/365 + age[race %in% c("B", "W")] <- age[race %in% c("B", "W")] + time.unit/365 ## Save out dat$attr$age <- age diff --git a/R/mod.births.R b/R/mod.births.R index efb5f693..64ab11bb 100644 --- a/R/mod.births.R +++ b/R/mod.births.R @@ -9,10 +9,10 @@ #' @details #' New population members are added based on expected numbers of entries among #' black and white MSM, stochastically determined with draws from Poisson -#' distributions. For each new entry, a set of attributes is added for that node, -#' and the nodes are added onto the network objects. Only attributes that are -#' a part of the network model formulae are updated as vertex attributes on the -#' network objects. +#' distributions. For each new entry, a set of attributes is added for that +#' node, and the nodes are added onto the network objects. Only attributes that +#' are a part of the network model formulae are updated as vertex attributes on +#' the network objects. #' #' @return #' This function updates the \code{attr} list with new attributes for each new @@ -106,6 +106,67 @@ setBirthAttr_msm <- function(dat, at, nBirths.B, nBirths.W) { nBirths.W, replace = TRUE, prob = dat$param$tt.traj.W.prob) + # Non-NA HIV variables + dat$attr$time.hivneg[newIds] <- rep(0, nBirths) + dat$attr$time.off.prep[newIds] <- rep(0, nBirths) + dat$attr$time.on.prep[newIds] <- rep(0, nBirths) + dat$attr$stage.time[newIds] <- rep(0, nBirths) + dat$attr$stage.time.ar.ndx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.ar.dx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.af.ndx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.af.dx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.ar.ndx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.ar.dx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.af.ndx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.af.dx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.early.chronic.ndx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.early.chronic.dx.yrone[newIds] <- rep(0, nBirths) + dat$attr$stage.time.early.chronic.dx.yrstwotolate[newIds] <- rep(0, nBirths) + dat$attr$stage.time.early.chronic.art[newIds] <- rep(0, nBirths) + dat$attr$stage.time.late.chronic.ndx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.late.chronic.dx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.late.chronic.art[newIds] <- rep(0, nBirths) + dat$attr$stage.time.aids.ndx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.aids.dx[newIds] <- rep(0, nBirths) + dat$attr$stage.time.aids.art[newIds] <- rep(0, nBirths) + + # Non-NA STI variables + dat$attr$syphilis[newIds] <- rep(0, nBirths) + dat$attr$rGC[newIds] <- rep(0, nBirths) + dat$attr$rCT[newIds] <- rep(0, nBirths) + dat$attr$uGC[newIds] <- rep(0, nBirths) + dat$attr$uCT[newIds] <- rep(0, nBirths) + dat$attr$recentpartners[newIds] <- rep(0, nBirths) + dat$attr$stitest.ind.active[newIds] <- rep(0, nBirths) + dat$attr$stitest.ind.recentpartners[newIds] <- rep(0, nBirths) + dat$attr$testing.events.syph[newIds] <- rep(0, nBirths) + dat$attr$testing.events.syph.asympt[newIds] <- rep(0, nBirths) + dat$attr$testing.events.rgc[newIds] <- rep(0, nBirths) + dat$attr$testing.events.rgc.asympt[newIds] <- rep(0, nBirths) + dat$attr$testing.events.ugc[newIds] <- rep(0, nBirths) + dat$attr$testing.events.ugc.asympt[newIds] <- rep(0, nBirths) + dat$attr$testing.events.gc[newIds] <- rep(0, nBirths) + dat$attr$testing.events.gc.asympt[newIds] <- rep(0, nBirths) + dat$attr$testing.events.sti[newIds] <- rep(0, nBirths) + dat$attr$testing.events.sti.asympt[newIds] <- rep(0, nBirths) + dat$attr$testing.events.rct[newIds] <- rep(0, nBirths) + dat$attr$testing.events.rct.asympt[newIds] <- rep(0, nBirths) + dat$attr$testing.events.uct[newIds] <- rep(0, nBirths) + dat$attr$testing.events.uct.asympt[newIds] <- rep(0, nBirths) + dat$attr$testing.events.ct[newIds] <- rep(0, nBirths) + dat$attr$testing.events.ct.asympt[newIds] <- rep(0, nBirths) + + + + selected <- newIds + tslastsyphtest <- ceiling(runif(length(selected), max = (dat$param$stitest.active.int))) + tslastcttest <- tslastgctest <- ceiling(runif(length(selected), max = (dat$param$stitest.active.int))) + dat$attr$time.since.last.test.syph[newIds] <- tslastsyphtest + dat$attr$time.since.last.test.rgc[newIds] <- tslastgctest + dat$attr$time.since.last.test.ugc[newIds] <- tslastgctest + dat$attr$time.since.last.test.rct[newIds] <- tslastcttest + dat$attr$time.since.last.test.uct[newIds] <- tslastcttest + # Circumcision dat$attr$circ[newIds[newB]] <- rbinom(nBirths.B, 1, dat$param$circ.B.prob) dat$attr$circ[newIds[newW]] <- rbinom(nBirths.W, 1, dat$param$circ.W.prob) @@ -131,11 +192,13 @@ setBirthAttr_msm <- function(dat, at, nBirths.B, nBirths.W) { dat$attr$ccr5[newIds[newB]] <- sample(c("WW", "DW", "DD"), nBirths.B, replace = TRUE, prob = c(1 - sum(ccr5.B.prob), - ccr5.B.prob[2], ccr5.B.prob[1])) + ccr5.B.prob[2], + ccr5.B.prob[1])) dat$attr$ccr5[newIds[newW]] <- sample(c("WW", "DW", "DD"), nBirths.W, replace = TRUE, prob = c(1 - sum(ccr5.W.prob), - ccr5.W.prob[2], ccr5.W.prob[1])) + ccr5.W.prob[2], + ccr5.W.prob[1])) # Degree @@ -149,7 +212,8 @@ setBirthAttr_msm <- function(dat, at, nBirths.B, nBirths.W) { p1 <- dat$param$cond.pers.always.prob p2 <- dat$param$cond.inst.always.prob rho <- dat$param$cond.always.prob.corr - uai.always <- bindata::rmvbin(nBirths, c(p1, p2), bincorr = (1 - rho) * diag(2) + rho) + uai.always <- bindata::rmvbin(nBirths, c(p1, p2), bincorr = + (1 - rho) * diag(2) + rho) dat$attr$cond.always.pers[newIds] <- uai.always[, 1] dat$attr$cond.always.inst[newIds] <- uai.always[, 2] @@ -161,21 +225,30 @@ setBirthAttr_msm <- function(dat, at, nBirths.B, nBirths.W) { +#' @title Births Module +#' +#' @description Module for simulating births/entries into the population, +#' including initialization of attributes for incoming nodes. +#' +#' @inheritParams aging_het +#' +#' @keywords module het +#' #' @export -#' @rdname births_msm +#' births_het <- function(dat, at) { # Variables b.rate.method <- dat$param$b.rate.method b.rate <- dat$param$b.rate - active <- dat$attr$active + race <- dat$attr$race # Process nBirths <- 0 if (b.rate.method == "stgrowth") { exptPopSize <- dat$epi$num[1] * (1 + b.rate*at) - numNeeded <- exptPopSize - sum(active == 1) + numNeeded <- exptPopSize - sum(race %in% c("B","W")) if (numNeeded > 0) { nBirths <- rpois(1, numNeeded) } @@ -197,10 +270,10 @@ births_het <- function(dat, at) { # Update Population Structure if (nBirths > 0) { dat <- setBirthAttr_het(dat, at, nBirths) - dat$el[[1]] <- tergmLite::add_vertices(dat$el[[1]], nBirths) + dat$el <- tergmLite::add_vertices(dat$el, nBirths) } - if (unique(sapply(dat$attr, length)) != attributes(dat$el[[1]])$n) { + if (unique(sapply(dat$attr, length)) != attributes(dat$el)$n) { stop("mismatch between el and attr length in births mod") } @@ -211,6 +284,19 @@ births_het <- function(dat, at) { } +#' @title Assign Vertex Attributes at Network Entry +#' +#' @description Assigns vertex attributes to incoming nodes at birth/entry into +#' the network. +#' +#' @inheritParams births_het +#' @param nBirths Number of new births as determined by \code{\link{births_het}}. +#' +#' @keywords het +#' +#' @export +#' +#' setBirthAttr_het <- function(dat, at, nBirths) { # Set attributes for new births to NA diff --git a/R/mod.cd4.R b/R/mod.cd4.R index 1dd78774..9559b5d7 100644 --- a/R/mod.cd4.R +++ b/R/mod.cd4.R @@ -60,11 +60,13 @@ cd4_het <- function(dat, at) { if (length(idsTxFeml) > 0) { cd4Cap <- expected_cd4(method = "assign", male = 0, age = 25, ageInf = 25) - cd4Count[idsTxFeml] <- pmin(cd4Count[idsTxFeml] + tx.cd4.recrat.feml, cd4Cap) + cd4Count[idsTxFeml] <- pmin(cd4Count[idsTxFeml] + tx.cd4.recrat.feml, + cd4Cap) } if (length(idsTxMale) > 0) { cd4Cap <- expected_cd4(method = "assign", male = 1, age = 25, ageInf = 25) - cd4Count[idsTxMale] <- pmin(cd4Count[idsTxMale] + tx.cd4.recrat.male, cd4Cap) + cd4Count[idsTxMale] <- pmin(cd4Count[idsTxMale] + tx.cd4.recrat.male, + cd4Cap) } diff --git a/R/mod.condoms.R b/R/mod.condoms.R index 0a123b42..cd4a8087 100644 --- a/R/mod.condoms.R +++ b/R/mod.condoms.R @@ -2,20 +2,22 @@ #' @title Condom Use Module #' #' @description Module function stochastically simulates potential condom use -#' for each act on the discordant edgelist. +#' for each act on the edgelist. #' #' @inheritParams aging_msm #' #' @details -#' For each act on the discordant edgelist, condom use is stochastically simulated -#' based on the partnership type and racial combination of the dyad. Other -#' modifiers for the probability of condom use in that pair are diagnosis of -#' disease, disclosure of status, and full or partial HIV viral suppression +#' For each act on the edgelist, condom use is stochastically +#' simulated based on the partnership type and racial combination of the dyad. +#' Other modifiers for the probability of condom use in that pair are diagnosis +#' of disease, disclosure of status, and full or partial HIV viral suppression #' given HIV anti-retroviral therapy. #' #' @return -#' Updates the discordant edgelist with a \code{uai} variable indicating whether -#' condoms were used in that act. +#' Updates the edgelist with a \code{uai} variable indicating whether +#' condoms were used in that act. An act list \code{al} is created. +#' The act list \code{al} is a data frame with the ids of the pair +#' repeated the number of times they have AI. #' #' @keywords module msm #' @export @@ -91,14 +93,19 @@ condoms_msm <- function(dat, at) { uai.prob <- 1 - cond.prob uai.logodds <- log(uai.prob / (1 - uai.prob)) - # Diagnosis modifier + # Diagnosis modifier ---- applies to all diagnosed, discordant + isDiscord <- which((elt[, "st1"] - elt[, "st2"]) == 1) # pull vector of discordant pos.diag <- diag.status[elt[, 1]] - isDx <- which(pos.diag == 1) - uai.logodds[isDx] <- uai.logodds[isDx] + diag.beta + isDx <- which(pos.diag == 1) # pull vector of diagnosis status + isDiscord.dx <- intersect(isDiscord, isDx) + uai.logodds[isDiscord.dx] <- uai.logodds[isDiscord.dx] + diag.beta - # Disclosure modifier + # Disclosure modifier ---- applies to all discordant, disclosed isDiscord <- which((elt[, "st1"] - elt[, "st2"]) == 1) delt <- elt[isDiscord, ] + + if (nrow(delt) > 0) { + discl.list <- dat$temp$discl.list disclose.cdl <- discl.list[, 1] * 1e7 + discl.list[, 2] delt.cdl <- uid[delt[, 1]] * 1e7 + uid[delt[, 2]] @@ -110,6 +117,8 @@ condoms_msm <- function(dat, at) { isDisc <- which(discl == 1) uai.logodds[isDisc] <- uai.logodds[isDisc] + discl.beta + } + # Back transform to prob old.uai.prob <- uai.prob uai.prob <- exp(uai.logodds) / (1 + exp(uai.logodds)) @@ -134,8 +143,9 @@ condoms_msm <- function(dat, at) { # PrEP Status (risk compensation) if (rcomp.prob > 0) { - idsRC <- which((prepStat[elt[, 1]] == 1 & prepClass[elt[, 1]] %in% rcomp.adh.groups) | - (prepStat[elt[, 2]] == 1 & prepClass[elt[, 2]] %in% rcomp.adh.groups)) + idsRC <- which( + (prepStat[elt[, 1]] == 1 & prepClass[elt[, 1]] %in% rcomp.adh.groups) | + (prepStat[elt[, 2]] == 1 & prepClass[elt[, 2]] %in% rcomp.adh.groups)) if (rcomp.main.only == TRUE & ptype > 1) { idsRC <- NULL diff --git a/R/mod.death.R b/R/mod.death.R index 36e3e3b6..0b9aa178 100644 --- a/R/mod.death.R +++ b/R/mod.death.R @@ -50,6 +50,7 @@ deaths_msm <- function(dat, at) { dth.all <- NULL dth.all <- unique(c(dth.gen, dth.dis)) + # dat$epi$deathage[at] <- mean(c(dat$attr$age[dth.all])) if (length(dth.all) > 0) { dat$attr$active[dth.all] <- 0 @@ -64,15 +65,25 @@ deaths_msm <- function(dat, at) { ## Summary Output - dat$epi$dth.gen[at] <- length(dth.gen) - dat$epi$dth.dis[at] <- length(dth.dis) + # dat$epi$dth.gen[at] <- length(dth.gen) + # dat$epi$dth.dis[at] <- length(dth.dis) return(dat) } + +#' @title Deaths Module +#' +#' @description Module for simulating deaths among susceptible and infected +#' persons within the population. +#' +#' @inheritParams aging_het +#' +#' @keywords module het +#' #' @export -#' @rdname deaths_msm +#' deaths_het <- function(dat, at) { ### 1. Susceptible Deaths ### @@ -150,10 +161,10 @@ deaths_het <- function(dat, at) { ## 4. Update Population Structure ## inactive <- which(dat$attr$active == 0) - dat$el[[1]] <- tergmLite::delete_vertices(dat$el[[1]], inactive) + dat$el <- tergmLite::delete_vertices(dat$el, inactive) dat$attr <- deleteAttr(dat$attr, inactive) - if (unique(sapply(dat$attr, length)) != attributes(dat$el[[1]])$n) { + if (unique(sapply(dat$attr, length)) != attributes(dat$el)$n) { stop("mismatch between el and attr length in death mod") } diff --git a/R/mod.disclose.R b/R/mod.disclose.R index b736899a..04ab806b 100644 --- a/R/mod.disclose.R +++ b/R/mod.disclose.R @@ -10,8 +10,8 @@ #' Persons who are infected may disclose their status to partners at three #' distinct time points: at relationship onset for newly formed discordant #' pairs; at diagnosis for pairs starting as both negative but with one newly -#' infected; or post diagnosis for one recently infected. The rates of disclosure -#' vary at these three points, and also by the partnership type. +#' infected; or post diagnosis for one recently infected. The rates of +#' disclosure vary at these three points, and also by the partnership type. #' #' @return #' This function returns the \code{dat} object with the updated disclosure list, @@ -20,7 +20,7 @@ #' @keywords module msm #' @export #' -disclose_msm <- function(dat, at){ +hiv_disclose_msm <- function(dat, at){ for (type in c("main", "pers", "inst")) { @@ -131,15 +131,15 @@ disclose_msm <- function(dat, at){ dat$temp$discl.list <- rbind(dat$temp$discl.list, discl.mat) } } + } if (at > 2) { discl.list <- dat$temp$discl.list master.el <- rbind(dat$el[[1]], dat$el[[2]], dat$el[[3]]) - m <- which(match(discl.list[, 1] * 1e7 + discl.list[, 2], - uid[master.el[, 1]] * 1e7 + uid[master.el[, 2]]) | - match(discl.list[, 2] * 1e7 + discl.list[, 1], - uid[master.el[, 1]] * 1e7 + uid[master.el[, 2]])) + m <- which( + match(discl.list[, 1] * 1e7 + discl.list[, 2], uid[master.el[, 1]] * 1e7 + uid[master.el[, 2]]) | + match(discl.list[, 2] * 1e7 + discl.list[, 1], uid[master.el[, 1]] * 1e7 + uid[master.el[, 2]])) dat$temp$discl.list <- discl.list[m, ] } diff --git a/R/mod.ept.R b/R/mod.ept.R new file mode 100644 index 00000000..e6d7f5d0 --- /dev/null +++ b/R/mod.ept.R @@ -0,0 +1,796 @@ + +#' @title EPT Module +#' +#' @description Module function for eligibility of non-index partner, provision +#' of expedited partner therapy (EPT) from index partner to +#' non-index partner, and uptake by non-index partner to prevent +#' STI infection. Eligibility for index partner is handled in the +#' STI treatment module. +#' +#' @inheritParams aging_msm +#' +#' @keywords module msm +#' +#' @export +#' +sti_ept_msm <- function(dat, at) { + + if (at < dat$param$ept.start) { + return(dat) + } + + ## Variables --------------------------------------------------------------- + + # Attributes + rGC <- dat$attr$rGC + uGC <- dat$attr$uGC + rCT <- dat$attr$rCT + uCT <- dat$attr$uCT + + ## Attributes + #uid <- dat$attr$uid + rGC.tx <- dat$attr$rGC.tx + uGC.tx <- dat$attr$uGC.tx + rCT.tx <- dat$attr$rCT.tx + uCT.tx <- dat$attr$uCT.tx + rGC.tx.prep <- dat$attr$rGC.tx.prep + uGC.tx.prep <- dat$attr$uGC.tx.prep + rCT.tx.prep <- dat$attr$rCT.tx.prep + uCT.tx.prep <- dat$attr$uCT.tx.prep + rGC.tx.ept <- dat$attr$rGC.tx.ept + uGC.tx.ept <- dat$attr$uGC.tx.ept + rCT.tx.ept <- dat$attr$rCT.tx.ept + uCT.tx.ept <- dat$attr$uCT.tx.ept + eptindexElig <- dat$attr$eptindexElig + eptindexStat <- dat$attr$eptindexStat + eptindexEligdate <- dat$attr$eptindexEligdate + eptpartEligReceive <- dat$attr$eptpartEligReceive + + ## Parameters + ept.risk.int <- dat$param$ept.risk.int + ept.provision.main.ong <- dat$param$ept.provision.partner.main.ong + ept.provision.pers.ong <- dat$param$ept.provision.partner.pers.ong + ept.provision.main.end <- dat$param$ept.provision.partner.main.end + ept.provision.pers.end <- dat$param$ept.provision.partner.pers.end + ept.provision.inst <- dat$param$ept.provision.partner.inst + ept.uptake.main <- dat$param$ept.uptake.partner.main + ept.uptake.pers <- dat$param$ept.uptake.partner.pers + ept.uptake.inst <- dat$param$ept.uptake.partner.inst + + # Partnership list + part.list <- dat$temp$part.list + + ## Stoppage for Index ------------------------------------------------------ + + # Index no longer eligible(> 1 time step since treatment time) + idseptExpired <- which((at - eptindexEligdate) > 1) + + # Reset EPT status + idsStp <- c(idseptExpired) + eptindexStat[idsStp] <- NA + eptindexElig[idsStp] <- NA + + + ## Indications for non-index-------------------------------------- + ## Eligibility of partners + part.list <- dat$temp$part.list + + # Subset partner list to partnerships active within an EPT interval - last active date within risk interval + part.list <- part.list[which((at - (part.list[, "last.active.time"]) <= ept.risk.int)), , drop = FALSE] + + # Subset partner list to where both partners are alive (a dead index can't provide EPT to alive non-index) + part.list <- part.list[which(part.list[, "uid1"] %in% dat$attr$uid & part.list[, "uid2"] %in% dat$attr$uid), , drop = FALSE] + + # Different partnership subsets + part.listept.main.ong <- part.list[which((part.list[, "ptype"] == 1) & + (part.list[, "last.active.time"] == at)), , drop = FALSE] + part.listept.pers.ong <- part.list[which((part.list[, "ptype"] == 2) & + (part.list[, "last.active.time"] == at)), , drop = FALSE] + part.listept.main.end <- part.list[which((part.list[, "ptype"] == 1) & + (part.list[, "last.active.time"] < at)), , drop = FALSE] + part.listept.pers.end <- part.list[which((part.list[, "ptype"] == 2) & + (part.list[, "last.active.time"] < at)), , drop = FALSE] + part.listept.inst <- part.list[which((part.list[, "ptype"] == 3)), , drop = FALSE] + + + ## Gonorrhea-------------------------------------- + + ### Partner 1 has been given EPT, so partner 2 eligible + ## Main, ongoing + # List Partner 1 IDs + idspartlist.col1.main.ong.gc <- which(dat$attr$uid %in% part.listept.main.ong[, "uid1"]) + + # Return ID for partner 1 who has been given EPT and is currently being treated for GC + idspartlist.col1.ept.main.ong.gc <- idspartlist.col1.main.ong.gc[which(eptindexStat[idspartlist.col1.main.ong.gc] == 1 & + (rGC.tx[idspartlist.col1.main.ong.gc] == 1 | uGC.tx[idspartlist.col1.main.ong.gc] == 1))] + + # Return rows in each subset where partner 1 has been given EPT + partlist.col1.ept.main.ong.gc <- part.listept.main.ong[which(part.listept.main.ong[, "uid1"] %in% dat$attr$uid[idspartlist.col1.ept.main.ong.gc]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept1.main.ong.gc <- which(dat$attr$uid %in% partlist.col1.ept.main.ong.gc[, "uid2"]) + + # Check STI Tx status of partner 2 + idspartlistsept1.main.ong.gc <- idspartlistsept1.main.ong.gc[which(rGC.tx[idspartlistsept1.main.ong.gc] %in% c(0, NA) & + uGC.tx[idspartlistsept1.main.ong.gc] %in% c(0, NA) & + rGC.tx.prep[idspartlistsept1.main.ong.gc] %in% c(0, NA) & + uGC.tx.prep[idspartlistsept1.main.ong.gc] %in% c(0, NA) & + is.na(rGC.tx.ept[idspartlistsept1.main.ong.gc]) & + is.na(uGC.tx.ept[idspartlistsept1.main.ong.gc]) & + is.na(eptpartEligReceive[idspartlistsept1.main.ong.gc]))] + ## Casual, ongoing + # List Partner 1 IDs + idspartlist.col1.pers.ong.gc <- which(dat$attr$uid %in% part.listept.pers.ong[, "uid1"]) + + # Return ID for partner 1 who has been given EPT and is currently being treated for GC + idspartlist.col1.ept.pers.ong.gc <- idspartlist.col1.pers.ong.gc[which(eptindexStat[idspartlist.col1.pers.ong.gc] == 1 & + (rGC.tx[idspartlist.col1.pers.ong.gc] == 1 | uGC.tx[idspartlist.col1.pers.ong.gc] == 1))] + eptindexStat[idspartlist.col1.ept.pers.ong.gc] + + # Return rows in each subset where partner 1 has been given EPT + partlist.col1.ept.pers.ong.gc <- part.listept.pers.ong[which(part.listept.pers.ong[, "uid1"] %in% dat$attr$uid[idspartlist.col1.ept.pers.ong.gc]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept1.pers.ong.gc <- which(dat$attr$uid %in% partlist.col1.ept.pers.ong.gc[, "uid2"]) + + # Check STI Tx status of partner 2 + idspartlistsept1.pers.ong.gc <- idspartlistsept1.pers.ong.gc[which(rGC.tx[idspartlistsept1.pers.ong.gc] %in% c(0, NA) & + uGC.tx[idspartlistsept1.pers.ong.gc] %in% c(0, NA) & + rGC.tx.prep[idspartlistsept1.pers.ong.gc] %in% c(0, NA) & + uGC.tx.prep[idspartlistsept1.pers.ong.gc] %in% c(0, NA) & + is.na(rGC.tx.ept[idspartlistsept1.pers.ong.gc]) & + is.na(uGC.tx.ept[idspartlistsept1.pers.ong.gc]) & + is.na(eptpartEligReceive[idspartlistsept1.pers.ong.gc]))] + + ## Main, ended + # List Partner 1 IDs + idspartlist.col1.main.end.gc <- which(dat$attr$uid %in% part.listept.main.end[, "uid1"]) + + # Return ID for partner 1 who has been given EPT and is currently being treated for GC + idspartlist.col1.ept.main.end.gc <- idspartlist.col1.main.end.gc[which(eptindexStat[idspartlist.col1.main.end.gc] == 1 & + (rGC.tx[idspartlist.col1.main.end.gc] == 1 | uGC.tx[idspartlist.col1.main.end.gc] == 1))] + eptindexStat[idspartlist.col1.ept.main.end.gc] + + # Return rows in each subset where partner 1 has been given EPT + partlist.col1.ept.main.end.gc <- part.listept.main.end[which(part.listept.main.end[, "uid1"] %in% dat$attr$uid[idspartlist.col1.ept.main.end.gc]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept1.main.end.gc <- which(dat$attr$uid %in% partlist.col1.ept.main.end.gc[, "uid2"]) + + # Check STI Tx status of partner 2 + idspartlistsept1.main.end.gc <- idspartlistsept1.main.end.gc[which(rGC.tx[idspartlistsept1.main.end.gc] %in% c(0, NA) & + uGC.tx[idspartlistsept1.main.end.gc] %in% c(0, NA) & + rGC.tx.prep[idspartlistsept1.main.end.gc] %in% c(0, NA) & + uGC.tx.prep[idspartlistsept1.main.end.gc] %in% c(0, NA) & + is.na(rGC.tx.ept[idspartlistsept1.main.end.gc]) & + is.na(uGC.tx.ept[idspartlistsept1.main.end.gc]) & + is.na(eptpartEligReceive[idspartlistsept1.main.end.gc]))] + ## Casual, ended + # List Partner 1 IDs + idspartlist.col1.pers.end.gc <- which(dat$attr$uid %in% part.listept.pers.end[, "uid1"]) + + # Return ID for partner 1 who has been given EPT and is currently being treated for GC + idspartlist.col1.ept.pers.end.gc <- idspartlist.col1.pers.end.gc[which(eptindexStat[idspartlist.col1.pers.end.gc] == 1 & + (rGC.tx[idspartlist.col1.pers.end.gc] == 1 | uGC.tx[idspartlist.col1.pers.end.gc] == 1))] + eptindexStat[idspartlist.col1.ept.pers.end.gc] + + + # Return rows in each subset where partner 1 has been given EPT + partlist.col1.ept.pers.end.gc <- part.listept.pers.end[which(part.listept.pers.end[, "uid1"] %in% dat$attr$uid[idspartlist.col1.ept.pers.end.gc]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept1.pers.end.gc <- which(dat$attr$uid %in% partlist.col1.ept.pers.end.gc[, "uid2"]) + + # Check STI Tx status of partner 2 + idspartlistsept1.pers.end.gc <- idspartlistsept1.pers.end.gc[which(rGC.tx[idspartlistsept1.pers.end.gc] %in% c(0, NA) & + uGC.tx[idspartlistsept1.pers.end.gc] %in% c(0, NA) & + rGC.tx.prep[idspartlistsept1.pers.end.gc] %in% c(0, NA) & + uGC.tx.prep[idspartlistsept1.pers.end.gc] %in% c(0, NA) & + is.na(rGC.tx.ept[idspartlistsept1.pers.end.gc]) & + is.na(uGC.tx.ept[idspartlistsept1.pers.end.gc]) & + is.na(eptpartEligReceive[idspartlistsept1.pers.end.gc]))] + + ## Instantaneous + # List Partner 1 IDs + idspartlist.col1.inst.gc <- which(dat$attr$uid %in% part.listept.inst[, "uid1"]) + + # Return ID for partner 1 who has been given EPT and is currently being treated for GC + idspartlist.col1.ept.inst.gc <- idspartlist.col1.inst.gc[which(eptindexStat[idspartlist.col1.inst.gc] == 1 & + (rGC.tx[idspartlist.col1.inst.gc] == 1 | uGC.tx[idspartlist.col1.inst.gc] == 1))] + eptindexStat[idspartlist.col1.ept.inst.gc] + + # Return rows in each subset where partner 1 has been given EPT + partlist.col1.ept.inst.gc <- part.listept.inst[which(part.listept.inst[, "uid1"] %in% dat$attr$uid[idspartlist.col1.ept.inst.gc]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept1.inst.gc <- which(dat$attr$uid %in% partlist.col1.ept.inst.gc[, "uid2"]) + + # Check STI Tx status of partner 2 + idspartlistsept1.inst.gc <- idspartlistsept1.inst.gc[which(rGC.tx[idspartlistsept1.inst.gc] %in% c(0, NA) & + uGC.tx[idspartlistsept1.inst.gc] %in% c(0, NA) & + rGC.tx.prep[idspartlistsept1.inst.gc] %in% c(0, NA) & + uGC.tx.prep[idspartlistsept1.inst.gc] %in% c(0, NA) & + is.na(rGC.tx.ept[idspartlistsept1.inst.gc]) & + is.na(uGC.tx.ept[idspartlistsept1.inst.gc]) & + is.na(eptpartEligReceive[idspartlistsept1.inst.gc]))] + + + ### Partner 2 has been given EPT, so partner 1 eligible + ## Main, ongoing + idspartlist.col2.main.ong.gc <- which(dat$attr$uid %in% part.listept.main.ong[, "uid2"]) + + # Return ID for partner 2 who has been given EPT and is currently being treated for GC + idspartlist.col2.ept.main.ong.gc <- idspartlist.col2.main.ong.gc[which(eptindexStat[idspartlist.col2.main.ong.gc] == 1 & + (rGC.tx[idspartlist.col2.main.ong.gc] == 1 | uGC.tx[idspartlist.col2.main.ong.gc] == 1))] + eptindexStat[idspartlist.col2.ept.main.ong.gc] + + # Return rows in each subset where partner 2 has been given EPT + partlist.col2.ept.main.ong.gc <- part.listept.main.ong[which(part.listept.main.ong[, "uid2"] %in% dat$attr$uid[idspartlist.col1.ept.main.ong.gc]), , drop = FALSE] + + # Select IDs of partner 1 + idspartlistsept2.main.ong.gc <- which(dat$attr$uid %in% partlist.col2.ept.main.ong.gc[, "uid1"]) + + # Check STI Tx status of partner 1 + idspartlistsept2.main.ong.gc <- idspartlistsept2.main.ong.gc[which(rGC.tx[idspartlistsept2.main.ong.gc] %in% c(0, NA) & + uGC.tx[idspartlistsept2.main.ong.gc] %in% c(0, NA) & + rGC.tx.prep[idspartlistsept2.main.ong.gc] %in% c(0, NA) & + uGC.tx.prep[idspartlistsept2.main.ong.gc] %in% c(0, NA) & + is.na(rGC.tx.ept[idspartlistsept2.main.ong.gc]) & + is.na(uGC.tx.ept[idspartlistsept2.main.ong.gc]) & + is.na(eptpartEligReceive[idspartlistsept2.main.ong.gc]))] + ## Casual, ongoing + # List Partner 2 IDs + idspartlist.col2.pers.ong.gc <- which(dat$attr$uid %in% part.listept.pers.ong[, "uid2"]) + + # Return ID for partner 2 who has been given EPT and is currently being treated for GC + idspartlist.col2.ept.pers.ong.gc <- idspartlist.col2.pers.ong.gc[which(eptindexStat[idspartlist.col2.pers.ong.gc] == 1 & + (rGC.tx[idspartlist.col2.pers.ong.gc] == 1 | uGC.tx[idspartlist.col2.pers.ong.gc] == 1))] + eptindexStat[idspartlist.col2.ept.pers.ong.gc] + + # Return rows in each subset where partner 2 has been given EPT + partlist.col2.ept.pers.ong.gc <- part.listept.pers.ong[which(part.listept.pers.ong[, "uid2"] %in% dat$attr$uid[idspartlist.col2.ept.pers.ong.gc]), , drop = FALSE] + + # Select IDs of partner 1 + idspartlistsept2.pers.ong.gc <- which(dat$attr$uid %in% partlist.col2.ept.pers.ong.gc[, "uid1"]) + + # Check STI Tx status of partner 1 + idspartlistsept2.pers.ong.gc <- idspartlistsept2.pers.ong.gc[which(rGC.tx[idspartlistsept2.pers.ong.gc] %in% c(0, NA) & + uGC.tx[idspartlistsept2.pers.ong.gc] %in% c(0, NA) & + rGC.tx.prep[idspartlistsept2.pers.ong.gc] %in% c(0, NA) & + uGC.tx.prep[idspartlistsept2.pers.ong.gc] %in% c(0, NA) & + is.na(rGC.tx.ept[idspartlistsept2.pers.ong.gc]) & + is.na(uGC.tx.ept[idspartlistsept2.pers.ong.gc]) & + is.na(eptpartEligReceive[idspartlistsept2.pers.ong.gc]))] + + ## Main, ended + # List Partner 2 IDs + idspartlist.col2.main.end.gc <- which(dat$attr$uid %in% part.listept.main.end[, "uid2"]) + + # Return ID for partner 2 who has been given EPT and is currently being treated for GC + idspartlist.col2.ept.main.end.gc <- idspartlist.col2.main.end.gc[which(eptindexStat[idspartlist.col2.main.end.gc] == 1 & + (rGC.tx[idspartlist.col2.main.end.gc] == 1 | uGC.tx[idspartlist.col2.main.end.gc] == 1))] + eptindexStat[idspartlist.col2.ept.main.end.gc] + + + # Return rows in each subset where partner 2 has been given EPT + partlist.col2.ept.main.end.gc <- part.listept.main.end[which(part.listept.main.end[, "uid2"] %in% dat$attr$uid[idspartlist.col2.ept.main.end.gc]), , drop = FALSE] + + # Select IDs of partner 1 + idspartlistsept2.main.end.gc <- which(dat$attr$uid %in% partlist.col2.ept.main.end.gc[, "uid1"]) + + # Check STI Tx status of partner 1 + idspartlistsept2.main.end.gc <- idspartlistsept2.main.end.gc[which(rGC.tx[idspartlistsept2.main.end.gc] %in% c(0, NA) & + uGC.tx[idspartlistsept2.main.end.gc] %in% c(0, NA) & + rGC.tx.prep[idspartlistsept2.main.end.gc] %in% c(0, NA) & + uGC.tx.prep[idspartlistsept2.main.end.gc] %in% c(0, NA) & + is.na(rGC.tx.ept[idspartlistsept2.main.end.gc]) & + is.na(uGC.tx.ept[idspartlistsept2.main.end.gc]) & + is.na(eptpartEligReceive[idspartlistsept2.main.end.gc]))] + ## Casual, ended + # List Partner 2 IDs + idspartlist.col2.pers.end.gc <- which(dat$attr$uid %in% part.listept.pers.end[, "uid2"]) + + # Return ID for partner 2 who has been given EPT and is currently being treated for GC + idspartlist.col2.ept.pers.end.gc <- idspartlist.col2.pers.end.gc[which(eptindexStat[idspartlist.col2.pers.end.gc] == 1 & + (rGC.tx[idspartlist.col2.pers.end.gc] == 1 | uGC.tx[idspartlist.col2.pers.end.gc] == 1))] + eptindexStat[idspartlist.col2.ept.pers.end.gc] + + # Return rows in each subset where partner 2 has been given EPT + partlist.col2.ept.pers.end.gc <- part.listept.pers.end[which(part.listept.pers.end[, "uid2"] %in% dat$attr$uid[idspartlist.col2.ept.pers.end.gc]), , drop = FALSE] + + # Select IDs of partner 1 + idspartlistsept2.pers.end.gc <- which(dat$attr$uid %in% partlist.col2.ept.pers.end.gc[, "uid1"]) + + # Check STI Tx status of partner 1 + idspartlistsept2.pers.end.gc <- idspartlistsept2.pers.end.gc[which(rGC.tx[idspartlistsept2.pers.end.gc] %in% c(0, NA) & + uGC.tx[idspartlistsept2.pers.end.gc] %in% c(0, NA) & + rGC.tx.prep[idspartlistsept2.pers.end.gc] %in% c(0, NA) & + uGC.tx.prep[idspartlistsept2.pers.end.gc] %in% c(0, NA) & + is.na(rGC.tx.ept[idspartlistsept2.pers.end.gc]) & + is.na(uGC.tx.ept[idspartlistsept2.pers.end.gc]) & + is.na(eptpartEligReceive[idspartlistsept2.pers.end.gc]))] + + ## Instantaneous + # List Partner 2 IDs + idspartlist.col2.inst.gc <- which(dat$attr$uid %in% part.listept.inst[, "uid2"]) + + # Return ID for partner 2 who has been given EPT and is currently being treated for GC + idspartlist.col2.ept.inst.gc <- idspartlist.col2.inst.gc[which(eptindexStat[idspartlist.col2.inst.gc] == 1 & + (rGC.tx[idspartlist.col2.inst.gc] == 1 | uGC.tx[idspartlist.col2.inst.gc] == 1))] + eptindexStat[idspartlist.col2.ept.inst.gc] + + + # Return rows in each subset where partner 1 has been given EPT + partlist.col2.ept.inst.gc <- part.listept.inst[which(part.listept.inst[, "uid2"] %in% dat$attr$uid[idspartlist.col2.ept.inst.gc]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept2.inst.gc <- which(dat$attr$uid %in% partlist.col2.ept.inst.gc[, "uid1"]) + + # Check STI Tx status of partner 2 + idspartlistsept2.inst.gc <- idspartlistsept2.inst.gc[which(rGC.tx[idspartlistsept2.inst.gc] %in% c(0, NA) & + uGC.tx[idspartlistsept2.inst.gc] %in% c(0, NA) & + rGC.tx.prep[idspartlistsept2.inst.gc] %in% c(0, NA) & + uGC.tx.prep[idspartlistsept2.inst.gc] %in% c(0, NA) & + is.na(rGC.tx.ept[idspartlistsept2.inst.gc]) & + is.na(uGC.tx.ept[idspartlistsept2.inst.gc]) & + is.na(eptpartEligReceive[idspartlistsept2.inst.gc]))] + + + ## Chlamydia-------------------------------------- + + ### Partner 1 has been given EPT, so partner 2 eligible + ## Main, ongoing + # List Partner 1 IDs + idspartlist.col1.main.ong.ct <- which(dat$attr$uid %in% part.listept.main.ong[, "uid1"]) + + # Return ID for partner 1 who has been given EPT and is being treated for CT + idspartlist.col1.ept.main.ong.ct <- idspartlist.col1.main.ong.ct[which(eptindexStat[idspartlist.col1.main.ong.ct] == 1 & + (rCT.tx[idspartlist.col1.main.ong.ct] == 1 | uCT.tx[idspartlist.col1.main.ong.ct] == 1))] + + # Return rows in each subset where partner 1 has been given EPT + partlist.col1.ept.main.ong.ct <- part.listept.main.ong[which(part.listept.main.ong[, "uid1"] %in% dat$attr$uid[idspartlist.col1.ept.main.ong.ct]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept1.main.ong.ct <- which(dat$attr$uid %in% partlist.col1.ept.main.ong.ct[, "uid2"]) + + # Check STI Tx status of partner 2 + idspartlistsept1.main.ong.ct <- idspartlistsept1.main.ong.ct[which(rCT.tx[idspartlistsept1.main.ong.ct] %in% c(0, NA) & + uCT.tx[idspartlistsept1.main.ong.ct] %in% c(0, NA) & + rCT.tx.prep[idspartlistsept1.main.ong.ct] %in% c(0, NA) & + uCT.tx.prep[idspartlistsept1.main.ong.ct] %in% c(0, NA) & + is.na(rCT.tx.ept[idspartlistsept1.main.ong.ct]) & + is.na(uCT.tx.ept[idspartlistsept1.main.ong.ct]) & + is.na(eptpartEligReceive[idspartlistsept1.main.ong.ct]))] + ## Casual, ongoing + # List Partner 1 IDs + idspartlist.col1.pers.ong.ct <- which(dat$attr$uid %in% part.listept.pers.ong[, "uid1"]) + + # Return ID for partner 1 who has been given EPT and is being treated for CT + idspartlist.col1.ept.pers.ong.ct <- idspartlist.col1.pers.ong.ct[which(eptindexStat[idspartlist.col1.pers.ong.ct] == 1 & + (rCT.tx[idspartlist.col1.pers.ong.ct] == 1 | uCT.tx[idspartlist.col1.pers.ong.ct] == 1))] + eptindexStat[idspartlist.col1.ept.pers.ong.ct] + + # Return rows in each subset where partner 1 has been given EPT + partlist.col1.ept.pers.ong.ct <- part.listept.pers.ong[which(part.listept.pers.ong[, "uid1"] %in% dat$attr$uid[idspartlist.col1.ept.pers.ong.ct]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept1.pers.ong.ct <- which(dat$attr$uid %in% partlist.col1.ept.pers.ong.ct[, "uid2"]) + + # Check STI Tx status of partner 2 + idspartlistsept1.pers.ong.ct <- idspartlistsept1.pers.ong.ct[which(rCT.tx[idspartlistsept1.pers.ong.ct] %in% c(0, NA) & + uCT.tx[idspartlistsept1.pers.ong.ct] %in% c(0, NA) & + rCT.tx.prep[idspartlistsept1.pers.ong.ct] %in% c(0, NA) & + uCT.tx.prep[idspartlistsept1.pers.ong.ct] %in% c(0, NA) & + is.na(rCT.tx.ept[idspartlistsept1.pers.ong.ct]) & + is.na(uCT.tx.ept[idspartlistsept1.pers.ong.ct]) & + is.na(eptpartEligReceive[idspartlistsept1.pers.ong.ct]))] + + ## Main, ended + # List Partner 1 IDs + idspartlist.col1.main.end.ct <- which(dat$attr$uid %in% part.listept.main.end[, "uid1"]) + + # Return ID for partner 1 who has been given EPT and is being treated for CT + idspartlist.col1.ept.main.end.ct <- idspartlist.col1.main.end.ct[which(eptindexStat[idspartlist.col1.main.end.ct] == 1 & + (rCT.tx[idspartlist.col1.main.end.ct] == 1 | uCT.tx[idspartlist.col1.main.end.ct] == 1))] + eptindexStat[idspartlist.col1.ept.main.end.ct] + + # Return rows in each subset where partner 1 has been given EPT + partlist.col1.ept.main.end.ct <- part.listept.main.end[which(part.listept.main.end[, "uid1"] %in% dat$attr$uid[idspartlist.col1.ept.main.end.ct]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept1.main.end.ct <- which(dat$attr$uid %in% partlist.col1.ept.main.end.ct[, "uid2"]) + + # Check STI Tx status of partner 2 + idspartlistsept1.main.end.ct <- idspartlistsept1.main.end.ct[which(rCT.tx[idspartlistsept1.main.end.ct] %in% c(0, NA) & + uCT.tx[idspartlistsept1.main.end.ct] %in% c(0, NA) & + rCT.tx.prep[idspartlistsept1.main.end.ct] %in% c(0, NA) & + uCT.tx.prep[idspartlistsept1.main.end.ct] %in% c(0, NA) & + is.na(rCT.tx.ept[idspartlistsept1.main.end.ct]) & + is.na(uCT.tx.ept[idspartlistsept1.main.end.ct]) & + is.na(eptpartEligReceive[idspartlistsept1.main.end.ct]))] + ## Casual, ended + # List Partner 1 IDs + idspartlist.col1.pers.end.ct <- which(dat$attr$uid %in% part.listept.pers.end[, "uid1"]) + + # Return ID for partner 1 who has been given EPT and is being treated for CT + idspartlist.col1.ept.pers.end.ct <- idspartlist.col1.pers.end.ct[which(eptindexStat[idspartlist.col1.pers.end.ct] == 1 & + (rCT.tx[idspartlist.col1.pers.end.ct] == 1 | uCT.tx[idspartlist.col1.pers.end.ct] == 1))] + eptindexStat[idspartlist.col1.ept.pers.end.ct] + + # Return rows in each subset where partner 1 has been given EPT + partlist.col1.ept.pers.end.ct <- part.listept.pers.end[which(part.listept.pers.end[, "uid1"] %in% dat$attr$uid[idspartlist.col1.ept.pers.end.ct]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept1.pers.end.ct <- which(dat$attr$uid %in% partlist.col1.ept.pers.end.ct[, "uid2"]) + + # Check STI Tx status of partner 2 + idspartlistsept1.pers.end.ct <- idspartlistsept1.pers.end.ct[which(rCT.tx[idspartlistsept1.pers.end.ct] %in% c(0, NA) & + uCT.tx[idspartlistsept1.pers.end.ct] %in% c(0, NA) & + rCT.tx.prep[idspartlistsept1.pers.end.ct] %in% c(0, NA) & + uCT.tx.prep[idspartlistsept1.pers.end.ct] %in% c(0, NA) & + is.na(rCT.tx.ept[idspartlistsept1.pers.end.ct]) & + is.na(uCT.tx.ept[idspartlistsept1.pers.end.ct]) & + is.na(eptpartEligReceive[idspartlistsept1.pers.end.ct]))] + + ## Instantaneous + # List Partner 1 IDs + idspartlist.col1.inst.ct <- which(dat$attr$uid %in% part.listept.inst[, "uid1"]) + + # Return ID for partner 1 who has been given EPT and is being treated for CT + idspartlist.col1.ept.inst.ct <- idspartlist.col1.inst.ct[which(eptindexStat[idspartlist.col1.inst.ct] == 1 & + (rCT.tx[idspartlist.col1.inst.ct] == 1 | uCT.tx[idspartlist.col1.inst.ct] == 1))] + eptindexStat[idspartlist.col1.ept.inst.ct] + + # Return rows in each subset where partner 1 has been given EPT + partlist.col1.ept.inst.ct <- part.listept.inst[which(part.listept.inst[, "uid1"] %in% dat$attr$uid[idspartlist.col1.ept.inst.ct]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept1.inst.ct <- which(dat$attr$uid %in% partlist.col1.ept.inst.ct[, "uid2"]) + + # Check STI Tx status of partner 2 + idspartlistsept1.inst.ct <- idspartlistsept1.inst.ct[which(rCT.tx[idspartlistsept1.inst.ct] %in% c(0, NA) & + uCT.tx[idspartlistsept1.inst.ct] %in% c(0, NA) & + rCT.tx.prep[idspartlistsept1.inst.ct] %in% c(0, NA) & + uCT.tx.prep[idspartlistsept1.inst.ct] %in% c(0, NA) & + is.na(rCT.tx.ept[idspartlistsept1.inst.ct]) & + is.na(uCT.tx.ept[idspartlistsept1.inst.ct]) & + is.na(eptpartEligReceive[idspartlistsept1.inst.ct]))] + + + ### Partner 2 has been given EPT, so partner 1 eligible + ## Main, ongoing + idspartlist.col2.main.ong.ct <- which(dat$attr$uid %in% part.listept.main.ong[, "uid2"]) + + # Return ID for partner 2 who has been given EPT and is being treated for CT + idspartlist.col2.ept.main.ong.ct <- idspartlist.col2.main.ong.ct[which(eptindexStat[idspartlist.col2.main.ong.ct] == 1 & + (rCT.tx[idspartlist.col2.main.ong.ct] == 1 | uCT.tx[idspartlist.col2.main.ong.ct] == 1))] + eptindexStat[idspartlist.col2.ept.main.ong.ct] + + # Return rows in each subset where partner 2 has been given EPT + partlist.col2.ept.main.ong.ct <- part.listept.main.ong[which(part.listept.main.ong[, "uid2"] %in% dat$attr$uid[idspartlist.col1.ept.main.ong.ct]), , drop = FALSE] + + # Select IDs of partner 1 + idspartlistsept2.main.ong.ct <- which(dat$attr$uid %in% partlist.col2.ept.main.ong.ct[, "uid1"]) + + # Check STI Tx status of partner 1 + idspartlistsept2.main.ong.ct <- idspartlistsept2.main.ong.ct[which(rCT.tx[idspartlistsept2.main.ong.ct] %in% c(0, NA) & + uCT.tx[idspartlistsept2.main.ong.ct] %in% c(0, NA) & + rCT.tx.prep[idspartlistsept2.main.ong.ct] %in% c(0, NA) & + uCT.tx.prep[idspartlistsept2.main.ong.ct] %in% c(0, NA) & + is.na(rCT.tx.ept[idspartlistsept2.main.ong.ct]) & + is.na(uCT.tx.ept[idspartlistsept2.main.ong.ct]) & + is.na(eptpartEligReceive[idspartlistsept2.main.ong.ct]))] + ## Casual, ongoing + # List Partner 2 IDs + idspartlist.col2.pers.ong.ct <- which(dat$attr$uid %in% part.listept.pers.ong[, "uid2"]) + + # Return ID for partner 2 who has been given EPT and is being treated for CT + idspartlist.col2.ept.pers.ong.ct <- idspartlist.col2.pers.ong.ct[which(eptindexStat[idspartlist.col2.pers.ong.ct] == 1 & + (rCT.tx[idspartlist.col2.pers.ong.ct] == 1 | uCT.tx[idspartlist.col2.pers.ong.ct] == 1))] + eptindexStat[idspartlist.col2.ept.pers.ong.ct] + + # Return rows in each subset where partner 2 has been given EPT + partlist.col2.ept.pers.ong.ct <- part.listept.pers.ong[which(part.listept.pers.ong[, "uid2"] %in% dat$attr$uid[idspartlist.col2.ept.pers.ong.ct]), , drop = FALSE] + + # Select IDs of partner 1 + idspartlistsept2.pers.ong.ct <- which(dat$attr$uid %in% partlist.col2.ept.pers.ong.ct[, "uid1"]) + + # Check STI Tx status of partner 1 + idspartlistsept2.pers.ong.ct <- idspartlistsept2.pers.ong.ct[which(rCT.tx[idspartlistsept2.pers.ong.ct] %in% c(0, NA) & + uCT.tx[idspartlistsept2.pers.ong.ct] %in% c(0, NA) & + rCT.tx.prep[idspartlistsept2.pers.ong.ct] %in% c(0, NA) & + uCT.tx.prep[idspartlistsept2.pers.ong.ct] %in% c(0, NA) & + is.na(rCT.tx.ept[idspartlistsept2.pers.ong.ct]) & + is.na(uCT.tx.ept[idspartlistsept2.pers.ong.ct]) & + is.na(eptpartEligReceive[idspartlistsept2.pers.ong.ct]))] + + ## Main, ended + # List Partner 2 IDs + idspartlist.col2.main.end.ct <- which(dat$attr$uid %in% part.listept.main.end[, "uid2"]) + + # Return ID for partner 2 who has been given EPT and is being treated for CT + idspartlist.col2.ept.main.end.ct <- idspartlist.col2.main.end.ct[which(eptindexStat[idspartlist.col2.main.end.ct] == 1 & + (rCT.tx[idspartlist.col2.main.end.ct] == 1 | uCT.tx[idspartlist.col2.main.end.ct] == 1))] + eptindexStat[idspartlist.col2.ept.main.end.ct] + + # Return rows in each subset where partner 2 has been given EPT + partlist.col2.ept.main.end.ct <- part.listept.main.end[which(part.listept.main.end[, "uid2"] %in% dat$attr$uid[idspartlist.col2.ept.main.end.ct]), , drop = FALSE] + + # Select IDs of partner 1 + idspartlistsept2.main.end.ct <- which(dat$attr$uid %in% partlist.col2.ept.main.end.ct[, "uid1"]) + + # Check STI Tx status of partner 1 + idspartlistsept2.main.end.ct <- idspartlistsept2.main.end.ct[which(rCT.tx[idspartlistsept2.main.end.ct] %in% c(0, NA) & + uCT.tx[idspartlistsept2.main.end.ct] %in% c(0, NA) & + rCT.tx.prep[idspartlistsept2.main.end.ct] %in% c(0, NA) & + uCT.tx.prep[idspartlistsept2.main.end.ct] %in% c(0, NA) & + is.na(rCT.tx.ept[idspartlistsept2.main.end.ct]) & + is.na(uCT.tx.ept[idspartlistsept2.main.end.ct]) & + is.na(eptpartEligReceive[idspartlistsept2.main.end.ct]))] + ## Casual, ended + # List Partner 2 IDs + idspartlist.col2.pers.end.ct <- which(dat$attr$uid %in% part.listept.pers.end[, "uid2"]) + + # Return ID for partner 2 who has been given EPT and is being treated for CT + idspartlist.col2.ept.pers.end.ct <- idspartlist.col2.pers.end.ct[which(eptindexStat[idspartlist.col2.pers.end.ct] == 1 & + (rCT.tx[idspartlist.col2.pers.end.ct] == 1 | uCT.tx[idspartlist.col2.pers.end.ct] == 1))] + eptindexStat[idspartlist.col2.ept.pers.end.ct] + + # Return rows in each subset where partner 2 has been given EPT + partlist.col2.ept.pers.end.ct <- part.listept.pers.end[which(part.listept.pers.end[, "uid2"] %in% dat$attr$uid[idspartlist.col2.ept.pers.end.ct]), , drop = FALSE] + + # Select IDs of partner 1 + idspartlistsept2.pers.end.ct <- which(dat$attr$uid %in% partlist.col2.ept.pers.end.ct[, "uid1"]) + + # Check STI Tx status of partner 1 + idspartlistsept2.pers.end.ct <- idspartlistsept2.pers.end.ct[which(rCT.tx[idspartlistsept2.pers.end.ct] %in% c(0, NA) & + uCT.tx[idspartlistsept2.pers.end.ct] %in% c(0, NA) & + rCT.tx.prep[idspartlistsept2.pers.end.ct] %in% c(0, NA) & + uCT.tx.prep[idspartlistsept2.pers.end.ct] %in% c(0, NA) & + is.na(rCT.tx.ept[idspartlistsept2.pers.end.ct]) & + is.na(uCT.tx.ept[idspartlistsept2.pers.end.ct]) & + is.na(eptpartEligReceive[idspartlistsept2.pers.end.ct]))] + + ## Instantaneous + # List Partner 2 IDs + idspartlist.col2.inst.ct <- which(dat$attr$uid %in% part.listept.inst[, "uid2"]) + + # Return ID for partner 2 who has been given EPT and is being treated for CT + idspartlist.col2.ept.inst.ct <- idspartlist.col2.inst.ct[which(eptindexStat[idspartlist.col2.inst.ct] == 1 & + (rCT.tx[idspartlist.col2.inst.ct] == 1 | uCT.tx[idspartlist.col2.inst.ct] == 1))] + eptindexStat[idspartlist.col2.ept.inst.ct] + + + # Return rows in each subset where partner 1 has been given EPT + partlist.col2.ept.inst.ct <- part.listept.inst[which(part.listept.inst[, "uid2"] %in% dat$attr$uid[idspartlist.col2.ept.inst.ct]), , drop = FALSE] + + # Select IDs of partner 2 + idspartlistsept2.inst.ct <- which(dat$attr$uid %in% partlist.col2.ept.inst.ct[, "uid1"]) + + # Check STI Tx status of partner 2 + idspartlistsept2.inst.ct <- idspartlistsept2.inst.ct[which(rCT.tx[idspartlistsept2.inst.ct] %in% c(0, NA) & + uCT.tx[idspartlistsept2.inst.ct] %in% c(0, NA) & + rCT.tx.prep[idspartlistsept2.inst.ct] %in% c(0, NA) & + uCT.tx.prep[idspartlistsept2.inst.ct] %in% c(0, NA) & + is.na(rCT.tx.ept[idspartlistsept2.inst.ct]) & + is.na(uCT.tx.ept[idspartlistsept2.inst.ct]) & + is.na(eptpartEligReceive[idspartlistsept2.inst.ct]))] + + # All EPT-tx eligible IDs (partners of index) + idsept <- unique(c(idspartlistsept1.main.ong.gc, idspartlistsept2.main.ong.gc, + idspartlistsept1.pers.ong.gc, idspartlistsept2.pers.ong.gc, + idspartlistsept1.main.end.gc, idspartlistsept2.main.end.gc, + idspartlistsept1.pers.end.gc, idspartlistsept2.pers.end.gc, + idspartlistsept1.inst.gc, idspartlistsept2.inst.gc, + idspartlistsept1.main.ong.ct, idspartlistsept2.main.ong.ct, + idspartlistsept1.pers.ong.ct, idspartlistsept2.pers.ong.ct, + idspartlistsept1.main.end.ct, idspartlistsept2.main.end.ct, + idspartlistsept1.pers.end.ct, idspartlistsept2.pers.end.ct, + idspartlistsept1.inst.ct, idspartlistsept2.inst.ct)) + + idsept.main.ong <- unique(c(idspartlistsept1.main.ong.gc, + idspartlistsept2.main.ong.gc, + idspartlistsept1.main.ong.ct, + idspartlistsept2.main.ong.ct)) + idsept.pers.ong <- unique(c(idspartlistsept1.pers.ong.gc, + idspartlistsept2.pers.ong.gc, + idspartlistsept1.pers.ong.ct, + idspartlistsept2.pers.ong.ct)) + idsept.main.end <- unique(c(idspartlistsept1.main.end.gc, + idspartlistsept2.main.end.gc, + idspartlistsept1.main.end.ct, + idspartlistsept2.main.end.ct)) + idsept.pers.end <- unique(c(idspartlistsept1.pers.end.gc, + idspartlistsept2.pers.end.gc, + idspartlistsept1.pers.end.ct, + idspartlistsept2.pers.end.ct)) + idsept.inst <- unique(c(idspartlistsept1.inst.gc, + idspartlistsept2.inst.gc, + idspartlistsept1.inst.ct, + idspartlistsept2.inst.ct)) + ids.ept.gc <- unique(c(idspartlistsept1.main.ong.gc, idspartlistsept2.main.ong.gc, + idspartlistsept1.pers.ong.gc, idspartlistsept2.pers.ong.gc, + idspartlistsept1.main.end.gc, idspartlistsept2.main.end.gc, + idspartlistsept1.pers.end.gc, idspartlistsept2.pers.end.gc, + idspartlistsept1.inst.gc, idspartlistsept2.inst.gc)) + ids.ept.ct <- unique(c(idspartlistsept1.main.ong.ct, idspartlistsept2.main.ong.ct, + idspartlistsept1.pers.ong.ct, idspartlistsept2.pers.ong.ct, + idspartlistsept1.main.end.ct, idspartlistsept2.main.end.ct, + idspartlistsept1.pers.end.ct, idspartlistsept2.pers.end.ct, + idspartlistsept1.inst.ct, idspartlistsept2.inst.ct)) + + ## Provision to non-index partners ----------------------------------------- + ##(to be treated at next time step) + idsprovided.main.ong <- idsept.main.ong[which(rbinom(length(idsept.main.ong), 1, + ept.provision.main.ong) == 1)] + idsprovided.pers.ong <- idsept.pers.ong[which(rbinom(length(idsept.pers.ong), 1, + ept.provision.pers.ong) == 1)] + idsprovided.main.end <- idsept.main.end[which(rbinom(length(idsept.main.end), 1, + ept.provision.main.end) == 1)] + idsprovided.pers.end <- idsept.pers.end[which(rbinom(length(idsept.pers.end), 1, + ept.provision.pers.end) == 1)] + idsprovided.inst <- idsept.inst[which(rbinom(length(idsept.inst), 1, + ept.provision.inst) == 1)] + + idsprovided_ept <- c(idsprovided.main.ong, idsprovided.pers.ong, + idsprovided.main.end, idsprovided.pers.end, + idsprovided.inst) + + idsprovided.main_ept <- c(idsprovided.main.ong, idsprovided.main.end) + + idsprovided.pers_ept <- c(idsprovided.pers.ong, idsprovided.pers.end) + + idsprovided.inst_ept <- c(idsprovided.inst) + + # Need to further refine + idsprovided_gc <- intersect(idsprovided_ept, ids.ept.gc) + idsprovided_ct <- intersect(idsprovided_ept, ids.ept.ct) + + # Uptake by non-index ------------------------------------------------------ + # Uptake occurs in same time step (or before next step) but non-index is + # actually treated at next time step + + idsept_tx.main <- idsprovided.main_ept[which(rbinom(length(idsprovided.main_ept), 1, + ept.uptake.main) == 1)] + idsept_tx.pers <- idsprovided.pers_ept[which(rbinom(length(idsprovided.pers_ept), 1, + ept.uptake.pers) == 1)] + idsept_tx.inst <- idsprovided.inst_ept[which(rbinom(length(idsprovided.inst_ept), 1, + ept.uptake.inst) == 1)] + idsuptake_ept <- unique(c(idsept_tx.main, idsept_tx.pers, idsept_tx.inst)) + + idsept_tx.gc <- intersect(idsuptake_ept, ids.ept.gc) + idsept_tx.ct <- intersect(idsuptake_ept, ids.ept.ct) + + + ## Output ----------------------------------------------------------------- + + # Update with new trackers + if (is.null(dat$epi$eptpartprovided_gc)) { + dat$epi$eptindexprovided_gc <- rep(NA, dat$control$nsteps) + dat$epi$eptindexprovided_ct <- rep(NA, dat$control$nsteps) + dat$epi$eptpartprovided_gc <- rep(NA, dat$control$nsteps) + dat$epi$eptpartprovided_ct <- rep(NA, dat$control$nsteps) + dat$epi$eptpartelig_main <- rep(NA, dat$control$nsteps) + dat$epi$eptpartelig_pers <- rep(NA, dat$control$nsteps) + dat$epi$eptpartelig_inst <- rep(NA, dat$control$nsteps) + dat$epi$eptpartprovided_main <- rep(NA, dat$control$nsteps) + dat$epi$eptpartprovided_pers <- rep(NA, dat$control$nsteps) + dat$epi$eptpartprovided_inst <- rep(NA, dat$control$nsteps) + dat$epi$eptpartuptake_main <- rep(NA, dat$control$nsteps) + dat$epi$eptpartuptake_pers <- rep(NA, dat$control$nsteps) + dat$epi$eptpartuptake_inst <- rep(NA, dat$control$nsteps) + dat$epi$eptpartuptake_gc <- rep(NA, dat$control$nsteps) + dat$epi$eptgcinfecthiv <- rep(NA, dat$control$nsteps) + dat$epi$eptctinfecthiv <- rep(NA, dat$control$nsteps) + dat$epi$eptgcctinfecthiv <- rep(NA, dat$control$nsteps) + dat$epi$eptgcctinfecthiv_main <- rep(NA, dat$control$nsteps) + dat$epi$eptgcctinfecthiv_pers <- rep(NA, dat$control$nsteps) + dat$epi$eptgcctinfecthiv_inst <- rep(NA, dat$control$nsteps) + dat$epi$eptgcinfectundiaghiv <- rep(NA, dat$control$nsteps) + dat$epi$eptctinfectundiaghiv <- rep(NA, dat$control$nsteps) + dat$epi$eptgcctinfectundiaghiv <- rep(NA, dat$control$nsteps) + dat$epi$eptgcctinfectundiaghiv_main <- rep(NA, dat$control$nsteps) + dat$epi$eptgcctinfectundiaghiv_pers <- rep(NA, dat$control$nsteps) + dat$epi$eptgcctinfectundiaghiv_inst <- rep(NA, dat$control$nsteps) + + } + + # Index attributes + dat$attr$eptindexElig <- eptindexElig + dat$attr$eptindexStat <- eptindexStat + dat$attr$eptindexEligdate <- eptindexEligdate + + # Non-index attributes + dat$attr$eptpartEligReceive[idsept] <- 1 + dat$attr$eptpartEligTx_GC[idsprovided_ept] <- 0 + dat$attr$eptpartEligTx_CT[idsprovided_ept] <- 0 + dat$attr$eptpartEligTx_GC[idsept_tx.gc] <- 1 + dat$attr$eptpartEligTx_CT[idsept_tx.ct] <- 1 + dat$attr$eptpartEligTxdate[idsprovided_ept] <- at + + # Update Epi + dat$epi$eptpartelig[at] <- length(idsept) + dat$epi$eptpartelig_main[at] <- length(unique(c(idsept.main.ong, idsept.main.end))) + dat$epi$eptpartelig_pers[at] <- length(unique(c(idsept.pers.ong, idsept.pers.end))) + dat$epi$eptpartelig_inst[at] <- length(unique(c(idsept.inst))) + dat$epi$eptpartprovided[at] <- length(idsprovided_ept) + dat$epi$eptpartprovided_gc[at] <- length(idsprovided_gc) + dat$epi$eptpartprovided_ct[at] <- length(idsprovided_ct) + dat$epi$eptpartprovided_main[at] <- length(idsprovided.main_ept) + dat$epi$eptpartprovided_pers[at] <- length(idsprovided.pers_ept) + dat$epi$eptpartprovided_inst[at] <- length(idsprovided.inst_ept) + dat$epi$eptpartuptake[at] <- length(idsuptake_ept) + dat$epi$eptpartuptake_main[at] <- length(idsept_tx.main) + dat$epi$eptpartuptake_pers[at] <- length(idsept_tx.pers) + dat$epi$eptpartuptake_inst[at] <- length(idsept_tx.inst) + dat$epi$eptpartuptake_gc[at] <- length(idsept_tx.gc) + dat$epi$eptpartuptake_ct[at] <- length(idsept_tx.ct) + + # Wasted EPT + dat$epi$eptuninfectedprovided[at] <- length(which(rGC[idsprovided_ept] == 0 & + uGC[idsprovided_ept] == 0 & + rCT[idsprovided_ept] == 0 & + uCT[idsprovided_ept] == 0)) + dat$epi$eptuninfecteduptake[at] <- length(which(rGC[idsuptake_ept] == 0 & + uGC[idsuptake_ept] == 0 & + rCT[idsuptake_ept] == 0 & + uCT[idsuptake_ept] == 0)) + + # Missed opportunities EPT + dat$epi$eptgcinfectsti[at] <- length(idsept_tx.gc[which(dat$attr$diag.status.gc[idsept_tx.gc] == 1 | + dat$attr$diag.status.ct[idsept_tx.gc] == 1 | + dat$attr$diag.status.syph[idsept_tx.gc] == 1 | + dat$attr$diag.status[idsept_tx.gc] == 1)]) + dat$epi$eptctinfectsti[at] <- length(idsept_tx.ct[which(dat$attr$diag.status.gc[idsept_tx.ct] == 1 | + dat$attr$diag.status.ct[idsept_tx.ct] == 1 | + dat$attr$diag.status.syph[idsept_tx.ct] == 1 | + dat$attr$diag.status[idsept_tx.ct] == 1)]) + # Uptake focus + # dat$epi$eptgcinfectsti[at] <- length(idsept_tx.gc[which(dat$attr$diag.status.gc[idsept_tx.gc] == 1 | + # dat$attr$diag.status.ct[idsept_tx.gc] == 1 | + # dat$attr$diag.status.syph[idsept_tx.gc] == 1 | + # dat$attr$diag.status[idsept_tx.gc] == 1)]) + # dat$epi$eptctinfectsti[at] <- length(idsept_tx.ct[which(dat$attr$diag.status.gc[idsept_tx.ct] == 1 | + # dat$attr$diag.status.ct[idsept_tx.ct] == 1 | + # dat$attr$diag.status.syph[idsept_tx.ct] == 1 | + # dat$attr$diag.status[idsept_tx.ct] == 1)]) + + # Change to provision, not uptake + + # Provision focused + dat$epi$eptgcinfectundiaghiv[at] <- length(idsprovided_gc[which(dat$attr$status[idsprovided_gc] == 1 & + dat$attr$diag.status[idsprovided_gc] == 0)]) + dat$epi$eptctinfectundiaghiv[at] <- length(idsprovided_ct[which(dat$attr$status[idsprovided_ct] == 1 & + dat$attr$diag.status[idsprovided_ct] == 0)]) + dat$epi$eptgcctinfectundiaghiv[at] <- length(idsprovided_ept[which(dat$attr$status[idsprovided_ept] == 1 & + dat$attr$diag.status[idsprovided_ept] == 0)]) + + dat$epi$eptgcctinfectundiaghiv_main[at] <- length(idsprovided.main_ept[which(dat$attr$status[idsprovided.main_ept] == 1 & + dat$attr$diag.status[idsprovided.main_ept] == 0)]) + dat$epi$eptgcctinfectundiaghiv_pers[at] <- length(idsprovided.pers_ept[which(dat$attr$status[idsprovided.pers_ept] == 1 & + dat$attr$diag.status[idsprovided.pers_ept] == 0)]) + dat$epi$eptgcctinfectundiaghiv_inst[at] <- length(idsprovided.inst_ept[which(dat$attr$status[idsprovided.inst_ept] == 1 & + dat$attr$diag.status[idsprovided.inst_ept] == 0)]) + + dat$epi$eptgcinfecthiv[at] <- length(idsprovided_gc[which(dat$attr$status[idsprovided_gc] == 1)]) + dat$epi$eptctinfecthiv[at] <- length(idsprovided_ct[which(dat$attr$status[idsprovided_ct] == 1)]) + dat$epi$eptgcctinfecthiv[at] <- length(idsprovided_ept[which(dat$attr$status[idsprovided_ept] == 1)]) + + dat$epi$eptgcctinfecthiv_main[at] <- length(idsprovided.main_ept[which(dat$attr$status[idsprovided.main_ept] == 1)]) + dat$epi$eptgcctinfecthiv_pers[at] <- length(idsprovided.pers_ept[which(dat$attr$status[idsprovided.pers_ept] == 1)]) + dat$epi$eptgcctinfecthiv_inst[at] <- length(idsprovided.inst_ept[which(dat$attr$status[idsprovided.inst_ept] == 1)]) + + # Uptake focused + # dat$epi$eptgcinfectundiaghiv[at] <- length(idsept_tx.gc[which(dat$attr$status[idsept_tx.gc] == 1 & + # dat$attr$diag.status[idsept_tx.gc] == 0)]) + # dat$epi$eptctinfectundiaghiv[at] <- length(idsept_tx.ct[which(dat$attr$status[idsept_tx.ct] == 1 & + # dat$attr$diag.status[idsept_tx.ct] == 0)]) + # dat$epi$eptgcctinfectundiaghiv[at] <- length(idsuptake_ept[which(dat$attr$status[idsuptake_ept] == 1 & + # dat$attr$diag.status[idsuptake_ept] == 0)]) + # dat$epi$eptgcinfecthiv[at] <- length(idsept_tx.gc[which(dat$attr$status[idsept_tx.gc] == 1)]) + # dat$epi$eptctinfecthiv[at] <- length(idsept_tx.ct[which(dat$attr$status[idsept_tx.ct] == 1)]) + # dat$epi$eptgcctinfecthiv[at] <- length(idsuptake_ept[which(dat$attr$status[idsuptake_ept] == 1)]) + + + return(dat) +} diff --git a/R/mod.initialize.R b/R/mod.initialize.R index 7fbd6422..51c843e3 100644 --- a/R/mod.initialize.R +++ b/R/mod.initialize.R @@ -14,8 +14,8 @@ #' @param s Simulation number, used for restarting dependent simulations. #' #' @return -#' This function returns the updated \code{dat} object with the initialized values -#' for demographics and disease-related variables. +#' This function returns the updated \code{dat} object with the initialized +#' values or demographics and disease-related variables. #' #' @export #' @keywords module msm @@ -47,15 +47,21 @@ initialize_msm <- function(x, param, init, control, s) { for (i in 1:2) { dat$el[[i]] <- as.edgelist(nw[[i]]) attributes(dat$el[[i]])$vnames <- NULL - p <- tergmLite::stergm_prep(nw[[i]], x[[i]]$formation, x[[i]]$coef.diss$dissolution, - x[[i]]$coef.form, x[[i]]$coef.diss$coef.adj, x[[i]]$constraints) + p <- tergmLite::stergm_prep(nw[[i]], x[[i]]$formation, + x[[i]]$coef.diss$dissolution, + x[[i]]$coef.form, + x[[i]]$coef.diss$coef.adj, + x[[i]]$constraints) p$model.form$formula <- NULL p$model.diss$formula <- NULL dat$p[[i]] <- p } dat$el[[3]] <- as.edgelist(nw[[3]]) attributes(dat$el[[3]])$vnames <- NULL - p <- tergmLite::ergm_prep(nw[[3]], x[[3]]$formation, x[[3]]$coef.form, x[[3]]$constraints) + p <- tergmLite::ergm_prep(nw[[3]], + x[[3]]$formation, + x[[3]]$coef.form, + x[[3]]$constraints) p$model.form$formula <- NULL dat$p[[3]] <- p @@ -137,69 +143,10 @@ initialize_msm <- function(x, param, init, control, s) { dat$attr$ins.quot <- ins.quot # HIV-related attributes - dat <- init_status_msm(dat) - - ## GC/CT status - idsUreth <- which(role.class %in% c("I", "V")) - idsRect <- which(role.class %in% c("R", "V")) - - uGC <- rGC <- rep(0, num) - uCT <- rCT <- rep(0, num) - - # Initialize GC infection at both sites - idsUGC <- sample(idsUreth, size = round(init$prev.ugc * num), FALSE) - uGC[idsUGC] <- 1 - - idsRGC <- sample(setdiff(idsRect, idsUGC), size = round(init$prev.rgc * num), FALSE) - rGC[idsRGC] <- 1 - - dat$attr$rGC <- rGC - dat$attr$uGC <- uGC - - dat$attr$rGC.sympt <- dat$attr$uGC.sympt <- rep(NA, num) - dat$attr$rGC.sympt[rGC == 1] <- rbinom(sum(rGC == 1), 1, dat$param$rgc.sympt.prob) - dat$attr$uGC.sympt[uGC == 1] <- rbinom(sum(uGC == 1), 1, dat$param$ugc.sympt.prob) - - dat$attr$rGC.infTime <- dat$attr$uGC.infTime <- rep(NA, length(dat$attr$active)) - dat$attr$rGC.infTime[rGC == 1] <- 1 - dat$attr$uGC.infTime[uGC == 1] <- 1 - - dat$attr$rGC.timesInf <- rep(0, num) - dat$attr$rGC.timesInf[rGC == 1] <- 1 - dat$attr$uGC.timesInf <- rep(0, num) - dat$attr$uGC.timesInf[uGC == 1] <- 1 - - dat$attr$rGC.tx <- dat$attr$uGC.tx <- rep(NA, num) - dat$attr$rGC.tx.prep <- dat$attr$uGC.tx.prep <- rep(NA, num) - dat$attr$GC.cease <- rep(NA, num) - - # Initialize CT infection at both sites - idsUCT <- sample(idsUreth, size = round(init$prev.uct * num), FALSE) - uCT[idsUCT] <- 1 - - idsRCT <- sample(setdiff(idsRect, idsUCT), size = round(init$prev.rct * num), FALSE) - rCT[idsRCT] <- 1 - - dat$attr$rCT <- rCT - dat$attr$uCT <- uCT - - dat$attr$rCT.sympt <- dat$attr$uCT.sympt <- rep(NA, num) - dat$attr$rCT.sympt[rCT == 1] <- rbinom(sum(rCT == 1), 1, dat$param$rct.sympt.prob) - dat$attr$uCT.sympt[uCT == 1] <- rbinom(sum(uCT == 1), 1, dat$param$uct.sympt.prob) - - dat$attr$rCT.infTime <- dat$attr$uCT.infTime <- rep(NA, num) - dat$attr$rCT.infTime[dat$attr$rCT == 1] <- 1 - dat$attr$uCT.infTime[dat$attr$uCT == 1] <- 1 - - dat$attr$rCT.timesInf <- rep(0, num) - dat$attr$rCT.timesInf[rCT == 1] <- 1 - dat$attr$uCT.timesInf <- rep(0, num) - dat$attr$uCT.timesInf[uCT == 1] <- 1 - - dat$attr$rCT.tx <- dat$attr$uCT.tx <- rep(NA, num) - dat$attr$rCT.tx.prep <- dat$attr$uCT.tx.prep <- rep(NA, num) - dat$attr$CT.cease <- rep(NA, num) + dat <- init_status_hiv_msm(dat) + # Syphilis- and STI-related attributes + dat <- init_status_sti_msm(dat) # CCR5 dat <- init_ccr5_msm(dat) @@ -214,7 +161,16 @@ initialize_msm <- function(x, param, init, control, s) { dat$temp$discl.list <- matrix(NA, nrow = 0, ncol = 3) colnames(dat$temp$discl.list) <- c("pos", "neg", "discl.time") - dat <- prevalence_msm(dat, at = 1) + # Relationship tracking + dat$temp$part.list <- matrix(NA, nrow = 0, ncol = 6) + colnames(dat$temp$part.list) <- c("uid1", "uid2", "ptype", "start.time", + "last.active.time", "end.time") + + if (dat$param$partlist.start == 1) { + dat <- part_msm(dat, at = 1) + } + + dat <- prevalence_msm_tnt(dat, at = 1) class(dat) <- "dat" return(dat) @@ -267,7 +223,7 @@ remove_bad_roles_msm <- function(nw) { #' @export #' @keywords initiation utility msm #' -init_status_msm <- function(dat) { +init_status_hiv_msm <- function(dat) { num.B <- dat$init$num.B num.W <- dat$init$num.W @@ -288,10 +244,10 @@ init_status_msm <- function(dat) { probInfCrW <- age[ids.W] * dat$init$init.prev.age.slope.W probInfW <- probInfCrW + (nInfW - sum(probInfCrW)) / num.W - if (any(probInfB <= 0) | any(probInfW <= 0)) { - stop("Slope of initial prevalence by age must be sufficiently low to ", - "avoid non-positive probabilities.", call. = FALSE) - } + # if (any(probInfB <= 0) | any(probInfW <= 0)) { + # stop("Slope of initial prevalence by age must be sufficiently low to ", + # "avoid non-positive probabilities.", call. = FALSE) + # } # Infection status status <- rep(0, num) @@ -314,11 +270,15 @@ init_status_msm <- function(dat) { dat$attr$tt.traj <- tt.traj - ## Infection-related attributes stage <- rep(NA, num) - stage.time <- rep(NA, num) + stage.time <- rep(0, num) + stage.time.ar.ndx <- rep(0, num) + stage.time.af.ndx <- rep(0, num) + stage.time.early.chronic.ndx <- rep(0, num) + stage.time.late.chronic.ndx <- rep(0, num) + stage.time.aids.ndx <- rep(0, num) inf.time <- rep(NA, num) vl <- rep(NA, num) diag.status <- rep(NA, num) @@ -328,16 +288,10 @@ init_status_msm <- function(dat) { tx.init.time <- rep(NA, num) cum.time.on.tx <- rep(NA, num) cum.time.off.tx <- rep(NA, num) - infector <- rep(NA, num) inf.role <- rep(NA, num) inf.type <- rep(NA, num) - inf.diag <- rep(NA, num) - inf.tx <- rep(NA, num) - inf.stage <- rep(NA, num) - - time.sex.active <- pmax(1, - round((365 / dat$param$time.unit) * age - (365 / dat$param$time.unit) * - min(dat$init$ages), 0)) + time.sex.active <- pmax(1,round((365 / dat$param$time.unit) * age - + (365 / dat$param$time.unit) * min(dat$init$ages), 0)) vlar.int <- dat$param$vl.acute.rise.int vlap <- dat$param$vl.acute.peak @@ -349,6 +303,11 @@ init_status_msm <- function(dat) { vlds <- (vlf - vlsp) / vl.aids.int vl.acute.int <- vlar.int + vlaf.int + # Seventy percent value for early/late chronic split + early.chronic.full.int <- floor(0.7 * dat$param$max.time.off.tx.full.int) + early.chronic.part.int <- floor(0.7 * dat$param$max.time.off.tx.part.int) + late.chronic.full.int <- floor(0.7 * dat$param$max.time.off.tx.full.int) + late.chronic.part.int <- floor(0.7 * dat$param$max.time.off.tx.part.int) ### Non-treater type: tester and non-tester selected <- which(status == 1 & tt.traj %in% c(1, 2)) @@ -364,13 +323,29 @@ init_status_msm <- function(dat) { stage[selected[time.since.inf > vl.acute.int & time.since.inf <= vldo.int]] <- 3 stage[selected[time.since.inf > vldo.int]] <- 4 + # Need to make this ART/no? stage.time[selected][stage[selected] == 1] <- time.since.inf[stage[selected] == 1] - stage.time[selected][stage[selected] == 2] <- time.since.inf[stage[selected] == 2] - - vlar.int - stage.time[selected][stage[selected] == 3] <- time.since.inf[stage[selected] == 3] - - vl.acute.int - stage.time[selected][stage[selected] == 4] <- time.since.inf[stage[selected] == 4] - - vldo.int + stage.time[selected][stage[selected] == 2] <- time.since.inf[stage[selected] == 2] - vlar.int + stage.time[selected][stage[selected] == 3] <- time.since.inf[stage[selected] == 3] - vl.acute.int + stage.time[selected][stage[selected] == 4] <- time.since.inf[stage[selected] == 4] - vldo.int + + # HIV stage times + stage.time.ar.ndx[selected][stage[selected] == 1] <- time.since.inf[stage[selected] == 1] + stage.time.af.ndx[selected][stage[selected] == 2] <- time.since.inf[stage[selected] == 2] - vlar.int + stage.time.early.chronic.ndx[selected][stage[selected] == 3 & cum.time.off.tx[selected] <= early.chronic.full.int] <- + time.since.inf[stage[selected] == 3 & + cum.time.off.tx[selected] <= early.chronic.full.int] - + vl.acute.int + stage.time.late.chronic.ndx[selected][stage[selected] == 3 & cum.time.off.tx[selected] > early.chronic.full.int] <- time.since.inf[stage[selected] == 3 & + cum.time.off.tx[selected] > early.chronic.full.int] - + vl.acute.int - early.chronic.full.int + stage.time.aids.ndx[selected][stage[selected] == 4] <- time.since.inf[stage[selected] == 4] - vldo.int + + # Assign time spent in earlier stages for those initialized into later stages + stage.time.ar.ndx[selected][stage[selected] %in% c(2, 3, 4)] <- vlar.int + stage.time.af.ndx[selected][stage[selected] %in% c(3, 4)] <- vlaf.int + stage.time.early.chronic.ndx[selected][stage[selected] == 4] <- early.chronic.full.int + stage.time.late.chronic.ndx[selected][stage[selected] == 4] <- late.chronic.full.int vl[selected] <- (time.since.inf <= vlar.int) * (vlap * time.since.inf / vlar.int) + (time.since.inf > vlar.int) * (time.since.inf <= vlar.int + vlaf.int) * @@ -385,15 +360,13 @@ init_status_msm <- function(dat) { # Time to next test if (dat$param$testing.pattern == "interval") { - ttntest <- ceiling(runif(length(selected), - min = 0, + ttntest <- ceiling(runif(length(selected), min = 0, max = dat$param$mean.test.B.int * (race[selected] == "B") + dat$param$mean.test.W.int * (race[selected] == "W"))) } if (dat$param$testing.pattern == "memoryless") { - ttntest <- rgeom(length(selected), - 1 / (dat$param$mean.test.B.int * (race[selected] == "B") + - dat$param$mean.test.W.int * (race[selected] == "W"))) + ttntest <- rgeom(length(selected), 1 / (dat$param$mean.test.B.int * (race[selected] == "B") + + dat$param$mean.test.W.int * (race[selected] == "W"))) } twind.int <- dat$param$test.window.int @@ -412,46 +385,34 @@ init_status_msm <- function(dat) { tx.init.time.W <- twind.int + dat$param$last.neg.test.W.int + 1 / dat$param$tx.init.W.prob # Stage for Blacks - prop.time.on.tx.B <- dat$param$tx.reinit.B.prob / - (dat$param$tx.halt.B.prob + dat$param$tx.reinit.B.prob) - offon.B <- matrix(c(1:tx.init.time.B, rep(0, tx.init.time.B)), - nrow = tx.init.time.B) - numsteps.B <- (dat$param$max.time.off.tx.full.int - tx.init.time.B) / - (1 - prop.time.on.tx.B) - offon.B <- rbind(offon.B, - cbind(tx.init.time.B + (1 - prop.time.on.tx.B) * 1:numsteps.B, - prop.time.on.tx.B * 1:numsteps.B)) + prop.time.on.tx.B <- dat$param$tx.reinit.B.prob / (dat$param$tx.halt.B.prob + dat$param$tx.reinit.B.prob) + offon.B <- matrix(c(1:tx.init.time.B, rep(0, tx.init.time.B)), nrow = tx.init.time.B) + numsteps.B <- (dat$param$max.time.off.tx.full.int - tx.init.time.B) / (1 - prop.time.on.tx.B) + offon.B <- rbind(offon.B, cbind(tx.init.time.B + (1 - prop.time.on.tx.B) * 1:numsteps.B, + prop.time.on.tx.B * 1:numsteps.B)) offon.B <- round(offon.B) exp.dur.chronic.B <- nrow(offon.B) - vl.acute.int exp.onset.aids.B <- nrow(offon.B) offon.last.B <- offon.B[nrow(offon.B), ] - offon.B <- rbind(offon.B, - matrix(c(offon.last.B[1] + (1:vl.aids.int), - rep(offon.last.B[2], vl.aids.int)), - ncol = 2)) + offon.B <- rbind(offon.B, matrix(c(offon.last.B[1] + (1:vl.aids.int), rep(offon.last.B[2], vl.aids.int)), + ncol = 2)) max.possible.inf.time.B <- nrow(offon.B) offon.B[, 2] <- (1:max.possible.inf.time.B) - offon.B[, 1] stage.B <- rep(c(1, 2, 3, 4), c(vlar.int, vlaf.int, exp.dur.chronic.B, vl.aids.int)) stage.time.B <- c(1:vlar.int, 1:vlaf.int, 1:exp.dur.chronic.B, 1:vl.aids.int) # Stage for Whites - prop.time.on.tx.W <- dat$param$tx.reinit.W.prob / - (dat$param$tx.halt.W.prob + dat$param$tx.reinit.W.prob) - offon.W <- matrix(c(1:tx.init.time.W, rep(0, tx.init.time.W)), - nrow = tx.init.time.W) - numsteps.W <- (dat$param$max.time.off.tx.full.int - tx.init.time.W) / - (1 - prop.time.on.tx.W) - offon.W <- rbind(offon.W, - cbind(tx.init.time.W + (1 - prop.time.on.tx.W) * 1:numsteps.W, - prop.time.on.tx.W * 1:numsteps.W)) + prop.time.on.tx.W <- dat$param$tx.reinit.W.prob / (dat$param$tx.halt.W.prob + dat$param$tx.reinit.W.prob) + offon.W <- matrix(c(1:tx.init.time.W, rep(0, tx.init.time.W)), nrow = tx.init.time.W) + numsteps.W <- (dat$param$max.time.off.tx.full.int - tx.init.time.W) / (1 - prop.time.on.tx.W) + offon.W <- rbind(offon.W, cbind(tx.init.time.W + (1 - prop.time.on.tx.W) * 1:numsteps.W, + prop.time.on.tx.W * 1:numsteps.W)) offon.W <- round(offon.W) exp.dur.chronic.W <- nrow(offon.W) - vl.acute.int exp.onset.aids.W <- nrow(offon.W) offon.last.W <- offon.W[nrow(offon.W), ] - offon.W <- rbind(offon.W, - matrix(c(offon.last.W[1] + (1:vl.aids.int), - rep(offon.last.W[2], vl.aids.int)), - ncol = 2)) + offon.W <- rbind(offon.W, matrix(c(offon.last.W[1] + (1:vl.aids.int), rep(offon.last.W[2], vl.aids.int)), + ncol = 2)) max.possible.inf.time.W <- nrow(offon.W) offon.W[, 2] <- (1:max.possible.inf.time.W) - offon.W[, 1] stage.W <- rep(c(1, 2, 3, 4), c(vlar.int, vlaf.int, exp.dur.chronic.W, vl.aids.int)) @@ -466,17 +427,31 @@ init_status_msm <- function(dat) { cum.time.off.tx[selected] <- offon.B[time.since.inf, 1] stage[selected] <- stage.B[time.since.inf] stage.time[selected] <- stage.time.B[time.since.inf] + + # HIV stage times + stage.time.ar.ndx[selected][stage[selected] == 1] <- stage.time[selected][stage[selected] == 1] + stage.time.af.ndx[selected][stage[selected] == 2] <- stage.time[selected][stage[selected] == 2] + stage.time.early.chronic.ndx[selected][stage[selected] == 3 & cum.time.off.tx[selected] <= early.chronic.full.int] <- stage.time[selected][stage[selected] == 3 & + cum.time.off.tx[selected] <= early.chronic.full.int] + stage.time.late.chronic.ndx[selected][stage[selected] == 4 & cum.time.off.tx[selected] > early.chronic.full.int] <- stage.time[selected][stage[selected] == 4 & + cum.time.off.tx[selected] > early.chronic.full.int] - + early.chronic.full.int + stage.time.aids.ndx[selected][stage[selected] == 4] <- stage.time[selected][stage[selected] == 4] + + # Assign time spent in earlier stages for those initialized into later stages + stage.time.ar.ndx[selected][stage[selected] %in% c(2, 3, 4)] <- vlar.int + stage.time.af.ndx[selected][stage[selected] %in% c(3, 4)] <- vlaf.int + stage.time.early.chronic.ndx[selected][stage[selected] == 4] <- early.chronic.full.int + stage.time.late.chronic.ndx[selected][stage[selected] == 4] <- late.chronic.full.int + tx.status[selected] <- 0 - tx.status[selected][stage[selected] == 3 & cum.time.on.tx[selected] > 0] <- - rbinom(sum(stage[selected] == 3 & cum.time.on.tx[selected] > 0), - 1, prop.time.on.tx.B) + tx.status[selected][stage[selected] == 3 & cum.time.on.tx[selected] > 0] <- rbinom(sum(stage[selected] == 3 & cum.time.on.tx[selected] > 0), + 1, prop.time.on.tx.B) vl[selected] <- (time.since.inf <= vlar.int) * (vlap * time.since.inf / vlar.int) + (time.since.inf > vlar.int) * (time.since.inf <= vlar.int + vlaf.int) * ((vlsp - vlap) * (time.since.inf - vlar.int) / vlaf.int + vlap) + - (time.since.inf > vlar.int + vlaf.int) * - (time.since.inf <= exp.onset.aids.B) * (vlsp) + - (time.since.inf > exp.onset.aids.B) * - (vlsp + (time.since.inf - exp.onset.aids.B) * vlds) + (time.since.inf > vlar.int + vlaf.int) * (time.since.inf <= exp.onset.aids.B) * (vlsp) + + (time.since.inf > exp.onset.aids.B) * (vlsp + (time.since.inf - exp.onset.aids.B) * vlds) vl[selected][tx.status[selected] == 1] <- dat$param$vl.full.supp # VL for Whites @@ -488,36 +463,48 @@ init_status_msm <- function(dat) { cum.time.off.tx[selected] <- offon.W[time.since.inf, 1] stage[selected] <- stage.W[time.since.inf] stage.time[selected] <- stage.time.W[time.since.inf] + + # HIV stage times - 7 years for early chronic, 3 years for late chronic + stage.time.ar.ndx[selected][stage[selected] == 1] <- stage.time[selected][stage[selected] == 1] + stage.time.af.ndx[selected][stage[selected] == 2] <- stage.time[selected][stage[selected] == 2] + stage.time.early.chronic.ndx[selected][stage[selected] == 3 & cum.time.off.tx[selected] <= early.chronic.full.int] <- stage.time[selected][stage[selected] == 3 & + cum.time.off.tx[selected] <= early.chronic.full.int] + stage.time.late.chronic.ndx[selected][stage[selected] == 3 & cum.time.off.tx[selected] > early.chronic.full.int] <- stage.time[selected][stage[selected] == 3 & + cum.time.off.tx[selected] > early.chronic.full.int] - + early.chronic.full.int + stage.time.aids.ndx[selected][stage[selected] == 4] <- stage.time[selected][stage[selected] == 4] + + # Assign time spent in earlier stages for those initialized into later stages + stage.time.ar.ndx[selected][stage[selected] %in% c(2, 3, 4)] <- vlar.int + stage.time.af.ndx[selected][stage[selected] %in% c(3, 4)] <- vlaf.int + stage.time.early.chronic.ndx[selected][stage[selected] == 4] <- early.chronic.full.int + stage.time.late.chronic.ndx[selected][stage[selected] == 4] <- late.chronic.full.int + tx.status[selected] <- 0 - tx.status[selected][stage[selected] == 3 & cum.time.on.tx[selected] > 0] <- - rbinom(sum(stage[selected] == 3 & cum.time.on.tx[selected] > 0), - 1, prop.time.on.tx.W) + tx.status[selected][stage[selected] == 3 & cum.time.on.tx[selected] > 0] <- rbinom(sum(stage[selected] == 3 & cum.time.on.tx[selected] > 0), + 1, prop.time.on.tx.W) vl[selected] <- (time.since.inf <= vlar.int) * (vlap * time.since.inf / vlar.int) + - (time.since.inf > vlar.int) * (time.since.inf <= vlar.int + vlaf.int) * - ((vlsp - vlap) * (time.since.inf - vlar.int) / vlaf.int + vlap) + - (time.since.inf > vlar.int + vlaf.int) * - (time.since.inf <= exp.onset.aids.W) * (vlsp) + - (time.since.inf > exp.onset.aids.W) * - (vlsp + (time.since.inf - exp.onset.aids.W) * vlds) + (time.since.inf > vlar.int) * (time.since.inf <= vlar.int + vlaf.int) * + ((vlsp - vlap) * (time.since.inf - vlar.int) / vlaf.int + vlap) + + (time.since.inf > vlar.int + vlaf.int) * (time.since.inf <= exp.onset.aids.W) * (vlsp) + + (time.since.inf > exp.onset.aids.W) * (vlsp + (time.since.inf - exp.onset.aids.W) * vlds) vl[selected][tx.status[selected] == 1] <- dat$param$vl.full.supp # Diagnosis selected <- which(status == 1 & tt.traj == 4) if (dat$param$testing.pattern == "interval") { - ttntest <- ceiling(runif(length(selected), - min = 0, + ttntest <- ceiling(runif(length(selected), min = 0, max = dat$param$mean.test.B.int * (race[selected] == "B") + dat$param$mean.test.W.int * (race[selected] == "W"))) } if (dat$param$testing.pattern == "memoryless") { - ttntest <- rgeom(length(selected), - 1 / (dat$param$mean.test.B.int * (race[selected] == "B") + - dat$param$mean.test.W.int * (race[selected] == "W"))) + ttntest <- rgeom(length(selected), 1 / (dat$param$mean.test.B.int * (race[selected] == "B") + + dat$param$mean.test.W.int * (race[selected] == "W"))) } diag.status[selected][ttntest > cum.time.off.tx[selected] - twind.int] <- 0 last.neg.test[selected][ttntest > cum.time.off.tx[selected] - twind.int] <- - -ttntest[ttntest > cum.time.off.tx[selected] - twind.int] + -ttntest[ttntest > cum.time.off.tx[selected] - twind.int] diag.status[selected][ttntest <= cum.time.off.tx[selected] - twind.int] <- 1 diag.status[selected][cum.time.on.tx[selected] > 0] <- 1 last.neg.test[selected][cum.time.on.tx[selected] > 0] <- NA @@ -527,48 +514,39 @@ init_status_msm <- function(dat) { # Create set of expected values for (cum.time.off.tx,cum.time.on.tx) - prop.time.on.tx.B <- dat$param$tx.reinit.B.prob / - (dat$param$tx.halt.B.prob + dat$param$tx.reinit.B.prob) - offon.B <- matrix(c(1:tx.init.time.B, rep(0, tx.init.time.B)), - nrow = tx.init.time.B) + prop.time.on.tx.B <- dat$param$tx.reinit.B.prob / (dat$param$tx.halt.B.prob + dat$param$tx.reinit.B.prob) + offon.B <- matrix(c(1:tx.init.time.B, rep(0, tx.init.time.B)), nrow = tx.init.time.B) while (offon.B[nrow(offon.B), 1] / dat$param$max.time.off.tx.part.int + offon.B[nrow(offon.B), 2] / dat$param$max.time.on.tx.part.int < 1) { - offon.B <- rbind(offon.B, - offon.B[nrow(offon.B), ] + c(1 - prop.time.on.tx.B, - prop.time.on.tx.B)) + offon.B <- rbind(offon.B, + offon.B[nrow(offon.B), ] + c(1 - prop.time.on.tx.B, prop.time.on.tx.B)) } offon.B <- round(offon.B) exp.dur.chronic.B <- nrow(offon.B) - vl.acute.int exp.onset.aids.B <- nrow(offon.B) offon.last.B <- offon.B[nrow(offon.B), ] - offon.B <- rbind(offon.B, - matrix(c(offon.last.B[1] + (1:vl.aids.int), - rep(offon.last.B[2], vl.aids.int)), - ncol = 2)) + offon.B <- rbind(offon.B, matrix(c(offon.last.B[1] + (1:vl.aids.int), rep(offon.last.B[2], vl.aids.int)), + ncol = 2)) max.possible.inf.time.B <- nrow(offon.B) offon.B[, 2] <- (1:max.possible.inf.time.B) - offon.B[, 1] stage.B <- rep(c(1, 2, 3, 4), c(vlar.int, vlaf.int, exp.dur.chronic.B, vl.aids.int)) stage.time.B <- c(1:vlar.int, 1:vlaf.int, 1:exp.dur.chronic.B, 1:vl.aids.int) - prop.time.on.tx.W <- dat$param$tx.reinit.W.prob / - (dat$param$tx.halt.W.prob + dat$param$tx.reinit.W.prob) - offon.W <- matrix(c(1:tx.init.time.W, rep(0, tx.init.time.W)), - nrow = tx.init.time.W) + prop.time.on.tx.W <- dat$param$tx.reinit.W.prob / (dat$param$tx.halt.W.prob + dat$param$tx.reinit.W.prob) + offon.W <- matrix(c(1:tx.init.time.W, rep(0, tx.init.time.W)), nrow = tx.init.time.W) while (offon.W[nrow(offon.W), 1] / dat$param$max.time.off.tx.part.int + offon.W[nrow(offon.W), 2] / dat$param$max.time.on.tx.part.int < 1) { - offon.W <- rbind(offon.W, - offon.W[nrow(offon.W), ] + c(1 - prop.time.on.tx.W, + offon.W <- rbind(offon.W, + offon.W[nrow(offon.W), ] + c(1 - prop.time.on.tx.W, prop.time.on.tx.W)) } offon.W <- round(offon.W) exp.dur.chronic.W <- nrow(offon.W) - vl.acute.int exp.onset.aids.W <- nrow(offon.W) offon.last.W <- offon.W[nrow(offon.W), ] - offon.W <- rbind(offon.W, - matrix(c(offon.last.W[1] + (1:vl.aids.int), - rep(offon.last.W[2], vl.aids.int)), - ncol = 2)) + offon.W <- rbind(offon.W, matrix(c(offon.last.W[1] + (1:vl.aids.int), rep(offon.last.W[2], vl.aids.int)), + ncol = 2)) max.possible.inf.time.W <- nrow(offon.W) offon.W[, 2] <- (1:max.possible.inf.time.W) - offon.W[, 1] stage.W <- rep(c(1, 2, 3, 4), c(vlar.int, vlaf.int, exp.dur.chronic.W, vl.aids.int)) @@ -583,17 +561,31 @@ init_status_msm <- function(dat) { cum.time.off.tx[selected] <- offon.B[time.since.inf, 1] stage[selected] <- stage.B[time.since.inf] stage.time[selected] <- stage.time.B[time.since.inf] + + # HIV stage times + stage.time.ar.ndx[selected][stage[selected] == 1] <- stage.time[selected][stage[selected] == 1] + stage.time.af.ndx[selected][stage[selected] == 2] <- stage.time[selected][stage[selected] == 2] + stage.time.early.chronic.ndx[selected][stage[selected] == 3 & cum.time.off.tx[selected] <= early.chronic.part.int] <- stage.time[selected][stage[selected] == 3 & + cum.time.off.tx[selected] <= early.chronic.part.int] + stage.time.late.chronic.ndx[selected][stage[selected] == 3 & cum.time.off.tx[selected] > early.chronic.part.int] <- stage.time[selected][stage[selected] == 3 & + cum.time.off.tx[selected] > early.chronic.part.int] - + early.chronic.part.int + stage.time.aids.ndx[selected][stage[selected] == 4] <- stage.time[selected][stage[selected] == 4] + + # Assign time spent in earlier stages for those initialized into later stages + stage.time.ar.ndx[selected][stage[selected] %in% c(2, 3, 4)] <- vlar.int + stage.time.af.ndx[selected][stage[selected] %in% c(3, 4)] <- vlaf.int + stage.time.early.chronic.ndx[selected][stage[selected] == 4] <- early.chronic.part.int + stage.time.late.chronic.ndx[selected][stage[selected] == 4] <- late.chronic.part.int + tx.status[selected] <- 0 - tx.status[selected][stage[selected] == 3 & cum.time.on.tx[selected] > 0] <- - rbinom(sum(stage[selected] == 3 & cum.time.on.tx[selected] > 0), - 1, prop.time.on.tx.B) + tx.status[selected][stage[selected] == 3 & cum.time.on.tx[selected] > 0] <- rbinom(sum(stage[selected] == 3 & cum.time.on.tx[selected] > 0), + 1, prop.time.on.tx.B) vl[selected] <- (time.since.inf <= vlar.int) * (vlap * time.since.inf / vlar.int) + (time.since.inf > vlar.int) * (time.since.inf <= vlar.int + vlaf.int) * - ((vlsp - vlap) * (time.since.inf - vlar.int) / vlaf.int + vlap) + - (time.since.inf > vlar.int + vlaf.int) * - (time.since.inf <= exp.onset.aids.B) * (vlsp) + - (time.since.inf > exp.onset.aids.B) * - (vlsp + (time.since.inf - exp.onset.aids.B) * vlds) + ((vlsp - vlap) * (time.since.inf - vlar.int) / vlaf.int + vlap) + + (time.since.inf > vlar.int + vlaf.int) * (time.since.inf <= exp.onset.aids.B) * (vlsp) + + (time.since.inf > exp.onset.aids.B) * (vlsp + (time.since.inf - exp.onset.aids.B) * vlds) vl[selected][tx.status[selected] == 1] <- dat$param$vl.part.supp # VL for Whites @@ -605,38 +597,50 @@ init_status_msm <- function(dat) { cum.time.off.tx[selected] <- offon.W[time.since.inf, 1] stage[selected] <- stage.W[time.since.inf] stage.time[selected] <- stage.time.W[time.since.inf] + + # HIV stage times + stage.time.ar.ndx[selected][stage[selected] == 1] <- stage.time[selected][stage[selected] == 1] + stage.time.af.ndx[selected][stage[selected] == 2] <- stage.time[selected][stage[selected] == 2] + stage.time.early.chronic.ndx[selected][stage[selected] == 3 & cum.time.off.tx[selected] <= early.chronic.part.int] <- stage.time[selected][stage[selected] == 3 & + cum.time.off.tx[selected] <= early.chronic.part.int] + stage.time.late.chronic.ndx[selected][stage[selected] == 3 & cum.time.off.tx[selected] > early.chronic.part.int] <- stage.time[selected][stage[selected] == 3 & + cum.time.off.tx[selected] > early.chronic.part.int] - + early.chronic.part.int + stage.time.aids.ndx[selected][stage[selected] == 4] <- stage.time[selected][stage[selected] == 4] + + # Assign time spent in earlier stages for those initialized into later stages + stage.time.ar.ndx[selected][stage[selected] %in% c(2, 3, 4)] <- vlar.int + stage.time.af.ndx[selected][stage[selected] %in% c(3, 4)] <- vlaf.int + stage.time.early.chronic.ndx[selected][stage[selected] == 4] <- 52 * 7 + stage.time.late.chronic.ndx[selected][stage[selected] == 4] <- 52 * 3 + tx.status[selected] <- 0 - tx.status[selected][stage[selected] == 3 & cum.time.on.tx[selected] > 0] <- - rbinom(sum(stage[selected] == 3 & cum.time.on.tx[selected] > 0), - 1, prop.time.on.tx.W) + tx.status[selected][stage[selected] == 3 & cum.time.on.tx[selected] > 0] <- rbinom(sum(stage[selected] == 3 & cum.time.on.tx[selected] > 0), + 1, prop.time.on.tx.W) vl[selected] <- (time.since.inf <= vlar.int) * (vlap * time.since.inf / vlar.int) + (time.since.inf > vlar.int) * (time.since.inf <= vlar.int + vlaf.int) * - ((vlsp - vlap) * (time.since.inf - vlar.int) / vlaf.int + vlap) + - (time.since.inf > vlar.int + vlaf.int) * - (time.since.inf <= exp.onset.aids.W) * (vlsp) + - (time.since.inf > exp.onset.aids.W) * - (vlsp + (time.since.inf - exp.onset.aids.W) * vlds) + ((vlsp - vlap) * (time.since.inf - vlar.int) / vlaf.int + vlap) + + (time.since.inf > vlar.int + vlaf.int) * (time.since.inf <= exp.onset.aids.W) * (vlsp) + + (time.since.inf > exp.onset.aids.W) * (vlsp + (time.since.inf - exp.onset.aids.W) * vlds) vl[selected][tx.status[selected] == 1] <- dat$param$vl.part.supp # Implement diagnosis for both selected <- which(status == 1 & tt.traj == 3) if (dat$param$testing.pattern == "interval") { - ttntest <- ceiling(runif(length(selected), - min = 0, + ttntest <- ceiling(runif(length(selected), min = 0, max = dat$param$mean.test.B.int * (race[selected] == "B") + dat$param$mean.test.W.int * (race[selected] == "W"))) } if (dat$param$testing.pattern == "memoryless") { - ttntest <- rgeom(length(selected), - 1 / (dat$param$mean.test.B.int * (race[selected] == "B") + - dat$param$mean.test.W.int * (race[selected] == "W"))) + ttntest <- rgeom(length(selected), 1 / (dat$param$mean.test.B.int * (race[selected] == "B") + + dat$param$mean.test.W.int * (race[selected] == "W"))) } diag.status[selected][ttntest > cum.time.off.tx[selected] - twind.int] <- 0 last.neg.test[selected][ttntest > cum.time.off.tx[selected] - twind.int] <- - -ttntest[ttntest > cum.time.off.tx[selected] - twind.int] + -ttntest[ttntest > cum.time.off.tx[selected] - twind.int] diag.status[selected][ttntest <= cum.time.off.tx[selected] - twind.int] <- 1 diag.status[selected][cum.time.on.tx[selected] > 0] <- 1 @@ -647,22 +651,37 @@ init_status_msm <- function(dat) { selected <- which(status == 0 & tt.traj %in% c(2, 3, 4)) if (dat$param$testing.pattern == "interval") { - tslt <- ceiling(runif(length(selected), - min = 0, + tslt <- ceiling(runif(length(selected), min = 0, max = dat$param$mean.test.B.int * (race[selected] == "B") + dat$param$mean.test.W.int * (race[selected] == "W"))) } if (dat$param$testing.pattern == "memoryless") { - tslt <- rgeom(length(selected), - 1 / (dat$param$mean.test.B.int * (race[selected] == "B") + - dat$param$mean.test.W.int * (race[selected] == "W"))) + tslt <- rgeom(length(selected), 1 / (dat$param$mean.test.B.int * (race[selected] == "B") + + dat$param$mean.test.W.int * (race[selected] == "W"))) } last.neg.test[selected] <- -tslt ## Set all onto dat$attr + dat$attr$time.hivneg <- rep(0, num) + dat$attr$time.on.prep <- rep(0, num) + dat$attr$time.off.prep <- rep(0, num) dat$attr$stage <- stage dat$attr$stage.time <- stage.time + dat$attr$stage.time.ar.ndx <- stage.time.ar.ndx + dat$attr$stage.time.ar.dx <- rep(0, num) + dat$attr$stage.time.af.ndx <- stage.time.af.ndx + dat$attr$stage.time.af.dx <- rep(0, num) + dat$attr$stage.time.early.chronic.ndx <- stage.time.early.chronic.ndx + dat$attr$stage.time.early.chronic.dx.yrone <- rep(0, num) + dat$attr$stage.time.early.chronic.dx.yrstwotolate <- rep(0, num) + dat$attr$stage.time.early.chronic.art <- rep(0, num) + dat$attr$stage.time.late.chronic.ndx <- stage.time.late.chronic.ndx + dat$attr$stage.time.late.chronic.dx <- rep(0, num) + dat$attr$stage.time.late.chronic.art <- rep(0, num) + dat$attr$stage.time.aids.ndx <- stage.time.aids.ndx + dat$attr$stage.time.aids.dx <- rep(0, num) + dat$attr$stage.time.aids.art <- rep(0, num) dat$attr$inf.time <- inf.time dat$attr$vl <- vl dat$attr$diag.status <- diag.status @@ -672,18 +691,375 @@ init_status_msm <- function(dat) { dat$attr$tx.init.time <- tx.init.time dat$attr$cum.time.on.tx <- cum.time.on.tx dat$attr$cum.time.off.tx <- cum.time.off.tx - dat$attr$infector <- infector dat$attr$inf.role <- inf.role dat$attr$inf.type <- inf.type - dat$attr$inf.diag <- inf.diag - dat$attr$inf.tx <- inf.tx - dat$attr$inf.stage <- inf.stage + return(dat) } + +#' @title Initialize the STI status of persons in the network +#' +#' @description Sets the initial individual-level disease status of persons +#' in the network, as well as disease-related attributes for +#' infected persons. +#' +#' @param dat Data object created in initialization module. +#' +#' @export +#' @keywords initiation utility msm STI syphilis GC CT +#' +init_status_sti_msm <- function(dat) { + + ## Initial values and attributes ------------------------------------------- + + num.B <- dat$init$num.B + num.W <- dat$init$num.W + num <- num.B + num.W + ids.B <- which(dat$attr$race == "B") + ids.W <- which(dat$attr$race == "W") + age <- dat$attr$age + role.class <- dat$attr$role.class + + # Infection Status + nInfsyphB <- round(dat$init$prev.syph.B * num.B) + nInfsyphW <- round(dat$init$prev.syph.W * num.W) + + # Syphilis stage-specific starting prevalence (among cases) + stage.syph.B.prob <- dat$init$stage.syph.B.prob + stage.syph.W.prob <- dat$init$stage.syph.W.prob + + if (dat$param$race.method == 1) { + stage.syph.B.prob = (stage.syph.B.prob + stage.syph.W.prob)/2 + stage.syph.W.prob = (stage.syph.B.prob + stage.syph.W.prob)/2 + } + + # Infection-related attributes + # Syphilis + syphilis <- rep(0, num) + syph.infTime <- rep(NA, num) + last.syph.infTime <- rep(NA, num) + stage.syph <- rep(NA, num) + stage.time.syph <- rep(NA, num) + diag.status.syph <- rep(NA, num) + last.diag.time.syph <- rep(NA, num) + last.neg.test.syph <- rep(NA, num) + last.tx.time.syph <- rep(NA, num) + last.tx.time.syph.prep <- rep(NA, num) + syph.incub.tx <- rep(NA, num) + syph.prim.tx <- rep(NA, num) + syph.seco.tx <- rep(NA, num) + syph.earlat.tx <- rep(NA, num) + syph.latelat.tx <- rep(NA, num) + syph.tert.tx <- rep(NA, num) + syph.tx.prep <- rep(NA, num) + syph.sympt <- rep(NA, num) + + # Gonorrhea + uGC <- rep(0, num) + rGC <- rep(0, num) + rGC.infTime <- rep(NA, num) + uGC.infTime <- rep(NA, num) + last.rGC.infTime <- rep(NA, num) + last.uGC.infTime <- rep(NA, num) + rGC.sympt <- rep(NA, num) + uGC.sympt <- rep(NA, num) + diag.status.gc <- rep(NA, num) + last.diag.time.gc <- rep(NA, num) + last.neg.test.rgc <- rep(NA, num) + last.neg.test.ugc <- rep(NA, num) + last.tx.time.rgc <- rep(NA, num) + last.tx.time.ugc <- rep(NA, num) + last.tx.time.rgc.prep <- rep(NA, num) + last.tx.time.ugc.prep <- rep(NA, num) + + # Chlamydia + uCT <- rep(0, num) + rCT <- rep(0, num) + rCT.infTime <- rep(NA, num) + uCT.infTime <- rep(NA, num) + last.rCT.infTime <- rep(NA, num) + last.uCT.infTime <- rep(NA, num) + rCT.sympt <- rep(NA, num) + uCT.sympt <- rep(NA, num) + diag.status.ct <- rep(NA, num) + last.diag.time.ct <- rep(NA, num) + last.neg.test.rct <- rep(NA, num) + last.neg.test.uct <- rep(NA, num) + last.tx.time.rct <- rep(NA, num) + last.tx.time.uct <- rep(NA, num) + last.tx.time.rct.prep <- rep(NA, num) + last.tx.time.uct.prep <- rep(NA, num) + + # Syphilis infection parameters + incu.syph.int <- dat$param$incu.syph.int + prim.syph.int <- dat$param$prim.syph.int + seco.syph.int <- dat$param$seco.syph.int + earlat.syph.int <- dat$param$earlat.syph.int + latelat.syph.int <- dat$param$latelat.syph.int + + # Testing attributes + recentpartners <- rep(0, num) + time.sex.active <- pmax(1, round((365 / dat$param$time.unit) * age - + (365 / dat$param$time.unit) * min(dat$init$ages), 0)) + + selected <- which(dat$attr$race %in% c("B", "W")) + tslastsyphtest <- ceiling(runif(length(selected), max = (dat$param$stitest.active.int - 2))) + tslastcttest <- tslastgctest <- ceiling(runif(length(selected), max = (dat$param$stitest.active.int - 2))) + + ## Syphilis ---------------------------------------------------------------- + + # Infection status for syphilis + while (sum(syphilis[ids.B]) != nInfsyphB) { + syphilis[ids.B] <- rbinom(num.B, 1, dat$init$prev.syph.B) + } + while (sum(syphilis[ids.W]) != nInfsyphW) { + syphilis[ids.W] <- rbinom(num.W, 1, dat$init$prev.syph.W) + } + + inf.ids.B <- intersect(ids.B, which(syphilis == 1)) + inf.ids.W <- intersect(ids.W, which(syphilis == 1)) + inf.ids <- c(inf.ids.B, inf.ids.W) + + # Stage of syphilis infection + if (length(inf.ids.B) > 0 ) { + stage.syph[inf.ids.B] <- sample(apportion_lr(length(inf.ids.B), c(1, 2, 3, 4, 5, 6), stage.syph.B.prob)) + } + if (length(inf.ids.W) > 0) { + stage.syph[inf.ids.W] <- sample(apportion_lr(length(inf.ids.W), c(1, 2, 3, 4, 5, 6), stage.syph.W.prob)) + } + # Assign duration of untreated infection and symptomatic at beginning + # Incubating + selected <- intersect(inf.ids, which(stage.syph == 1)) + syph.sympt[selected] <- rbinom(length(selected), 1, dat$param$syph.incub.sympt.prob) + max.inf.time <- pmin(time.sex.active[selected], dat$param$incu.syph.int) + time.in.incub.syph <- ceiling(runif(length(selected), max = max.inf.time)) + stage.time.syph[selected] <- time.in.incub.syph + syph.infTime[selected] <- last.syph.infTime[selected] <- 1 - time.in.incub.syph + + # Primary + selected <- intersect(inf.ids, which(stage.syph == 2)) + syph.sympt[selected] <- rbinom(length(selected), 1, dat$param$syph.prim.sympt.prob) + max.inf.time <- pmin(time.sex.active[selected], dat$param$prim.syph.int) + time.in.prim.syph <- ceiling(runif(length(selected), max = max.inf.time)) + stage.time.syph[selected] <- time.in.prim.syph + syph.infTime[selected] <- last.syph.infTime[selected] <- 1 - time.in.prim.syph - incu.syph.int + + # Secondary + selected <- intersect(inf.ids, which(stage.syph == 3)) + syph.sympt[selected] <- rbinom(length(selected), 1, dat$param$syph.seco.sympt.prob) + max.inf.time <- pmin(time.sex.active[selected], dat$param$seco.syph.int) + time.in.seco.syph <- ceiling(runif(length(selected), max = max.inf.time)) + stage.time.syph[selected] <- time.in.seco.syph + syph.infTime[selected] <- last.syph.infTime[selected] <- 1 - time.in.seco.syph - prim.syph.int - incu.syph.int + + # Early latent + selected <- intersect(inf.ids, which(stage.syph == 4)) + syph.sympt[selected] <- rbinom(length(selected), 1, dat$param$syph.earlat.sympt.prob) + max.inf.time <- pmin(time.sex.active[selected], dat$param$earlat.syph.int) + time.in.earlat.syph <- ceiling(runif(length(selected), max = max.inf.time)) + stage.time.syph[selected] <- time.in.earlat.syph + syph.infTime[selected] <- last.syph.infTime[selected] <- 1 - time.in.earlat.syph - seco.syph.int - + prim.syph.int - incu.syph.int + + # Late latent + selected <- intersect(inf.ids, which(stage.syph == 5)) + syph.sympt[selected] <- rbinom(length(selected), 1, dat$param$syph.latelat.sympt.prob) + max.inf.time <- pmin(time.sex.active[selected], dat$param$latelat.syph.int) + time.in.latelat.syph <- ceiling(runif(length(selected), max = max.inf.time)) + stage.time.syph[selected] <- time.in.latelat.syph + syph.infTime[selected] <- last.syph.infTime[selected] <- 1 - time.in.latelat.syph - earlat.syph.int - + seco.syph.int - prim.syph.int - incu.syph.int + + # Tertiary + selected <- intersect(inf.ids, which(stage.syph == 6)) + syph.sympt[selected] <- rbinom(length(selected), 1, dat$param$syph.tert.sympt.prob) + max.inf.time <- pmin(time.sex.active[selected], dat$param$tert.syph.int) + time.in.tert.syph <- ceiling(runif(length(selected), max = max.inf.time)) + stage.time.syph[selected] <- time.in.tert.syph + syph.infTime[selected] <- last.syph.infTime[selected] <- 1 - time.in.tert.syph - latelat.syph.int - + earlat.syph.int - seco.syph.int - prim.syph.int - + incu.syph.int + + # Set diagnosis status for syphilis + diag.status.syph[syphilis == 1] <- 0 + + ## Gonorrhea (GC) ---------------------------------------------------------- + idsUreth <- which(role.class %in% c("I", "V")) + idsRect <- which(role.class %in% c("R", "V")) + + # Initialize GC infection at both sites + idsUGC <- sample(idsUreth, size = round(dat$init$prev.ugc * num), FALSE) + uGC[idsUGC] <- 1 + + idsRGC <- sample(setdiff(idsRect, idsUGC), size = round(dat$init$prev.rgc * num), FALSE) + rGC[idsRGC] <- 1 + + rGC.sympt[rGC == 1] <- rbinom(sum(rGC == 1), 1, dat$param$rgc.sympt.prob) + uGC.sympt[uGC == 1] <- rbinom(sum(uGC == 1), 1, dat$param$ugc.sympt.prob) + + rGC.infTime[rGC == 1] <- last.rGC.infTime[rGC == 1] <- 1 + uGC.infTime[uGC == 1] <- last.uGC.infTime[uGC == 1] <- 1 + + diag.status.gc[uGC == 1 | rGC == 1] <- 0 + + ## Chlamydia (CT) ---------------------------------------------------------- + idsUreth <- which(role.class %in% c("I", "V")) + idsRect <- which(role.class %in% c("R", "V")) + + idsUCT <- sample(idsUreth, size = round(dat$init$prev.uct * num), FALSE) + uCT[idsUCT] <- 1 + + idsRCT <- sample(setdiff(idsRect, idsUCT), size = + round(dat$init$prev.rct * num), FALSE) + rCT[idsRCT] <- 1 + + rCT.sympt[rCT == 1] <- rbinom(sum(rCT == 1), 1, dat$param$rct.sympt.prob) + uCT.sympt[uCT == 1] <- rbinom(sum(uCT == 1), 1, dat$param$uct.sympt.prob) + + rCT.infTime[rCT == 1] <- last.rCT.infTime[rCT == 1] <- 1 + uCT.infTime[uCT == 1] <- last.uCT.infTime[uCT == 1] <- 1 + + diag.status.ct[uCT == 1 | rCT == 1] <- 0 + + ## Set all attributes onto dat$attr --------------------------------------- + + # Syphilis + dat$attr$syphilis <- syphilis + dat$attr$syph.timesInf <- rep(0, num) + dat$attr$syph.timesInf[syphilis == 1] <- 1 + dat$attr$stage.syph <- stage.syph + dat$attr$stage.time.syph <- stage.time.syph + dat$attr$diag.status.syph <- diag.status.syph + dat$attr$syph.infTime <- syph.infTime + dat$attr$last.syph.infTime <- last.syph.infTime + dat$attr$last.syph.recovTime <- rep(NA, num) + dat$attr$syph.sympt <- syph.sympt + dat$attr$last.neg.test.syph <- last.neg.test.syph + dat$attr$last.diag.time.syph <- last.diag.time.syph + dat$attr$syph.incub.tx <- syph.incub.tx + dat$attr$syph.prim.tx <- syph.prim.tx + dat$attr$syph.seco.tx <- syph.seco.tx + dat$attr$syph.earlat.tx <- syph.earlat.tx + dat$attr$syph.latelat.tx <- syph.latelat.tx + dat$attr$syph.tert.tx <- syph.tert.tx + dat$attr$syph.tx.prep <- syph.tx.prep + dat$attr$last.tx.time.syph <- last.tx.time.syph + dat$attr$last.tx.time.syph.prep <- last.tx.time.syph.prep + dat$attr$tt.traj.syph.hivpos <- rep(NA, num) + dat$attr$tt.traj.syph.hivneg <- rep(NA, num) + dat$attr$time.since.last.test.syph <- tslastsyphtest + dat$attr$testing.events.syph <- rep(0, num) + dat$attr$testing.events.syph.asympt <- rep(0, num) + + # Gonorrhea + dat$attr$rGC <- rGC + dat$attr$uGC <- uGC + dat$attr$rGC.timesInf <- rep(0, num) + dat$attr$rGC.timesInf[rGC == 1] <- 1 + dat$attr$uGC.timesInf <- rep(0, num) + dat$attr$uGC.timesInf[uGC == 1] <- 1 + dat$attr$diag.status.gc <- diag.status.gc + dat$attr$rGC.infTime <- rGC.infTime + dat$attr$uGC.infTime <- uGC.infTime + dat$attr$last.rGC.infTime <- last.rGC.infTime + dat$attr$last.uGC.infTime <- last.uGC.infTime + dat$attr$last.rGC.recovTime <- rep(NA, num) + dat$attr$last.uGC.recovTime <- rep(NA, num) + dat$attr$rGC.sympt <- rGC.sympt + dat$attr$uGC.sympt <- uGC.sympt + dat$attr$last.neg.test.rgc <- last.neg.test.rgc + dat$attr$last.neg.test.ugc <- last.neg.test.ugc + dat$attr$last.diag.time.gc <- last.diag.time.gc + dat$attr$rGC.tx <- rep(NA, num) + dat$attr$uGC.tx <- rep(NA, num) + dat$attr$rGC.tx.prep <- rep(NA, num) + dat$attr$uGC.tx.prep <- rep(NA, num) + dat$attr$last.tx.time.rgc <- last.tx.time.rgc + dat$attr$last.tx.time.ugc <- last.tx.time.ugc + dat$attr$last.tx.time.rgc.prep <- last.tx.time.rgc.prep + dat$attr$last.tx.time.ugc.prep <- last.tx.time.ugc.prep + dat$attr$tt.traj.gc.hivpos <- rep(NA, num) + dat$attr$tt.traj.gc.hivneg <- rep(NA, num) + dat$attr$time.since.last.test.rgc <- tslastgctest + dat$attr$time.since.last.test.ugc <- tslastgctest + dat$attr$testing.events.rgc <- rep(0, num) + dat$attr$testing.events.rgc.asympt <- rep(0, num) + dat$attr$testing.events.ugc <- rep(0, num) + dat$attr$testing.events.ugc.asympt <- rep(0, num) + dat$attr$testing.events.gc <- rep(0, num) + dat$attr$testing.events.gc.asympt <- rep(0, num) + + # Chlamydia + dat$attr$rCT <- rCT + dat$attr$uCT <- uCT + dat$attr$rCT.timesInf <- rep(0, num) + dat$attr$rCT.timesInf[rCT == 1] <- 1 + dat$attr$uCT.timesInf <- rep(0, num) + dat$attr$uCT.timesInf[uCT == 1] <- 1 + dat$attr$diag.status.ct <- diag.status.ct + dat$attr$rCT.infTime <- rCT.infTime + dat$attr$uCT.infTime <- uCT.infTime + dat$attr$last.rCT.infTime <- last.rCT.infTime + dat$attr$last.uCT.infTime <- last.uCT.infTime + dat$attr$last.rCT.recovTime <- rep(NA, num) + dat$attr$last.uCT.recovTime <- rep(NA, num) + dat$attr$rCT.sympt <- rCT.sympt + dat$attr$uCT.sympt <- uCT.sympt + dat$attr$last.neg.test.rct <- last.neg.test.rct + dat$attr$last.neg.test.uct <- last.neg.test.uct + dat$attr$last.diag.time.ct <- last.diag.time.ct + dat$attr$rCT.tx <- rep(NA, num) + dat$attr$uCT.tx <- rep(NA, num) + dat$attr$rCT.tx.prep <- rep(NA, num) + dat$attr$uCT.tx.prep <- rep(NA, num) + dat$attr$last.tx.time.rct <- last.tx.time.rct + dat$attr$last.tx.time.uct <- last.tx.time.uct + dat$attr$last.tx.time.rct.prep <- last.tx.time.rct.prep + dat$attr$last.tx.time.uct.prep <- last.tx.time.uct.prep + dat$attr$tt.traj.ct.hivpos <- rep(NA, num) + dat$attr$tt.traj.ct.hivneg <- rep(NA, num) + dat$attr$time.since.last.test.rct <- tslastcttest + dat$attr$time.since.last.test.uct <- tslastcttest + dat$attr$testing.events.rct <- rep(0, num) + dat$attr$testing.events.rct.asympt <- rep(0, num) + dat$attr$testing.events.uct <- rep(0, num) + dat$attr$testing.events.uct.asympt <- rep(0, num) + dat$attr$testing.events.ct <- rep(0, num) + dat$attr$testing.events.ct.asympt <- rep(0, num) + + # EPT variables + dat$attr$eptindexElig <- rep(NA, num) + dat$attr$eptindexStat <- rep(NA, num) + dat$attr$eptindexEligdate <- rep(NA, num) + dat$attr$eptpartEligReceive <- rep(NA, num) + dat$attr$eptpartEligTx_GC <- rep(NA, num) + dat$attr$eptpartEligTx_CT <- rep(NA, num) + dat$attr$eptpartEligTxdate <- rep(NA, num) + dat$attr$eptpartTx <- rep(NA, num) + dat$attr$rCT.tx.ept <- rep(NA, num) + dat$attr$uCT.tx.ept <- rep(NA, num) + dat$attr$rGC.tx.ept <- rep(NA, num) + dat$attr$uGC.tx.ept <- rep(NA, num) + + # Testing variables + dat$attr$time.last.sex <- rep(NA, num) + dat$attr$recentpartners <- recentpartners + dat$attr$stianntestLastElig <- rep(NA, num) + dat$attr$stihighrisktestLastElig <- rep(NA, num) + dat$attr$stitest.ind.active <- rep(0, num) + dat$attr$stitest.ind.recentpartners <- rep(0, num) + dat$attr$testing.events.sti <- rep(0, num) + dat$attr$testing.events.sti.asympt <- rep(0, num) + + return(dat) + +} + + #' @title Sets the CCR5 genetic status of persons #' #' @description Initializes the CCR5-delta-32 genetic allele of the men in the @@ -788,6 +1164,10 @@ reinit_msm <- function(x, param, init, control, s) { s <- 1 } + if (length(x$el) > 1) { + s <- round(runif(1, min = 1, max = length(x$attr)), 0) + } + dat <- list() dat$param <- param @@ -812,6 +1192,34 @@ reinit_msm <- function(x, param, init, control, s) { dat$temp <- x$temp[[s]] + # If adding new statistics at follow-up in prevalence module (gets overwritten) + #dat <- prevalence_msm(dat, at = 5201) + + # Add times inf (temporary) + if (is.null(dat$epi$gc.timesInf)) { + + rGC.timesInf <- rep(0, length(dat$attr$active)) + uGC.timesInf <- rep(0, length(dat$attr$active)) + rCT.timesInf <- rep(0, length(dat$attr$active)) + uCT.timesInf <- rep(0, length(dat$attr$active)) + + rGC.timesInf[which(dat$attr$rGC == 1)] <- 1 + uGC.timesInf[which(dat$attr$uGC == 1)] <- 1 + rCT.timesInf[which(dat$attr$rCT == 1)] <- 1 + uCT.timesInf[which(dat$attr$uCT == 1)] <- 1 + + dat$attr$rGC.timesInf <- rGC.timesInf + dat$attr$uGC.timesInf <- uGC.timesInf + dat$attr$rCT.timesInf <- rCT.timesInf + dat$attr$uCT.timesInf <- uCT.timesInf + + dat$epi$gc.timesInf <- rep(0, dat$control$nsteps) + dat$epi$ct.timesInf <- rep(0, dat$control$nsteps) + dat$epi$sti.timesInf <- rep(0, dat$control$nsteps) + + } + + class(dat) <- "dat" return(dat) } @@ -821,23 +1229,39 @@ reinit_msm <- function(x, param, init, control, s) { # HET ----------------------------------------------------------------- +#' @title Initialization Module +#' +#' @description This function initializes the master \code{dat} object on which +#' data are stored, simulates the initial state of the network, and +#' simulates disease status and other attributes. +#' +#' @param x An \code{EpiModel} object of class \code{\link{netest}}. +#' @param param An \code{EpiModel} object of class \code{\link{param_het}}. +#' @param init An \code{EpiModel} object of class \code{\link{init_het}}. +#' @param control An \code{EpiModel} object of class \code{\link{control_het}}. +#' @param s Simulation number, used for restarting dependent simulations. +#' +#' @return +#' This function returns the updated \code{dat} object with the initialized +#' values for demographics and disease-related variables. +#' +#' @keywords module het +#' #' @export -#' @rdname initialize_msm +#' initialize_het <- function(x, param, init, control, s) { dat <- list() dat$temp <- list() nw <- simulate(x$fit, control = control.simulate.ergm(MCMC.burnin = 1e6)) - dat$el <- list() - dat$el[[1]] <- as.edgelist(nw) + dat$el <- as.edgelist(nw) attributes(dat$el)$vnames <- NULL - p <- tergmLite::stergm_prep(nw, x$formation, x$coef.diss$dissolution, x$coef.form, - x$coef.diss$coef.adj, x$constraints) + p <- tergmLite::stergm_prep(nw, x$formation, x$coef.diss$dissolution, + x$coef.form, x$coef.diss$coef.adj, x$constraints) p$model.form$formula <- NULL p$model.diss$formula <- NULL - dat$p <- list() - dat$p[[1]] <- p + dat$p <- p ## Network Model Parameters dat$nwparam <- list(x[-which(names(x) == "fit")]) @@ -897,9 +1321,9 @@ initialize_het <- function(x, param, init, control, s) { #' @title Reinitialization Module #' -#' @description This function reinitializes the master \code{dat} object on which -#' data are stored, simulates the initial state of the network, and -#' simulates disease status and other attributes. +#' @description This function reinitializes the master \code{dat} object on +#' which data are stored, simulates the initial state of the +#' network, and simulates disease status and other attributes. #' #' @param x An \code{EpiModel} object of class \code{\link{netest}}. #' @param param An \code{EpiModel} object of class \code{\link{param_het}}. @@ -908,51 +1332,28 @@ initialize_het <- function(x, param, init, control, s) { #' @param s Simulation number, used for restarting dependent simulations. #' #' @return -#' This function returns the updated \code{dat} object with the initialized values -#' for demographics and disease-related variables. +#' This function returns the updated \code{dat} object with the initialized +#' values for demographics and disease-related variables. #' #' @keywords module het #' #' @export #' reinit_het <- function(x, param, init, control, s) { - - need.for.reinit <- c("param", "control", "nwparam", "epi", - "attr", "temp", "el", "p") - if (!all(need.for.reinit %in% names(x))) { - stop("x must contain the following elements for restarting: ", - "param, control, nwparam, epi, attr, temp, el, p", - call. = FALSE) - } - - if (length(x$el) == 1) { - s <- 1 - } - dat <- list() - + dat$el <- x$el[[s]] dat$param <- param dat$param$modes <- 1 dat$control <- control dat$nwparam <- x$nwparam - dat$epi <- sapply(x$epi, function(var) var[s]) names(dat$epi) <- names(x$epi) - - dat$el <- x$el[[s]] - dat$p <- x$p[[s]] - dat$attr <- x$attr[[s]] + dat$stats <- list() + dat$stats$nwstats <- x$stats$nwstats[[s]] + dat$temp <- list() - if (!is.null(x$stats)) { - dat$stats <- list() - if (!is.null(x$stats$nwstats)) { - dat$stats$nwstats <- x$stats$nwstats[[s]] - } - } - - dat$temp <- x$temp[[s]] - + dat$param$modes <- 1 class(dat) <- "dat" return(dat) @@ -982,7 +1383,6 @@ initStatus_het <- function(dat) { return(dat) } - initInfTime_het <- function(dat) { status <- dat$attr$status @@ -994,22 +1394,21 @@ initInfTime_het <- function(dat) { inf.time.dist <- dat$init$inf.time.dist if (inf.time.dist == "allacute") { - max.inf.time <- dat$param$vl.acute.topeak + dat$param$vl.acute.toset - infTime[infecteds] <- sample(0:(-max.inf.time), length(infecteds), TRUE) + max.inf.time <- dat$param$vl.acute.topeak + dat$param$vl.acute.toset + infTime[infecteds] <- sample(0:(-max.inf.time), length(infecteds), TRUE) } else { max.inf.time <- dat$init$max.inf.time / dat$param$time.unit if (inf.time.dist == "geometric") { - total.d.rate <- 1/max.inf.time - infTime[infecteds] <- -rgeom(length(infecteds), total.d.rate) + total.d.rate <- 1/max.inf.time + infTime[infecteds] <- -rgeom(length(infecteds), total.d.rate) } if (inf.time.dist == "uniform") { - infTime[infecteds] <- sample(0:(-max.inf.time), length(infecteds), TRUE) + infTime[infecteds] <- sample(0:(-max.inf.time), length(infecteds), TRUE) } } ## Enforce that time infected < age - infTime[infecteds] <- pmax(infTime[infecteds], - 1 - dat$attr$age[infecteds] * (365 / dat$param$time.unit)) + infTime[infecteds] <- pmax(infTime[infecteds], 1 - dat$attr$age[infecteds] * (365 / dat$param$time.unit)) dat$attr$infTime <- infTime @@ -1025,7 +1424,7 @@ initInfTime_het <- function(dat) { initDx_het <- function(dat) { - n <- sum(dat$attr$active == 1) + n <- sum(dat$attr$race %in% c("B", "W")) status <- dat$attr$status dxStat <- rep(NA, n) @@ -1044,7 +1443,7 @@ initTx_het <- function(dat) { ## Variables status <- dat$attr$status - n <- sum(dat$attr$active == 1) + n <- sum(dat$attr$race %in% c("B", "W")) nInf <- sum(status == 1) tx.init.cd4.mean <- dat$param$tx.init.cd4.mean diff --git a/R/mod.part.R b/R/mod.part.R new file mode 100644 index 00000000..dfbe5f81 --- /dev/null +++ b/R/mod.part.R @@ -0,0 +1,115 @@ + +#' @title Partnership tracking Module +#' +#' @description Module function for tracking partnerships for STD testing +#' and EPT. +#' +#' @inheritParams aging_msm +#' +#' @details +#' Partnerships are tracked in a persistent edge list that allows for easy +#' reference to determine if a participant has been in a particular type of +#' relationship within a defined time frame infected; or post diagnosis for +#' one recently infected. The rates of disclosure vary at these three points, +#' and also by the partnership type. +#' +#' @return +#' This function returns the \code{dat} object with the updated master +#' partnership list, on \code{temp$part.list}. +#' +#' @keywords module msm +#' @export +#' +part_msm <- function(dat, at){ + + if (at < dat$param$partlist.start) { + return(dat) + } + + # Cycle through three partnership types + for (type in 1:3) { + + # Variables ----------------------------------------------------------- + + # Attributes + uid <- dat$attr$uid + + # Parameters and network + part.int <- dat$param$riskhist.int + + # pull edgelist, expressed as uid + el <- dat$el[[type]] + el <- matrix(uid[el], ncol = 2) + + + # Processes ----------------------------------------------------------- + + # STI tracking - start with existing edge list + highlow <- el[which(el[, 1] > el[, 2]), , drop = FALSE] + lowhigh <- el[which(el[, 1] < el[, 2]), , drop = FALSE] + part.el <- rbind(highlow[, 2:1], lowhigh) + + # Check for not already in partnership list + part.list <- dat$temp$part.list + part.list <- part.list[which(part.list[, "ptype"] == type), , drop = FALSE] + + exist.partel.ids <- part.list[, 1] * 1e7 + part.list[, 2] + check.partel.ids <- part.el[, 1] * 1e7 + part.el[, 2] + new.part.ids <- which(!(check.partel.ids %in% exist.partel.ids)) + + # matrix of dyads not yet in cumulative edgelist + new.part.el <- part.el[new.part.ids, , drop = FALSE] + + # Write output + if (nrow(new.part.el) > 0) { + new.part <- cbind(uid1 = new.part.el[, 1], + uid2 = new.part.el[, 2], + ptype = type, + start.time = at, + last.active.time = at, + end.time = NA) + + if (type %in% 1:2) { + # Dissolved dyads: in part.list but not in part.el *that have not already ended* + diss.part.ids <- which(!(exist.partel.ids %in% check.partel.ids)) + toUpdate <- intersect(diss.part.ids, which(is.na(part.list[, "end.time"]))) + part.list[toUpdate, "end.time"] <- at + + # Active dyads: end.time is now or have no end.time yet + # For those, set last.active.time to now + last.active.now <- which(part.list[, "end.time"] == at | + is.na(part.list[, "end.time"])) + part.list[last.active.now, "last.active.time"] <- at + } + + if (type == 3) { + # Set end.time for all one-offs to now (last active time already set) + new.part[, "end.time"] <- at + + # Newly re-active one-offs: of those in current EL, also in existing PL + # For those, reset last.active.time and end.time to now + update.oneoff.ids <- (exist.partel.ids %in% check.partel.ids) + if (sum(update.oneoff.ids) > 0) { + part.list[update.oneoff.ids, c("last.active.time", "end.time")] <- at + } + } + + # Bind old PL and new PL + part.list <- rbind(part.list, new.part) + } + + # Update PL on dat$temp + toRemove <- dat$temp$part.list[, "ptype"] == type + dat$temp$part.list <- dat$temp$part.list[!toRemove, ] + dat$temp$part.list <- rbind(dat$temp$part.list, part.list) + } + + # Subset PL to current observation window + if (at > (dat$param$partlist.start)) { + toKeep <- which((at - (dat$temp$part.list[, "last.active.time"]) <= part.int)) + # toDrop <- which((at - (dat$temp$part.list[, "last.active.time"]) > part.int)) + dat$temp$part.list <- dat$temp$part.list[toKeep, , drop = FALSE] + } + + return(dat) +} diff --git a/R/mod.position.R b/R/mod.position.R index 5c24aea5..39e20771 100644 --- a/R/mod.position.R +++ b/R/mod.position.R @@ -15,8 +15,8 @@ #' determined stochastically for each act. #' #' @return -#' This function returns the updated discordant edgelist with a \code{ins} -#' attribute for values of whether the infected node is insertive or the +#' This function returns the updated act list with a \code{ins} +#' attribute for values of whether the node is insertive or the #' susceptible node is insertive for that act. #' #' @keywords module msm diff --git a/R/mod.prep.R b/R/mod.prep.R index fb97b5c6..926dfc6d 100644 --- a/R/mod.prep.R +++ b/R/mod.prep.R @@ -13,6 +13,27 @@ prep_msm <- function(dat, at) { if (at < dat$param$prep.start) { + + # Update # of PrEP asymptomatic STI tests to 0 + dat$epi$rGCasympttests.prep[at] <- 0 + dat$epi$uGCasympttests.prep[at] <- 0 + dat$epi$GCasympttests.prep[at] <- 0 + dat$epi$rGCasympttests.pos.prep[at] <- 0 + dat$epi$uGCasympttests.pos.prep[at] <- 0 + dat$epi$GCasympttests.pos.prep[at] <- 0 + + dat$epi$rCTasympttests.prep[at] <- 0 + dat$epi$uCTasympttests.prep[at] <- 0 + dat$epi$CTasympttests.prep[at] <- 0 + dat$epi$rCTasympttests.pos.prep[at] <- 0 + dat$epi$uCTasympttests.pos.prep[at] <- 0 + dat$epi$CTasympttests.pos.prep[at] <- 0 + + dat$epi$syphasympttests.prep[at] <- 0 + dat$epi$syphasympttests.pos.prep[at] <- 0 + dat$epi$syphearlyasympttests.pos.prep[at] <- 0 + dat$epi$syphlateasympttests.pos.prep[at] <- 0 + return(dat) } @@ -20,8 +41,19 @@ prep_msm <- function(dat, at) { # Attributes active <- dat$attr$active + race <- dat$attr$race status <- dat$attr$status diag.status <- dat$attr$diag.status + diag.status.syph <- dat$attr$diag.status.syph + diag.status.gc <- dat$attr$diag.status.gc + diag.status.ct <- dat$attr$diag.status.ct + tst.rect.sti.rr <- dat$param$tst.rect.sti.rr + rGC <- dat$attr$rGC + uGC <- dat$attr$uGC + rCT <- dat$attr$rCT + uCT <- dat$attr$uCT + syphilis <- dat$attr$syphilis + stage.syph <- dat$attr$stage.syph lnt <- dat$attr$last.neg.test prepElig <- dat$attr$prepElig prepStat <- dat$attr$prepStat @@ -29,6 +61,9 @@ prep_msm <- function(dat, at) { prepLastRisk <- dat$attr$prepLastRisk prepStartTime <- dat$attr$prepStartTime prepLastStiScreen <- dat$attr$prepLastStiScreen + prep.tst.int <- dat$param$prep.tst.int + time.on.prep <- dat$attr$time.on.prep + # Parameters @@ -36,11 +71,31 @@ prep_msm <- function(dat, at) { prep.cov.rate <- dat$param$prep.cov.rate prep.class.prob <- dat$param$prep.class.prob + if (at == dat$param$prep.start) { + dat$attr$time.hivneg[status == 0] <- 0 + dat$attr$time.off.prep[status == 0] <- 0 + dat$attr$stage.time[status == 1] <- 0 + dat$attr$stage.time.ar.ndx[status == 1] <- 0 + dat$attr$stage.time.ar.dx[status == 1] <- 0 + dat$attr$stage.time.af.ndx[status == 1] <- 0 + dat$attr$stage.time.af.dx[status == 1] <- 0 + dat$epi$stage.time.early.chronic.ndx[status == 1] <- 0 + dat$epi$stage.time.early.chronic.dx.yrone[status == 1] <- 0 + dat$epi$stage.time.early.chronic.dx.yrstwotolate[status == 1] <- 0 + dat$epi$stage.time.early.chronic.art[status == 1] <- 0 + dat$epi$stage.time.late.chronic.ndx[status == 1] <- 0 + dat$epi$stage.time.late.chronic.dx[status == 1] <- 0 + dat$epi$stage.time.late.chronic.art[status == 1] <- 0 + dat$attr$stage.time.aids.ndx[status == 1] <- 0 + dat$attr$stage.time.aids.dx[status == 1] <- 0 + dat$attr$stage.time.aids.art[status == 1] <- 0 + + } ## Eligibility --------------------------------------------------------------- # Base eligibility - idsEligStart <- which(active == 1 & status == 0 & prepStat == 0 & lnt == at) + idsEligStart <- which(status == 0 & prepStat == 0 & lnt == at) # Core eligiblity ind1 <- dat$attr$prep.ind.uai.mono @@ -56,10 +111,10 @@ prep_msm <- function(dat, at) { prepElig[idsEligStart] <- 1 - ## Stoppage ------------------------------------------------------------------ + ## Stoppage ----------------------------------------------------------------- # No indications - idsRiskAssess <- which(active == 1 & prepStat == 1 & lnt == at & (at - prepLastRisk) >= 52) + idsRiskAssess <- which(prepStat == 1 & lnt == at & (at - prepLastRisk) >= 52) prepLastRisk[idsRiskAssess] <- at idsEligStop <- intersect(which(ind1 < twind & ind2 < twind & @@ -69,20 +124,20 @@ prep_msm <- function(dat, at) { prepElig[idsEligStop] <- 0 # Diagnosis - idsStpDx <- which(active == 1 & prepStat == 1 & diag.status == 1) - - # Death - idsStpDth <- which(active == 0 & prepStat == 1) + idsStpDx <- which(prepStat == 1 & diag.status == 1) # Reset PrEP status - idsStp <- c(idsStpDx, idsStpDth, idsEligStop) + idsStp <- c(idsStpDx, idsEligStop) prepStat[idsStp] <- 0 prepLastRisk[idsStp] <- NA prepStartTime[idsStp] <- NA prepLastStiScreen[idsStp] <- NA + # Update time on PrEP after people stop + time.on.prep[prepStat == 1] <- time.on.prep[prepStat == 1] + 1 + - ## Initiation ---------------------------------------------------------------- + ## Initiation --------------------------------------------------------------- prepCov <- sum(prepStat == 1, na.rm = TRUE)/sum(prepElig == 1, na.rm = TRUE) prepCov <- ifelse(is.nan(prepCov), 0, prepCov) @@ -113,8 +168,127 @@ prep_msm <- function(dat, at) { replace = TRUE, prob = prep.class.prob) } + # Update time off PrEP for those not starting PrEP (housed in PrEP module starting at PrEP start time) + if (at > dat$param$prep.start) { + dat$attr$time.off.prep[prepStat == 0] <- + dat$attr$time.off.prep[prepStat == 0] + 1 + } + + ## STI Testing on PrEP ------------------------------------------------------ + + if (is.null(dat$epi$num.asympt.tx)) { + dat$epi$rGCasympttests.prep <- rep(0, length(dat$control$nsteps)) + dat$epi$uGCasympttests.prep <- rep(0, length(dat$control$nsteps)) + dat$epi$GCasympttests.prep <- rep(0, length(dat$control$nsteps)) + dat$epi$rCTasympttests.prep <- rep(0, length(dat$control$nsteps)) + dat$epi$uCTasympttests.prep <- rep(0, length(dat$control$nsteps)) + dat$epi$CTasympttests.prep <- rep(0, length(dat$control$nsteps)) + dat$epi$syphasympttests.prep <- rep(0, length(dat$control$nsteps)) + } - ## Output -------------------------------------------------------------------- + ## Testing + tsincelntst.syph <- at - dat$attr$last.neg.test.syph + tsincelntst.syph[is.na(tsincelntst.syph)] <- at - dat$attr$arrival.time[is.na(tsincelntst.syph)] + + tsincelntst.rgc <- at - dat$attr$last.neg.test.rgc + tsincelntst.ugc <- at - dat$attr$last.neg.test.ugc + tsincelntst.rgc[is.na(tsincelntst.rgc)] <- at - dat$attr$arrival.time[is.na(tsincelntst.rgc)] + tsincelntst.ugc[is.na(tsincelntst.ugc)] <- at - dat$attr$arrival.time[is.na(tsincelntst.ugc)] + tsincelntst.gc <- min(tsincelntst.rgc, tsincelntst.ugc) + + tsincelntst.rct <- at - dat$attr$last.neg.test.rct + tsincelntst.uct <- at - dat$attr$last.neg.test.uct + tsincelntst.rct[is.na(tsincelntst.rct)] <- at - dat$attr$arrival.time[is.na(tsincelntst.rct)] + tsincelntst.uct[is.na(tsincelntst.uct)] <- at - dat$attr$arrival.time[is.na(tsincelntst.uct)] + tsincelntst.ct <- min(tsincelntst.rct, tsincelntst.uct) + + # PrEP STI testing + tst.syph.prep <- which((diag.status.syph == 0 | is.na(diag.status.syph)) & + prepStat == 1 & + tsincelntst.syph >= prep.tst.int) + tst.gc.prep <- which((diag.status.gc == 0 | is.na(diag.status.gc)) & + prepStat == 1 & + tsincelntst.gc >= prep.tst.int) + tst.ct.prep <- which((diag.status.ct == 0 | is.na(diag.status.ct)) & + prepStat == 1 & + tsincelntst.ct >= prep.tst.int) + + # Syphilis PrEP testing + tst.syph.pos <- tst.syph.prep[syphilis[tst.syph.prep] == 1 & stage.syph[tst.syph.prep] %in% c(2, 3, 4, 5, 6)] + tst.syph.neg <- setdiff(tst.syph.prep, tst.syph.pos) + tst.earlysyph.pos <- tst.syph.prep[syphilis[tst.syph.prep] == 1 & stage.syph[tst.syph.prep] %in% c(2, 3, 4)] + tst.latesyph.pos <- tst.syph.prep[syphilis[tst.syph.prep] == 1 & stage.syph[tst.syph.prep] %in% c(5, 6)] + + # GC PrEP testing + tst.rgc <- tst.gc.prep[dat$attr$role.class %in% c("R", "V")] + tst.rgc <- sample(tst.rgc, tst.rect.sti.rr * length(tst.rgc)) + tst.ugc <- tst.gc.prep[dat$attr$role.class %in% c("I", "V")] + tst.rgc.pos <- tst.rgc[rGC == 1] + tst.ugc.pos <- tst.ugc[uGC == 1] + tst.rgc.neg <- setdiff(tst.rgc, tst.rgc.pos) + tst.ugc.neg <- setdiff(tst.ugc, tst.ugc.pos) + tst.gc.pos <- unique(c(tst.rgc.pos, tst.ugc.pos)) + + # CT PrEP testing + tst.rct <- tst.ct.prep[dat$attr$role.class %in% c("R", "V")] + tst.rct <- sample(tst.rct, tst.rect.sti.rr * length(tst.rct)) + tst.uct <- tst.ct.prep[dat$attr$role.class %in% c("I", "V")] + tst.rct.pos <- tst.rct[rCT == 1] + tst.uct.pos <- tst.uct[uCT == 1] + tst.rct.neg <- setdiff(tst.rct, tst.rct.pos) + tst.uct.neg <- setdiff(tst.uct, tst.uct.pos) + tst.ct.pos <- unique(c(tst.rct.pos, tst.uct.pos)) + + # Syphilis Attributes + dat$attr$last.neg.test.syph[tst.syph.neg] <- at + dat$attr$last.neg.test.syph[tst.syph.pos] <- NA + dat$attr$diag.status.syph[tst.syph.pos] <- 1 + dat$attr$last.diag.time.syph[tst.syph.pos] <- at + + # GC Attributes + dat$attr$last.neg.test.rgc[tst.rgc.neg] <- at + dat$attr$last.neg.test.ugc[tst.ugc.neg] <- at + dat$attr$last.neg.test.rgc[tst.rgc.pos] <- NA + dat$attr$last.neg.test.ugc[tst.ugc.pos] <- NA + dat$attr$diag.status.gc[tst.gc.pos] <- 1 + dat$attr$last.diag.time.gc[tst.gc.pos] <- at + + # CT Attributes + dat$attr$last.neg.test.rct[tst.rct.neg] <- at + dat$attr$last.neg.test.uct[tst.uct.neg] <- at + dat$attr$last.neg.test.rct[tst.rct.pos] <- NA + dat$attr$last.neg.test.uct[tst.uct.pos] <- NA + dat$attr$diag.status.ct[tst.ct.pos] <- 1 + dat$attr$last.diag.time.ct[tst.ct.pos] <- at + + # Count number of tests due to PrEP + dat$epi$rGCasympttests.prep[at] <- length(tst.rgc) + dat$epi$uGCasympttests.prep[at] <- length(tst.ugc) + dat$epi$GCasympttests.prep[at] <- length(tst.rgc) + length(tst.ugc) + + dat$epi$rGCasympttests.pos.prep[at] <- length(tst.rgc) + dat$epi$uGCasympttests.pos.prep[at] <- length(tst.ugc) + dat$epi$GCasympttests.pos.prep[at] <- length(tst.rgc.pos) + length(tst.ugc.pos) + + dat$epi$rCTasympttests.prep[at] <- length(tst.rct) + dat$epi$uCTasympttests.prep[at] <- length(tst.uct) + dat$epi$CTasympttests.prep[at] <- length(tst.rct) + length(tst.uct) + + dat$epi$rCTasympttests.pos.prep[at] <- length(tst.rct) + dat$epi$uCTasympttests.pos.prep[at] <- length(tst.uct) + dat$epi$CTasympttests.pos.prep[at] <- + + dat$epi$syphasympttests.prep[at] <- length(tst.syph.prep) + dat$epi$syphasympttests.pos.prep[at] <- length(tst.syph.pos) + dat$epi$syphearlyasympttests.pos.prep[at] <- length(c(tst.earlysyph.pos)) + dat$epi$syphlateasympttests.pos.prep[at] <- length(c(tst.latesyph.pos)) + + dat$epi$stiasympttests.prep[at] <- length(tst.rgc) + length(tst.ugc) + + length(tst.rct) + length(tst.uct) + length(tst.syph.prep) + dat$epi$stiasympttests.pos.prep[at] <- length(tst.rgc.pos) + length(tst.ugc.pos) + + length(tst.rct.pos) + length(tst.uct.pos) + length(tst.syph.pos) + + ## Output ------------------------------------------------------------------- # Attributes dat$attr$prepElig <- prepElig @@ -123,10 +297,14 @@ prep_msm <- function(dat, at) { dat$attr$prepClass <- prepClass dat$attr$prepLastRisk <- prepLastRisk dat$attr$prepLastStiScreen <- prepLastStiScreen + dat$attr$time.on.prep <- time.on.prep # Summary Statistics dat$epi$prepCov[at] <- prepCov dat$epi$prepStart[at] <- length(idsStart) + + + return(dat) } diff --git a/R/mod.prevalence.R b/R/mod.prevalence.R index 6c5e2324..76f9df16 100644 --- a/R/mod.prevalence.R +++ b/R/mod.prevalence.R @@ -1,4 +1,3 @@ - #' @title Prevalence Calculations within Time Steps #' #' @description This module calculates demographic, transmission, and clinical @@ -15,38 +14,536 @@ #' vectors that are not stored external to the module. #' #' @return -#' This function returns the \code{dat} object with an updated summary of current -#' attributes stored in \code{dat$epi}. +#' This function returns the \code{dat} object with an updated summary of +#' current attributes stored in \code{dat$epi}. #' #' @keywords module msm #' #' @export #' -prevalence_msm <- function(dat, at) { +prevalence_msm_ept <- function(dat, at) { ## Variables # Attributes + active <- dat$attr$active + race <- dat$attr$race + status <- dat$attr$status + + rGC <- dat$attr$rGC + uGC <- dat$attr$uGC + rCT <- dat$attr$rCT + uCT <- dat$attr$uCT + syphilis <- dat$attr$syphilis + + tslt.rgc <- dat$attr$time.since.last.test.rgc + tslt.ugc <- dat$attr$time.since.last.test.ugc + tslt.rct <- dat$attr$time.since.last.test.rct + tslt.uct <- dat$attr$time.since.last.test.uct + + diag.status <- dat$attr$diag.status + tt.traj.gc.hivpos <- dat$attr$tt.traj.gc.hivpos + tt.traj.gc.hivneg <- dat$attr$tt.traj.gc.hivneg + tt.traj.ct.hivneg <- dat$attr$tt.traj.ct.hivneg + tt.traj.ct.hivpos <- dat$attr$tt.traj.ct.hivpos + tt.traj.syph.hivpos <- dat$attr$tt.traj.syph.hivpos + tt.traj.syph.hivneg <- dat$attr$tt.traj.syph.hivneg + + # Population sizes and HIV incidence/prevalence + dat$epi$num[at] <- sum(active == 1, na.rm = TRUE) + dat$epi$num.B[at] <- sum(race == "B", na.rm = TRUE) + dat$epi$num.W[at] <- sum(race == "W", na.rm = TRUE) + dat$epi$s.num[at] <- sum(status == 0, na.rm = TRUE) + dat$epi$i.num[at] <- sum(status == 1, na.rm = TRUE) + dat$epi$i.prev[at] <- ifelse(dat$epi$num[at] > 0, dat$epi$i.num[at] / dat$epi$num[at], 0) + dat$epi$ir100[at] <- ifelse(sum(status == 0,dat$epi$incid[at], na.rm = TRUE) > 0, + (dat$epi$incid[at] / + sum(status == 0,dat$epi$incid[at], na.rm = TRUE)) * 5200, 0) + + # STI and Co-infection Prevalence + dat$epi$prev.rgc[at] <- ifelse(dat$epi$num[at] > 0, sum(rGC == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ugc[at] <- ifelse(dat$epi$num[at] > 0, sum(uGC == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.gc[at] <- ifelse(dat$epi$num[at] > 0, sum((rGC == 1 | uGC == 1), na.rm = TRUE) / dat$epi$num[at], 0) + + dat$epi$prev.gc.tttraj1[at] <- ifelse((dat$epi$tt.traj.gc1[at] == 0 | is.na(dat$epi$tt.traj.gc1[at]) + | is.nan(dat$epi$tt.traj.gc1[at]) | is.null(dat$epi$tt.traj.gc1[at])), 0, + sum((rGC == 1 | uGC == 1) & + (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), na.rm = TRUE) / + dat$epi$tt.traj.gc1[at]) + dat$epi$prev.gc.tttraj2[at] <- ifelse((dat$epi$tt.traj.gc2[at] == 0 | is.na(dat$epi$tt.traj.gc2[at]) | + is.nan(dat$epi$tt.traj.gc2[at]) | is.null(dat$epi$tt.traj.gc2[at])), 0 , + sum((rGC == 1 | uGC == 1) & + (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), na.rm = TRUE) / + dat$epi$tt.traj.gc2[at]) + + dat$epi$prev.gcct[at] <- ifelse(dat$epi$num[at] > 0, sum((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1), na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.gcct.tttraj1[at] <- ifelse((dat$epi$tt.traj.gc1[at] == 0 | is.na(dat$epi$tt.traj.gc1[at]) | + is.nan(dat$epi$tt.traj.gc1[at]) | is.null(dat$epi$tt.traj.gc1[at]) | + dat$epi$tt.traj.ct1[at] == 0 | is.na(dat$epi$tt.traj.ct1[at]) | + is.nan(dat$epi$tt.traj.ct1[at]) | is.null(dat$epi$tt.traj.ct1[at])), 0, + sum((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1) & + (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1 | + tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), na.rm = TRUE) / + (dat$epi$tt.traj.gc1[at] + dat$epi$tt.traj.ct1[at])) + dat$epi$prev.gcct.tttraj2[at] <- ifelse((dat$epi$tt.traj.gc2[at] == 0 | is.na(dat$epi$tt.traj.gc2[at]) | + is.nan(dat$epi$tt.traj.gc2[at]) | is.null(dat$epi$tt.traj.gc2[at]) | + dat$epi$tt.traj.ct2[at] == 0 | is.na(dat$epi$tt.traj.ct2[at]) | + is.nan(dat$epi$tt.traj.ct2[at]) | is.null(dat$epi$tt.traj.ct2[at])), 0, + sum((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1) & + (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2 | + tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), na.rm = TRUE) / + (dat$epi$tt.traj.gc2[at] + dat$epi$tt.traj.ct2[at])) + + dat$epi$prev.rct[at] <- ifelse(dat$epi$num[at] > 0, sum(rCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.uct[at] <- ifelse(dat$epi$num[at] > 0, sum(uCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ct[at] <- ifelse(dat$epi$num[at] > 0, sum((rCT == 1 | uCT == 1), na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ct.tttraj1[at] <- ifelse((dat$epi$tt.traj.ct1[at] == 0 | is.na(dat$epi$tt.traj.ct1[at]) | + is.nan(dat$epi$tt.traj.ct1[at]) | is.null(dat$epi$tt.traj.ct1[at])), 0, + sum((rCT == 1 | uCT == 1) & + (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), na.rm = TRUE) / + dat$epi$tt.traj.ct1[at]) + dat$epi$prev.ct.tttraj2[at] <- ifelse((dat$epi$tt.traj.ct2[at] == 0 | is.na(dat$epi$tt.traj.ct2[at]) | + is.nan(dat$epi$tt.traj.ct2[at]) | is.null(dat$epi$tt.traj.ct2[at])), 0, + sum((rCT == 1 | uCT == 1) & + (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), na.rm = TRUE) / + dat$epi$tt.traj.ct2[at]) + + dat$epi$prev.rgcct[at] <- ifelse(dat$epi$num[at] > 0, sum(rGC == 1 | rCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ugcct[at] <- ifelse(dat$epi$num[at] > 0, sum(uGC == 1 | uCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + + + # Site-specific STI incidence rates + # Gonorrhea + dat$epi$ir100.rgc[at] <- ifelse(sum(rGC == 0, dat$epi$incid.rgc[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc[at] / sum(rGC == 0, dat$epi$incid.rgc[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ugc[at] <- ifelse(sum(uGC == 0, dat$epi$incid.ugc[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc[at] / sum(uGC == 0, dat$epi$incid.ugc[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc[at] <- dat$epi$ir100.rgc[at] + dat$epi$ir100.ugc[at] + + ir100.rgc.hivneg <- ifelse(sum(rGC == 0 & status == 0, dat$epi$incid.rgc.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc.hivneg[at] / sum(rGC == 0 & status == 0, dat$epi$incid.rgc.hivneg[at], na.rm = TRUE)) * 5200, 0) + ir100.ugc.hivneg <- ifelse(sum(uGC == 0 & status == 0, dat$epi$incid.ugc.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.hivneg[at] / sum(uGC == 0 & status == 0, dat$epi$incid.ugc.hivneg[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.hivneg[at] <- ir100.rgc.hivneg + ir100.ugc.hivneg + + ir100.rgc.hivpos <- ifelse(sum(rGC == 0 & status == 1, na.rm = TRUE) > 0, + (dat$epi$incid.rgc.hivpos[at] / sum(rGC == 0 & status == 1, na.rm = TRUE)) * 5200, 0) + ir100.ugc.hivpos <- ifelse(sum(uGC == 0 & status == 1, dat$epi$incid.ugc.hivpos[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.hivpos[at] / sum(uGC == 0 & status == 1, dat$epi$incid.ugc.hivpos[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.hivpos[at] <- ir100.rgc.hivpos + ir100.ugc.hivpos + + ir100.rgc.tttraj1 <- ifelse(sum(rGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), dat$epi$incid.rgc.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc.tttraj1[at] / sum(rGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), + dat$epi$incid.rgc.tttraj1[at], na.rm = TRUE)) * 5100, 0) + ir100.ugc.tttraj1 <- ifelse(sum(uGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), dat$epi$incid.ugc.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.tttraj1[at] / sum(uGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), + dat$epi$incid.ugc.tttraj1[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.tttraj1[at] <- ir100.rgc.tttraj1 + ir100.ugc.tttraj1 + + ir100.rgc.tttraj2 <- ifelse(sum(rGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), dat$epi$incid.rgc.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc.tttraj2[at] / sum(rGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), + dat$epi$incid.rgc.tttraj2[at], na.rm = TRUE)) * 5200, 0) + ir100.ugc.tttraj2 <- ifelse(sum(uGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), dat$epi$incid.ugc.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.tttraj2[at] / sum(uGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), + dat$epi$incid.ugc.tttraj2[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.tttraj2[at] <- ir100.rgc.tttraj2 + ir100.ugc.tttraj2 + + # Chlamydia + dat$epi$ir100.rct[at] <- ifelse(sum(rCT == 0, dat$epi$incid.rct[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct[at] / sum(rCT == 0, dat$epi$incid.rct[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.uct[at] <- ifelse(sum(uCT == 0, dat$epi$incid.uct[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct[at] / sum(uCT == 0, dat$epi$incid.uct[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct[at] <- dat$epi$ir100.rct[at] + dat$epi$ir100.uct[at] + + ir100.rct.hivneg <- ifelse(sum(rCT == 0 & status == 0, dat$epi$incid.rct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.hivneg[at] / sum(rCT == 0 & status == 0, dat$epi$incid.rct.hivneg[at], na.rm = TRUE)) * 5200, 0) + ir100.uct.hivneg <- ifelse(sum(uCT == 0 & status == 0, dat$epi$incid.uct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.hivneg[at] / sum(uCT == 0 & status == 0, dat$epi$incid.uct.hivneg[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.hivneg[at] <- ir100.rct.hivneg + ir100.uct.hivneg + + ir100.rct.hivpos <- ifelse(sum(rCT == 0 & status == 1, dat$epi$incid.rct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.hivneg[at] / sum(rCT == 0 & status == 1, dat$epi$incid.rct.hivneg[at], na.rm = TRUE)) * 5200, 0) + ir100.uct.hivpos <- ifelse(sum(uCT == 0 & status == 1, dat$epi$incid.uct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.hivneg[at] / sum(uCT == 0 & status == 1, dat$epi$incid.uct.hivneg[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.hivpos[at] <- ir100.rct.hivpos + ir100.uct.hivpos + + ir100.rct.tttraj1 <- ifelse(sum(rCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), dat$epi$incid.rct.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.tttraj1[at] / sum(rCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), + dat$epi$incid.rct.tttraj1[at], na.rm = TRUE)) * 5100, 0) + ir100.uct.tttraj1 <- ifelse(sum(uCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), dat$epi$incid.uct.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.tttraj1[at] / sum(uCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), + dat$epi$incid.uct.tttraj1[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.tttraj1[at] <- ir100.rct.tttraj1 + ir100.uct.tttraj1 + + ir100.rct.tttraj2 <- ifelse(sum(rCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), dat$epi$incid.rct.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.tttraj2[at] / sum(rCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), + dat$epi$incid.rct.tttraj2[at], na.rm = TRUE)) * 5200, 0) + ir100.uct.tttraj2 <- ifelse(sum(uCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), dat$epi$incid.uct.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.tttraj2[at] / sum(uCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), + dat$epi$incid.uct.tttraj2[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.tttraj2[at] <- ir100.rct.tttraj2 + ir100.uct.tttraj2 + + # dat$epi$ir100.syph[at] <- ifelse(sum(syphilis == 0, dat$epi$incid.syph[at], na.rm = TRUE) > 0, + # (dat$epi$incid.syph[at] / sum(syphilis == 0, dat$epi$incid.syph[at], na.rm = TRUE)) * 5200, 0) + + # Combined GC/CT Incidence + dat$epi$ir100.gcct[at] <- dat$epi$ir100.gc[at] + dat$epi$ir100.ct[at] + dat$epi$ir100.gcct.tttraj1[at] <- dat$epi$ir100.gc.tttraj1[at] + dat$epi$ir100.ct.tttraj1[at] + dat$epi$ir100.gcct.tttraj2[at] <- dat$epi$ir100.gc.tttraj2[at] + dat$epi$ir100.ct.tttraj2[at] + + # All STI Incidence + dat$epi$ir100.sti[at] <- dat$epi$ir100.gc[at] + dat$epi$ir100.ct[at] + dat$epi$ir100.syph[at] + dat$epi$ir100.sti.tttraj1[at] <- dat$epi$ir100.gc.tttraj1[at] + dat$epi$ir100.ct.tttraj1[at] + dat$epi$ir100.syph.tttraj1[at] + dat$epi$ir100.sti.tttraj2[at] <- dat$epi$ir100.gc.tttraj2[at] + dat$epi$ir100.ct.tttraj2[at] + dat$epi$ir100.syph.tttraj2[at] + + # STI Prevalence + dat$epi$prev.sti[at] <- ifelse(sum(rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1 , na.rm = TRUE) > 0, + sum(rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1 , na.rm = TRUE) / dat$epi$num[at], 0) + + dat$epi$prev.sti.tttraj1[at] <- ifelse((dat$epi$tt.traj.sti1[at] == 0 | is.na(dat$epi$tt.traj.sti1[at]) | + is.nan(dat$epi$tt.traj.sti1[at]) | is.null(dat$epi$tt.traj.sti1[at])), 0, + length(which((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1) & + (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1 | + tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1 | + tt.traj.syph.hivneg == 1 | tt.traj.syph.hivpos == 1))) / + dat$epi$tt.traj.sti1[at]) + + dat$epi$prev.sti.tttraj2[at] <- ifelse((dat$epi$tt.traj.sti2[at] == 0 | is.na(dat$epi$tt.traj.sti2[at]) | + is.nan(dat$epi$tt.traj.sti2[at]) | is.null(dat$epi$tt.traj.sti2[at])), 0, + length(which((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1) & + (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2 | + tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2 | + tt.traj.syph.hivneg == 2 | tt.traj.syph.hivpos == 2))) / + dat$epi$tt.traj.sti2[at]) + + # Testing indications + dat$epi$stiactiveind.prop[at] <- dat$epi$stiactiveind[at] / dat$epi$num[at] + dat$epi$recentpartners.prop[at] <- dat$epi$recentpartners[at] / dat$epi$num[at] + + # Testing in last 12 months + # Overall + dat$epi$test.gc.12mo[at] <- length(which(tslt.rgc <= 52 | tslt.ugc <= 52)) / dat$epi$num[at] + dat$epi$test.ct.12mo[at] <- length(which(tslt.rct <= 52 | tslt.uct <= 52)) / dat$epi$num[at] + + # Among those HIV-negative or undiagnosed + dat$epi$test.gc.12mo.nonhivdiag[at] <- length(which((tslt.rgc <= 52 | tslt.ugc <= 52) & + (is.na(diag.status) | diag.status == 0))) / length(which(is.na(diag.status) | diag.status == 0)) + dat$epi$test.ct.12mo.nonhivdiag[at] <- length(which((tslt.rct <= 52 | tslt.uct <= 52) & + (is.na(diag.status) | diag.status == 0))) / length(which(is.na(diag.status) | diag.status == 0)) + # Among those diagnosed + dat$epi$test.gc.12mo.hivdiag[at] <- length(which((tslt.rgc <= 52 | tslt.ugc <= 52) & + diag.status == 1)) / length(which(diag.status == 1)) + dat$epi$test.ct.12mo.hivdiag[at] <- length(which((tslt.rct <= 52 | tslt.uct <= 52) & + diag.status == 1)) / length(which(diag.status == 1)) + + return(dat) +} + +#' @title Prevalence Calculations within Time Steps +#' +#' @description This module calculates demographic, transmission, and clinical +#' statistics at each time step within the simulation. +#' +#' @inheritParams aging_msm +#' +#' @details +#' Summary statistic calculations are of two broad forms: prevalence and +#' incidence. This function establishes the summary statistic vectors for both +#' prevalence and incidence at time 1, and then calculates the prevalence +#' statistics for times 2 onward. Incidence statistics (e.g., number of new +#' infections or deaths) are calculated within the modules as they depend on +#' vectors that are not stored external to the module. +#' +#' @return +#' This function returns the \code{dat} object with an updated summary of +#' current attributes stored in \code{dat$epi}. +#' +#' @keywords module msm +#' +#' @export +#' +prevalence_msm_tnt <- function(dat, at) { + + ## Variables + # Attributes active <- dat$attr$active race <- dat$attr$race status <- dat$attr$status + # prepStat <- dat$attr$prepStat + # prepElig <- dat$attr$prepElig + rGC <- dat$attr$rGC + uGC <- dat$attr$uGC + rCT <- dat$attr$rCT + uCT <- dat$attr$uCT + syphilis <- dat$attr$syphilis + # stage.syph <- dat$attr$stage.syph + # diag.status.syph <- dat$attr$diag.status.syph + # last.diag.time.syph <- dat$attr$last.diag.time.syph + tslt.rgc <- dat$attr$time.since.last.test.rgc + tslt.ugc <- dat$attr$time.since.last.test.ugc + tslt.rct <- dat$attr$time.since.last.test.rct + tslt.uct <- dat$attr$time.since.last.test.uct + # tslt.syph <- dat$attr$time.since.last.test.syph + diag.status <- dat$attr$diag.status + tt.traj.gc.hivpos <- dat$attr$tt.traj.gc.hivpos + tt.traj.gc.hivneg <- dat$attr$tt.traj.gc.hivneg + tt.traj.ct.hivneg <- dat$attr$tt.traj.ct.hivneg + tt.traj.ct.hivpos <- dat$attr$tt.traj.ct.hivpos + tt.traj.syph.hivpos <- dat$attr$tt.traj.syph.hivpos + tt.traj.syph.hivneg <- dat$attr$tt.traj.syph.hivneg + + # nsteps <- dat$control$nsteps + + # Population sizes and HIV incidence/prevalence + dat$epi$num[at] <- sum(active == 1, na.rm = TRUE) + dat$epi$num.B[at] <- sum(race == "B", na.rm = TRUE) + dat$epi$num.W[at] <- sum(race == "W", na.rm = TRUE) + dat$epi$s.num[at] <- sum(status == 0, na.rm = TRUE) + dat$epi$i.num[at] <- sum(status == 1, na.rm = TRUE) + dat$epi$i.prev[at] <- ifelse(dat$epi$num[at] > 0, dat$epi$i.num[at] / dat$epi$num[at], 0) + dat$epi$ir100[at] <- ifelse(sum(status == 0,dat$epi$incid[at], na.rm = TRUE) > 0, + (dat$epi$incid[at] / + sum(status == 0,dat$epi$incid[at], na.rm = TRUE)) * 5200, 0) + + # STI and Co-infection Prevalence + dat$epi$prev.rgc[at] <- ifelse(dat$epi$num[at] > 0, sum(rGC == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ugc[at] <- ifelse(dat$epi$num[at] > 0, sum(uGC == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.gc[at] <- ifelse(dat$epi$num[at] > 0, sum((rGC == 1 | uGC == 1), na.rm = TRUE) / dat$epi$num[at], 0) + + dat$epi$prev.gc.tttraj1[at] <- ifelse((dat$epi$tt.traj.gc1[at] == 0 | is.na(dat$epi$tt.traj.gc1[at]) + | is.nan(dat$epi$tt.traj.gc1[at]) | is.null(dat$epi$tt.traj.gc1[at])), 0, + sum((rGC == 1 | uGC == 1) & + (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), na.rm = TRUE) / + dat$epi$tt.traj.gc1[at]) + dat$epi$prev.gc.tttraj2[at] <- ifelse((dat$epi$tt.traj.gc2[at] == 0 | is.na(dat$epi$tt.traj.gc2[at]) | + is.nan(dat$epi$tt.traj.gc2[at]) | is.null(dat$epi$tt.traj.gc2[at])), 0 , + sum((rGC == 1 | uGC == 1) & + (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), na.rm = TRUE) / + dat$epi$tt.traj.gc2[at]) + + dat$epi$prev.gcct[at] <- ifelse(dat$epi$num[at] > 0, sum((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1), na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.gcct.tttraj1[at] <- ifelse((dat$epi$tt.traj.gc1[at] == 0 | is.na(dat$epi$tt.traj.gc1[at]) | + is.nan(dat$epi$tt.traj.gc1[at]) | is.null(dat$epi$tt.traj.gc1[at]) | + dat$epi$tt.traj.ct1[at] == 0 | is.na(dat$epi$tt.traj.ct1[at]) | + is.nan(dat$epi$tt.traj.ct1[at]) | is.null(dat$epi$tt.traj.ct1[at])), 0, + sum((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1) & + (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1 | + tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), na.rm = TRUE) / + (dat$epi$tt.traj.gc1[at] + dat$epi$tt.traj.ct1[at])) + dat$epi$prev.gcct.tttraj2[at] <- ifelse((dat$epi$tt.traj.gc2[at] == 0 | is.na(dat$epi$tt.traj.gc2[at]) | + is.nan(dat$epi$tt.traj.gc2[at]) | is.null(dat$epi$tt.traj.gc2[at]) | + dat$epi$tt.traj.ct2[at] == 0 | is.na(dat$epi$tt.traj.ct2[at]) | + is.nan(dat$epi$tt.traj.ct2[at]) | is.null(dat$epi$tt.traj.ct2[at])), 0, + sum((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1) & + (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2 | + tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), na.rm = TRUE) / + (dat$epi$tt.traj.gc2[at] + dat$epi$tt.traj.ct2[at])) + + dat$epi$prev.rct[at] <- ifelse(dat$epi$num[at] > 0, sum(rCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.uct[at] <- ifelse(dat$epi$num[at] > 0, sum(uCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ct[at] <- ifelse(dat$epi$num[at] > 0, sum((rCT == 1 | uCT == 1), na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ct.tttraj1[at] <- ifelse((dat$epi$tt.traj.ct1[at] == 0 | is.na(dat$epi$tt.traj.ct1[at]) | + is.nan(dat$epi$tt.traj.ct1[at]) | is.null(dat$epi$tt.traj.ct1[at])), 0, + sum((rCT == 1 | uCT == 1) & + (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), na.rm = TRUE) / + dat$epi$tt.traj.ct1[at]) + dat$epi$prev.ct.tttraj2[at] <- ifelse((dat$epi$tt.traj.ct2[at] == 0 | is.na(dat$epi$tt.traj.ct2[at]) | + is.nan(dat$epi$tt.traj.ct2[at]) | is.null(dat$epi$tt.traj.ct2[at])), 0, + sum((rCT == 1 | uCT == 1) & + (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), na.rm = TRUE) / + dat$epi$tt.traj.ct2[at]) + + dat$epi$prev.rgcct[at] <- ifelse(dat$epi$num[at] > 0, sum(rGC == 1 | rCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ugcct[at] <- ifelse(dat$epi$num[at] > 0, sum(uGC == 1 | uCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + + + # Site-specific STI incidence rates + # Gonorrhea + dat$epi$ir100.rgc[at] <- ifelse(sum(rGC == 0, dat$epi$incid.rgc[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc[at] / sum(rGC == 0, dat$epi$incid.rgc[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ugc[at] <- ifelse(sum(uGC == 0, dat$epi$incid.ugc[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc[at] / sum(uGC == 0, dat$epi$incid.ugc[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc[at] <- dat$epi$ir100.rgc[at] + dat$epi$ir100.ugc[at] + + ir100.rgc.hivneg <- ifelse(sum(rGC == 0 & status == 0, dat$epi$incid.rgc.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc.hivneg[at] / sum(rGC == 0 & status == 0, dat$epi$incid.rgc.hivneg[at], na.rm = TRUE)) * 5200, 0) + ir100.ugc.hivneg <- ifelse(sum(uGC == 0 & status == 0, dat$epi$incid.ugc.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.hivneg[at] / sum(uGC == 0 & status == 0, dat$epi$incid.ugc.hivneg[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.hivneg[at] <- ir100.rgc.hivneg + ir100.ugc.hivneg + + ir100.rgc.hivpos <- ifelse(sum(rGC == 0 & status == 1, na.rm = TRUE) > 0, + (dat$epi$incid.rgc.hivpos[at] / sum(rGC == 0 & status == 1, na.rm = TRUE)) * 5200, 0) + ir100.ugc.hivpos <- ifelse(sum(uGC == 0 & status == 1, dat$epi$incid.ugc.hivpos[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.hivpos[at] / sum(uGC == 0 & status == 1, dat$epi$incid.ugc.hivpos[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.hivpos[at] <- ir100.rgc.hivpos + ir100.ugc.hivpos + + ir100.rgc.tttraj1 <- ifelse(sum(rGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), dat$epi$incid.rgc.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc.tttraj1[at] / sum(rGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), + dat$epi$incid.rgc.tttraj1[at], na.rm = TRUE)) * 5100, 0) + ir100.ugc.tttraj1 <- ifelse(sum(uGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), dat$epi$incid.ugc.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.tttraj1[at] / sum(uGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), + dat$epi$incid.ugc.tttraj1[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.tttraj1[at] <- ir100.rgc.tttraj1 + ir100.ugc.tttraj1 + + ir100.rgc.tttraj2 <- ifelse(sum(rGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), dat$epi$incid.rgc.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc.tttraj2[at] / sum(rGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), + dat$epi$incid.rgc.tttraj2[at], na.rm = TRUE)) * 5200, 0) + ir100.ugc.tttraj2 <- ifelse(sum(uGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), dat$epi$incid.ugc.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.tttraj2[at] / sum(uGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), + dat$epi$incid.ugc.tttraj2[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.tttraj2[at] <- ir100.rgc.tttraj2 + ir100.ugc.tttraj2 + + # Chlamydia + dat$epi$ir100.rct[at] <- ifelse(sum(rCT == 0, dat$epi$incid.rct[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct[at] / sum(rCT == 0, dat$epi$incid.rct[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.uct[at] <- ifelse(sum(uCT == 0, dat$epi$incid.uct[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct[at] / sum(uCT == 0, dat$epi$incid.uct[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct[at] <- dat$epi$ir100.rct[at] + dat$epi$ir100.uct[at] + + ir100.rct.hivneg <- ifelse(sum(rCT == 0 & status == 0, dat$epi$incid.rct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.hivneg[at] / sum(rCT == 0 & status == 0, dat$epi$incid.rct.hivneg[at], na.rm = TRUE)) * 5200, 0) + ir100.uct.hivneg <- ifelse(sum(uCT == 0 & status == 0, dat$epi$incid.uct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.hivneg[at] / sum(uCT == 0 & status == 0, dat$epi$incid.uct.hivneg[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.hivneg[at] <- ir100.rct.hivneg + ir100.uct.hivneg + + ir100.rct.hivpos <- ifelse(sum(rCT == 0 & status == 1, dat$epi$incid.rct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.hivneg[at] / sum(rCT == 0 & status == 1, dat$epi$incid.rct.hivneg[at], na.rm = TRUE)) * 5200, 0) + ir100.uct.hivpos <- ifelse(sum(uCT == 0 & status == 1, dat$epi$incid.uct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.hivneg[at] / sum(uCT == 0 & status == 1, dat$epi$incid.uct.hivneg[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.hivpos[at] <- ir100.rct.hivpos + ir100.uct.hivpos + + ir100.rct.tttraj1 <- ifelse(sum(rCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), dat$epi$incid.rct.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.tttraj1[at] / sum(rCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), + dat$epi$incid.rct.tttraj1[at], na.rm = TRUE)) * 5100, 0) + ir100.uct.tttraj1 <- ifelse(sum(uCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), dat$epi$incid.uct.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.tttraj1[at] / sum(uCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), + dat$epi$incid.uct.tttraj1[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.tttraj1[at] <- ir100.rct.tttraj1 + ir100.uct.tttraj1 + + ir100.rct.tttraj2 <- ifelse(sum(rCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), dat$epi$incid.rct.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.tttraj2[at] / sum(rCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), + dat$epi$incid.rct.tttraj2[at], na.rm = TRUE)) * 5200, 0) + ir100.uct.tttraj2 <- ifelse(sum(uCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), dat$epi$incid.uct.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.tttraj2[at] / sum(uCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), + dat$epi$incid.uct.tttraj2[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.tttraj2[at] <- ir100.rct.tttraj2 + ir100.uct.tttraj2 + + # dat$epi$ir100.syph[at] <- ifelse(sum(syphilis == 0, dat$epi$incid.syph[at], na.rm = TRUE) > 0, + # (dat$epi$incid.syph[at] / sum(syphilis == 0, dat$epi$incid.syph[at], na.rm = TRUE)) * 5200, 0) + + # Combined GC/CT Incidence + dat$epi$ir100.gcct[at] <- dat$epi$ir100.gc[at] + dat$epi$ir100.ct[at] + dat$epi$ir100.gcct.tttraj1[at] <- dat$epi$ir100.gc.tttraj1[at] + dat$epi$ir100.ct.tttraj1[at] + dat$epi$ir100.gcct.tttraj2[at] <- dat$epi$ir100.gc.tttraj2[at] + dat$epi$ir100.ct.tttraj2[at] + + # All STI Incidence + dat$epi$ir100.sti[at] <- dat$epi$ir100.gc[at] + dat$epi$ir100.ct[at] + dat$epi$ir100.syph[at] + dat$epi$ir100.sti.tttraj1[at] <- dat$epi$ir100.gc.tttraj1[at] + dat$epi$ir100.ct.tttraj1[at] + dat$epi$ir100.syph.tttraj1[at] + dat$epi$ir100.sti.tttraj2[at] <- dat$epi$ir100.gc.tttraj2[at] + dat$epi$ir100.ct.tttraj2[at] + dat$epi$ir100.syph.tttraj2[at] + + # STI Prevalence + dat$epi$prev.sti[at] <- ifelse(sum(rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1 , na.rm = TRUE) > 0, + sum(rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1 , na.rm = TRUE) / dat$epi$num[at], 0) + + dat$epi$prev.sti.tttraj1[at] <- ifelse((dat$epi$tt.traj.sti1[at] == 0 | is.na(dat$epi$tt.traj.sti1[at]) | + is.nan(dat$epi$tt.traj.sti1[at]) | is.null(dat$epi$tt.traj.sti1[at])), 0, + length(which((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1) & + (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1 | + tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1 | + tt.traj.syph.hivneg == 1 | tt.traj.syph.hivpos == 1))) / + dat$epi$tt.traj.sti1[at]) + + dat$epi$prev.sti.tttraj2[at] <- ifelse((dat$epi$tt.traj.sti2[at] == 0 | is.na(dat$epi$tt.traj.sti2[at]) | + is.nan(dat$epi$tt.traj.sti2[at]) | is.null(dat$epi$tt.traj.sti2[at])), 0, + length(which((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1) & + (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2 | + tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2 | + tt.traj.syph.hivneg == 2 | tt.traj.syph.hivpos == 2))) / + dat$epi$tt.traj.sti2[at]) + + # Testing indications + dat$epi$stiactiveind.prop[at] <- dat$epi$stiactiveind[at] / dat$epi$num[at] + dat$epi$recentpartners.prop[at] <- dat$epi$recentpartners[at] / dat$epi$num[at] + + # Testing in last 12 months + # Overall + dat$epi$test.gc.12mo[at] <- length(which(tslt.rgc <= 52 | tslt.ugc <= 52)) / dat$epi$num[at] + dat$epi$test.ct.12mo[at] <- length(which(tslt.rct <= 52 | tslt.uct <= 52)) / dat$epi$num[at] + + # Among those HIV-negative or undiagnosed + dat$epi$test.gc.12mo.nonhivdiag[at] <- length(which((tslt.rgc <= 52 | tslt.ugc <= 52) & + (is.na(diag.status) | diag.status == 0))) / length(which(is.na(diag.status) | diag.status == 0)) + dat$epi$test.ct.12mo.nonhivdiag[at] <- length(which((tslt.rct <= 52 | tslt.uct <= 52) & + (is.na(diag.status) | diag.status == 0))) / length(which(is.na(diag.status) | diag.status == 0)) + # Among those diagnosed + dat$epi$test.gc.12mo.hivdiag[at] <- length(which((tslt.rgc <= 52 | tslt.ugc <= 52) & + diag.status == 1)) / length(which(diag.status == 1)) + dat$epi$test.ct.12mo.hivdiag[at] <- length(which((tslt.rct <= 52 | tslt.uct <= 52) & + diag.status == 1)) / length(which(diag.status == 1)) + + return(dat) +} + +#' @title Prevalence Calculations within Time Steps +#' +#' @description This module calculates demographic, transmission, and clinical +#' statistics at each time step within the simulation. +#' +#' @inheritParams aging_msm +#' +#' @details +#' Summary statistic calculations are of two broad forms: prevalence and +#' incidence. This function establishes the summary statistic vectors for both +#' prevalence and incidence at time 1, and then calculates the prevalence +#' statistics for times 2 onward. Incidence statistics (e.g., number of new +#' infections or deaths) are calculated within the modules as they depend on +#' vectors that are not stored external to the module. +#' +#' @return +#' This function returns the \code{dat} object with an updated summary of +#' current attributes stored in \code{dat$epi}. +#' +#' @keywords module msm +#' +#' @export +#' +prevalence_msm <- function(dat, at) { + + ## Variables + + # Attributes + race <- dat$attr$race + status <- dat$attr$status prepStat <- dat$attr$prepStat prepElig <- dat$attr$prepElig rGC <- dat$attr$rGC uGC <- dat$attr$uGC rCT <- dat$attr$rCT uCT <- dat$attr$uCT - rGC.sympt <- dat$attr$rGC.sympt - uGC.sympt <- dat$attr$uGC.sympt - rCT.sympt <- dat$attr$rCT.sympt - uCT.sympt <- dat$attr$uCT.sympt - + syphilis <- dat$attr$syphilis + stage.syph <- dat$attr$stage.syph + diag.status.syph <- dat$attr$diag.status.syph + last.diag.time.syph <- dat$attr$last.diag.time.syph + tslt.rgc <- dat$attr$time.since.last.test.rgc + tslt.ugc <- dat$attr$time.since.last.test.ugc + tslt.rct <- dat$attr$time.since.last.test.rct + tslt.uct <- dat$attr$time.since.last.test.uct + tslt.syph <- dat$attr$time.since.last.test.syph + diag.status <- dat$attr$diag.status + tt.traj.gc.hivpos <- dat$attr$tt.traj.gc.hivpos + tt.traj.gc.hivneg <- dat$attr$tt.traj.gc.hivneg + tt.traj.ct.hivneg <- dat$attr$tt.traj.ct.hivneg + tt.traj.ct.hivpos <- dat$attr$tt.traj.ct.hivpos + tt.traj.syph.hivpos <- dat$attr$tt.traj.syph.hivpos + tt.traj.syph.hivneg <- dat$attr$tt.traj.syph.hivneg nsteps <- dat$control$nsteps rNA <- rep(NA, nsteps) if (at == 1) { + + # Population sizes and HIV incidence/prevalence dat$epi$num <- rNA dat$epi$num.B <- rNA dat$epi$num.W <- rNA @@ -59,7 +556,9 @@ prevalence_msm <- function(dat, at) { dat$epi$i.prev.W <- rNA dat$epi$incid <- rNA dat$epi$ir100 <- rNA + dat$epi$deathage <- rNA + # PrEP dat$epi$prepCurr <- rNA dat$epi$prepCov <- rNA dat$epi$prepElig <- rNA @@ -67,27 +566,160 @@ prevalence_msm <- function(dat, at) { dat$epi$i.num.prep0 <- rNA dat$epi$i.num.prep1 <- rNA + #Time in health-related states + dat$epi$time.hivneg <- rep(0, nsteps) + dat$epi$time.on.prep <- rep(0, nsteps) + dat$epi$time.off.prep <- rep(0, nsteps) + dat$epi$stage.time.ar.ndx <- rep(0, nsteps) + dat$epi$stage.time.ar.dx <- rep(0, nsteps) + dat$epi$stage.time.af.ndx <- rep(0, nsteps) + dat$epi$stage.time.af.dx <- rep(0, nsteps) + dat$epi$stage.time.early.chronic.ndx <- rep(0, nsteps) + dat$epi$stage.time.early.chronic.dx.yrone <- rep(0, nsteps) + dat$epi$stage.time.early.chronic.dx.yrstwotolate <- rep(0, nsteps) + dat$epi$stage.time.early.chronic.art <- rep(0, nsteps) + dat$epi$stage.time.late.chronic.ndx <- rep(0, nsteps) + dat$epi$stage.time.late.chronic.dx <- rep(0, nsteps) + dat$epi$stage.time.late.chronic.art <- rep(0, nsteps) + dat$epi$stage.time.aids.ndx <- rep(0, nsteps) + dat$epi$stage.time.aids.dx <- rep(0, nsteps) + dat$epi$stage.time.aids.art <- rep(0, nsteps) + + # Number of HIV tests + dat$epi$hivtests.prep <- rep(0, nsteps) + dat$epi$hivtests.nprep <- rep(0, nsteps) + dat$epi$hivtests.pos <- rep(0, nsteps) + + # Number of STI tests + dat$epi$rGCsympttests <- rep(0, nsteps) + dat$epi$uGCsympttests <- rep(0, nsteps) + dat$epi$rCTsympttests <- rep(0, nsteps) + dat$epi$uCTsympttests <- rep(0, nsteps) + dat$epi$syphsympttests <- rep(0, nsteps) + dat$epi$rGCsympttests.pos <- rep(0, nsteps) + dat$epi$uGCsympttests.pos <- rep(0, nsteps) + dat$epi$GCsympttests.pos <- rep(0, nsteps) + dat$epi$rCTsympttests.pos <- rep(0, nsteps) + dat$epi$uCTsympttests.pos <- rep(0, nsteps) + dat$epi$CTsympttests.pos <- rep(0, nsteps) + dat$epi$syphsympttests.pos <- rep(0, nsteps) + dat$epi$syphearlysympttests.pos <- rep(0, nsteps) + dat$epi$syphlatesympttests.pos <- rep(0, nsteps) + + dat$epi$rGCasympttests <- rep(0, nsteps) + dat$epi$uGCasympttests <- rep(0, nsteps) + dat$epi$GCasympttests <- rep(0, nsteps) + dat$epi$rGCasympttests.pos <- rep(0, nsteps) + dat$epi$uGCasympttests.pos <- rep(0, nsteps) + dat$epi$GCasympttests.pos <- rep(0, nsteps) + + dat$epi$rCTasympttests <- rep(0, nsteps) + dat$epi$uCTasympttests <- rep(0, nsteps) + dat$epi$CTasympttests <- rep(0, nsteps) + dat$epi$rCTasympttests.pos <- rep(0, nsteps) + dat$epi$uCTasympttests.pos <- rep(0, nsteps) + dat$epi$CTasympttests.pos <- rep(0, nsteps) + + dat$epi$syphasympttests <- rep(0, nsteps) + dat$epi$syphasympttests.pos <- rep(0, nsteps) + dat$epi$syphearlyasympttests.pos <- rep(0, nsteps) + dat$epi$syphlateasympttests.pos <- rep(0, nsteps) + + dat$epi$stiasympttests <- rep(0, nsteps) + dat$epi$stiasympttests.pos <- rep(0, nsteps) + dat$epi$stisympttests <- rep(0, nsteps) + dat$epi$stisympttests.pos <- rep(0, nsteps) + dat$epi$stiasympttests.prep <- rep(0, nsteps) + dat$epi$stiasympttests.pos.prep <- rep(0, nsteps) + + # STI diagnostic testing due to symptoms at a site (rectal or urethral) + dat$epi$rGC_symptstidxtime <- rep(0, nsteps) + dat$epi$uGC_symptstidxtime <- rep(0, nsteps) + dat$epi$rCT_symptstidxtime <- rep(0, nsteps) + dat$epi$uCT_symptstidxtime <- rep(0, nsteps) + dat$epi$syph_symptstidxtime <- rep(0, nsteps) + + dat$epi$rGC_pos_symptstidxtime <- rep(0, nsteps) + dat$epi$uGC_pos_symptstidxtime <- rep(0, nsteps) + dat$epi$rCT_pos_symptstidxtime <- rep(0, nsteps) + dat$epi$uCT_pos_symptstidxtime <- rep(0, nsteps) + dat$epi$syph_pos_symptstidxtime <- rep(0, nsteps) + + # STI prevalence and coinfection prevalence dat$epi$prev.rgc <- rNA dat$epi$prev.ugc <- rNA dat$epi$prev.gc <- rNA - dat$epi$prev.gc.sympt <- rNA - dat$epi$prev.gc.dual <- rNA dat$epi$prev.rct <- rNA dat$epi$prev.uct <- rNA dat$epi$prev.ct <- rNA - dat$epi$prev.ct.sympt <- rNA - dat$epi$prev.ct.dual <- rNA + dat$epi$prev.gcct <- rNA dat$epi$prev.rgcct <- rNA dat$epi$prev.ugcct <- rNA + dat$epi$prev.syph <- rNA + dat$epi$prev.stage.prim <- rNA + dat$epi$prev.stage.seco <- rNA + dat$epi$prev.stage.earlat <- rNA + dat$epi$prev.stage.latelat <- rNA + dat$epi$prev.stage.tert <- rNA + dat$epi$prev.earlysyph <- rNA + dat$epi$prev.latesyph <- rNA + dat$epi$prev.primsecosyph <- rNA + dat$epi$num.newearlydiagsyph <- rNA + dat$epi$num.newlatediagsyph <- rNA + dat$epi$early.late.syphratio <- rNA + dat$epi$early.late.diagsyphratio <- rNA + dat$epi$prev.dxhiv.dxipssyph <- rNA + dat$epi$prev.dxhiv.atdxipssyph <- rNA + + # Multi STI + dat$epi$prev.hivposmultsti <- rNA + dat$epi$prev.hivnegmultsti <- rNA + + #HIV/STI coinfection with conditional HIV serostatus denominators + dat$epi$prev.primsecosyph.hivneg <- rNA + dat$epi$prev.primsecosyph.hivpos <- rNA + dat$epi$prev.syph.hivneg <- rNA + dat$epi$prev.syph.hivpos <- rNA + dat$epi$prev.gc.hivneg <- rNA + dat$epi$prev.gc.hivpos <- rNA + dat$epi$prev.ct.hivneg <- rNA + dat$epi$prev.ct.hivpos <- rNA + dat$epi$prev.hiv.primsecosyphpos <- rNA + dat$epi$prev.hiv.primsecosyphneg <- rNA + dat$epi$prev.rgc.hivpos <- rNA + dat$epi$prev.ugc.hivpos <- rNA + dat$epi$prev.rct.hivpos <- rNA + dat$epi$prev.uct.hivpos <- rNA + dat$epi$prev.rgc.hivneg <- rNA + dat$epi$prev.ugc.hivneg <- rNA + dat$epi$prev.rct.hivneg <- rNA + dat$epi$prev.uct.hivneg <- rNA + + # STI incidence dat$epi$incid.rgc <- rNA dat$epi$incid.ugc <- rNA dat$epi$incid.gc <- rNA dat$epi$incid.rct <- rNA dat$epi$incid.uct <- rNA dat$epi$incid.ct <- rNA + dat$epi$incid.syph <- rNA + dat$epi$incid.gcct <- rNA + dat$epi$incid.sti <- rNA + + + dat$epi$incid.rgc.hivneg <- rNA + dat$epi$incid.ugc.hivneg <- rNA + dat$epi$incid.rgc.hivpos <- rNA + dat$epi$incid.ugc.hivpos <- rNA + dat$epi$incid.rct.hivneg <- rNA + dat$epi$incid.uct.hivneg <- rNA + dat$epi$incid.rct.hivpos <- rNA + dat$epi$incid.uct.hivpos <- rNA + dat$epi$incid.syph.hivneg <- rNA + dat$epi$incid.syph.hivpos <- rNA dat$epi$ir100.rgc <- rNA dat$epi$ir100.ugc <- rNA @@ -95,94 +727,707 @@ prevalence_msm <- function(dat, at) { dat$epi$ir100.rct <- rNA dat$epi$ir100.uct <- rNA dat$epi$ir100.ct <- rNA - + dat$epi$ir100.syph <- rNA + dat$epi$ir100.gcct <- rNA dat$epi$ir100.sti <- rNA - dat$epi$incid.gcct.prep <- rNA + dat$epi$ir100.gc.hivneg <- rNA + dat$epi$ir100.gc.hivpos <- rNA + dat$epi$ir100.ct.hivneg <- rNA + dat$epi$ir100.ct.hivpos <- rNA + dat$epi$ir100.syph.hivneg <- rNA + dat$epi$ir100.syph.hivpos <- rNA + + #PAF + dat$epi$sum_GC <- rNA + dat$epi$sum_CT <- rNA + dat$epi$sum_syph <- rNA + dat$epi$sum_urethral <- rNA + dat$epi$sum_rectal <- rNA + #2x2 for PAF + # HIV+ + # STI+ STI- + #HIV- STI + 1 2 + # STI - 3 4 + dat$epi$cell1_gc <- rNA + dat$epi$cell2_gc <- rNA + dat$epi$cell3_gc <- rNA + dat$epi$cell4_gc <- rNA + dat$epi$cell1_ct <- rNA + dat$epi$cell2_ct <- rNA + dat$epi$cell3_ct <- rNA + dat$epi$cell4_ct <- rNA + dat$epi$cell1_syph <- rNA + dat$epi$cell2_syph <- rNA + dat$epi$cell3_syph <- rNA + dat$epi$cell4_syph <- rNA + dat$epi$cell1_sti <- rNA + dat$epi$cell2_sti <- rNA + dat$epi$cell3_sti <- rNA + dat$epi$cell4_sti <- rNA + + # STI Recovery dat$epi$recov.rgc <- rNA dat$epi$recov.ugc <- rNA dat$epi$recov.rct <- rNA dat$epi$recov.uct <- rNA + dat$epi$recov.earlysyph <- rNA + dat$epi$recov.syphilis <- rNA + # HIV transmissions by partner type dat$epi$trans.main <- rNA - dat$epi$trans.casl <- rNA + dat$epi$trans.pers <- rNA dat$epi$trans.inst <- rNA + # STI treatment dat$epi$txGC <- rNA + dat$epi$txGC_asympt <- rNA dat$epi$txCT <- rNA + dat$epi$txCT_asympt <- rNA + dat$epi$txsyph <- rNA + dat$epi$txsyph_asympt <- rNA + dat$epi$txearlysyph <- rNA + dat$epi$txlatesyph <- rNA + + # STI testing indications + dat$epi$stiactiveind <- rNA + dat$epi$recentpartners <- rNA + # dat$epi$recentSTI <- rNA + # dat$epi$newpartner <- rNA + # dat$epi$concurrpart <- rNA + # dat$epi$partnersti <- rNA + # dat$epi$uai.nmain <- rNA + # dat$epi$uai.any <- rNA + dat$epi$stiactiveind.prop <- rNA + dat$epi$recentpartners.prop <- rNA + + #EPT + #EPT + dat$epi$eptCov <- rNA + dat$epi$eptpartelig <- rNA + dat$epi$eptpartelig_main <- rNA + dat$epi$eptpartelig_main <- rNA + dat$epi$eptpartelig_main <- rNA + dat$epi$eptindexprovided_gc <- rNA + dat$epi$eptindexprovided_ct <- rNA + dat$epi$eptpartprovided <- rNA + dat$epi$eptpartprovided_gc <- rNA + dat$epi$eptpartprovided_ct <- rNA + dat$epi$eptpartprovided_main <- rNA + dat$epi$eptpartprovided_pers <- rNA + dat$epi$eptpartprovided_inst <- rNA + dat$epi$eptpartuptake <- rNA + dat$epi$eptpartuptake_main <- rNA + dat$epi$eptpartuptake_pers <- rNA + dat$epi$eptpartuptake_inst <- rNA + dat$epi$eptpartuptake_gc <- rNA + dat$epi$eptpartuptake_ct <- rNA + dat$epi$eptTx <- rNA + dat$epi$propindexeptElig <- rNA + # dat$epi$eptprop_tx <- rNA + dat$epi$eptuninfectedprovided <- rNA + dat$epi$eptuninfecteduptake <- rNA + dat$epi$eptgcinfectsti <- rNA + dat$epi$eptctinfectsti <- rNA + dat$epi$eptgcinfecthiv <- rNA + dat$epi$eptctinfecthiv <- rNA + dat$epi$eptgcctinfecthiv <- rNA + dat$epi$eptgcinfectundiaghiv <- rNA + dat$epi$eptctinfectundiaghiv <- rNA + dat$epi$eptgcctinfectundiaghiv <- rNA + dat$epi$eptgcctinfecthiv_main <- rNA + dat$epi$eptgcctinfecthiv_pers <- rNA + dat$epi$eptgcctinfecthiv_inst <- rNA + dat$epi$eptgcctinfectundiaghiv_main <- rNA + dat$epi$eptgcctinfectundiaghiv_pers <- rNA + dat$epi$eptgcctinfectundiaghiv_inst <- rNA + + # STI testing trajectories + dat$epi$tt.traj.syph1.hivneg <- rep(0, nsteps) + dat$epi$tt.traj.gc1.hivneg <- rep(0, nsteps) + dat$epi$tt.traj.ct1.hivneg <- rep(0, nsteps) + dat$epi$tt.traj.syph2.hivneg <- rep(0, nsteps) + dat$epi$tt.traj.gc2.hivneg <- rep(0, nsteps) + dat$epi$tt.traj.ct2.hivneg <- rep(0, nsteps) + dat$epi$tt.traj.syph1.hivpos <- rep(0, nsteps) + dat$epi$tt.traj.gc1.hivpos <- rep(0, nsteps) + dat$epi$tt.traj.ct1.hivpos <- rep(0, nsteps) + dat$epi$tt.traj.syph2.hivpos <- rep(0, nsteps) + dat$epi$tt.traj.gc2.hivpos <- rep(0, nsteps) + dat$epi$tt.traj.ct2.hivpos <- rep(0, nsteps) + dat$epi$tt.traj.syph1 <- rep(0, nsteps) + dat$epi$tt.traj.gc1 <- rep(0, nsteps) + dat$epi$tt.traj.ct1 <- rep(0, nsteps) + dat$epi$tt.traj.sti1 <- rep(0, nsteps) + dat$epi$tt.traj.syph2 <- rep(0, nsteps) + dat$epi$tt.traj.gc2 <- rep(0, nsteps) + dat$epi$tt.traj.ct2 <- rep(0, nsteps) + dat$epi$tt.traj.sti2 <- rep(0, nsteps) + + #STI Testing in last 12 months + dat$epi$test.gc.12mo <- rNA + dat$epi$test.ct.12mo <- rNA + dat$epi$test.syph.12mo <- rNA + + dat$epi$test.gc.12mo.nonhivdiag <- rNA + dat$epi$test.ct.12mo.nonhivdiag <- rNA + dat$epi$test.syph.12mo.nonhivdiag <- rNA + + dat$epi$test.gc.12mo.hivneg <- rNA + dat$epi$test.ct.12mo.hivneg <- rNA + dat$epi$test.syph.12mo.hivneg <- rNA + + dat$epi$test.gc.12mo.hivdiag <- rNA + dat$epi$test.ct.12mo.hivdiag <- rNA + dat$epi$test.syph.12mo.hivdiag <- rNA + + dat$epi$test.gc.12mo.hivpos <- rNA + dat$epi$test.ct.12mo.hivpos <- rNA + dat$epi$test.syph.12mo.hivpos <- rNA + + # Incidence by risk group + dat$epi$ir100.ct.tttraj1 <- rNA + dat$epi$ir100.ct.tttraj2 <- rNA + dat$epi$ir100.gc.tttraj1 <- rNA + dat$epi$ir100.gc.tttraj2 <- rNA + dat$epi$ir100.syph.tttraj1 <- rNA + dat$epi$ir100.syph.tttraj2 <- rNA + dat$epi$ir100.gcct.tttraj1 <- rNA + dat$epi$ir100.gcct.tttraj2 <- rNA + dat$epi$ir100.sti.tttraj1 <- rNA + dat$epi$ir100.sti.tttraj2 <- rNA + + dat$epi$incid.gc.tttraj1 <- rNA + dat$epi$incid.gc.tttraj1 <- rNA + dat$epi$incid.gc.tttraj2 <- rNA + dat$epi$incid.gc.tttraj2 <- rNA + dat$epi$incid.ct.tttraj1 <- rNA + dat$epi$incid.ct.tttraj1 <- rNA + dat$epi$incid.ct.tttraj2 <- rNA + dat$epi$incid.ct.tttraj2 <- rNA + dat$epi$incid.syph.tttraj1 <- rNA + dat$epi$incid.syph.tttraj2 <- rNA + dat$epi$incid.gcct.tttraj1 <- rNA + dat$epi$incid.gcct.tttraj2 <- rNA + + dat$epi$incid.sti.tttraj1 <- rNA + dat$epi$incid.sti.tttraj2 <- rNA + + # Prevalence by risk group + dat$epi$prev.gcct.tttraj1 <- rNA + dat$epi$prev.gcct.tttraj2 <- rNA + dat$epi$prev.gc.tttraj1 <- rNA + dat$epi$prev.gc.tttraj2 <- rNA + dat$epi$prev.ct.tttraj1 <- rNA + dat$epi$prev.ct.tttraj2 <- rNA + dat$epi$prev.syph.tttraj1 <- rNA + dat$epi$prev.syph.tttraj2 <- rNA + dat$epi$prev.primsecosyph.tttraj1 <- rNA + dat$epi$prev.primsecosyph.tttraj2 <- rNA + dat$epi$prev.sti.tttraj1 <- rNA + dat$epi$prev.sti.tttraj2 <- rNA + + # Tests by risk group + dat$epi$rCTasympttests.tttraj1 <- rNA + dat$epi$rCTasympttests.tttraj2 <- rNA + dat$epi$uCTasympttests.tttraj1 <- rNA + dat$epi$uCTasympttests.tttraj2 <- rNA + dat$epi$CTasympttests.tttraj1 <- rNA + dat$epi$CTasympttests.tttraj2 <- rNA + dat$epi$rGCasympttests.tttraj1 <- rNA + dat$epi$rGCasympttests.tttraj2 <- rNA + dat$epi$uGCasympttests.tttraj1 <- rNA + dat$epi$uGCasympttests.tttraj2 <- rNA + dat$epi$GCasympttests.tttraj1 <- rNA + dat$epi$GCasympttests.tttraj2 <- rNA + dat$epi$syphasympttests.tttraj1 <- rNA + dat$epi$syphasympttests.tttraj2 <- rNA + dat$epi$stiasympttests.tttraj1 <- rNA + dat$epi$stiasympttests.tttraj2 <- rNA + dat$epi$rCTsympttests.tttraj1 <- rNA + dat$epi$rCTsympttests.tttraj2 <- rNA + dat$epi$uCTsympttests.tttraj1 <- rNA + dat$epi$uCTsympttests.tttraj2 <- rNA + dat$epi$CTsympttests.tttraj1 <- rNA + dat$epi$CTsympttests.tttraj2 <- rNA + dat$epi$rGCsympttests.tttraj1 <- rNA + dat$epi$rGCsympttests.tttraj2 <- rNA + dat$epi$uGCsympttests.tttraj1 <- rNA + dat$epi$uGCsympttests.tttraj2 <- rNA + dat$epi$GCsympttests.tttraj1 <- rNA + dat$epi$GCsympttests.tttraj2 <- rNA + dat$epi$syphsympttests.tttraj1 <- rNA + dat$epi$syphsympttests.tttraj2 <- rNA + dat$epi$stisympttests.tttraj1 <- rNA + dat$epi$stisympttests.tttraj2 <- rNA + + # Treatments by risk group + dat$epi$txGC.tttraj1 <- rNA + dat$epi$txGC_asympt.tttraj1 <- rNA + dat$epi$txGC.tttraj2 <- rNA + dat$epi$txGC_asympt.tttraj2 <- rNA + dat$epi$txCT.tttraj1 <- rNA + dat$epi$txCT_asympt.tttraj1 <- rNA + dat$epi$txCT.tttraj2 <- rNA + dat$epi$txCT_asympt.tttraj2 <- rNA + dat$epi$txsyph.tttraj1 <- rNA + dat$epi$txsyph_asympt.tttraj1 <- rNA + dat$epi$txsyph.tttraj2 <- rNA + dat$epi$txsyph_asympt.tttraj2 <- rNA + dat$epi$txearlysyph.tttraj1 <- rNA + dat$epi$txlatesyph.tttraj1 <- rNA + dat$epi$txearlysyph.tttraj2 <- rNA + dat$epi$txlatesyph.tttraj2 <- rNA + dat$epi$txSTI <- rNA + dat$epi$txSTI_asympt <- rNA + dat$epi$txSTI.tttraj1 <- rNA + dat$epi$txSTI.tttraj2 <- rNA + dat$epi$txSTI_asympt.tttraj1 <- rNA + dat$epi$txSTI_asympt.tttraj2 <- rNA + + # Proportion of infections treated in past year + dat$epi$tx.gc.prop <- rNA + dat$epi$tx.ct.prop <- rNA + dat$epi$tx.gcct.prop <- rNA + dat$epi$tx.syph.prop <- rNA + + # Duration of infection + dat$epi$gc.infect.dur <- rNA + dat$epi$ct.infect.dur <- rNA + dat$epi$gcct.infect.dur <- rNA + dat$epi$syph.infect.dur <- rNA + + # UAI by concordancy + dat$epi$num.acts.negneg <- rNA + dat$epi$num.acts.negpos <- rNA + dat$epi$num.acts.pospos <- rNA + dat$epi$prop.uai.negneg <- rNA + dat$epi$prop.uai.negpos <- rNA + dat$epi$prop.uai.pospos <- rNA + dat$epi$prop.acts.negneg <- rNA + dat$epi$prop.acts.negpos <- rNA + dat$epi$prop.acts.pospos <- rNA + + # Testing events + dat$epi$testing.events.syph <- rep(0, nsteps) + dat$epi$testing.events.syph.asympt <- rep(0, nsteps) + dat$epi$testing.events.rgc <- rep(0, nsteps) + dat$epi$testing.events.rgc.asympt <- rep(0, nsteps) + dat$epi$testing.events.ugc <- rep(0, nsteps) + dat$epi$testing.events.ugc.asympt <- rep(0, nsteps) + dat$epi$testing.events.gc <- rep(0, nsteps) + dat$epi$testing.events.gc.asympt <- rep(0, nsteps) + dat$epi$testing.events.sti <- rep(0, nsteps) + dat$epi$testing.events.sti.asympt <- rep(0, nsteps) + dat$epi$testing.events.rct <- rep(0, nsteps) + dat$epi$testing.events.rct.asympt <- rep(0, nsteps) + dat$epi$testing.events.uct <- rep(0, nsteps) + dat$epi$testing.events.uct.asympt <- rep(0, nsteps) + dat$epi$testing.events.ct <- rep(0, nsteps) + dat$epi$testing.events.ct.asympt <- rep(0, nsteps) + } - dat$epi$num[at] <- sum(active == 1, na.rm = TRUE) + # Population sizes and HIV incidence/prevalence + dat$epi$num[at] <- sum(race %in% c("B","W"), na.rm = TRUE) dat$epi$num.B[at] <- sum(race == "B", na.rm = TRUE) dat$epi$num.W[at] <- sum(race == "W", na.rm = TRUE) dat$epi$s.num[at] <- sum(status == 0, na.rm = TRUE) dat$epi$i.num[at] <- sum(status == 1, na.rm = TRUE) dat$epi$i.num.B[at] <- sum(status == 1 & race == "B", na.rm = TRUE) dat$epi$i.num.W[at] <- sum(status == 1 & race == "W", na.rm = TRUE) - dat$epi$i.prev[at] <- dat$epi$i.num[at] / dat$epi$num[at] - dat$epi$i.prev.B[at] <- dat$epi$i.num.B[at] / dat$epi$num.B[at] - dat$epi$i.prev.W[at] <- dat$epi$i.num.W[at] / dat$epi$num.W[at] - dat$epi$ir100[at] <- (dat$epi$incid[at] / sum(status == 0, na.rm = TRUE)) * 5200 + dat$epi$i.prev[at] <- ifelse(dat$epi$num[at] > 0, dat$epi$i.num[at] / dat$epi$num[at], 0) + dat$epi$i.prev.B[at] <- ifelse(dat$epi$num[at] > 0, dat$epi$i.num.B[at] / dat$epi$num.B[at], 0) + dat$epi$i.prev.W[at] <- ifelse(dat$epi$num[at] > 0, dat$epi$i.num.W[at] / dat$epi$num.W[at], 0) + dat$epi$ir100[at] <- ifelse(sum(status == 0,dat$epi$incid[at], na.rm = TRUE) > 0, + (dat$epi$incid[at] / + sum(status == 0,dat$epi$incid[at], na.rm = TRUE)) * 5200, 0) + # PrEP dat$epi$prepCurr[at] <- sum(prepStat == 1, na.rm = TRUE) dat$epi$prepElig[at] <- sum(prepElig == 1, na.rm = TRUE) dat$epi$i.num.prep0[at] <- sum((is.na(prepStat) | prepStat == 0) & status == 1, na.rm = TRUE) dat$epi$i.num.prep1[at] <- sum(prepStat == 1 & status == 1, na.rm = TRUE) - dat$epi$i.prev.prep0[at] <- dat$epi$i.num.prep0[at] / - sum((is.na(prepStat) | prepStat == 0), na.rm = TRUE) + dat$epi$i.prev.prep0[at] <- dat$epi$i.num.prep0[at] / sum((is.na(prepStat) | prepStat == 0), na.rm = TRUE) + if (at == 1) { dat$epi$i.prev.prep1[1] <- 0 } else { dat$epi$i.prev.prep1[at] <- dat$epi$i.num.prep1[at] / sum(prepStat == 1, na.rm = TRUE) } - dat$epi$prev.rgc[at] <- sum(rGC == 1, na.rm = TRUE) / dat$epi$num[at] - dat$epi$prev.ugc[at] <- sum(uGC == 1, na.rm = TRUE) / dat$epi$num[at] - dat$epi$prev.gc[at] <- sum((rGC == 1 | uGC == 1), na.rm = TRUE) / dat$epi$num[at] - dat$epi$prev.gc.sympt[at] <- sum((rGC.sympt == 1 | uGC.sympt == 1)) / dat$epi$num[at] - dat$epi$prev.gc.dual[at] <- sum((rGC == 1 & uGC == 1), na.rm = TRUE) / dat$epi$num[at] - - dat$epi$prev.rct[at] <- sum(rCT == 1, na.rm = TRUE) / dat$epi$num[at] - dat$epi$prev.uct[at] <- sum(uCT == 1, na.rm = TRUE) / dat$epi$num[at] - dat$epi$prev.ct[at] <- sum((rCT == 1 | uCT == 1), na.rm = TRUE) / dat$epi$num[at] - dat$epi$prev.ct.sympt[at] <- sum((rCT.sympt == 1 | uCT.sympt == 1)) / dat$epi$num[at] - dat$epi$prev.ct.dual[at] <- sum((rCT == 1 & uCT == 1), na.rm = TRUE) / dat$epi$num[at] - - dat$epi$prev.rgcct[at] <- sum(rGC == 1 | rCT == 1, na.rm = TRUE) / dat$epi$num[at] - dat$epi$prev.ugcct[at] <- sum(uGC == 1 | uCT == 1, na.rm = TRUE) / dat$epi$num[at] - - dat$epi$ir100.rgc[at] <- (dat$epi$incid.rgc[at] / sum(rGC == 0, na.rm = TRUE)) * 5200 - dat$epi$ir100.ugc[at] <- (dat$epi$incid.ugc[at] / sum(uGC == 0, na.rm = TRUE)) * 5200 - dat$epi$ir100.gc[at] <- (dat$epi$incid.gc[at] / - (sum(rGC == 0, na.rm = TRUE) + - sum(uGC == 0, na.rm = TRUE))) * 5200 - - dat$epi$ir100.rct[at] <- (dat$epi$incid.rct[at] / sum(rCT == 0, na.rm = TRUE)) * 5200 - dat$epi$ir100.uct[at] <- (dat$epi$incid.uct[at] / sum(uCT == 0, na.rm = TRUE)) * 5200 - dat$epi$ir100.ct[at] <- (dat$epi$incid.ct[at] / - (sum(rCT == 0, na.rm = TRUE) + - sum(uCT == 0, na.rm = TRUE))) * 5200 - - dat$epi$prev.sti[at] <- sum(rGC == 1 | uGC == 1 | - rCT ==1 | uCT == 1, na.rm = TRUE) / dat$epi$num[at] - dat$epi$ir100.sti[at] <- ((dat$epi$incid.ct[at] + dat$epi$incid.gc[at]) / - (sum(rGC == 0, na.rm = TRUE) + - sum(uGC == 0, na.rm = TRUE) + - sum(rCT == 0, na.rm = TRUE) + - sum(uCT == 0, na.rm = TRUE))) * 5200 - - dat$epi$ir100.sti.prep[at] <- (dat$epi$incid.gcct.prep[at] / - (sum(rGC == 0 & prepStat == 1, na.rm = TRUE) + - sum(uGC == 0 & prepStat == 1, na.rm = TRUE) + - sum(rCT == 0 & prepStat == 1, na.rm = TRUE) + - sum(uCT == 0 & prepStat == 1, na.rm = TRUE))) * 5200 + dat$epi$time.on.prep[at] <- length(which(dat$attr$prepStat == 1)) + dat$epi$time.off.prep[at] <- length(which(dat$attr$prepStat == 0)) + + # STI and Co-infection Prevalence + dat$epi$prev.rgc[at] <- ifelse(dat$epi$num[at] > 0, sum(rGC == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ugc[at] <- ifelse(dat$epi$num[at] > 0, sum(uGC == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.gc[at] <- ifelse(dat$epi$num[at] > 0, sum((rGC == 1 | uGC == 1), na.rm = TRUE) / dat$epi$num[at], 0) + + dat$epi$prev.gc.tttraj1[at] <- ifelse((dat$epi$tt.traj.gc1[at] == 0 | is.na(dat$epi$tt.traj.gc1[at]) + | is.nan(dat$epi$tt.traj.gc1[at]) | is.null(dat$epi$tt.traj.gc1[at])), 0, + sum((rGC == 1 | uGC == 1) & + (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), na.rm = TRUE) / + dat$epi$tt.traj.gc1[at]) + dat$epi$prev.gc.tttraj2[at] <- ifelse((dat$epi$tt.traj.gc2[at] == 0 | is.na(dat$epi$tt.traj.gc2[at]) | + is.nan(dat$epi$tt.traj.gc2[at]) | is.null(dat$epi$tt.traj.gc2[at])), 0 , + sum((rGC == 1 | uGC == 1) & + (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), na.rm = TRUE) / + dat$epi$tt.traj.gc2[at]) + + dat$epi$prev.gcct[at] <- ifelse(dat$epi$num[at] > 0, sum((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1), na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.gcct.tttraj1[at] <- ifelse((dat$epi$tt.traj.gc1[at] == 0 | is.na(dat$epi$tt.traj.gc1[at]) | + is.nan(dat$epi$tt.traj.gc1[at]) | is.null(dat$epi$tt.traj.gc1[at]) | + dat$epi$tt.traj.ct1[at] == 0 | is.na(dat$epi$tt.traj.ct1[at]) | + is.nan(dat$epi$tt.traj.ct1[at]) | is.null(dat$epi$tt.traj.ct1[at])), 0, + sum((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1) & + (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1 | + tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), na.rm = TRUE) / + (dat$epi$tt.traj.gc1[at] + dat$epi$tt.traj.ct1[at])) + dat$epi$prev.gcct.tttraj2[at] <- ifelse((dat$epi$tt.traj.gc2[at] == 0 | is.na(dat$epi$tt.traj.gc2[at]) | + is.nan(dat$epi$tt.traj.gc2[at]) | is.null(dat$epi$tt.traj.gc2[at]) | + dat$epi$tt.traj.ct2[at] == 0 | is.na(dat$epi$tt.traj.ct2[at]) | + is.nan(dat$epi$tt.traj.ct2[at]) | is.null(dat$epi$tt.traj.ct2[at])), 0, + sum((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1) & + (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2 | + tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), na.rm = TRUE) / + (dat$epi$tt.traj.gc2[at] + dat$epi$tt.traj.ct2[at])) + + dat$epi$prev.rct[at] <- ifelse(dat$epi$num[at] > 0, sum(rCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.uct[at] <- ifelse(dat$epi$num[at] > 0, sum(uCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ct[at] <- ifelse(dat$epi$num[at] > 0, sum((rCT == 1 | uCT == 1), na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ct.tttraj1[at] <- ifelse((dat$epi$tt.traj.ct1[at] == 0 | is.na(dat$epi$tt.traj.ct1[at]) | + is.nan(dat$epi$tt.traj.ct1[at]) | is.null(dat$epi$tt.traj.ct1[at])), 0, + sum((rCT == 1 | uCT == 1) & + (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), na.rm = TRUE) / + dat$epi$tt.traj.ct1[at]) + dat$epi$prev.ct.tttraj2[at] <- ifelse((dat$epi$tt.traj.ct2[at] == 0 | is.na(dat$epi$tt.traj.ct2[at]) | + is.nan(dat$epi$tt.traj.ct2[at]) | is.null(dat$epi$tt.traj.ct2[at])), 0, + sum((rCT == 1 | uCT == 1) & + (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), na.rm = TRUE) / + dat$epi$tt.traj.ct2[at]) + + dat$epi$prev.rgcct[at] <- ifelse(dat$epi$num[at] > 0, sum(rGC == 1 | rCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + dat$epi$prev.ugcct[at] <- ifelse(dat$epi$num[at] > 0, sum(uGC == 1 | uCT == 1, na.rm = TRUE) / dat$epi$num[at], 0) + + dat$epi$prev.stage.incub[at] <- ifelse(length(which(syphilis == 1)) > 0, + length(which(stage.syph == 1)) / length(which(syphilis == 1)), 0) + dat$epi$prev.stage.prim[at] <- ifelse(length(which(syphilis == 1)) > 0, + length(which(stage.syph == 2)) / length(which(syphilis == 1)), 0) + dat$epi$prev.stage.incubprim[at] <- ifelse(length(which(syphilis == 1)) > 0, + length(which(stage.syph == 1 | stage.syph == 2)) / length(which(syphilis == 1)), 0) + dat$epi$prev.stage.seco[at] <- ifelse(length(which(syphilis == 1)) > 0, + length(which(stage.syph == 3)) / length(which(syphilis == 1)), 0) + dat$epi$prev.stage.earlat[at] <- ifelse(length(which(syphilis == 1)) > 0, + length(which(stage.syph == 4)) / length(which(syphilis == 1)), 0) + dat$epi$prev.stage.latelat[at] <- ifelse(length(which(syphilis == 1)) > 0, + length(which(stage.syph == 5)) / length(which(syphilis == 1)), 0) + dat$epi$prev.stage.tert[at] <- ifelse(length(which(syphilis == 1)) > 0, + length(which(stage.syph == 6)) / length(which(syphilis == 1)), 0) + dat$epi$prev.earlysyph[at] <- ifelse(length(which(syphilis == 1)) > 0, + length(which(stage.syph %in% c(1, 2, 3))) / length(which(syphilis == 1)), 0) + dat$epi$prev.latesyph[at] <- ifelse(length(which(syphilis == 1)) > 0, + length(which(stage.syph %in% c(4, 5, 6))) / length(which(syphilis == 1)), 0) + dat$epi$num.newearlydiagsyph[at] <- length(which(last.diag.time.syph == at & stage.syph %in% c(1, 2, 3))) + dat$epi$num.newlatediagsyph[at] <- length(which(last.diag.time.syph == at & stage.syph %in% c(4, 5, 6))) + dat$epi$early.late.syphratio[at] <- ifelse(length(which(stage.syph %in% c(4, 5, 6))) > 0, + length(which(stage.syph %in% c(1, 2, 3))) / + length(which(stage.syph %in% c(4, 5, 6))), 0) + dat$epi$early.late.diagsyphratio[at] <- ifelse(length(which(diag.status.syph == 1 & stage.syph %in% c(4, 5, 6))), + length(which(diag.status.syph == 1 & stage.syph %in% c(1, 2, 3))) / + length(which(diag.status.syph == 1 & stage.syph %in% c(4, 5, 6))), 0) + + dat$epi$prev.dxhiv.dxipssyph[at] <- ifelse(length(which(diag.status.syph == 1 & stage.syph %in% c(1, 2, 3))) == 0, 0, + length(which(diag.status == 1 & + diag.status.syph == 1 & + stage.syph %in% c(1, 2, 3))) / + length(which(diag.status.syph == 1 & stage.syph %in% c(1, 2, 3)))) + + dat$epi$prev.dxhiv.atdxipssyph[at] <- ifelse(length(which(diag.status.syph == 1 & stage.syph %in% c(1, 2, 3) & + dat$attr$last.diag.time.syph == at)) == 0, 0, + length(which(diag.status == 1 & + diag.status.syph == 1 & + stage.syph %in% c(1, 2, 3) & + dat$attr$last.diag.time.syph == at)) / + length(which(diag.status.syph == 1 & stage.syph %in% c(1, 2, 3) & + dat$attr$last.diag.time.syph == at))) + + dat$epi$prev.syph[at] <- ifelse(dat$epi$num[at] > 0, length(which(syphilis == 1)) / dat$epi$num[at], 0) + dat$epi$prev.syph.tttraj1[at] <- ifelse((dat$epi$tt.traj.syph1[at] == 0 | is.na(dat$epi$tt.traj.syph1[at]) | + is.nan(dat$epi$tt.traj.syph1[at]) | is.null(dat$epi$tt.traj.syph1[at])), 0, + sum((syphilis == 1) & + (tt.traj.syph.hivneg == 1 | tt.traj.syph.hivpos == 1), na.rm = TRUE) / + dat$epi$tt.traj.syph1[at]) + dat$epi$prev.syph.tttraj2[at] <- ifelse((dat$epi$tt.traj.syph2[at] == 0 | is.na(dat$epi$tt.traj.syph2[at]) | + is.nan(dat$epi$tt.traj.syph2[at]) | is.null(dat$epi$tt.traj.syph2[at])), 0, + sum((syphilis == 1) & + (tt.traj.syph.hivneg == 2 | tt.traj.syph.hivpos == 2), na.rm = TRUE) / dat$epi$tt.traj.syph2[at]) + + dat$epi$prev.primsecosyph[at] <- ifelse(dat$epi$num[at] > 0, length(which(stage.syph %in% c(1, 2, 3))) / + dat$epi$num[at], 0) + dat$epi$prev.primsecosyph.tttraj1[at] <- ifelse((dat$epi$tt.traj.syph1[at] == 0 | is.na(dat$epi$tt.traj.syph1[at]) | + is.nan(dat$epi$tt.traj.syph1[at]) | is.null(dat$epi$tt.traj.syph1[at])), 0, + length(which(stage.syph %in% c(1, 2, 3) & + (tt.traj.syph.hivneg == 1 | tt.traj.syph.hivpos == 1))) / + dat$epi$tt.traj.syph1[at]) + dat$epi$prev.primsecosyph.tttraj2[at] <- ifelse((dat$epi$tt.traj.syph2[at] == 0 | is.na(dat$epi$tt.traj.syph2[at]) | + is.nan(dat$epi$tt.traj.syph2[at]) | is.null(dat$epi$tt.traj.syph2[at])), 0, + length(which(stage.syph %in% c(1, 2, 3) & + (tt.traj.syph.hivneg == 2 | tt.traj.syph.hivpos == 2))) / + dat$epi$tt.traj.syph2[at]) + + # Prevalence of HIV/STI overlap (conditional denominators) + dat$epi$prev.primsecosyph.hivneg[at] <- ifelse(dat$epi$s.num[at] > 0, + length(intersect(which(status == 0), which(stage.syph %in% c(1, 2, 3)))) / dat$epi$s.num[at], 0) + dat$epi$prev.primsecosyph.hivpos[at] <- ifelse(dat$epi$i.num[at] > 0, + length(intersect(which(status == 1), which(stage.syph %in% c(1, 2, 3)))) / dat$epi$i.num[at], 0) + dat$epi$prev.syph.hivneg[at] <- ifelse(dat$epi$s.num[at] > 0, + length(intersect(which(status == 0), which(syphilis == 1))) / dat$epi$s.num[at], 0) + dat$epi$prev.syph.hivpos[at] <- ifelse(dat$epi$i.num[at] > 0, + length(intersect(which(status == 1), which(syphilis == 1))) / dat$epi$i.num[at], 0) + + dat$epi$prev.gc.hivneg[at] <- ifelse(dat$epi$s.num[at] > 0, + length(intersect(which(status == 0), which((rGC == 1 | uGC == 1)))) / dat$epi$s.num[at], 0) + dat$epi$prev.gc.hivpos[at] <- ifelse(dat$epi$i.num[at] > 0, + length(intersect(which(status == 1), which((rGC == 1 | uGC == 1)))) / dat$epi$i.num[at], 0) + + dat$epi$prev.ct.hivneg[at] <- ifelse(dat$epi$s.num[at] > 0, + length(intersect(which(status == 0), which((rCT == 1 | uCT == 1)))) / dat$epi$s.num[at], 0) + dat$epi$prev.ct.hivpos[at] <- ifelse(dat$epi$i.num[at] > 0, + length(intersect(which(status == 1), which((rCT == 1 | uCT == 1)))) / dat$epi$i.num[at], 0) + + dat$epi$prev.hiv.primsecosyphpos[at] <- ifelse(length(which(stage.syph %in% c(1, 2, 3))) > 0, + length(intersect(which(status == 1), which(stage.syph %in% c(1, 2, 3)))) / length(which(stage.syph %in% c(1, 2, 3))), 0) + dat$epi$prev.hiv.primsecosyphneg[at] <- ifelse(length(which(stage.syph %in% c(1, 2, 3))) > 0, + length(intersect(which(status == 0), which(stage.syph %in% c(1, 2, 3)))) / length(which(stage.syph %in% c(1, 2, 3))), 0) + + dat$epi$prev.rgc.hivpos[at] <- ifelse(dat$epi$i.num[at] > 0, + length(intersect(which(status == 1), which(rGC == 1))) / dat$epi$i.num[at], 0) + dat$epi$prev.ugc.hivpos[at] <- ifelse(dat$epi$i.num[at] > 0, + length(intersect(which(status == 1), which(uGC == 1))) / dat$epi$i.num[at], 0) + dat$epi$prev.rct.hivpos[at] <- ifelse(dat$epi$i.num[at] > 0, + length(intersect(which(status == 1), which(rCT == 1))) / dat$epi$i.num[at], 0) + dat$epi$prev.uct.hivpos[at] <- ifelse(dat$epi$i.num[at] > 0, + length(intersect(which(status == 1), which(uCT == 1))) / dat$epi$i.num[at], 0) + + dat$epi$prev.rgc.hivneg[at] <- ifelse(dat$epi$s.num[at] > 0, + length(intersect(which(status == 1), which(rGC == 1))) / dat$epi$s.num[at], 0) + dat$epi$prev.ugc.hivneg[at] <- ifelse(dat$epi$s.num[at] > 0, + length(intersect(which(status == 1), which(uGC == 1))) / dat$epi$s.num[at], 0) + dat$epi$prev.rct.hivneg[at] <- ifelse(dat$epi$s.num[at] > 0, + length(intersect(which(status == 1), which(rCT == 1))) / dat$epi$s.num[at], 0) + dat$epi$prev.uct.hivneg[at] <- ifelse(dat$epi$s.num[at] > 0, + length(intersect(which(status == 1), which(uCT == 1))) / dat$epi$s.num[at], 0) + + # STI Co-infection prevalence + dat$epi$prev.hivnegmultsti[at] <- sum(status == 0 & + (rGC == 1 & (uGC == 1 | rCT == 1 | uCT == 1 | stage.syph %in% c(1, 2, 3))) | + (uGC == 1 & (rGC == 1 | rCT == 1 | uCT == 1 | stage.syph %in% c(1, 2, 3))) | + (rCT == 1 & (uGC == 1 | rGC == 1 | uCT == 1 | stage.syph %in% c(1, 2, 3))) | + (uCT == 1 & (uGC == 1 | rGC == 1 | rCT == 1 | stage.syph %in% c(1, 2, 3))) | + (stage.syph %in% c(1, 2, 3) & (uGC == 1 | rGC == 1 | rCT == 1 | uCT == 1))) / dat$epi$s.num[at] + + #HIV/Multiple STI + dat$epi$prev.hivposmultsti[at] <- sum(status == 1 & + ((rGC == 1 & (uGC == 1 | rCT == 1 | uCT == 1 | stage.syph %in% c(1, 2, 3))) | + (uGC == 1 & (rGC == 1 | rCT == 1 | uCT == 1 | stage.syph %in% c(1, 2, 3))) | + (rCT == 1 & (uGC == 1 | rGC == 1 | uCT == 1 | stage.syph %in% c(1, 2, 3))) | + (uCT == 1 & (uGC == 1 | rGC == 1 | rCT == 1 | stage.syph %in% c(1, 2, 3))) | + (stage.syph %in% c(1, 2, 3) & (uGC == 1 | rGC == 1 | rCT == 1 | uCT == 1)))) / dat$epi$i.num[at] + + # Site-specific STI incidence rates + + # Gonorrhea + dat$epi$ir100.rgc[at] <- ifelse(sum(rGC == 0, dat$epi$incid.rgc[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc[at] / sum(rGC == 0, dat$epi$incid.rgc[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ugc[at] <- ifelse(sum(uGC == 0, dat$epi$incid.ugc[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc[at] / sum(uGC == 0, dat$epi$incid.ugc[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc[at] <- dat$epi$ir100.rgc[at] + dat$epi$ir100.ugc[at] + + ir100.rgc.hivneg <- ifelse(sum(rGC == 0 & status == 0, dat$epi$incid.rgc.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc.hivneg[at] / sum(rGC == 0 & status == 0, dat$epi$incid.rgc.hivneg[at], na.rm = TRUE)) * 5200, 0) + ir100.ugc.hivneg <- ifelse(sum(uGC == 0 & status == 0, dat$epi$incid.ugc.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.hivneg[at] / sum(uGC == 0 & status == 0, dat$epi$incid.ugc.hivneg[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.hivneg[at] <- ir100.rgc.hivneg + ir100.ugc.hivneg + + ir100.rgc.hivpos <- ifelse(sum(rGC == 0 & status == 1, na.rm = TRUE) > 0, + (dat$epi$incid.rgc.hivpos[at] / sum(rGC == 0 & status == 1, na.rm = TRUE)) * 5200, 0) + ir100.ugc.hivpos <- ifelse(sum(uGC == 0 & status == 1, dat$epi$incid.ugc.hivpos[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.hivpos[at] / sum(uGC == 0 & status == 1, dat$epi$incid.ugc.hivpos[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.hivpos[at] <- ir100.rgc.hivpos + ir100.ugc.hivpos + + ir100.rgc.tttraj1 <- ifelse(sum(rGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), dat$epi$incid.rgc.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc.tttraj1[at] / sum(rGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), + dat$epi$incid.rgc.tttraj1[at], na.rm = TRUE)) * 5100, 0) + ir100.ugc.tttraj1 <- ifelse(sum(uGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), dat$epi$incid.ugc.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.tttraj1[at] / sum(uGC == 0 & (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1), + dat$epi$incid.ugc.tttraj1[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.tttraj1[at] <- ir100.rgc.tttraj1 + ir100.ugc.tttraj1 + + ir100.rgc.tttraj2 <- ifelse(sum(rGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), dat$epi$incid.rgc.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.rgc.tttraj2[at] / sum(rGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), + dat$epi$incid.rgc.tttraj2[at], na.rm = TRUE)) * 5200, 0) + ir100.ugc.tttraj2 <- ifelse(sum(uGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), dat$epi$incid.ugc.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.ugc.tttraj2[at] / sum(uGC == 0 & (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2), + dat$epi$incid.ugc.tttraj2[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.gc.tttraj2[at] <- ir100.rgc.tttraj2 + ir100.ugc.tttraj2 + + # Chlamydia + dat$epi$ir100.rct[at] <- ifelse(sum(rCT == 0, dat$epi$incid.rct[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct[at] / sum(rCT == 0, dat$epi$incid.rct[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.uct[at] <- ifelse(sum(uCT == 0, dat$epi$incid.uct[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct[at] / sum(uCT == 0, dat$epi$incid.uct[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct[at] <- dat$epi$ir100.rct[at] + dat$epi$ir100.uct[at] + + ir100.rct.hivneg <- ifelse(sum(rCT == 0 & status == 0, dat$epi$incid.rct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.hivneg[at] / sum(rCT == 0 & status == 0, dat$epi$incid.rct.hivneg[at], na.rm = TRUE)) * 5200, 0) + ir100.uct.hivneg <- ifelse(sum(uCT == 0 & status == 0, dat$epi$incid.uct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.hivneg[at] / sum(uCT == 0 & status == 0, dat$epi$incid.uct.hivneg[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.hivneg[at] <- ir100.rct.hivneg + ir100.uct.hivneg + + ir100.rct.hivpos <- ifelse(sum(rCT == 0 & status == 1, dat$epi$incid.rct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.hivneg[at] / sum(rCT == 0 & status == 1, dat$epi$incid.rct.hivneg[at], na.rm = TRUE)) * 5200, 0) + ir100.uct.hivpos <- ifelse(sum(uCT == 0 & status == 1, dat$epi$incid.uct.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.hivneg[at] / sum(uCT == 0 & status == 1, dat$epi$incid.uct.hivneg[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.hivpos[at] <- ir100.rct.hivpos + ir100.uct.hivpos + + ir100.rct.tttraj1 <- ifelse(sum(rCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), dat$epi$incid.rct.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.tttraj1[at] / sum(rCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), + dat$epi$incid.rct.tttraj1[at], na.rm = TRUE)) * 5100, 0) + ir100.uct.tttraj1 <- ifelse(sum(uCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), dat$epi$incid.uct.tttraj1[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.tttraj1[at] / sum(uCT == 0 & (tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1), + dat$epi$incid.uct.tttraj1[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.tttraj1[at] <- ir100.rct.tttraj1 + ir100.uct.tttraj1 + + ir100.rct.tttraj2 <- ifelse(sum(rCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), dat$epi$incid.rct.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.rct.tttraj2[at] / sum(rCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), + dat$epi$incid.rct.tttraj2[at], na.rm = TRUE)) * 5200, 0) + ir100.uct.tttraj2 <- ifelse(sum(uCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), dat$epi$incid.uct.tttraj2[at], na.rm = TRUE) > 0, + (dat$epi$incid.uct.tttraj2[at] / sum(uCT == 0 & (tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2), + dat$epi$incid.uct.tttraj2[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.ct.tttraj2[at] <- ir100.rct.tttraj2 + ir100.uct.tttraj2 + + # Syphilis + dat$epi$ir100.syph[at] <- ifelse(sum(syphilis == 0, dat$epi$incid.syph[at], na.rm = TRUE) > 0, + (dat$epi$incid.syph[at] / sum(syphilis == 0, dat$epi$incid.syph[at], na.rm = TRUE)) * 5200, 0) + + dat$epi$ir100.syph.tttraj1[at] <- ifelse((sum(syphilis == 0 & (tt.traj.syph.hivneg == 1 | tt.traj.syph.hivpos == 1), dat$epi$incid.syph.tttraj1[at], na.rm = TRUE)) > 0, + (dat$epi$incid.syph.tttraj1[at] / + (sum(syphilis == 0 & (tt.traj.syph.hivneg == 1 | tt.traj.syph.hivpos == 1), dat$epi$incid.syph.tttraj1[at], na.rm = TRUE))) * 5200, 0) + + dat$epi$ir100.syph.tttraj2[at] <- ifelse((sum(syphilis == 0 & (tt.traj.syph.hivneg == 2 | tt.traj.syph.hivpos == 2), dat$epi$incid.syph.tttraj2[at], na.rm = TRUE)) > 0, + (dat$epi$incid.syph.tttraj2[at] / + (sum(syphilis == 0 & (tt.traj.syph.hivneg == 2 | tt.traj.syph.hivpos == 2), dat$epi$incid.syph.tttraj2[at], na.rm = TRUE))) * 5200, 0) + + dat$epi$ir100.gc.tttraj1[at] <- ir100.rgc.tttraj1 + ir100.ugc.tttraj1 + + dat$epi$ir100.syph.hivneg[at] <- ifelse(sum(syphilis == 0 & status == 0, dat$epi$incid.syph.hivneg[at], na.rm = TRUE) > 0, + (dat$epi$incid.syph.hivneg[at] / sum(syphilis == 0 & status == 0, dat$epi$incid.syph.hivneg[at], na.rm = TRUE)) * 5200, 0) + dat$epi$ir100.syph.hivpos[at] <- ifelse(sum(syphilis == 0 & status == 1, dat$epi$incid.syph.hivpos[at], na.rm = TRUE) > 0, + (dat$epi$incid.syph.hivpos[at] / sum(syphilis == 0 & status == 1, dat$epi$incid.syph.hivpos[at], na.rm = TRUE)) * 5200, 0) + + + # Combined GC/CT Incidence + dat$epi$ir100.gcct[at] <- dat$epi$ir100.gc[at] + dat$epi$ir100.ct[at] + + dat$epi$ir100.gcct.tttraj1[at] <- dat$epi$ir100.gc.tttraj1[at] + dat$epi$ir100.ct.tttraj1[at] + + dat$epi$ir100.gcct.tttraj2[at] <- dat$epi$ir100.gc.tttraj2[at] + dat$epi$ir100.ct.tttraj2[at] + + # All STI Incidence + dat$epi$ir100.sti[at] <- dat$epi$ir100.gc[at] + dat$epi$ir100.ct[at] + dat$epi$ir100.syph[at] + + dat$epi$ir100.sti.tttraj1[at] <- dat$epi$ir100.gc.tttraj1[at] + dat$epi$ir100.ct.tttraj1[at] + dat$epi$ir100.syph.tttraj1[at] + + dat$epi$ir100.sti.tttraj2[at] <- dat$epi$ir100.gc.tttraj2[at] + dat$epi$ir100.ct.tttraj2[at] + dat$epi$ir100.syph.tttraj2[at] + + dat$epi$ir100.sti.prep[at] <- ifelse((sum(rGC == 0 & prepStat == 1, na.rm = TRUE) + sum(uGC == 0 & prepStat == 1, na.rm = TRUE) + + sum(rCT == 0 & prepStat == 1, na.rm = TRUE) + sum(uCT == 0 & prepStat == 1, na.rm = TRUE) + + sum(syphilis == 0 & prepStat == 1, na.rm = TRUE)) > 0, + (dat$epi$incid.gcct.prep[at] + dat$epi$incid.syph.prep[at] / + (sum(rGC == 0 & prepStat == 1, na.rm = TRUE) + sum(uGC == 0 & prepStat == 1, na.rm = TRUE) + + sum(rCT == 0 & prepStat == 1, na.rm = TRUE) + sum(uCT == 0 & prepStat == 1, na.rm = TRUE) + + sum(syphilis == 0 & prepStat == 1, na.rm = TRUE))) * 5200, 0) + + + # STI Prevalence + dat$epi$prev.sti[at] <- ifelse(sum(rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1 , na.rm = TRUE) > 0, + sum(rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1 , na.rm = TRUE) / dat$epi$num[at], 0) + + dat$epi$prev.sti.tttraj1[at] <- ifelse((dat$epi$tt.traj.sti1[at] == 0 | is.na(dat$epi$tt.traj.sti1[at]) | + is.nan(dat$epi$tt.traj.sti1[at]) | is.null(dat$epi$tt.traj.sti1[at])), 0, + length(which((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1) & + (tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1 | + tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1 | + tt.traj.syph.hivneg == 1 | tt.traj.syph.hivpos == 1))) / + dat$epi$tt.traj.sti1[at]) + + dat$epi$prev.sti.tttraj2[at] <- ifelse((dat$epi$tt.traj.sti2[at] == 0 | is.na(dat$epi$tt.traj.sti2[at]) | + is.nan(dat$epi$tt.traj.sti2[at]) | is.null(dat$epi$tt.traj.sti2[at])), 0, + length(which((rGC == 1 | uGC == 1 | rCT == 1 | uCT == 1 | syphilis == 1) & + (tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2 | + tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2 | + tt.traj.syph.hivneg == 2 | tt.traj.syph.hivpos == 2))) / + dat$epi$tt.traj.sti2[at]) + + # Testing indications + dat$epi$stiactiveind.prop[at] <- dat$epi$stiactiveind[at] / dat$epi$num[at] + dat$epi$recentpartners.prop[at] <- dat$epi$recentpartners[at] / dat$epi$num[at] + + # Testing in last 12 months + # Overall + dat$epi$test.gc.12mo[at] <- length(which(tslt.rgc <= 52 | tslt.ugc <= 52)) / dat$epi$num[at] + dat$epi$test.ct.12mo[at] <- length(which(tslt.rct <= 52 | tslt.uct <= 52)) / dat$epi$num[at] + dat$epi$test.syph.12mo[at] <- length(which(tslt.syph <= 52)) / dat$epi$num[at] + + # Among those HIV-negative or undiagnosed + dat$epi$test.gc.12mo.nonhivdiag[at] <- length(which((tslt.rgc <= 52 | tslt.ugc <= 52) & + (is.na(diag.status) | diag.status == 0))) / length(which(is.na(diag.status) | diag.status == 0)) + dat$epi$test.ct.12mo.nonhivdiag[at] <- length(which((tslt.rct <= 52 | tslt.uct <= 52) & + (is.na(diag.status) | diag.status == 0))) / length(which(is.na(diag.status) | diag.status == 0)) + dat$epi$test.syph.12mo.nonhivdiag[at] <- length(which((tslt.syph <= 52) & + (is.na(diag.status) | diag.status == 0))) / length(which(is.na(diag.status) | diag.status == 0)) + + # Among those diagnosed + dat$epi$test.gc.12mo.hivdiag[at] <- length(which((tslt.rgc <= 52 | tslt.ugc <= 52) & + diag.status == 1)) / length(which(diag.status == 1)) + dat$epi$test.ct.12mo.hivdiag[at] <- length(which((tslt.rct <= 52 | tslt.uct <= 52) & + diag.status == 1)) / length(which(diag.status == 1)) + dat$epi$test.syph.12mo.hivdiag[at] <- length(which((tslt.syph <= 52) & + diag.status == 1)) / length(which(diag.status == 1)) + + # Among those HIV-negative + dat$epi$test.gc.12mo.hivneg[at] <- length(which((tslt.rgc <= 52 | tslt.ugc <= 52) & + status == 0)) / length(which(status == 0)) + dat$epi$test.ct.12mo.hivneg[at] <- length(which((tslt.rct <= 52 | tslt.uct <= 52) & + status == 0)) / length(which(status == 0)) + dat$epi$test.syph.12mo.hivneg[at] <- length(which((tslt.syph <= 52) & + status == 0)) / length(which(status == 0)) + + # Among those HIV-positive + dat$epi$test.gc.12mo.hivpos[at] <- length(which((tslt.rgc <= 52 | tslt.ugc <= 52) & + status == 1)) / length(which(status == 1)) + dat$epi$test.ct.12mo.hivpos[at] <- length(which((tslt.rct <= 52 | tslt.uct <= 52) & + status == 1)) / length(which(status == 1)) + dat$epi$test.syph.12mo.hivpos[at] <- length(which((tslt.syph <= 52) & + status == 1)) / length(which(status == 1)) return(dat) } +#' @title Prevalence Module +#' +#' @description Module function to calculate and store summary statistics for +#' disease prevalence, demographics, and other epidemiological +#' outcomes. +#' +#' @inheritParams aging_het +#' +#' @keywords module het +#' #' @export -#' @rdname prevalence_msm +#' prevalence_het <- function(dat, at) { status <- dat$attr$status @@ -220,10 +1465,8 @@ prevalence_het <- function(dat, at) { dat$epi$i.num.male[at] <- sum(status == 1 & male == 1, na.rm = TRUE) dat$epi$i.num.feml[at] <- sum(status == 1 & male == 0, na.rm = TRUE) - dat$epi$i.prev.male[at] <- sum(status == 1 & male == 1, na.rm = TRUE) / - sum(male == 1, na.rm = TRUE) - dat$epi$i.prev.feml[at] <- sum(status == 1 & male == 0, na.rm = TRUE) / - sum(male == 0, na.rm = TRUE) + dat$epi$i.prev.male[at] <- sum(status == 1 & male == 1, na.rm = TRUE) / sum(male == 1, na.rm = TRUE) + dat$epi$i.prev.feml[at] <- sum(status == 1 & male == 0, na.rm = TRUE) / sum(male == 0, na.rm = TRUE) dat$epi$num.male[at] <- sum(male == 1, na.rm = TRUE) dat$epi$num.feml[at] <- sum(male == 0, na.rm = TRUE) @@ -237,6 +1480,5 @@ prevalence_het <- function(dat, at) { whichVlSupp <- function(attr, param) { which(attr$status == 1 & attr$vlLevel <= log10(50) & - (attr$age - attr$ageInf) * (365 / param$time.unit) > - (param$vl.acute.topeak + param$vl.acute.toset)) + (attr$age - attr$ageInf) * (365 / param$time.unit) > (param$vl.acute.topeak + param$vl.acute.toset)) } diff --git a/R/mod.progress.R b/R/mod.progress.R index 61772e87..ba1b7539 100644 --- a/R/mod.progress.R +++ b/R/mod.progress.R @@ -1,8 +1,8 @@ #' @title Disease Progression Module #' -#' @description Module function for HIV disease progression through acute, chronic -#' and AIDS stages. +#' @description Module function for HIV disease progression through acute, +#' chronic and AIDS stages. #' #' @inheritParams aging_msm #' @@ -12,89 +12,345 @@ #' acute falling is the time from peak viremia to chronic stage infection with #' an established set-point HIV viral load. #' -#' The time spent in chronic stage infection, and thus the time from infection to -#' AIDS, depends on ART history. For ART-naive persons, time to AIDS is established -#' by the \code{vl.aids.onset} parameter. For persons ever on ART who fall into -#' the partially suppressed category (the \code{tt.traj} attribute is \code{3}), -#' time to AIDS depends on the sum of two ratios: time on treatment over maximum -#' time on treatment plus time off treatment over maximum time off treatment. -#' For persons ever on ART who fall into the fully suppressed cateogry -#' (\code{tt.traj=4}), time to AIDS depends on whether the cumulative time -#' off treatment exceeds a time threshold specified in the \code{max.time.off.tx.full} -#' parameter. +#' The time spent in chronic stage infection, and thus the time from infection +#' to AIDS, depends on ART history. For ART-naive persons, time to AIDS is +#' established by the \code{vl.aids.onset.int} parameter. For persons ever on ART +#' who fall into the partially suppressed category (the \code{tt.traj} attribute +#' is \code{3}), time to AIDS depends on the sum of two ratios: time on +#' treatment over maximum time on treatment plus time off treatment over maximum +#' time off treatment. For persons ever on ART who fall into the fully +#' suppressed category (\code{tt.traj=4}), time to AIDS depends on whether the +#' cumulative time off treatment exceeds a time threshold specified in the +#' \code{max.time.off.tx.full} parameter. #' #' @return #' This function returns the \code{dat} object after updating the disease stage #' of infected individuals. #' #' @keywords module msm -#' +#' #' @export #' -progress_msm <- function(dat, at) { +hiv_progress_msm <- function(dat, at) { ## Variables # Attributes - active <- dat$attr$active status <- dat$attr$status time.since.inf <- at - dat$attr$inf.time + time.since.diag <- at - dat$attr$diag.time cum.time.on.tx <- dat$attr$cum.time.on.tx cum.time.off.tx <- dat$attr$cum.time.off.tx stage <- dat$attr$stage stage.time <- dat$attr$stage.time + stage.time.ar.ndx <- dat$attr$stage.time.ar.ndx + stage.time.ar.dx <- dat$attr$stage.time.ar.dx + stage.time.af.ndx <- dat$attr$stage.time.af.ndx + stage.time.af.dx <- dat$attr$stage.time.af.dx + stage.time.early.chronic.ndx <- dat$attr$stage.time.early.chronic.ndx + stage.time.early.chronic.dx.yrone <- dat$attr$stage.time.early.chronic.dx.yrone + stage.time.early.chronic.dx.yrstwotolate <- dat$attr$stage.time.early.chronic.dx.yrstwotolate + stage.time.early.chronic.art <- dat$attr$stage.time.early.chronic.art + stage.time.late.chronic.ndx <- dat$attr$stage.time.late.chronic.ndx + stage.time.late.chronic.dx <- dat$attr$stage.time.late.chronic.dx + stage.time.late.chronic.art <- dat$attr$stage.time.late.chronic.art + stage.time.aids.ndx <- dat$attr$stage.time.aids.ndx + stage.time.aids.dx <- dat$attr$stage.time.aids.dx + stage.time.aids.art <- dat$attr$stage.time.aids.art tt.traj <- dat$attr$tt.traj tx.status <- dat$attr$tx.status + diag.status <- dat$attr$diag.status # Parameters vl.acute.rise.int <- dat$param$vl.acute.rise.int vl.acute.fall.int <- dat$param$vl.acute.fall.int - vl.aids.onset <- dat$param$vl.aids.onset + vl.aids.onset.int <- dat$param$vl.aids.onset.int max.time.off.tx.part <- dat$param$max.time.off.tx.part max.time.on.tx.part <- dat$param$max.time.on.tx.part - max.time.off.tx.full <- dat$param$max.time.off.tx.full + # Seventy percent value for early/late chronic split + early.chronic.int <- floor(0.7 * dat$param$max.time.off.tx.full.int) ## Process + # Current stage + AR.ndx <- which(stage == 1 & diag.status == 0) + AF.ndx <- which(stage == 2 & diag.status == 0) + early.chronic.ndx <- which(stage == 3 & diag.status == 0 & cum.time.off.tx <= early.chronic.int) + late.chronic.ndx <- which(stage == 3 & diag.status == 0 & cum.time.off.tx > early.chronic.int) + aids.ndx <- which(stage == 4 & diag.status == 0) + + AR.dx <- which(stage == 1 & diag.status == 1) + AF.dx <- which(stage == 2 & diag.status == 1) + early.chronic.dx.yrone <- which(stage == 3 & diag.status == 1 & + time.since.diag <= 52 & + cum.time.off.tx <= early.chronic.int & + tx.status == 0) + early.chronic.dx.yrstwotolate <- which(stage == 3 & diag.status == 1 & + time.since.diag > 52 & + cum.time.off.tx <= early.chronic.int & + tx.status == 0) + late.chronic.dx <- which(stage == 3 & diag.status == 1 & + cum.time.off.tx > early.chronic.int & + tx.status == 0) + aids.dx <- which(stage == 4 & diag.status == 1 & tx.status == 0) + + early.chronic.art <- which(stage == 3 & diag.status == 1 & + cum.time.off.tx <= early.chronic.int & + tx.status == 1) + late.chronic.art <- which(stage == 3 & diag.status == 1 & + cum.time.off.tx > early.chronic.int & + tx.status == 1) + aids.art <- which(stage == 4 & diag.status == 1 & tx.status == 1) + + # Population numbers (person-time contributed at each time step) + dat$epi$stage.time.ar.ndx[at] <- length(AR.ndx) + dat$epi$stage.time.ar.dx[at] <- length(AR.dx) + dat$epi$stage.time.af.ndx[at] <- length(AF.ndx) + dat$epi$stage.time.af.dx[at] <- length(AF.dx) + dat$epi$stage.time.early.chronic.ndx[at] <- length(early.chronic.ndx) + dat$epi$stage.time.early.chronic.dx.yrone[at] <- length(early.chronic.dx.yrone) + dat$epi$stage.time.early.chronic.dx.yrstwotolate[at] <- length(early.chronic.dx.yrstwotolate) + dat$epi$stage.time.early.chronic.art[at] <- length(early.chronic.art) + dat$epi$stage.time.late.chronic.ndx[at] <- length(late.chronic.ndx) + dat$epi$stage.time.late.chronic.dx[at] <- length(late.chronic.dx) + dat$epi$stage.time.late.chronic.art[at] <- length(late.chronic.art) + dat$epi$stage.time.aids.ndx[at] <- length(aids.ndx) + dat$epi$stage.time.aids.dx[at] <- length(aids.dx) + dat$epi$stage.time.aids.art[at] <- length(aids.art) + dat$epi$time.hivneg[at] <- length(which(status == 0)) - # Increment day - stage.time[active == 1] <- stage.time[active == 1] + 1 + # Increment time step + stage.time[status == 1] <- stage.time[status == 1] + 1 + stage.time.ar.ndx[AR.ndx] <- stage.time.ar.ndx[AR.ndx] + 1 + stage.time.ar.dx[AR.dx] <- stage.time.ar.dx[AR.dx] + 1 + stage.time.af.ndx[AF.ndx] <- stage.time.af.ndx[AF.ndx] + 1 + stage.time.af.dx[AF.dx] <- stage.time.af.dx[AF.dx] + 1 + stage.time.early.chronic.ndx[early.chronic.ndx] <- stage.time.early.chronic.ndx[early.chronic.ndx] + 1 + stage.time.early.chronic.dx.yrone[early.chronic.dx.yrone] <- stage.time.early.chronic.dx.yrone[early.chronic.dx.yrone] + 1 + stage.time.early.chronic.dx.yrstwotolate[early.chronic.dx.yrstwotolate] <- + stage.time.early.chronic.dx.yrstwotolate[early.chronic.dx.yrstwotolate] + 1 + stage.time.early.chronic.art[early.chronic.art] <- stage.time.early.chronic.art[early.chronic.art] + 1 + stage.time.late.chronic.ndx[late.chronic.ndx] <- stage.time.late.chronic.ndx[late.chronic.ndx] + 1 + stage.time.late.chronic.dx[late.chronic.dx] <- stage.time.late.chronic.dx[late.chronic.dx] + 1 + stage.time.late.chronic.art[late.chronic.art] <- stage.time.late.chronic.art[late.chronic.art] + 1 + stage.time.aids.ndx[aids.ndx] <- stage.time.aids.ndx[aids.ndx] + 1 + stage.time.aids.dx[aids.dx] <- stage.time.aids.dx[aids.dx] + 1 + stage.time.aids.art[aids.art] <- stage.time.aids.art[aids.art] + 1 # Change stage to Acute Falling - toAF <- which(active == 1 & time.since.inf == (vl.acute.rise.int + 1)) - stage[toAF] <- 2 - stage.time[toAF] <- 1 + toAF.ndx <- which(time.since.inf == (vl.acute.rise.int + 1) & diag.status == 0) + toAF.dx <- which(time.since.inf == (vl.acute.rise.int + 1) & diag.status == 1) + toAF <- which(time.since.inf == (vl.acute.rise.int + 1)) + stage[toAF.ndx] <- 2 + stage[toAF.dx] <- 2 + stage.time[toAF] <- 0 # Change stage to Chronic - toC <- which(active == 1 & time.since.inf == (vl.acute.rise.int + - vl.acute.fall.int + 1)) - stage[toC] <- 3 - stage.time[toC] <- 1 + toC <- which(time.since.inf == (vl.acute.rise.int + vl.acute.fall.int + 1)) + toC.ndx <- which(time.since.inf == (vl.acute.rise.int + vl.acute.fall.int + 1) & diag.status == 0) + toC.dx <- which(time.since.inf == (vl.acute.rise.int + vl.acute.fall.int + 1) & diag.status == 1) + + stage[toC.ndx] <- 3 + stage[toC.dx] <- 3 + stage.time[toC] <- 0 # Change stage to AIDS - aids.tx.naive <- which(active == 1 & status == 1 & cum.time.on.tx == 0 & - (time.since.inf >= vl.aids.onset) & stage != 4) + aids.tx.naive.ndx <- which(status == 1 & cum.time.on.tx == 0 & + (time.since.inf >= vl.aids.onset.int) & stage != 4 & + diag.status == 0) + aids.tx.naive.dx <- which(status == 1 & cum.time.on.tx == 0 & + (time.since.inf >= vl.aids.onset.int) & stage != 4 + & diag.status == 1 & tx.status == 0) + aids.tx.naive.art <- which(status == 1 & cum.time.on.tx == 0 & + (time.since.inf >= vl.aids.onset.int) & stage != 4 + & diag.status == 1 & tx.status == 1) part.tx.score <- (cum.time.off.tx / max.time.off.tx.part) + (cum.time.on.tx / max.time.on.tx.part) - aids.part.escape <- which(active == 1 & cum.time.on.tx > 0 & tt.traj == 3 & - stage == 3 & part.tx.score >= 1 & stage != 4) + aids.part.escape.ndx <- which(cum.time.on.tx > 0 & tt.traj == 3 & + stage == 3 & part.tx.score >= 1 & stage != 4 & + diag.status == 0) + aids.part.escape.dx <- which(cum.time.on.tx > 0 & tt.traj == 3 & + stage == 3 & part.tx.score >= 1 & stage != 4 & + diag.status == 1 & tx.status == 0) + aids.part.escape.art <- which(cum.time.on.tx > 0 & tt.traj == 3 & + stage == 3 & part.tx.score >= 1 & stage != 4 & + diag.status == 1 & tx.status == 1) - aids.off.tx.full.escape <- which(active == 1 & tx.status == 0 & tt.traj == 4 & - cum.time.on.tx > 0 & - cum.time.off.tx >= max.time.off.tx.full & - stage != 4) + aids.off.tx.full.escape.ndx <- which(tx.status == 0 & tt.traj == 4 & + cum.time.on.tx > 0 & cum.time.off.tx >= max.time.off.tx.full & + stage != 4 & diag.status == 0) + aids.off.tx.full.escape.dx <- which(tx.status == 0 & tt.traj == 4 & + cum.time.on.tx > 0 & cum.time.off.tx >= max.time.off.tx.full & + stage != 4 & diag.status == 1) + aids.off.tx.full.escape.art <- which(tx.status == 1 & tt.traj == 4 & + cum.time.on.tx > 0 & cum.time.off.tx >= max.time.off.tx.full & + stage != 4 & diag.status == 1) - isAIDS <- c(aids.tx.naive, aids.part.escape, aids.off.tx.full.escape) - stage[isAIDS] <- 4 - stage.time[isAIDS] <- 1 + isAIDS <- c(aids.tx.naive.ndx, aids.tx.naive.dx, aids.tx.naive.art, + aids.part.escape.ndx, aids.part.escape.dx, aids.part.escape.art, + aids.off.tx.full.escape.ndx, aids.off.tx.full.escape.dx) + isAIDS.ndx <- c(aids.tx.naive.ndx, aids.part.escape.ndx, + aids.off.tx.full.escape.ndx) + isAIDS.dx <- c(aids.tx.naive.dx, aids.part.escape.dx, + aids.off.tx.full.escape.dx) + isAIDS.art <- c(aids.tx.naive.art, aids.part.escape.art, aids.off.tx.full.escape.art) + stage[isAIDS.ndx] <- 4 + stage[isAIDS.dx] <- 4 + stage[isAIDS.art] <- 4 + stage.time[isAIDS] <- 0 ## Output + # Individual attribute: time in stage dat$attr$stage <- stage dat$attr$stage.time <- stage.time + dat$attr$stage.time.ar.ndx <- stage.time.ar.ndx + dat$attr$stage.time.ar.dx <- stage.time.ar.dx + dat$attr$stage.time.af.ndx <- stage.time.af.ndx + dat$attr$stage.time.af.dx <- stage.time.af.dx + dat$attr$stage.time.early.chronic.dx.yrone <- stage.time.early.chronic.dx.yrone + dat$attr$stage.time.early.chronic.dx.yrstwotolate <- stage.time.early.chronic.dx.yrstwotolate + dat$attr$stage.time.early.chronic.art <- stage.time.early.chronic.art + dat$attr$stage.time.late.chronic.ndx <- stage.time.late.chronic.ndx + dat$attr$stage.time.late.chronic.dx <- stage.time.late.chronic.dx + dat$attr$stage.time.late.chronic.art <- stage.time.late.chronic.art + dat$attr$stage.time.aids.ndx <- stage.time.aids.ndx + dat$attr$stage.time.aids.dx <- stage.time.aids.dx + dat$attr$stage.time.aids.art <- stage.time.aids.art + + if (at < dat$param$prep.start) { + dat$attr$time.off.prep[dat$attr$prepStat == 0] <- dat$attr$time.off.prep[dat$attr$prepStat == 0] + 1 + } + + return(dat) +} + +#' @title Disease Progression Module +#' +#' @description Module function for Syphilis disease progression through +#' multiple stages. +#' +#' @inheritParams aging_msm +#' +#' @details +#' Syphilis disease is divided into multiple stages: incubating, primary, +#' secondary, early latent, late latent, tertiary, and remission. +#' +#' The time spent in chronic stage infection, and thus the time from infection +#' to AIDS, depends on ART history. For ART-naive persons, time to AIDS is +#' established by the \code{vl.aids.onset.int} parameter. For persons ever on ART +#' who fall into the partially suppressed category (the \code{tt.traj} attribute +#' is \code{3}), time to AIDS depends on the sum of two ratios: time on +#' treatment over maximum time on treatment plus time off treatment over maximum +#' time off treatment. +#' For persons ever on ART who fall into the fully suppressed category +#' (\code{tt.traj=4}), time to AIDS depends on whether the cumulative time +#' off treatment exceeds a time threshold specified in the +#' \code{max.time.off.tx.full} parameter. +#' +#' @return +#' This function returns the \code{dat} object after updating the disease stage +#' of infected individuals. +#' +#' @keywords module msm syphilis +#' +#' @export +#' +syph_progress_msm <- function(dat, at) { + + ## Variables + + # Attributes + syphilis <- dat$attr$syphilis + stage.syph <- dat$attr$stage.syph + stage.time.syph <- dat$attr$stage.time.syph + syph.sympt <- dat$attr$syph.sympt + syph.incub.tx <- dat$attr$syph.incub.tx + syph.prim.tx <- dat$attr$syph.prim.tx + syph.seco.tx <- dat$attr$syph.seco.tx + syph.earlat.tx <- dat$attr$syph.earlat.tx + syph.latelat.tx <- dat$attr$syph.latelat.tx + + # Parameters + incu.syph.int <- dat$param$incu.syph.int + prim.syph.int <- dat$param$prim.syph.int + seco.syph.int <- dat$param$seco.syph.int + earlat.syph.int <- dat$param$earlat.syph.int + + syph.prim.sympt.prob <- dat$param$syph.prim.sympt.prob + syph.seco.sympt.prob <- dat$param$syph.seco.sympt.prob + syph.earlat.sympt.prob <- dat$param$syph.earlat.sympt.prob + syph.latelat.sympt.prob <- dat$param$syph.latelat.sympt.prob + syph.tert.sympt.prob <- dat$param$syph.tert.sympt.prob + syph.tert.prog.prob <- dat$param$syph.tert.prog.prob + + ## Process + + # Increment time unit + stage.time.syph[which(syphilis == 1)] <- stage.time.syph[which(syphilis == 1)] + 1 + + # Change stage to Primary and assign symptoms + toPrim <- which(stage.time.syph == (incu.syph.int + 1) & + stage.syph == 1 & + syphilis == 1) + stage.syph[toPrim] <- 2 + stage.time.syph[toPrim] <- 0 + syph.incub.tx[toPrim] <- NA + syph.sympt[toPrim] <- NA + syph.sympt[toPrim] <- rbinom(length(toPrim), 1, syph.prim.sympt.prob) + + # Change stage to Secondary and assign symptoms + toSeco <- which(stage.time.syph == (prim.syph.int + 1) & + stage.syph == 2 & + syphilis == 1) + stage.syph[toSeco] <- 3 + stage.time.syph[toSeco] <- 0 + syph.prim.tx[toSeco] <- 0 + syph.sympt[toSeco] <- NA + syph.sympt[toSeco] <- rbinom(length(toSeco), 1, syph.seco.sympt.prob) + + # Change stage to Early Latent and assign symptoms + toEarLat <- which(stage.time.syph == (seco.syph.int + 1) & + stage.syph == 3 & + syphilis == 1) + stage.syph[toEarLat] <- 4 + stage.time.syph[toEarLat] <- 0 + syph.seco.tx[toEarLat] <- NA + syph.sympt[toEarLat] <- NA + syph.sympt[toEarLat] <- rbinom(length(toEarLat), 1, syph.earlat.sympt.prob) + + # Change stage to Late Latent and assign symptoms + toLateLat <- which(stage.time.syph == (earlat.syph.int + 1) & + stage.syph == 4 & + syphilis == 1) + stage.syph[toLateLat] <- 5 + stage.time.syph[toLateLat] <- 0 + syph.earlat.tx[toLateLat] <- NA + syph.sympt[toLateLat] <- NA + syph.sympt[toLateLat] <- rbinom(length(toLateLat), 1, syph.latelat.sympt.prob) + + # Change stage to tertiary for fraction of those in late late latent + toTert <- which(stage.syph == 5 & + syphilis == 1) + toTert <- which(rbinom(length(toTert), 1, syph.tert.prog.prob) == 1) + stage.syph[toTert] <- 6 + stage.time.syph[toTert] <- 0 + syph.latelat.tx[toTert] <- NA + syph.sympt[toTert] <- NA + syph.sympt[toTert] <- rbinom(length(toTert), 1, syph.tert.sympt.prob) + + ## Output + dat$attr$syph.incub.tx <- syph.incub.tx + dat$attr$syph.prim.tx <- syph.prim.tx + dat$attr$syph.seco.tx <- syph.seco.tx + dat$attr$syph.earlat.tx <- syph.earlat.tx + dat$attr$syph.latelat.tx <- syph.latelat.tx + dat$attr$stage.syph <- stage.syph + dat$attr$stage.time.syph <- stage.time.syph + dat$attr$syph.sympt <- syph.sympt return(dat) } diff --git a/R/mod.riskhist.R b/R/mod.riskhist.R index e6978070..2f397fcf 100644 --- a/R/mod.riskhist.R +++ b/R/mod.riskhist.R @@ -1,8 +1,8 @@ -#' @title Risk History Module +#' @title Risk History for PrEP Module #' #' @description Module function to track the risk history of uninfected persons -#' for purpose of intervention targeting. +#' for purpose of PrEP prevention intervention targeting. #' #' @inheritParams aging_msm #' @@ -10,9 +10,9 @@ #' #' @export #' -riskhist_msm <- function(dat, at) { +riskhist_prep_msm <- function(dat, at) { - if (at < dat$param$riskh.start) { + if (at < dat$param$riskh.prep.start) { return(dat) } @@ -24,6 +24,12 @@ riskhist_msm <- function(dat, at) { uGC.tx <- dat$attr$uGC.tx rCT.tx <- dat$attr$rCT.tx uCT.tx <- dat$attr$uCT.tx + syph.incub.tx <- dat$attr$syph.incub.tx + syph.prim.tx <- dat$attr$syph.prim.tx + syph.seco.tx <- dat$attr$syph.seco.tx + syph.earlat.tx <- dat$attr$syph.earlat.tx + syph.latelat.tx <- dat$attr$syph.latelat.tx + syph.tert.tx <- dat$attr$syph.tert.tx ## Parameters time.unit <- dat$param$time.unit @@ -48,18 +54,18 @@ riskhist_msm <- function(dat, at) { ## Degree ## main.deg <- get_degree(dat$el[[1]]) - casl.deg <- get_degree(dat$el[[2]]) + pers.deg <- get_degree(dat$el[[2]]) inst.deg <- get_degree(dat$el[[3]]) - ## Preconditions ## + # Indications ------------------------------------------------------------- # Any UAI uai.any <- unique(c(el2$p1[el2$uai > 0], el2$p2[el2$uai > 0])) # Monogamous partnerships: 1-sided - tot.deg <- main.deg + casl.deg + inst.deg + tot.deg <- main.deg + pers.deg + inst.deg uai.mono1 <- intersect(which(tot.deg == 1), uai.any) # "Negative" partnerships @@ -91,10 +97,80 @@ riskhist_msm <- function(dat, at) { ai.sd <- el2.cond3$p2[discl == TRUE] dat$attr$prep.ind.ai.sd[ai.sd] <- at - ## Condition 4, any STI diagnosis + ## Condition 4, any current STI diagnosis (before recovery) idsDx <- which(rGC.tx == 1 | uGC.tx == 1 | - rCT.tx == 1 | uCT.tx == 1) + rCT.tx == 1 | uCT.tx == 1 | syph.incub.tx == 1 | + syph.prim.tx == 1 | syph.seco.tx == 1 | + syph.earlat.tx == 1 | syph.latelat.tx == 1 | + syph.tert.tx == 1) dat$attr$prep.ind.sti[idsDx] <- at return(dat) } + + +#' @title Risk History for STI Testing Module +#' +#' @description Module function to track the risk history of uninfected persons +#' for purpose of STI testing prevention intervention targeting. +#' +#' @inheritParams aging_msm +#' +#' @keywords module msm +#' +#' @export +#' +riskhist_stitest_msm <- function(dat, at) { + + ## Parameters + partnercutoff <- dat$param$partnercutoff + stitest.active.int <- dat$param$stitest.active.int + + ## Attributes + uid <- dat$attr$uid + race <- dat$attr$race + stitestind1 <- dat$attr$time.last.sex + + # Indications ------------------------------------------------------------- + + part.list <- dat$temp$part.list + + ### Lower risk - sexually active in the last year + idsactive <- which((at - stitestind1) <= stitest.active.int) + idsnotactive <- setdiff(which(race %in% c("B","W")), idsactive) + # these are relative ids of nodes in partner list + + ### High-risk: Have more than one sex partner in last x months + # Reset # of partners at each time step- length of "recent" interval is drawn from interval of partner list lookback + dat$attr$recentpartners <- rep(0, length(dat$attr$race)) + + if (at >= dat$param$stitest.start | at >= dat$param$ept.start) { + + # For those who had partners, calculate # of occurrences in partner list + part.count <- as.data.frame(table(part.list[, c("uid1", "uid2")])) + + if (nrow(part.count) > 1) { + + # Calculate # of recent partners: 0 for those not in part list, update numbers for only actives in part list + dat$attr$recentpartners[which(part.count[, "Var1"] %in% uid)] <- part.count[which(part.count[, "Var1"] %in% uid), 2] + + # Choose those who have had more than X partners in last x months + idsrecentpartners <- which(dat$attr$recentpartners > partnercutoff) + idsnotrecentpartners <- setdiff(which(race %in% c("B","W")), idsrecentpartners) + + dat$attr$stitest.ind.recentpartners[idsrecentpartners] <- 1 + dat$attr$stitest.ind.recentpartners[idsnotrecentpartners] <- 0 + dat$epi$recentpartners[at] <- length(idsrecentpartners) + + } + + } + ### Update STI indication attributes + dat$attr$stitest.ind.active[idsactive] <- 1 + dat$attr$stitest.ind.active[idsnotactive] <- 0 + + dat$epi$stiactiveind[at] <- length(idsactive) + + + return(dat) +} diff --git a/R/mod.simnet.R b/R/mod.simnet.R index a72e3014..7b2ae1b9 100644 --- a/R/mod.simnet.R +++ b/R/mod.simnet.R @@ -3,8 +3,8 @@ #' @title Network Resimulation Module #' -#' @description Module function for resimulating the sexual networks for one -#' time step. +#' @description Module function for resimulating the main, casual, and one-off +#' networks for one time step. #' #' @inheritParams aging_msm #' @@ -21,35 +21,41 @@ simnet_msm <- function(dat, at) { nwparam.m <- EpiModel::get_nwparam(dat, network = 1) if (dat$param$method == 1) { - dat$attr$deg.pers <- get_degree(dat$el[[2]]) + dat$attr$deg.pers <- get_degree(dat$el[[2]]) } else { - dat$attr$deg.pers <- paste0(dat$attr$race, get_degree(dat$el[[2]])) + dat$attr$deg.pers <- paste0(dat$attr$race, get_degree(dat$el[[2]])) } dat <- tergmLite::updateModelTermInputs(dat, network = 1) + dat$el[[1]] <- tergmLite::simulate_network(p = dat$p[[1]], el = dat$el[[1]], coef.form = nwparam.m$coef.form, coef.diss = nwparam.m$coef.diss$coef.adj, save.changes = TRUE) + dat$temp$new.edges <- NULL if (at == 2) { - new.edges.m <- matrix(dat$el[[1]], ncol = 2) + new.edges.m <- matrix(dat$attr$uid[dat$el[[1]]], ncol = 2) + highlow <- new.edges.m[which(new.edges.m[, 1] > new.edges.m[, 2]), , drop = FALSE] + lowhigh <- new.edges.m[which(new.edges.m[, 1] < new.edges.m[, 2]), , drop = FALSE] + new.edges.m <- rbind(highlow[, 2:1], lowhigh) } else { new.edges.m <- attributes(dat$el[[1]])$changes new.edges.m <- new.edges.m[new.edges.m[, "to"] == 1, 1:2, drop = FALSE] + new.edges.m <- matrix(dat$attr$uid[new.edges.m], ncol = 2) } - dat$temp$new.edges <- matrix(dat$attr$uid[new.edges.m], ncol = 2) + dat$temp$new.edges <- matrix(new.edges.m, ncol = 2) ## Casual network nwparam.p <- EpiModel::get_nwparam(dat, network = 2) if (dat$param$method == 1) { - dat$attr$deg.main <- get_degree(dat$el[[1]]) + dat$attr$deg.main <- get_degree(dat$el[[1]]) } else { - dat$attr$deg.main <- paste0(dat$attr$race, get_degree(dat$el[[1]])) + dat$attr$deg.main <- paste0(dat$attr$race, get_degree(dat$el[[1]])) } dat <- tergmLite::updateModelTermInputs(dat, network = 2) @@ -60,22 +66,27 @@ simnet_msm <- function(dat, at) { save.changes = TRUE) if (at == 2) { - new.edges.p <- matrix(dat$el[[2]], ncol = 2) + new.edges.p <- matrix(dat$attr$uid[dat$el[[2]]], ncol = 2) + highlow <- new.edges.p[which(new.edges.p[, 1] > new.edges.p[, 2]), , drop = FALSE] + lowhigh <- new.edges.p[which(new.edges.p[, 1] < new.edges.p[, 2]), , drop = FALSE] + new.edges.p <- rbind(highlow[, 2:1], lowhigh) + } else { new.edges.p <- attributes(dat$el[[2]])$changes new.edges.p <- new.edges.p[new.edges.p[, "to"] == 1, 1:2, drop = FALSE] + new.edges.p <- matrix(dat$attr$uid[new.edges.p], ncol = 2) } dat$temp$new.edges <- rbind(dat$temp$new.edges, - matrix(dat$attr$uid[new.edges.p], ncol = 2)) + matrix(new.edges.p, ncol = 2)) ## One-off network nwparam.i <- EpiModel::get_nwparam(dat, network = 3) if (dat$param$method == 1) { - dat$attr$deg.pers <- get_degree(dat$el[[2]]) + dat$attr$deg.pers <- get_degree(dat$el[[2]]) } else { - dat$attr$deg.pers <- paste0(dat$attr$race, get_degree(dat$el[[2]])) + dat$attr$deg.pers <- paste0(dat$attr$race, get_degree(dat$el[[2]])) } dat <- tergmLite::updateModelTermInputs(dat, network = 3) @@ -87,11 +98,55 @@ simnet_msm <- function(dat, at) { dat <- calc_resim_nwstats(dat, at) } + # Set last sexually active date - doesn't need to be uid-based + # dat$attr$time.last.sex[c(dat$el[[1]], dat$el[[2]], dat$el[[3]])] <- at + + # Calculate discordant/concordant proportion + if (is.null(dat$epi$prop.edges.negneg)) { + dat$epi$prop.edges.negneg <- rep(NA, dat$control$nsteps) + dat$epi$prop.edges.negpos <- rep(NA, dat$control$nsteps) + dat$epi$prop.edges.pospos <- rep(NA, dat$control$nsteps) + dat$epi$prop.main.edges.negneg <- rep(NA, dat$control$nsteps) + dat$epi$prop.main.edges.negpos <- rep(NA, dat$control$nsteps) + dat$epi$prop.main.edges.pospos <- rep(NA, dat$control$nsteps) + dat$epi$prop.cas.edges.negneg <- rep(NA, dat$control$nsteps) + dat$epi$prop.cas.edges.negpos <- rep(NA, dat$control$nsteps) + dat$epi$prop.cas.edges.pospos <- rep(NA, dat$control$nsteps) + dat$epi$prop.inst.edges.negneg <- rep(NA, dat$control$nsteps) + dat$epi$prop.inst.edges.negpos <- rep(NA, dat$control$nsteps) + dat$epi$prop.inst.edges.pospos <- rep(NA, dat$control$nsteps) + } + + alledge <- rbind(dat$el[[1]], dat$el[[2]], dat$el[[3]]) + status <- cbind(dat$attr$status[alledge[, 1]], dat$attr$status[alledge[, 2]]) + + main <- rbind(dat$el[[1]]) + cas <- rbind(dat$el[[2]]) + inst <- rbind(dat$el[[3]]) + + main.status <- cbind(dat$attr$status[main[, 1]], dat$attr$status[main[, 2]]) + cas.status <- cbind(dat$attr$status[cas[, 1]], dat$attr$status[cas[, 2]]) + inst.status <- cbind(dat$attr$status[inst[, 1]], dat$attr$status[inst[, 2]]) + + dat$epi$prop.edges.negneg[at] <- length(which(status[, 1] == 0 & status[, 2] == 0)) / nrow(alledge) + dat$epi$prop.edges.negpos[at] <- length(which((status[, 1] == 1 & status[, 2] == 0) | + (status[, 1] == 0 & status[, 2] == 1))) / nrow(alledge) + dat$epi$prop.edges.pospos[at] <- length(which(status[, 1] == 1 & status[, 2] == 1)) / nrow(alledge) + + dat$epi$prop.main.edges.negneg[at] <- length(which(main.status[, 1] == 0 & main.status[, 2] == 0)) / nrow(main) + dat$epi$prop.main.edges.negpos[at] <- length(which((main.status[, 1] == 1 & main.status[, 2] == 0) | (main.status[, 1] == 0 & main.status[, 2] == 1))) / nrow(main) + dat$epi$prop.main.edges.pospos[at] <- length(which(main.status[, 1] == 1 & main.status[, 2] == 1)) / nrow(main) + dat$epi$prop.cas.edges.negneg[at] <- length(which(cas.status[, 1] == 0 & cas.status[, 2] == 0)) / nrow(cas) + dat$epi$prop.cas.edges.negpos[at] <- length(which((cas.status[, 1] == 1 & cas.status[, 2] == 0) | (cas.status[, 1] == 0 & cas.status[, 2] == 1))) / nrow(cas) + dat$epi$prop.cas.edges.pospos[at] <- length(which(cas.status[, 1] == 1 & cas.status[, 2] == 1)) / nrow(cas) + dat$epi$prop.inst.edges.negneg[at] <- length(which(inst.status[, 1] == 0 & inst.status[, 2] == 0)) / nrow(inst) + dat$epi$prop.inst.edges.negpos[at] <- length(which((inst.status[, 1] == 1 & inst.status[, 2] == 0) | (inst.status[, 1] == 0 & inst.status[, 2] == 1))) / nrow(inst) + dat$epi$prop.inst.edges.pospos[at] <- length(which(inst.status[, 1] == 1 & inst.status[, 2] == 1)) / nrow(inst) + return(dat) } - calc_resim_nwstats <- function(dat, at) { for (nw in 1:3) { @@ -113,7 +168,6 @@ calc_resim_nwstats <- function(dat, at) { } - #' @title Adjustment for the Edges Coefficient with Changing Network Size #' #' @description Adjusts the edges coefficients in a dynamic network model @@ -146,7 +200,7 @@ calc_resim_nwstats <- function(dat, at) { edges_correct_msm <- function(dat, at) { old.num <- dat$epi$num[at - 1] - new.num <- sum(dat$attr$active == 1, na.rm = TRUE) + new.num <- sum(dat$attr$race %in% c("B", "W"), na.rm = TRUE) adjust <- log(old.num) - log(new.num) coef.form.m <- get_nwparam(dat, network = 1)$coef.form @@ -170,36 +224,126 @@ edges_correct_msm <- function(dat, at) { # HET ----------------------------------------------------------------- +#' @title Network Resimulation Module +#' +#' @description Module function to resimulate the dynamic network forward one +#' time step conditional on current network structure and vertex +#' attributes. +#' +#' @inheritParams aging_het +#' +#' @keywords module het +#' #' @export -#' @rdname simnet_msm +#' simnet_het <- function(dat, at) { # Update edges coefficients dat <- edges_correct_het(dat, at) # Update internal ergm data - dat <- tergmLite::updateModelTermInputs(dat, network = 1) + dat <- update_nwp_het(dat) # Pull network parameters - nwparam <- get_nwparam(dat, network = 1) + nwparam <- get_nwparam(dat) # Simulate edgelist - dat$el[[1]] <- tergmLite::simulate_network(p = dat$p[[1]], - el = dat$el[[1]], - coef.form = nwparam$coef.form, - coef.diss = nwparam$coef.diss$coef.adj) + dat$el <- tergmLite::simulate_network(p = dat$p, + el = dat$el, + coef.form = nwparam$coef.form, + coef.diss = nwparam$coef.diss$coef.adj) return(dat) } +update_nwp_het <- function(dat) { + + mf <- dat$p$model.form + md <- dat$p$model.diss + mhf <- dat$p$MHproposal.form + mhd <- dat$p$MHproposal.diss + + n <- attributes(dat$el)$n + maxdyads <- choose(n, 2) + + ## 1. Update model.form ## + + # edges + # inputs <- c(0, 1, 0) # not changed + mf$terms[[1]]$maxval <- maxdyads + + # nodematch + nodecov <- dat$attr$male + u <- sort(unique(nodecov)) + nodecov <- match(nodecov, u, nomatch = length(u) + 1) + inputs <- nodecov + mf$terms[[2]]$inputs <- c(0, 1, length(inputs), inputs) + + ## Update combined maxval here + mf$maxval <- c(maxdyads, Inf) + + + ## 2. Update model.diss ## + md$terms[[1]]$maxval <- maxdyads + md$maxval <- maxdyads + + + ## 3. Update MHproposal.form ## + mhf$arguments$constraints$bd$attribs <- + matrix(rep(mhf$arguments$constraints$bd$attribs[1], n), ncol = 1) + mhf$arguments$constraints$bd$maxout <- + matrix(rep(mhf$arguments$constraints$bd$maxout[1], n), ncol = 1) + mhf$arguments$constraints$bd$maxin <- matrix(rep(n, n), ncol = 1) + mhf$arguments$constraints$bd$minout <- + mhf$arguments$constraints$bd$minin <- matrix(rep(0, n), ncol = 1) + + ## 4. Update MHproposal.diss ## + mhd$arguments$constraints$bd <- mhf$arguments$constraints$bd + + + ## 5. Output ## + p <- list(model.form = mf, model.diss = md, + MHproposal.form = mhf, MHproposal.diss = mhd) + + dat$p <- p + return(dat) +} + + +#' @title Adjustment for the Edges Coefficient with Changing Network Size +#' +#' @description Adjusts the edges coefficients in a dynamic network model +#' to preserve the mean degree. +#' +#' @inheritParams aging_het +#' +#' @details +#' In HIV/STI modeling, there is typically an assumption that changes in +#' population size do not affect one's number of partners, specified as the +#' mean degree for network models. A person would not have 10 times the number +#' of partners should he move from a city 10 times as large. This module uses +#' the adjustment of Krivitsky et al. to adjust the edges coefficients on the +#' three network models to account for varying population size in order to +#' preserve that mean degree. +#' +#' @return +#' The network model parameters stored in \code{dat$nwparam} are updated. +#' +#' @references +#' Krivitsky PN, Handcock MS, and Morris M. "Adjusting for network size and +#' composition effects in exponential-family random graph models." Statistical +#' Methodology. 2011; 8.4: 319-339. +#' +#' @keywords module het +#' #' @export -#' @rdname edges_correct_msm +#' edges_correct_het <- function(dat, at) { # Popsize old.num <- dat$epi$num[at - 1] - new.num <- sum(dat$attr$active == 1, na.rm = TRUE) + new.num <- sum(dat$attr$race %in% c("B", "W"), na.rm = TRUE) # New Coefs coef.form <- get_nwparam(dat)$coef.form diff --git a/R/mod.sti.R b/R/mod.sti.R index 969ecb35..f78b3b28 100644 --- a/R/mod.sti.R +++ b/R/mod.sti.R @@ -10,28 +10,32 @@ #' #' @export #' -sti_trans <- function(dat, at) { +sti_trans_msm <- function(dat, at) { # Parameters ---------------------------------------------------------- - # Acquisition probabilities given contact with infected man + # Acquisition probability | exposure rgc.tprob <- dat$param$rgc.tprob ugc.tprob <- dat$param$ugc.tprob rct.tprob <- dat$param$rct.tprob uct.tprob <- dat$param$uct.tprob + syph.tprob <- dat$param$syph.tprob - # Probability of symptoms given infection + # Relative risk by syphilis stage + syph.incub.rr <- dat$param$syph.incub.rr + syph.earlat.rr <- dat$param$syph.earlat.rr + syph.late.rr <- dat$param$syph.late.rr + + # Probability of symptoms | infection rgc.sympt.prob <- dat$param$rgc.sympt.prob ugc.sympt.prob <- dat$param$ugc.sympt.prob rct.sympt.prob <- dat$param$rct.sympt.prob uct.sympt.prob <- dat$param$uct.sympt.prob + syph.incub.sympt.prob <- dat$param$syph.incub.sympt.prob - # Relative risk of infection given condom use during act + # Relative risk of infection | condom use sti.cond.rr <- dat$param$sti.cond.rr - # Cessation - gc.prob.cease <- dat$param$gc.prob.cease - ct.prob.cease <- dat$param$ct.prob.cease # Attributes ---------------------------------------------------------- @@ -40,37 +44,37 @@ sti_trans <- function(dat, at) { uGC <- dat$attr$uGC rCT <- dat$attr$rCT uCT <- dat$attr$uCT - - # n Times infected - rGC.timesInf <- dat$attr$rGC.timesInf - uGC.timesInf <- dat$attr$uGC.timesInf - rCT.timesInf <- dat$attr$rCT.timesInf - uCT.timesInf <- dat$attr$uCT.timesInf - - # Set disease status to 0 for new births - newBirths <- which(dat$attr$arrival.time == at) - rGC[newBirths] <- rGC.timesInf[newBirths] <- 0 - uGC[newBirths] <- uGC.timesInf[newBirths] <- 0 - rCT[newBirths] <- rCT.timesInf[newBirths] <- 0 - uCT[newBirths] <- uCT.timesInf[newBirths] <- 0 + syphilis <- dat$attr$syphilis + stage.syph <- dat$attr$stage.syph + syph.sympt <- dat$attr$syph.sympt + stage.time.syph <- dat$attr$stage.time.syph # Infection time rGC.infTime <- dat$attr$rGC.infTime uGC.infTime <- dat$attr$uGC.infTime rCT.infTime <- dat$attr$rCT.infTime uCT.infTime <- dat$attr$uCT.infTime + syph.infTime <- dat$attr$syph.infTime + last.rGC.infTime <- dat$attr$rGC.infTime + last.uGC.infTime <- dat$attr$uGC.infTime + last.rCT.infTime <- dat$attr$rCT.infTime + last.uCT.infTime <- dat$attr$uCT.infTime + last.syph.infTime <- dat$attr$syph.infTime - - # Infection symptoms (non-varying) + # GC/CT Infection symptoms (non-varying) rGC.sympt <- dat$attr$rGC.sympt uGC.sympt <- dat$attr$uGC.sympt rCT.sympt <- dat$attr$rCT.sympt uCT.sympt <- dat$attr$uCT.sympt - # Men who cease sexual activity during symptomatic infection - GC.cease <- dat$attr$GC.cease - CT.cease <- dat$attr$CT.cease + # HIV + status <- dat$attr$status + + # Diagnosis status + diag.status.gc <- dat$attr$diag.status.gc + diag.status.ct <- dat$attr$diag.status.ct + diag.status.syph <- dat$attr$diag.status.syph # Pull act list al <- dat$temp$al @@ -80,7 +84,6 @@ sti_trans <- function(dat, at) { # ins = 1 : p1 is insertive # ins = 2 : both p1 and p2 are insertive - # Rectal GC ----------------------------------------------------------- # Requires: uGC in insertive man, and no rGC in receptive man @@ -108,9 +111,9 @@ sti_trans <- function(dat, at) { # Update attributes rGC[idsInf_rgc] <- 1 - rGC.infTime[idsInf_rgc] <- at + rGC.infTime[idsInf_rgc] <- last.rGC.infTime[idsInf_rgc] <- at rGC.sympt[idsInf_rgc] <- rbinom(length(idsInf_rgc), 1, rgc.sympt.prob) - rGC.timesInf[idsInf_rgc] <- rGC.timesInf[idsInf_rgc] + 1 + diag.status.gc[idsInf_rgc] <- 0 # Urethral GC --------------------------------------------------------- @@ -140,9 +143,9 @@ sti_trans <- function(dat, at) { # Update attributes uGC[idsInf_ugc] <- 1 - uGC.infTime[idsInf_ugc] <- at + uGC.infTime[idsInf_ugc] <- last.uGC.infTime[idsInf_ugc] <- at uGC.sympt[idsInf_ugc] <- rbinom(length(idsInf_ugc), 1, ugc.sympt.prob) - uGC.timesInf[idsInf_ugc] <- uGC.timesInf[idsInf_ugc] + 1 + diag.status.gc[idsInf_ugc] <- 0 # Rectal CT ----------------------------------------------------------- @@ -172,9 +175,9 @@ sti_trans <- function(dat, at) { # Update attributes rCT[idsInf_rct] <- 1 - rCT.infTime[idsInf_rct] <- at + rCT.infTime[idsInf_rct] <- last.rCT.infTime[idsInf_rct] <- at rCT.sympt[idsInf_rct] <- rbinom(length(idsInf_rct), 1, rct.sympt.prob) - rCT.timesInf[idsInf_rct] <- rCT.timesInf[idsInf_rct] + 1 + diag.status.ct[idsInf_rct] <- 0 # Urethral CT --------------------------------------------------------- @@ -204,87 +207,188 @@ sti_trans <- function(dat, at) { # Update attributes uCT[idsInf_uct] <- 1 - uCT.infTime[idsInf_uct] <- at + uCT.infTime[idsInf_uct] <- last.uCT.infTime[idsInf_uct] <- at uCT.sympt[idsInf_uct] <- rbinom(length(idsInf_uct), 1, uct.sympt.prob) - uCT.timesInf[idsInf_uct] <- uCT.timesInf[idsInf_uct] + 1 + diag.status.ct[idsInf_uct] <- 0 + + + # Syphilis --------------------------------------------------------- + + # Find the syphilis discordant pairs from the act list + p1Inf_syph <- al[which(syphilis[al[, "p1"]] == 1 & + syph.infTime[al[, "p1"]] < at & + syphilis[al[, "p2"]] == 0), , drop = FALSE] + p2Inf_syph <- al[which(syphilis[al[, "p2"]] == 1 & + syph.infTime[al[, "p2"]] < at & + syphilis[al[, "p1"]] == 0), , drop = FALSE] + # Invert so p1 is the infected partner, then rbind + p2Inf_syph[, 1:2] <- p2Inf_syph[, 2:1] + allActs_syph <- rbind(p1Inf_syph, p2Inf_syph) - # Set activity cessation attribute for newly infected ----------------- + if (nrow(allActs_syph) == 0) { + trans.syph <- NULL + } else { + # Syphilis stage of infected partner + dal.stage.syph <- stage.syph[allActs_syph[, 1]] + stopifnot(all(!is.na(dal.stage.syph))) + + # Base transmission probability + dal.syph.tprob <- rep(syph.tprob, length(dal.stage.syph)) + + # Transform to log odds + dal.syph.tlo <- log(dal.syph.tprob/(1 - dal.syph.tprob)) + + # Condom use multiplier + not.syph.UAI <- which(allActs_syph[, "uai"] == 0) + dal.syph.tlo[not.syph.UAI] <- dal.syph.tlo[not.syph.UAI] + log(sti.cond.rr) + + # Incubating stage multiplier + isincub <- which(dal.stage.syph == 1) + dal.syph.tlo[isincub] <- dal.syph.tlo[isincub] + log(syph.incub.rr) - # Symptomatic GC - GC.sympt <- which(is.na(GC.cease) & (rGC.sympt == 1 | uGC.sympt == 1)) - idsGC.cease <- GC.sympt[which(rbinom(length(GC.sympt), - 1, gc.prob.cease) == 1)] - GC.cease[GC.sympt] <- 0 - GC.cease[idsGC.cease] <- 1 + # Early latent-stage multiplier + isearlat <- which(dal.stage.syph == 4) + dal.syph.tlo[isearlat] <- dal.syph.tlo[isearlat] + log(syph.earlat.rr) - # Symptomatic CT - CT.sympt <- which(is.na(CT.cease) & (rCT.sympt == 1 | uCT.sympt == 1)) - idsCT.cease <- CT.sympt[which(rbinom(length(CT.sympt), - 1, ct.prob.cease) == 1)] - CT.cease[CT.sympt] <- 0 - CT.cease[idsCT.cease] <- 1 + # Late stage multiplier + islate <- which(dal.stage.syph %in% 5:6) + dal.syph.tlo[islate] <- dal.syph.tlo[islate] + log(syph.late.rr) + + # Retransformation to probability + dal.syph.tprob <- plogis(dal.syph.tlo) + + # Check for valid probabilities + stopifnot(dal.syph.tprob >= 0, dal.syph.tprob <= 1) + + ## Bernoulli Transmission Events + trans.syph <- rbinom(length(dal.syph.tprob), 1, dal.syph.tprob) + } + # Update attributes for newly infected + idsInf_syph <- NULL + if (sum(trans.syph, na.rm = TRUE) > 0) { + idsInf_syph <- unique(allActs_syph[trans.syph == 1, 2]) + syphilis[idsInf_syph] <- 1 + syph.infTime[idsInf_syph] <- last.syph.infTime[idsInf_syph] <- at + stage.syph[idsInf_syph] <- 1 + stage.time.syph[idsInf_syph] <- 0 + diag.status.syph[idsInf_syph] <- 0 + syph.sympt[idsInf_syph] <- rbinom(length(idsInf_syph), 1, syph.incub.sympt.prob) + } # Output -------------------------------------------------------------- - # attributes + # Gonorrhea attributes dat$attr$rGC <- rGC dat$attr$uGC <- uGC - dat$attr$rCT <- rCT - dat$attr$uCT <- uCT - + dat$attr$rGC.timesInf[idsInf_rgc] <- dat$attr$rGC.timesInf[idsInf_rgc] + 1 + dat$attr$uGC.timesInf[idsInf_ugc] <- dat$attr$uGC.timesInf[idsInf_ugc] + 1 dat$attr$rGC.infTime <- rGC.infTime dat$attr$uGC.infTime <- uGC.infTime - dat$attr$rCT.infTime <- rCT.infTime - dat$attr$uCT.infTime <- uCT.infTime - - dat$attr$rGC.timesInf <- rGC.timesInf - dat$attr$uGC.timesInf <- uGC.timesInf - dat$attr$rCT.timesInf <- rCT.timesInf - dat$attr$uCT.timesInf <- uCT.timesInf - + dat$attr$last.rGC.infTime <- last.rGC.infTime + dat$attr$last.uGC.infTime <- last.uGC.infTime dat$attr$rGC.sympt <- rGC.sympt dat$attr$uGC.sympt <- uGC.sympt + dat$attr$diag.status.gc <- diag.status.gc + + # Chlamydia attributes + dat$attr$rCT <- rCT + dat$attr$uCT <- uCT + dat$attr$rCT.timesInf[idsInf_rct] <- dat$attr$rCT.timesInf[idsInf_rct] + 1 + dat$attr$uCT.timesInf[idsInf_uct] <- dat$attr$uCT.timesInf[idsInf_uct] + 1 + dat$attr$rCT.infTime <- rCT.infTime + dat$attr$uCT.infTime <- uCT.infTime + dat$attr$last.rCT.infTime <- last.rCT.infTime + dat$attr$last.uCT.infTime <- last.uCT.infTime dat$attr$rCT.sympt <- rCT.sympt dat$attr$uCT.sympt <- uCT.sympt - - dat$attr$GC.cease <- GC.cease - dat$attr$CT.cease <- CT.cease - - - # Summary stats + dat$attr$diag.status.ct <- diag.status.ct + + # Syphilis attributes + dat$attr$syphilis <- syphilis + dat$attr$syph.timesInf[idsInf_syph] <- dat$attr$syph.timesInf[idsInf_syph] + 1 + dat$attr$syph.infTime <- syph.infTime + dat$attr$last.syph.infTime <- last.syph.infTime + dat$attr$stage.syph <- stage.syph + dat$attr$syph.sympt <- syph.sympt + dat$attr$stage.time.syph <- stage.time.syph + dat$attr$diag.status.syph <- diag.status.syph + + # Summary incidence statistics dat$epi$incid.rgc[at] <- length(idsInf_rgc) dat$epi$incid.ugc[at] <- length(idsInf_ugc) - dat$epi$incid.gc[at] <- length(idsInf_rgc) + length(idsInf_ugc) + dat$epi$incid.gc[at] <- length(unique(c(idsInf_rgc,idsInf_ugc))) + dat$epi$incid.rgc.hivneg[at] <- length(which(status[idsInf_rgc] == 0)) + dat$epi$incid.ugc.hivneg[at] <- length(which(status[idsInf_ugc] == 0)) + dat$epi$incid.rgc.hivpos[at] <- length(which(status[idsInf_rgc] == 1)) + dat$epi$incid.ugc.hivpos[at] <- length(which(status[idsInf_ugc] == 1)) dat$epi$incid.rct[at] <- length(idsInf_rct) dat$epi$incid.uct[at] <- length(idsInf_uct) - dat$epi$incid.ct[at] <- length(idsInf_rct) + length(idsInf_uct) - - dat$epi$incid.gcct.prep[at] <- length(intersect(unique(c(idsInf_rgc, idsInf_ugc, - idsInf_rct, idsInf_uct)), - which(dat$attr$prepStat == 1))) - - # Check all infected have all STI attributes - stopifnot(all(!is.na(rGC.infTime[rGC == 1])), - all(!is.na(rGC.sympt[rGC == 1])), - all(!is.na(uGC.infTime[uGC == 1])), - all(!is.na(uGC.sympt[uGC == 1])), - all(!is.na(rCT.infTime[rCT == 1])), - all(!is.na(rCT.sympt[rCT == 1])), - all(!is.na(uCT.infTime[uCT == 1])), - all(!is.na(uCT.sympt[uCT == 1]))) - - if (is.null(dat$epi$times.rgc)) { - dat$epi$times.rgc <- rep(NA, length(dat$epi$num)) - dat$epi$times.ugc <- rep(NA, length(dat$epi$num)) - dat$epi$times.rct <- rep(NA, length(dat$epi$num)) - dat$epi$times.uct <- rep(NA, length(dat$epi$num)) + dat$epi$incid.ct[at] <- length(unique(c(idsInf_rct,idsInf_uct))) + dat$epi$incid.rct.hivneg[at] <- length(which(status[idsInf_rct] == 0)) + dat$epi$incid.uct.hivneg[at] <- length(which(status[idsInf_uct] == 0)) + dat$epi$incid.rct.hivpos[at] <- length(which(status[idsInf_rct] == 1)) + dat$epi$incid.uct.hivpos[at] <- length(which(status[idsInf_uct] == 1)) + dat$epi$incid.syph[at] <- length(idsInf_syph) + dat$epi$incid.syph.hivneg[at] <- length(which(status[idsInf_syph] == 0)) + dat$epi$incid.syph.hivpos[at] <- length(which(status[idsInf_syph] == 1)) + dat$epi$incid.sti[at] <- dat$epi$incid.gc[at] + dat$epi$incid.ct[at] + dat$epi$incid.syph[at] + dat$epi$incid.gcct[at] <- length(unique(c(idsInf_rgc,idsInf_ugc))) + length(unique(c(idsInf_rct,idsInf_uct))) + + # Add times inf (temporary) + if (is.null(dat$epi$gc.timesInf)) { + dat$epi$gc.timesInf <- rep(NA, dat$control$nsteps) + dat$epi$ct.timesInf <- rep(NA, dat$control$nsteps) + dat$epi$sti.timesInf <- rep(NA, dat$control$nsteps) } - dat$epi$times.rgc[at] <- mean(rGC.timesInf, na.rm = TRUE) - dat$epi$times.ugc[at] <- mean(uGC.timesInf, na.rm = TRUE) - dat$epi$times.rct[at] <- mean(rCT.timesInf, na.rm = TRUE) - dat$epi$times.uct[at] <- mean(uCT.timesInf, na.rm = TRUE) + + dat$epi$gc.timesInf[at] <- mean(dat$attr$rGC.timesInf + dat$attr$uGC.timesInf, na.rm = TRUE) + dat$epi$ct.timesInf[at] <- mean(dat$attr$rCT.timesInf + dat$attr$uCT.timesInf, na.rm = TRUE) + dat$epi$sti.timesInf[at] <- mean(dat$attr$rGC.timesInf + dat$attr$uGC.timesInf + dat$attr$rCT.timesInf + dat$attr$uCT.timesInf, na.rm = TRUE) + + # Risk group-specific + dat$epi$incid.rgc.tttraj1[at] <- length(which(dat$attr$tt.traj.gc.hivneg[idsInf_rgc] == 1)) + + length(which(dat$attr$tt.traj.gc.hivpos[idsInf_rgc] == 1)) + dat$epi$incid.ugc.tttraj1[at] <- length(which(dat$attr$tt.traj.gc.hivneg[idsInf_ugc] == 1)) + + length(which(dat$attr$tt.traj.gc.hivpos[idsInf_ugc] == 1)) + dat$epi$incid.rct.tttraj1[at] <- length(which(dat$attr$tt.traj.ct.hivneg[idsInf_rct] == 1)) + + length(which(dat$attr$tt.traj.ct.hivpos[idsInf_rct] == 1)) + dat$epi$incid.uct.tttraj1[at] <- length(which(dat$attr$tt.traj.ct.hivneg[idsInf_uct] == 1)) + + length(which(dat$attr$tt.traj.ct.hivpos[idsInf_uct] == 1)) + dat$epi$incid.syph.tttraj1[at] <- length(which(dat$attr$tt.traj.syph.hivneg[unique(c(idsInf_syph))] == 1)) + + length(which(dat$attr$tt.traj.syph.hivpos[unique(c(idsInf_syph))] == 1)) + dat$epi$incid.sti.tttraj1[at] <- dat$epi$incid.gc.tttraj1[at] + dat$epi$incid.ct.tttraj1[at] + dat$epi$incid.syph.tttraj1[at] + dat$epi$incid.gcct.tttraj1[at] <- dat$epi$incid.gc.tttraj1[at] + dat$epi$incid.ct.tttraj1[at] + + dat$epi$incid.rgc.tttraj2[at] <- length(which(dat$attr$tt.traj.gc.hivneg[idsInf_rgc] == 2)) + + length(which(dat$attr$tt.traj.gc.hivpos[idsInf_rgc] == 2)) + dat$epi$incid.ugc.tttraj2[at] <- length(which(dat$attr$tt.traj.gc.hivneg[idsInf_ugc] == 2)) + + length(which(dat$attr$tt.traj.gc.hivpos[idsInf_ugc] == 2)) + dat$epi$incid.rct.tttraj2[at] <- length(which(dat$attr$tt.traj.ct.hivneg[idsInf_rct] == 2)) + + length(which(dat$attr$tt.traj.ct.hivpos[idsInf_rct] == 2)) + dat$epi$incid.uct.tttraj2[at] <- length(which(dat$attr$tt.traj.ct.hivneg[idsInf_uct] == 2)) + + length(which(dat$attr$tt.traj.ct.hivpos[idsInf_uct] == 2)) + dat$epi$incid.syph.tttraj2[at] <- length(which(dat$attr$tt.traj.syph.hivneg[unique(c(idsInf_syph))] == 2)) + + length(which(dat$attr$tt.traj.syph.hivpos[unique(c(idsInf_syph))] == 2)) + dat$epi$incid.sti.tttraj2[at] <- dat$epi$incid.gc.tttraj2[at] + dat$epi$incid.ct.tttraj2[at] + dat$epi$incid.syph.tttraj2[at] + dat$epi$incid.gcct.tttraj2[at] <- dat$epi$incid.gc.tttraj2[at] + dat$epi$incid.ct.tttraj2[at] + + # Stop check for STI attributes + stopifnot(all(!is.na(dat$attr$rGC.infTime[dat$attr$rGC == 1])), + all(!is.na(dat$attr$last.rGC.infTime[dat$attr$rGC == 1])), + all(!is.na(dat$attr$rGC.sympt[dat$attr$rGC == 1])), + all(!is.na(dat$attr$uGC.infTime[dat$attr$uGC == 1])), + all(!is.na(dat$attr$last.uGC.infTime[dat$attr$uGC == 1])), + all(!is.na(dat$attr$uGC.sympt[dat$attr$uGC == 1])), + all(!is.na(dat$attr$rCT.infTime[dat$attr$rCT == 1])), + all(!is.na(dat$attr$last.rCT.infTime[dat$attr$rCT == 1])), + all(!is.na(dat$attr$rCT.sympt[dat$attr$rCT == 1])), + all(!is.na(dat$attr$uCT.infTime[dat$attr$uCT == 1])), + all(!is.na(dat$attr$last.uCT.infTime[dat$attr$uCT == 1])), + all(!is.na(dat$attr$uCT.sympt[dat$attr$uCT == 1])), + all(!is.na(dat$attr$syph.infTime[dat$attr$syphilis == 1])), + all(!is.na(dat$attr$last.syph.infTime[dat$attr$syphilis == 1]))) return(dat) } @@ -300,176 +404,299 @@ sti_trans <- function(dat, at) { #' #' @export #' -sti_recov <- function(dat, at) { +sti_recov_msm <- function(dat, at) { # Parameters ---------------------------------------------------------- - rgc.asympt.int <- dat$param$rgc.asympt.int - ugc.asympt.int <- dat$param$ugc.asympt.int + rgc.asympt.rate <- dat$param$rgc.asympt.rate + ugc.asympt.rate <- dat$param$ugc.asympt.rate gc.tx.int <- dat$param$gc.tx.int gc.ntx.int <- dat$param$gc.ntx.int - rct.asympt.int <- dat$param$rct.asympt.int - uct.asympt.int <- dat$param$uct.asympt.int + rct.asympt.rate <- dat$param$rct.asympt.rate + uct.asympt.rate <- dat$param$uct.asympt.rate ct.tx.int <- dat$param$ct.tx.int ct.ntx.int <- dat$param$ct.ntx.int + syph.early.tx.int <- dat$param$syph.early.tx.int + syph.late.tx.int <- dat$param$syph.late.tx.int + + + # Attributes ---------------------------------------------------------- + + # Infection status + rGC <- dat$attr$rGC + uGC <- dat$attr$uGC + rCT <- dat$attr$rCT + uCT <- dat$attr$uCT + syphilis <- dat$attr$syphilis + stage.syph <- dat$attr$stage.syph + + # Infection time + rGC.infTime <- dat$attr$rGC.infTime + uGC.infTime <- dat$attr$uGC.infTime + rCT.infTime <- dat$attr$rCT.infTime + uCT.infTime <- dat$attr$uCT.infTime + syph.infTime <- dat$attr$syph.infTime + + # Symptoms + rGC.sympt <- dat$attr$rGC.sympt + uGC.sympt <- dat$attr$uGC.sympt + rCT.sympt <- dat$attr$rCT.sympt + uCT.sympt <- dat$attr$uCT.sympt + + # Tx + uGC.tx <- dat$attr$uGC.tx + uGC.tx.prep <- dat$attr$uGC.tx.prep + uGC.tx.ept <- dat$attr$uGC.tx.ept + rGC.tx <- dat$attr$rGC.tx + rGC.tx.prep <- dat$attr$rGC.tx.prep + rGC.tx.ept <- dat$attr$rGC.tx.ept + uCT.tx <- dat$attr$uCT.tx + uCT.tx.prep <- dat$attr$uCT.tx.prep + uCT.tx.ept <- dat$attr$uCT.tx.ept + rCT.tx <- dat$attr$rCT.tx + rCT.tx.prep <- dat$attr$rCT.tx.prep + rCT.tx.ept <- dat$attr$rCT.tx.ept + syph.incub.tx <- dat$attr$syph.incub.tx + syph.prim.tx <- dat$attr$syph.prim.tx + syph.seco.tx <- dat$attr$syph.seco.tx + syph.earlat.tx <- dat$attr$syph.earlat.tx + syph.latelat.tx <- dat$attr$syph.latelat.tx + syph.tert.tx <- dat$attr$syph.tert.tx + syph.tx.prep <- dat$attr$syph.tx.prep + # GC Recovery --------------------------------------------------------- - # Asymptomatic untreated - idsRGC_asympt_ntx <- which(dat$attr$rGC == 1 & - dat$attr$rGC.infTime < at & - dat$attr$rGC.sympt == 0 & - (is.na(dat$attr$rGC.tx) | dat$attr$rGC.tx == 0) & - (is.na(dat$attr$rGC.tx.prep) | dat$attr$rGC.tx.prep == 0)) - idsUGC_asympt_ntx <- which(dat$attr$uGC == 1 & - dat$attr$uGC.infTime < at & - dat$attr$uGC.sympt == 0 & - (is.na(dat$attr$uGC.tx) | dat$attr$uGC.tx == 0) & - (is.na(dat$attr$uGC.tx.prep) | dat$attr$uGC.tx.prep == 0)) - - recovRGC_asympt_ntx <- idsRGC_asympt_ntx[which(rbinom(length(idsRGC_asympt_ntx), 1, - 1/rgc.asympt.int) == 1)] - recovUGC_asympt_ntx <- idsUGC_asympt_ntx[which(rbinom(length(idsUGC_asympt_ntx), 1, - 1/ugc.asympt.int) == 1)] - - # Symptomatic untreated - idsRGC_sympt_ntx <- which(dat$attr$rGC == 1 & - dat$attr$rGC.infTime < at & - dat$attr$rGC.sympt == 1 & - (is.na(dat$attr$rGC.tx) | dat$attr$rGC.tx == 0) & - (is.na(dat$attr$rGC.tx.prep) | dat$attr$rGC.tx.prep == 0)) - idsUGC_sympt_ntx <- which(dat$attr$uGC == 1 & - dat$attr$uGC.infTime < at & - dat$attr$uGC.sympt == 1 & - (is.na(dat$attr$uGC.tx) | dat$attr$uGC.tx == 0) & - (is.na(dat$attr$uGC.tx.prep) | dat$attr$uGC.tx.prep == 0)) - - # If parameter is null, uses recovery rate of asytomatic untreated + ## Recovery for asymptomatic untreated (natural clearance) + idsRGC_asympt_ntx <- which(rGC == 1 & + rGC.infTime < at & + rGC.sympt == 0 & + (is.na(rGC.tx) | rGC.tx == 0) & + (is.na(rGC.tx.prep) | rGC.tx.prep == 0) & + (is.na(rGC.tx.ept) | rGC.tx.ept == 0)) + idsUGC_asympt_ntx <- which(uGC == 1 & + uGC.infTime < at & + uGC.sympt == 0 & + (is.na(uGC.tx) | uGC.tx == 0) & + (is.na(uGC.tx.prep) | uGC.tx.prep == 0) & + (is.na(uGC.tx.ept) | uGC.tx.ept == 0)) + + recovRGC_asympt_ntx <- idsRGC_asympt_ntx[which(rbinom(length(idsRGC_asympt_ntx), 1, rgc.asympt.rate) == 1)] + recovUGC_asympt_ntx <- idsUGC_asympt_ntx[which(rbinom(length(idsUGC_asympt_ntx), 1, ugc.asympt.rate) == 1)] + + ## Recovery for symptomatic untreated (natural clearance) + idsRGC_sympt_ntx <- which(rGC == 1 & + rGC.infTime < at & + rGC.sympt == 1 & + (is.na(rGC.tx) | rGC.tx == 0) & + (is.na(rGC.tx.prep) | rGC.tx.prep == 0) & + (is.na(rGC.tx.ept) | rGC.tx.ept == 0)) + idsUGC_sympt_ntx <- which(uGC == 1 & + uGC.infTime < at & + uGC.sympt == 1 & + (is.na(uGC.tx) | uGC.tx == 0) & + (is.na(uGC.tx.prep) | uGC.tx.prep == 0) & + (is.na(uGC.tx.ept) | uGC.tx.ept == 0)) + + # If NA, recovery rate for symptomatic untreated = rate for asymptomatic untreated if (!is.na(gc.ntx.int)) { - recovRGC_sympt_ntx <- idsRGC_sympt_ntx[which(rbinom(length(idsRGC_sympt_ntx), 1, - 1/gc.ntx.int) == 1)] - recovUGC_sympt_ntx <- idsUGC_sympt_ntx[which(rbinom(length(idsUGC_sympt_ntx), 1, - 1/gc.ntx.int) == 1)] + recovRGC_sympt_ntx <- idsRGC_sympt_ntx[which(rbinom(length(idsRGC_sympt_ntx), 1, 1/gc.ntx.int) == 1)] + recovUGC_sympt_ntx <- idsUGC_sympt_ntx[which(rbinom(length(idsUGC_sympt_ntx), 1, 1/gc.ntx.int) == 1)] } else { - recovRGC_sympt_ntx <- idsRGC_sympt_ntx[which(rbinom(length(idsRGC_sympt_ntx), 1, - 1/rgc.asympt.int) == 1)] - recovUGC_sympt_ntx <- idsUGC_sympt_ntx[which(rbinom(length(idsUGC_sympt_ntx), 1, - 1/ugc.asympt.int) == 1)] + recovRGC_sympt_ntx <- idsRGC_sympt_ntx[which(rbinom(length(idsRGC_sympt_ntx), 1, rgc.asympt.rate) == 1)] + recovUGC_sympt_ntx <- idsUGC_sympt_ntx[which(rbinom(length(idsUGC_sympt_ntx), 1, ugc.asympt.rate) == 1)] } - # Treated (asymptomatic and symptomatic) - idsRGC_tx <- which(dat$attr$rGC == 1 & - dat$attr$rGC.infTime < at & - (dat$attr$rGC.tx == 1 | dat$attr$rGC.tx.prep == 1)) - idsUGC_tx <- which(dat$attr$uGC == 1 & - dat$attr$uGC.infTime < at & - (dat$attr$uGC.tx == 1 | dat$attr$uGC.tx.prep == 1)) + ## Recovery for treated (both asymptomatic and symptomatic) + idsRGC_tx <- which(rGC == 1 & + rGC.infTime < at & + (rGC.tx == 1 | rGC.tx.prep == 1 | rGC.tx.ept == 1)) + idsUGC_tx <- which(uGC == 1 & + uGC.infTime < at & + (uGC.tx == 1 | uGC.tx.prep == 1 | uGC.tx.ept == 1)) - recovRGC_tx <- idsRGC_tx[which(rbinom(length(idsRGC_tx), 1, - 1/gc.tx.int) == 1)] - recovUGC_tx <- idsUGC_tx[which(rbinom(length(idsUGC_tx), 1, - 1/gc.tx.int) == 1)] + recovRGC_tx <- idsRGC_tx[which(rbinom(length(idsRGC_tx), 1, 1/gc.tx.int) == 1)] + recovUGC_tx <- idsUGC_tx[which(rbinom(length(idsUGC_tx), 1, 1/gc.tx.int) == 1)] recovRGC <- c(recovRGC_asympt_ntx, recovRGC_sympt_ntx, recovRGC_tx) recovUGC <- c(recovUGC_asympt_ntx, recovUGC_sympt_ntx, recovUGC_tx) - dat$attr$rGC[recovRGC] <- 0 - dat$attr$rGC.sympt[recovRGC] <- NA - dat$attr$rGC.infTime[recovRGC] <- NA - dat$attr$rGC.tx[recovRGC] <- NA - dat$attr$rGC.tx.prep[recovRGC] <- NA - - dat$attr$uGC[recovUGC] <- 0 - dat$attr$uGC.sympt[recovUGC] <- NA - dat$attr$uGC.infTime[recovUGC] <- NA - dat$attr$uGC.tx[recovUGC] <- NA - dat$attr$uGC.tx.prep[recovUGC] <- NA - - dat$attr$GC.cease[c(recovRGC, recovUGC)] <- NA - - # CT Recovery --------------------------------------------------------- - # Asymptomatic untreated - idsRCT_asympt_ntx <- which(dat$attr$rCT == 1 & - dat$attr$rCT.infTime < at & - dat$attr$rCT.sympt == 0 & - (is.na(dat$attr$rCT.tx) | dat$attr$rCT.tx == 0) & - (is.na(dat$attr$rCT.tx.prep) | dat$attr$rCT.tx.prep == 0)) - idsUCT_asympt_ntx <- which(dat$attr$uCT == 1 & - dat$attr$uCT.infTime < at & - dat$attr$uCT.sympt == 0 & - (is.na(dat$attr$uCT.tx) | dat$attr$uCT.tx == 0) & - (is.na(dat$attr$uCT.tx.prep) | dat$attr$uCT.tx.prep == 0)) - - recovRCT_asympt_ntx <- idsRCT_asympt_ntx[which(rbinom(length(idsRCT_asympt_ntx), - 1, 1/rct.asympt.int) == 1)] - recovUCT_asympt_ntx <- idsUCT_asympt_ntx[which(rbinom(length(idsUCT_asympt_ntx), - 1, 1/uct.asympt.int) == 1)] - - # Symptomatic untreated - idsRCT_sympt_ntx <- which(dat$attr$rCT == 1 & - dat$attr$rCT.infTime < at & - dat$attr$rCT.sympt == 1 & - (is.na(dat$attr$rCT.tx) | dat$attr$rCT.tx == 0) & - (is.na(dat$attr$rCT.tx.prep) | dat$attr$rCT.tx.prep == 0)) - idsUCT_sympt_ntx <- which(dat$attr$uCT == 1 & - dat$attr$uCT.infTime < at & - dat$attr$uCT.sympt == 1 & - (is.na(dat$attr$uCT.tx) | dat$attr$uCT.tx == 0) & - (is.na(dat$attr$uCT.tx.prep) | dat$attr$uCT.tx.prep == 0)) - + ## Recovery for asymptomatic untreated (natural clearance) + idsRCT_asympt_ntx <- which(rCT == 1 & + rCT.infTime < at & + rCT.sympt == 0 & + (is.na(rCT.tx) | rCT.tx == 0) & + (is.na(rCT.tx.prep) | rCT.tx.prep == 0) & + (is.na(rCT.tx.ept) | rCT.tx.ept == 0)) + idsUCT_asympt_ntx <- which(uCT == 1 & + uCT.infTime < at & + uCT.sympt == 0 & + (is.na(uCT.tx) | uCT.tx == 0) & + (is.na(uCT.tx.prep) | uCT.tx.prep == 0) & + (is.na(uCT.tx.ept) | uCT.tx.ept == 0)) + + recovRCT_asympt_ntx <- idsRCT_asympt_ntx[which(rbinom(length(idsRCT_asympt_ntx), 1, rct.asympt.rate) == 1)] + recovUCT_asympt_ntx <- idsUCT_asympt_ntx[which(rbinom(length(idsUCT_asympt_ntx), 1, uct.asympt.rate) == 1)] + + ## Recovery for symptomatic untreated (natural clearance) + idsRCT_sympt_ntx <- which(rCT == 1 & + rCT.infTime < at & + rCT.sympt == 1 & + (is.na(rCT.tx) | rCT.tx == 0) & + (is.na(rCT.tx.prep) | rCT.tx.prep == 0) & + (is.na(rCT.tx.ept) | rCT.tx.ept == 0)) + idsUCT_sympt_ntx <- which(uCT == 1 & + uCT.infTime < at & + uCT.sympt == 1 & + (is.na(uCT.tx) | uCT.tx == 0) & + (is.na(uCT.tx.prep) | uCT.tx.prep == 0) & + (is.na(rCT.tx.ept) | rCT.tx.ept == 0)) + + # If NA, recovery rate for symptomatic untreated = rate for asymptomatic untreated if (!is.na(ct.ntx.int)) { - recovRCT_sympt_ntx <- idsRCT_sympt_ntx[which(rbinom(length(idsRCT_sympt_ntx), - 1, 1/ct.ntx.int) == 1)] - recovUCT_sympt_ntx <- idsUCT_sympt_ntx[which(rbinom(length(idsUCT_sympt_ntx), - 1, 1/ct.ntx.int) == 1)] + recovRCT_sympt_ntx <- idsRCT_sympt_ntx[which(rbinom(length(idsRCT_sympt_ntx), 1, 1/ct.ntx.int) == 1)] + recovUCT_sympt_ntx <- idsUCT_sympt_ntx[which(rbinom(length(idsUCT_sympt_ntx), 1, 1/ct.ntx.int) == 1)] } else { - recovRCT_sympt_ntx <- idsRCT_sympt_ntx[which(rbinom(length(idsRCT_sympt_ntx), - 1, 1/rct.asympt.int) == 1)] - recovUCT_sympt_ntx <- idsUCT_sympt_ntx[which(rbinom(length(idsUCT_sympt_ntx), - 1, 1/uct.asympt.int) == 1)] + recovRCT_sympt_ntx <- idsRCT_sympt_ntx[which(rbinom(length(idsRCT_sympt_ntx), 1, rct.asympt.rate) == 1)] + recovUCT_sympt_ntx <- idsUCT_sympt_ntx[which(rbinom(length(idsUCT_sympt_ntx), 1, uct.asympt.rate) == 1)] } - # Treated (asymptomatic and symptomatic) - idsRCT_tx <- which(dat$attr$rCT == 1 & - dat$attr$rCT.infTime < at & - (dat$attr$rCT.tx == 1 | dat$attr$rCT.tx.prep == 1)) - idsUCT_tx <- which(dat$attr$uCT == 1 & - dat$attr$uCT.infTime < at & - (dat$attr$uCT.tx == 1 | dat$attr$uCT.tx.prep == 1)) - - recovRCT_tx <- idsRCT_tx[which(rbinom(length(idsRCT_tx), - 1, 1/ct.tx.int) == 1)] - recovUCT_tx <- idsUCT_tx[which(rbinom(length(idsUCT_tx), - 1, 1/ct.tx.int) == 1)] + ## Recovery for treated (both asymptomatic and symptomatic) + idsRCT_tx <- which(rCT == 1 & + rCT.infTime < at & + (rCT.tx == 1 | rCT.tx.prep == 1 | rCT.tx.ept == 1)) + idsUCT_tx <- which(uCT == 1 & + uCT.infTime < at & + (uCT.tx == 1 | uCT.tx.prep == 1 | uCT.tx.ept == 1)) + recovRCT_tx <- idsRCT_tx[which(rbinom(length(idsRCT_tx), 1, 1/ct.tx.int) == 1)] + recovUCT_tx <- idsUCT_tx[which(rbinom(length(idsUCT_tx), 1, 1/ct.tx.int) == 1)] recovRCT <- c(recovRCT_asympt_ntx, recovRCT_sympt_ntx, recovRCT_tx) recovUCT <- c(recovUCT_asympt_ntx, recovUCT_sympt_ntx, recovUCT_tx) + + # Syphilis Recovery ------------------------------------------------- + + ## Recovery for treated + idssyph_early_tx <- which(syphilis == 1 & + stage.syph %in% 1:4 & + syph.infTime < at & + (syph.incub.tx == 1 | syph.prim.tx == 1 | + syph.seco.tx == 1 | syph.earlat.tx == 1 | + syph.tx.prep == 1)) + idssyph_late_tx <- which(syphilis == 1 & + stage.syph %in% 5:6 & + syph.infTime < at & + (syph.latelat.tx == 1 | syph.tert.tx == 1 | + syph.tx.prep == 1)) + + ## Move stage-specific treated to recovered + recovsyph_early_tx <- idssyph_early_tx[which(rbinom(length(idssyph_early_tx), 1, 1/syph.early.tx.int) == 1)] + recovsyph_late_tx <- idssyph_late_tx[which(rbinom(length(idssyph_late_tx), 1, 1/syph.late.tx.int) == 1)] + + ## Aggregate recovery by stage + recovsyph <- c(recovsyph_early_tx, recovsyph_late_tx) + + + # Output ----------------------------------------------------------- + + ## All recovered + recovGCCT <- c(recovUCT, recovRCT, recovRGC, recovUGC) + + # Reset EPT attributes + dat$attr$eptindexEligdate[recovGCCT] <- NA + dat$attr$eptpartEligReceive[recovGCCT] <- NA + dat$attr$eptpartEligTx_GC[recovGCCT] <- NA + dat$attr$eptpartEligTx_CT[recovGCCT] <- NA + dat$attr$eptpartEligTxdate[recovGCCT] <- NA + dat$attr$eptpartTx[recovGCCT] <- NA + + + # Syphilis + dat$attr$syphilis[recovsyph] <- 0 + dat$attr$stage.syph[recovsyph] <- NA + dat$attr$stage.time.syph[recovsyph] <- NA + dat$attr$last.syph.recovTime[recovsyph] <- at + dat$attr$syph.sympt[recovsyph] <- NA + dat$attr$syph.infTime[recovsyph] <- NA + dat$attr$diag.status.syph[recovsyph] <- NA + dat$attr$syph.incub.tx[recovsyph] <- NA + dat$attr$syph.prim.tx[recovsyph] <- NA + dat$attr$syph.seco.tx[recovsyph] <- NA + dat$attr$syph.earlat.tx[recovsyph] <- NA + dat$attr$syph.latelat.tx[recovsyph] <- NA + dat$attr$syph.tert.tx[recovsyph] <- NA + dat$attr$syph.tx.prep[recovsyph] <- NA + + # Gonorrhea + dat$attr$rGC[recovRGC] <- 0 + dat$attr$rGC.sympt[recovRGC] <- NA + dat$attr$rGC.infTime[recovRGC] <- NA + dat$attr$last.rGC.recovTime[recovRGC] <- at + dat$attr$rGC.tx[recovRGC] <- NA + dat$attr$rGC.tx.prep[recovRGC] <- NA + dat$attr$rGC.tx.ept[recovRGC] <- NA + dat$attr$diag.status.gc[recovRGC] <- NA + dat$attr$uGC[recovUGC] <- 0 + dat$attr$uGC.sympt[recovUGC] <- NA + dat$attr$uGC.infTime[recovUGC] <- NA + dat$attr$last.uGC.recovTime[recovUGC] <- at + dat$attr$uGC.tx[recovUGC] <- NA + dat$attr$uGC.tx.prep[recovUGC] <- NA + dat$attr$uGC.tx.ept[recovUGC] <- NA + dat$attr$diag.status.gc[recovUGC] <- NA + + # Chlamydia dat$attr$rCT[recovRCT] <- 0 dat$attr$rCT.sympt[recovRCT] <- NA dat$attr$rCT.infTime[recovRCT] <- NA + dat$attr$last.rCT.recovTime[recovRCT] <- at dat$attr$rCT.tx[recovRCT] <- NA dat$attr$rCT.tx.prep[recovRCT] <- NA - + dat$attr$rCT.tx.ept[recovRCT] <- NA + dat$attr$diag.status.ct[recovRCT] <- NA dat$attr$uCT[recovUCT] <- 0 dat$attr$uCT.sympt[recovUCT] <- NA dat$attr$uCT.infTime[recovUCT] <- NA + dat$attr$last.uCT.recovTime[recovUCT] <- at dat$attr$uCT.tx[recovUCT] <- NA dat$attr$uCT.tx.prep[recovUCT] <- NA - - dat$attr$CT.cease[c(recovRCT, recovUCT)] <- NA + dat$attr$uCT.tx.ept[recovUCT] <- NA + dat$attr$diag.status.ct[recovUCT] <- NA # Summary stats dat$epi$recov.rgc[at] <- length(unique(recovRGC)) dat$epi$recov.ugc[at] <- length(unique(recovUGC)) dat$epi$recov.rct[at] <- length(unique(recovRCT)) dat$epi$recov.uct[at] <- length(unique(recovUCT)) + dat$epi$recov.syphilis[at] <- length(unique(recovsyph)) + dat$epi$recov.earlysyph[at] <- length(unique(recovsyph_early_tx)) + + # Calculate duration of infection for all those who have previously recovered + # (including this step) and are not currently infected + pastrecovRGC <- which(dat$attr$last.rGC.recovTime > dat$attr$last.rGC.infTime) + pastrecovUGC <- which(dat$attr$last.uGC.recovTime > dat$attr$last.uGC.infTime) + pastrecovRCT <- which(dat$attr$last.rCT.recovTime > dat$attr$last.rCT.infTime) + pastrecovUCT <- which(dat$attr$last.uCT.recovTime > dat$attr$last.uCT.infTime) + pastrecovsyph <- which(dat$attr$last.syph.recovTime > dat$attr$last.syph.infTime) + + rgc.infect.dur <- dat$attr$last.rGC.recovTime[pastrecovRGC] - dat$attr$last.rGC.infTime[pastrecovRGC] + ugc.infect.dur <- dat$attr$last.uGC.recovTime[pastrecovUGC] - dat$attr$last.uGC.infTime[pastrecovUGC] + rct.infect.dur <- dat$attr$last.rCT.recovTime[pastrecovRCT] - dat$attr$last.rCT.infTime[pastrecovRCT] + uct.infect.dur <- dat$attr$last.uCT.recovTime[pastrecovUCT] - dat$attr$last.uCT.infTime[pastrecovUCT] + syph.infect.dur <- dat$attr$last.syph.recovTime[pastrecovsyph] - dat$attr$last.syph.infTime[pastrecovsyph] + + dat$epi$gc.infect.dur[at] <- median(c(rgc.infect.dur, ugc.infect.dur), na.rm = TRUE) + dat$epi$ct.infect.dur[at] <- median(c(rct.infect.dur, uct.infect.dur), na.rm = TRUE) + dat$epi$gcct.infect.dur[at] <- median(c(rgc.infect.dur, ugc.infect.dur, + rct.infect.dur, uct.infect.dur), na.rm = TRUE) + dat$epi$syph.infect.dur[at] <- median(syph.infect.dur, na.rm = TRUE) return(dat) } @@ -477,7 +704,8 @@ sti_recov <- function(dat, at) { #' @title STI Treatment Module #' -#' @description Stochastically simulates GC/CT diagnosis and treatment. +#' @description Stochastically simulates GC/CT and syphilis diagnosis and +#' treatment. #' #' @inheritParams aging_msm #' @@ -485,58 +713,314 @@ sti_recov <- function(dat, at) { #' #' @export #' -sti_tx <- function(dat, at) { +sti_tx_msm <- function(dat, at) { - # Parameters + # Parameters ------------------------------------------------------------ gc.sympt.prob.tx <- dat$param$gc.sympt.prob.tx ct.sympt.prob.tx <- dat$param$ct.sympt.prob.tx gc.asympt.prob.tx <- dat$param$gc.asympt.prob.tx ct.asympt.prob.tx <- dat$param$ct.asympt.prob.tx + syph.incub.sympt.prob.tx <- dat$param$syph.incub.sympt.prob.tx + syph.incub.asympt.prob.tx <- dat$param$syph.incub.asympt.prob.tx + syph.prim.sympt.prob.tx <- dat$param$syph.prim.sympt.prob.tx + syph.prim.asympt.prob.tx <- dat$param$syph.prim.asympt.prob.tx + syph.seco.sympt.prob.tx <- dat$param$syph.seco.sympt.prob.tx + syph.seco.asympt.prob.tx <- dat$param$syph.seco.asympt.prob.tx + syph.earlat.sympt.prob.tx <- dat$param$syph.earlat.sympt.prob.tx + syph.earlat.asympt.prob.tx <- dat$param$syph.earlat.asympt.prob.tx + syph.latelat.sympt.prob.tx <- dat$param$syph.latelat.sympt.prob.tx + syph.latelat.asympt.prob.tx <- dat$param$syph.latelat.asympt.prob.tx + syph.tert.sympt.prob.tx <- dat$param$syph.tert.sympt.prob.tx + syph.tert.asympt.prob.tx <- dat$param$syph.tert.asympt.prob.tx + prep.sti.screen.int <- dat$param$prep.sti.screen.int prep.sti.prob.tx <- dat$param$prep.sti.prob.tx + ept.gc.success <- dat$param$ept.gc.success + ept.ct.success <- dat$param$ept.ct.success + ept.coverage <- dat$param$ept.coverage + ept.cov.rate <- dat$param$ept.cov.rate - prep.cont.stand.tx <- dat$param$prep.continue.stand.tx - if (prep.cont.stand.tx == TRUE) { - prep.stand.tx.grp <- 0:1 - } else { - prep.stand.tx.grp <- 0 - } + sti.correlation.time <- dat$param$sti.correlation.time + + # Attributes ------------------------------------------------------------ + + # Infection status + role.class <- dat$attr$role.class + rGC <- dat$attr$rGC + uGC <- dat$attr$uGC + rCT <- dat$attr$rCT + uCT <- dat$attr$uCT + syphilis <- dat$attr$syphilis + stage.syph <- dat$attr$stage.syph + + # Infection time + rGC.infTime <- dat$attr$rGC.infTime + uGC.infTime <- dat$attr$uGC.infTime + rCT.infTime <- dat$attr$rCT.infTime + uCT.infTime <- dat$attr$uCT.infTime + syph.infTime <- dat$attr$syph.infTime + + # Symptoms + rGC.sympt <- dat$attr$rGC.sympt + uGC.sympt <- dat$attr$uGC.sympt + rCT.sympt <- dat$attr$rCT.sympt + uCT.sympt <- dat$attr$uCT.sympt + syph.sympt <- dat$attr$syph.sympt + + # Tx + uGC.tx <- dat$attr$uGC.tx + uGC.tx.prep <- dat$attr$uGC.tx.prep + uGC.tx.ept <- dat$attr$uGC.tx.ept + rGC.tx <- dat$attr$rGC.tx + rGC.tx.prep <- dat$attr$rGC.tx.prep + rGC.tx.ept <- dat$attr$rGC.tx.ept + uCT.tx <- dat$attr$uCT.tx + uCT.tx.prep <- dat$attr$uCT.tx.prep + uCT.tx.ept <- dat$attr$uCT.tx.ept + rCT.tx <- dat$attr$rCT.tx + rCT.tx.prep <- dat$attr$rCT.tx.prep + rCT.tx.ept <- dat$attr$rCT.tx.ept + syph.incub.tx <- dat$attr$syph.incub.tx + syph.prim.tx <- dat$attr$syph.prim.tx + syph.seco.tx <- dat$attr$syph.seco.tx + syph.earlat.tx <- dat$attr$syph.earlat.tx + syph.latelat.tx <- dat$attr$syph.latelat.tx + syph.tert.tx <- dat$attr$syph.tert.tx + syph.tx.prep <- dat$attr$syph.tx.prep + prepStartTime <- dat$attr$prepStartTime + prepLastStiScreen <- dat$attr$prepLastStiScreen + + # tt.traj + tt.traj.gc.hivpos <- dat$attr$tt.traj.gc.hivpos + tt.traj.gc.hivneg <- dat$attr$tt.traj.gc.hivneg + tt.traj.ct.hivpos <- dat$attr$tt.traj.ct.hivpos + tt.traj.ct.hivneg <- dat$attr$tt.traj.ct.hivneg + tt.traj.syph.hivpos <- dat$attr$tt.traj.syph.hivpos + tt.traj.syph.hivneg <- dat$attr$tt.traj.syph.hivneg + + # Diagnosis/ Attributes from testing + diag.status.syph <- dat$attr$diag.status.syph + diag.status.gc <- dat$attr$diag.status.gc + diag.status.ct <- dat$attr$diag.status.ct + tsinceltst.syph <- dat$attr$time.since.last.test.syph + tsinceltst.rgc <- dat$attr$time.since.last.test.rgc + tsinceltst.ugc <- dat$attr$time.since.last.test.ugc + tsinceltst.rct <- dat$attr$time.since.last.test.rct + tsinceltst.uct <- dat$attr$time.since.last.test.uct + + # EPT + eptpartEligTx_GC <- dat$attr$eptpartEligTx_GC + eptpartEligTx_CT <- dat$attr$eptpartEligTx_CT + eptpartEligTxdate <- dat$attr$eptpartEligTxdate + + # Syphilis -------------------------------------------------------------- + + ## Symptomatic syphilis treatment + # Select those in incubating stage who are eligible to be treated + idssyph_tx_sympt_incub <- which(syphilis == 1 & + syph.infTime < at & + stage.syph == 1 & + syph.sympt == 1 & + is.na(syph.incub.tx)) + + # Select those who will be treated based on eligibility to be treated + txsyph_sympt_incub <- idssyph_tx_sympt_incub[which(rbinom(length(idssyph_tx_sympt_incub), + 1, syph.incub.sympt.prob.tx) == 1)] + + # Select those in primary stage who are eligible to be treated + idssyph_tx_sympt_prim <- which(syphilis == 1 & + syph.infTime < at & + stage.syph == 2 & + syph.sympt == 1 & + is.na(syph.prim.tx)) + + # Select those who will be treated based on eligibility to be treated + txsyph_sympt_prim <- idssyph_tx_sympt_prim[which(rbinom(length(idssyph_tx_sympt_prim), + 1, syph.prim.sympt.prob.tx) == 1)] + + # Select those in secondary stage who are eligible to be treated + idssyph_tx_sympt_seco <- which(syphilis == 1 & + syph.infTime < at & + stage.syph == 3 & + syph.sympt == 1 & + is.na(syph.seco.tx)) + + # Select those who will be treated based on eligibility to be treated + txsyph_sympt_seco <- idssyph_tx_sympt_seco[which(rbinom(length(idssyph_tx_sympt_seco), + 1, syph.seco.sympt.prob.tx) == 1)] + + # Select those in early latent stage who are eligible to be treated + idssyph_tx_sympt_earlat <- which(syphilis == 1 & + syph.infTime < at & + stage.syph == 4 & + syph.sympt == 1 & + is.na(syph.earlat.tx)) + + # Select those who will be treated based on eligibility to be treated + txsyph_sympt_earlat <- idssyph_tx_sympt_earlat[which(rbinom(length(idssyph_tx_sympt_earlat), + 1, syph.earlat.sympt.prob.tx) == 1)] + + # Select those in late latent stage who are eligible to be treated + idssyph_tx_sympt_latelat <- which(syphilis == 1 & + syph.infTime < at & + (stage.syph == 5) & + (syph.sympt == 1) & + is.na(syph.latelat.tx)) + + # Select those who will be treated based on eligibility to be treated + txsyph_sympt_latelat <- idssyph_tx_sympt_latelat[which(rbinom(length(idssyph_tx_sympt_latelat), + 1, syph.latelat.sympt.prob.tx) == 1)] + + # Select those in tertiary stage who are eligible to be treated + idssyph_tx_sympt_tert <- which(syphilis == 1 & + syph.infTime < at & + stage.syph == 6 & + syph.sympt == 1 & + is.na(syph.tert.tx)) + + # Select those who will be treated based on eligibility to be treated + txsyph_sympt_tert <- idssyph_tx_sympt_tert[which(rbinom(length(idssyph_tx_sympt_tert), + 1, syph.tert.sympt.prob.tx) == 1)] + + # Aggregate all those eligible to be treated + idssyph_tx_sympt <- c(idssyph_tx_sympt_incub, idssyph_tx_sympt_prim, idssyph_tx_sympt_seco, idssyph_tx_sympt_earlat, + idssyph_tx_sympt_latelat, idssyph_tx_sympt_tert) + + # Aggregate all those selected to be treated + txsyph_sympt <- c(txsyph_sympt_incub, txsyph_sympt_prim, txsyph_sympt_seco, txsyph_sympt_earlat, + txsyph_sympt_latelat, txsyph_sympt_tert) + + + ## Asymptomatic syphilis treatment + # Select those in primary stage who are eligible to be treated + idssyph_tx_asympt_incub <- which(syph.infTime < at & + stage.syph == 1 & + syph.sympt == 0 & + diag.status.syph == 1 & + (is.na(syph.incub.tx) | syph.incub.tx == 0)) + + # Select those to be treated + txsyph_asympt_incub <- idssyph_tx_asympt_incub[which(rbinom(length(idssyph_tx_asympt_incub), + 1, syph.incub.asympt.prob.tx) == 1)] + # Select those in primary stage who are eligible to be treated + idssyph_tx_asympt_prim <- which(syph.infTime < at & + stage.syph == 2 & + syph.sympt == 0 & + diag.status.syph == 1 & + (is.na(syph.prim.tx) | syph.prim.tx == 0)) + + # Select those to be treated + txsyph_asympt_prim <- idssyph_tx_asympt_prim[which(rbinom(length(idssyph_tx_asympt_prim), + 1, syph.prim.asympt.prob.tx) == 1)] + + # Select those in secondary stage who are eligible to be treated + idssyph_tx_asympt_seco <- which(syph.infTime < at & + stage.syph == 3 & + syph.sympt == 0 & + diag.status.syph == 1 & + (is.na(syph.seco.tx) | syph.seco.tx == 0)) + + # Select those to be treated + txsyph_asympt_seco <- idssyph_tx_asympt_seco[which(rbinom(length(idssyph_tx_asympt_seco), + 1, syph.seco.asympt.prob.tx) == 1)] + + + # Select those in early latent stage who are eligible to be treated + idssyph_tx_asympt_earlat <- which(syph.infTime < at & + stage.syph == 4 & + syph.sympt == 0 & + diag.status.syph == 1 & + (is.na(syph.earlat.tx) | syph.earlat.tx == 0)) + + # Select those to be treated + txsyph_asympt_earlat <- idssyph_tx_asympt_earlat[which(rbinom(length(idssyph_tx_asympt_earlat), + 1, syph.earlat.asympt.prob.tx) == 1)] + + # Select those in late latent stage who are eligible to be treated + idssyph_tx_asympt_latelat <- which(syph.infTime < at & + (stage.syph == 5) & + (syph.sympt == 0) & + diag.status.syph == 1 & + (is.na(syph.latelat.tx) | syph.latelat.tx == 0)) + + # Select those to be treated + txsyph_asympt_latelat <- idssyph_tx_asympt_latelat[which(rbinom(length(idssyph_tx_asympt_latelat), + 1, syph.latelat.asympt.prob.tx) == 1)] + # Select those in tertiary stage who are eligible to be treated + idssyph_tx_asympt_tert <- which(syph.infTime < at & + stage.syph == 6 & + syph.sympt == 0 & + diag.status.syph == 1 & + (is.na(syph.tert.tx) | syph.tert.tx == 0)) + + # Select those to be treated + txsyph_asympt_tert <- idssyph_tx_asympt_tert[which(rbinom(length(idssyph_tx_asympt_tert), + 1, syph.tert.asympt.prob.tx) == 1)] + + # Aggregate all those eligible to be treated + idssyph_tx_asympt <- c(idssyph_tx_asympt_incub, idssyph_tx_asympt_prim, idssyph_tx_asympt_seco, idssyph_tx_asympt_earlat, + idssyph_tx_asympt_latelat, idssyph_tx_asympt_tert) + + # Aggregate all those selected to be treated + txsyph_asympt <- c(txsyph_asympt_incub, txsyph_asympt_prim, txsyph_asympt_seco, txsyph_asympt_earlat, + txsyph_asympt_latelat, txsyph_asympt_tert) + + # All treated syphilis + txsyph <- union(txsyph_sympt, txsyph_asympt) + idssyph_tx <- union(idssyph_tx_sympt, idssyph_tx_asympt) + + # By stage + idssyph_incub_tx <- union(idssyph_tx_asympt_incub, idssyph_tx_sympt_incub) + idssyph_prim_tx <- union(idssyph_tx_asympt_prim, idssyph_tx_sympt_prim) + idssyph_seco_tx <- union(idssyph_tx_asympt_seco, idssyph_tx_sympt_seco) + idssyph_earlat_tx <- union(idssyph_tx_asympt_earlat, idssyph_tx_sympt_earlat) + idssyph_latelat_tx <- union(idssyph_tx_asympt_latelat, idssyph_tx_sympt_latelat) + idssyph_tert_tx <- union(idssyph_tx_asympt_tert, idssyph_tx_sympt_tert) + + syph_incub_tx <- union(txsyph_asympt_incub, txsyph_sympt_incub) + syph_prim_tx <- union(txsyph_asympt_prim, txsyph_sympt_prim) + syph_seco_tx <- union(txsyph_asympt_seco, txsyph_sympt_seco) + syph_earlat_tx <- union(txsyph_asympt_earlat, txsyph_sympt_earlat) + syph_latelat_tx <- union(txsyph_asympt_latelat, txsyph_sympt_latelat) + syph_tert_tx <- union(txsyph_asympt_tert, txsyph_sympt_tert) + + + # Gonorrhea --------------------------------------------------------------- # symptomatic gc treatment - idsRGC_tx_sympt <- which(dat$attr$rGC == 1 & - dat$attr$rGC.infTime < at & - dat$attr$rGC.sympt == 1 & - is.na(dat$attr$rGC.tx) & - dat$attr$prepStat %in% prep.stand.tx.grp) - idsUGC_tx_sympt <- which(dat$attr$uGC == 1 & - dat$attr$uGC.infTime < at & - dat$attr$uGC.sympt == 1 & - is.na(dat$attr$uGC.tx) & - dat$attr$prepStat %in% prep.stand.tx.grp) + idsRGC_tx_sympt <- which(rGC == 1 & + rGC.infTime < at & + rGC.sympt == 1 & + is.na(rGC.tx)) + + idsUGC_tx_sympt <- which(uGC == 1 & + uGC.infTime < at & + uGC.sympt == 1 & + is.na(uGC.tx)) + idsGC_tx_sympt <- c(idsRGC_tx_sympt, idsUGC_tx_sympt) - txGC_sympt <- idsGC_tx_sympt[which(rbinom(length(idsGC_tx_sympt), 1, - gc.sympt.prob.tx) == 1)] + txGC_sympt <- idsGC_tx_sympt[which(rbinom(length(idsGC_tx_sympt), 1, gc.sympt.prob.tx) == 1)] txRGC_sympt <- intersect(idsRGC_tx_sympt, txGC_sympt) txUGC_sympt <- intersect(idsUGC_tx_sympt, txGC_sympt) # asymptomatic gc treatment - idsRGC_tx_asympt <- which(dat$attr$rGC == 1 & - dat$attr$rGC.infTime < at & - dat$attr$rGC.sympt == 0 & - is.na(dat$attr$rGC.tx) & - dat$attr$prepStat %in% prep.stand.tx.grp) - idsUGC_tx_asympt <- which(dat$attr$uGC == 1 & - dat$attr$uGC.infTime < at & - dat$attr$uGC.sympt == 0 & - is.na(dat$attr$uGC.tx) & - dat$attr$prepStat %in% prep.stand.tx.grp) - idsGC_tx_asympt <- c(idsRGC_tx_asympt, idsUGC_tx_asympt) + idsRGC_tx_asympt <- which(rGC == 1 & + rGC.infTime < at & + rGC.sympt == 0 & + diag.status.gc == 1 & + is.na(rGC.tx)) + + idsUGC_tx_asympt <- which(uGC == 1 & + uGC.infTime < at & + uGC.sympt == 0 & + diag.status.gc == 1 & + is.na(uGC.tx)) - txGC_asympt <- idsGC_tx_asympt[which(rbinom(length(idsGC_tx_asympt), 1, - gc.asympt.prob.tx) == 1)] + idsGC_tx_asympt <- c(idsRGC_tx_asympt, idsUGC_tx_asympt) + txGC_asympt <- idsGC_tx_asympt[which(rbinom(length(idsGC_tx_asympt), 1, gc.asympt.prob.tx) == 1)] txRGC_asympt <- intersect(idsRGC_tx_asympt, txGC_asympt) txUGC_asympt <- intersect(idsUGC_tx_asympt, txGC_asympt) @@ -548,39 +1032,39 @@ sti_tx <- function(dat, at) { idsUGC_tx <- union(idsUGC_tx_sympt, idsUGC_tx_asympt) + # Chlamydia --------------------------------------------------------------- + # symptomatic ct treatment - idsRCT_tx_sympt <- which(dat$attr$rCT == 1 & - dat$attr$rCT.infTime < at & - dat$attr$rCT.sympt == 1 & - is.na(dat$attr$rCT.tx) & - dat$attr$prepStat %in% prep.stand.tx.grp) - idsUCT_tx_sympt <- which(dat$attr$uCT == 1 & - dat$attr$uCT.infTime < at & - dat$attr$uCT.sympt == 1 & - is.na(dat$attr$uCT.tx) & - dat$attr$prepStat %in% prep.stand.tx.grp) + idsRCT_tx_sympt <- which(rCT == 1 & + rCT.infTime < at & + rCT.sympt == 1 & + is.na(rCT.tx)) + + idsUCT_tx_sympt <- which(uCT == 1 & + uCT.infTime < at & + uCT.sympt == 1 & + is.na(uCT.tx)) idsCT_tx_sympt <- c(idsRCT_tx_sympt, idsUCT_tx_sympt) - txCT_sympt <- idsCT_tx_sympt[which(rbinom(length(idsCT_tx_sympt), 1, - ct.sympt.prob.tx) == 1)] + txCT_sympt <- idsCT_tx_sympt[which(rbinom(length(idsCT_tx_sympt), 1, ct.sympt.prob.tx) == 1)] txRCT_sympt <- intersect(idsRCT_tx_sympt, txCT_sympt) txUCT_sympt <- intersect(idsUCT_tx_sympt, txCT_sympt) # asymptomatic ct treatment - idsRCT_tx_asympt <- which(dat$attr$rCT == 1 & - dat$attr$rCT.infTime < at & - dat$attr$rCT.sympt == 0 & - is.na(dat$attr$rCT.tx) & - dat$attr$prepStat == 0) - idsUCT_tx_asympt <- which(dat$attr$uCT == 1 & - dat$attr$uCT.infTime < at & - dat$attr$uCT.sympt == 0 & - is.na(dat$attr$uCT.tx) & - dat$attr$prepStat == 0) - idsCT_tx_asympt <- c(idsRCT_tx_asympt, idsUCT_tx_asympt) + idsRCT_tx_asympt <- which(rCT == 1 & + rCT.infTime < at & + rCT.sympt == 0 & + diag.status.ct == 1 & + is.na(rCT.tx)) + + idsUCT_tx_asympt <- which(uCT == 1 & + uCT.infTime < at & + uCT.sympt == 0 & + diag.status.ct == 1 & + is.na(uCT.tx)) - txCT_asympt <- idsCT_tx_asympt[which(rbinom(length(idsCT_tx_asympt), 1, - ct.asympt.prob.tx) == 1)] + idsCT_tx_asympt <- c(idsRCT_tx_asympt, idsUCT_tx_asympt) + txCT_asympt <- idsCT_tx_asympt[which(rbinom(length(idsCT_tx_asympt), 1, ct.asympt.prob.tx) == 1)] txRCT_asympt <- intersect(idsRCT_tx_asympt, txCT_asympt) txUCT_asympt <- intersect(idsUCT_tx_asympt, txCT_asympt) @@ -591,115 +1075,496 @@ sti_tx <- function(dat, at) { idsRCT_tx <- union(idsRCT_tx_sympt, idsRCT_tx_asympt) idsUCT_tx <- union(idsUCT_tx_sympt, idsUCT_tx_asympt) + + # PrEP-related treatment for all STIs -------------------------------------- + # Interval-based treatment for MSM on PrEP - idsSTI_screen <- which(dat$attr$prepStartTime == at | - (at - dat$attr$prepLastStiScreen >= prep.sti.screen.int)) - - dat$attr$prepLastStiScreen[idsSTI_screen] <- at - - - idsRGC_prep_tx <- intersect(idsSTI_screen, - which(dat$attr$rGC == 1 & - dat$attr$rGC.infTime < at & - is.na(dat$attr$rGC.tx.prep))) - idsUGC_prep_tx <- intersect(idsSTI_screen, - which(dat$attr$uGC == 1 & - dat$attr$uGC.infTime < at & - is.na(dat$attr$uGC.tx.prep))) - idsRCT_prep_tx <- intersect(idsSTI_screen, - which(dat$attr$rCT == 1 & - dat$attr$rCT.infTime < at & - is.na(dat$attr$rCT.tx.prep))) - idsUCT_prep_tx <- intersect(idsSTI_screen, - which(dat$attr$uCT == 1 & - dat$attr$uCT.infTime < at & - is.na(dat$attr$uCT.tx.prep))) - - txRGC_prep <- idsRGC_prep_tx[which(rbinom(length(idsRGC_prep_tx), 1, - prep.sti.prob.tx) == 1)] - txUGC_prep <- idsUGC_prep_tx[which(rbinom(length(idsUGC_prep_tx), 1, - prep.sti.prob.tx) == 1)] - txRCT_prep <- idsRCT_prep_tx[which(rbinom(length(idsRCT_prep_tx), 1, - prep.sti.prob.tx) == 1)] - txUCT_prep <- idsUCT_prep_tx[which(rbinom(length(idsUCT_prep_tx), 1, - prep.sti.prob.tx) == 1)] - - - # update attributes + idsSTI_screen <- which(prepStartTime == at | (at - prepLastStiScreen >= prep.sti.screen.int)) + + prepLastStiScreen[idsSTI_screen] <- at + + idsRGC_prep_tx <- intersect(idsSTI_screen, which(rGC == 1 & rGC.infTime < at & is.na(rGC.tx.prep))) + idsUGC_prep_tx <- intersect(idsSTI_screen, which(uGC == 1 & uGC.infTime < at & is.na(uGC.tx.prep))) + idsRCT_prep_tx <- intersect(idsSTI_screen, which(rCT == 1 & rCT.infTime < at & is.na(rCT.tx.prep))) + idsUCT_prep_tx <- intersect(idsSTI_screen, which(uCT == 1 & uCT.infTime < at & is.na(uCT.tx.prep))) + idssyph_prep_tx <- intersect(idsSTI_screen, which(syphilis == 1 & syph.infTime < at & is.na(syph.tx.prep))) + + txRGC_prep <- idsRGC_prep_tx[which(rbinom(length(idsRGC_prep_tx), 1, prep.sti.prob.tx) == 1)] + txUGC_prep <- idsUGC_prep_tx[which(rbinom(length(idsUGC_prep_tx), 1, prep.sti.prob.tx) == 1)] + txRCT_prep <- idsRCT_prep_tx[which(rbinom(length(idsRCT_prep_tx), 1, prep.sti.prob.tx) == 1)] + txUCT_prep <- idsUCT_prep_tx[which(rbinom(length(idsUCT_prep_tx), 1, prep.sti.prob.tx) == 1)] + txsyph_prep <- idssyph_prep_tx[which(rbinom(length(idssyph_prep_tx), 1, prep.sti.prob.tx) == 1)] + + # Summarize all treated for each STI - EPT-treated not eligible to provide EPT to their partners + txRGC_all <- c(txRGC, txRGC_prep) + txUGC_all <- c(txUGC, txUGC_prep) + txRCT_all <- c(txRCT, txRCT_prep) + txUCT_all <- c(txUCT, txUCT_prep) + txsyph_all <- c(txsyph, txsyph_prep) + + # Subset all treated for GC/CT to treated with partners (for EPT) + ept_txRGC_all <- txRGC_all[dat$attr$recentpartners[txRGC_all] > 0] + ept_txUGC_all <- txUGC_all[dat$attr$recentpartners[txUGC_all] > 0] + ept_txRCT_all <- txRCT_all[dat$attr$recentpartners[txRCT_all] > 0] + ept_txUCT_all <- txUCT_all[dat$attr$recentpartners[txUCT_all] > 0] + ept_txGC_all <- c(ept_txRGC_all, ept_txUGC_all) + ept_txCT_all <- c(ept_txRCT_all, ept_txUCT_all) + ept_tx_all <- unique(c(ept_txRGC_all, ept_txUGC_all, ept_txRCT_all, ept_txUCT_all)) + + # Update EPT index status and eligibility for GC/CT treated with partners + dat$attr$eptindexElig[ept_tx_all] <- 1 + dat$attr$eptindexStat[ept_tx_all] <- 0 + dat$attr$eptindexEligdate[ept_tx_all] <- at + + # EPT Treatment for Non-index (no test is done) ------------------------------ + + # Have prevalent infection, are eligible for tx through EPT, are untreated, + # are not previously assigned for EPT tx, and were provided/uptake EPT last + # time step + idsRGC_tx_ept <- which(rGC == 1 & + rGC.infTime < at & + eptpartEligTx_GC == 1 & + eptpartEligTxdate == (at - 1) & + (is.na(rGC.tx) | rGC.tx == 0) & + (is.na(rGC.tx.prep) | rGC.tx.prep == 0) & + is.na(rGC.tx.ept)) + + idsUGC_tx_ept <- which(uGC == 1 & + uGC.infTime < at & + eptpartEligTx_GC == 1 & + eptpartEligTxdate == (at - 1) & + (is.na(uGC.tx) | uGC.tx == 0) & + (is.na(uGC.tx.prep) | uGC.tx.prep == 0) & + is.na(uGC.tx.ept)) + + idsGC_tx_ept <- c(idsRGC_tx_ept, idsUGC_tx_ept) + txGC_ept <- idsGC_tx_ept[which(rbinom(length(idsGC_tx_ept), 1, ept.gc.success) == 1)] + txRGC_ept <- intersect(idsRGC_tx_ept, txGC_ept) + txUGC_ept <- intersect(idsUGC_tx_ept, txGC_ept) + + idsRCT_tx_ept <- which(rCT == 1 & + rCT.infTime < at & + eptpartEligTx_CT == 1 & + eptpartEligTxdate == (at - 1) & + (is.na(rCT.tx) | rCT.tx == 0) & + (is.na(rCT.tx.prep) | rCT.tx.prep == 0) & + is.na(rCT.tx.ept)) + + idsUCT_tx_ept <- which(uCT == 1 & + uCT.infTime < at & + eptpartEligTx_CT == 1 & + eptpartEligTxdate == (at - 1) & + (is.na(uCT.tx) | uCT.tx == 0) & + (is.na(uCT.tx.prep) | uCT.tx.prep == 0) & + is.na(uCT.tx.ept)) + idsCT_tx_ept <- c(idsRCT_tx_ept, idsUCT_tx_ept) + + txCT_ept <- idsCT_tx_ept[which(rbinom(length(idsCT_tx_ept), 1, ept.ct.success) == 1)] + txRCT_ept <- intersect(idsRCT_tx_ept, txCT_ept) + txUCT_ept <- intersect(idsUCT_tx_ept, txCT_ept) + + # All EPT-treated index ids + allidsept <- unique(c(idsCT_tx_ept, idsGC_tx_ept)) + + # Summarize all successfully treated for each STI, now including EPT + alltxRGC <- c(txRGC, txRGC_prep, txRGC_ept) + alltxUGC <- c(txUGC, txUGC_prep, txUGC_ept) + alltxRCT <- c(txRCT, txRCT_prep, txRCT_ept) + alltxUCT <- c(txUCT, txUCT_prep, txUCT_ept) + alltxEPT <- c(txRGC_ept, txUGC_ept, txRCT_ept, txUCT_ept) + + # EPT Initiation for Index Partner ------------------------------------------- + + # Eligibility only lasts one time step - so coverage is 0 for current eligibles + eptCov <- 0 + idsEligSt <- which(dat$attr$eptindexElig == 1 & dat$attr$eptindexEligdate == at) + nEligSt <- length(idsEligSt) + + nStart <- max(0, min(nEligSt, round((ept.coverage - eptCov) * nEligSt))) + ept_idsStart <- NULL + if (nStart > 0) { + if (ept.cov.rate >= 1) { + ept_idsStart <- ssample(idsEligSt, nStart) + } else { + ept_idsStart <- idsEligSt[rbinom(nStart, 1, ept.cov.rate) == 1] + } + } + eptCov <- (length(ept_idsStart)) / nEligSt + + # Update EPT index status for those selected to receive EPT for their partners + dat$attr$eptindexStat[ept_idsStart] <- 1 + + index_gc <- intersect(ept_txGC_all, ept_idsStart) + index_ct <- intersect(ept_txCT_all, ept_idsStart) + + # Correlated testing for other STIs if symptomatic for one ------------------- + + # All treated for other site of STIs, minus those getting treated for STI through EPT + tst.rgc <- setdiff(txRCT_sympt, txRGC_ept) + tst.ugc <- setdiff(txUCT_sympt, txUGC_ept) + tst.rct <- setdiff(txRGC_sympt, txRCT_ept) + tst.uct <- setdiff(txUGC_sympt, txUCT_ept) + + # Remove those just treated for STI (either sympt/asympt) from testing + tst.rgc <- setdiff(tst.rgc, txRGC) + tst.ugc <- setdiff(tst.ugc, txUGC) + tst.rct <- setdiff(tst.rct, txRCT) + tst.uct <- setdiff(tst.uct, txUCT) + tst.syph <- setdiff(txsyph_sympt, txsyph_sympt) #no correlated testing + + # Subset to those not tested for particular STI recently (in last 12 weeks) + tst.rgc <- tst.rgc[which(tsinceltst.rgc[tst.rgc] > sti.correlation.time & + (is.na(diag.status.gc[tst.rgc]) | + diag.status.gc[tst.rgc]) & + role.class[tst.rgc] %in% c("R", "V"))] + tst.ugc <- tst.ugc[which(tsinceltst.ugc[tst.ugc] > sti.correlation.time & + (is.na(diag.status.gc[tst.ugc]) | + diag.status.gc[tst.ugc]) & + role.class[tst.ugc] %in% c("I", "V"))] + tst.rct <- tst.rct[which(tsinceltst.rct[tst.rct] > sti.correlation.time & + (is.na(diag.status.ct[tst.rct]) | + diag.status.ct[tst.rct]) & + role.class[tst.rct] %in% c("R", "V"))] + tst.uct <- tst.uct[which(tsinceltst.uct[tst.uct] > sti.correlation.time & + (is.na(diag.status.ct[tst.uct]) | + diag.status.ct[tst.uct]) & + role.class[tst.uct] %in% c("I", "V"))] + tst.syph <- tst.syph[which(tsinceltst.syph[tst.syph] > sti.correlation.time & + (is.na(diag.status.syph[tst.syph]) | + diag.status.syph[tst.syph]))] + + + tst.rgc.pos <- tst.rgc[which(rGC[tst.rgc] == 1)] + tst.ugc.pos <- tst.ugc[which(uGC[tst.ugc] == 1)] + tst.rgc.neg <- setdiff(tst.rgc, tst.ugc.pos) + tst.ugc.neg <- setdiff(tst.ugc, tst.ugc.pos) + tst.gc.pos <- c(tst.rgc.pos, tst.ugc.pos) + + tst.rct.pos <- tst.rct[which(rCT[tst.rct] == 1)] + tst.uct.pos <- tst.uct[which(uCT[tst.uct] == 1)] + tst.rct.neg <- setdiff(tst.rct, tst.uct.pos) + tst.uct.neg <- setdiff(tst.uct, tst.uct.pos) + tst.ct.pos <- c(tst.rct.pos, tst.uct.pos) + + tst.syph.pos <- tst.syph[which(syphilis[tst.syph] == 1 & + stage.syph[tst.syph] %in% 2:6)] + tst.syph.neg <- setdiff(tst.syph, tst.syph.pos) + tst.earlysyph.pos <- tst.syph[which(syphilis[tst.syph] == 1 & + stage.syph[tst.syph] %in% 2:3)] + tst.latesyph.pos <- tst.syph[which(syphilis[tst.syph] == 1 & + stage.syph[tst.syph] %in% 4:6)] + + # Output --------------------------------------------------------------------- + # PrEP + dat$attr$prepLastStiScreen <- prepLastStiScreen + + # Syphilis + dat$attr$syph.incub.tx[idssyph_incub_tx] <- 0 + dat$attr$syph.prim.tx[idssyph_prim_tx] <- 0 + dat$attr$syph.seco.tx[idssyph_seco_tx] <- 0 + dat$attr$syph.earlat.tx[idssyph_earlat_tx] <- 0 + dat$attr$syph.latelat.tx[idssyph_latelat_tx] <- 0 + dat$attr$syph.tert.tx[idssyph_tert_tx] <- 0 + dat$attr$syph.incub.tx[syph_incub_tx] <- 1 + dat$attr$syph.prim.tx[syph_prim_tx] <- 1 + dat$attr$syph.seco.tx[syph_seco_tx] <- 1 + dat$attr$syph.earlat.tx[syph_earlat_tx] <- 1 + dat$attr$syph.latelat.tx[syph_latelat_tx] <- 1 + dat$attr$syph.tert.tx[syph_tert_tx] <- 1 + dat$attr$last.tx.time.syph[txsyph_all] <- at + dat$attr$syph.tx.prep[idssyph_prep_tx] <- 0 + dat$attr$syph.tx.prep[txsyph_prep] <- 1 + dat$attr$last.tx.time.syph.prep[txsyph_prep] <- at + dat$attr$last.diag.time.syph[txsyph_sympt] <- at + dat$attr$last.neg.test.syph[txsyph_sympt] <- NA + dat$attr$time.since.last.test.syph[txsyph_sympt] <- 0 + dat$attr$diag.status.syph[idssyph_tx_sympt] <- 0 + dat$attr$diag.status.syph[txsyph_sympt] <- 1 + + ## Correlated Syphilis testing + dat$attr$last.neg.test.syph[tst.syph.neg] <- at + dat$attr$last.neg.test.syph[tst.syph.pos] <- NA + dat$attr$diag.status.syph[tst.syph.pos] <- 1 + dat$attr$last.diag.time.syph[tst.syph.pos] <- at + dat$attr$time.since.last.test.syph[tst.syph] <- 0 + + # Gonorrhea dat$attr$rGC.tx[idsRGC_tx] <- 0 dat$attr$rGC.tx[txRGC] <- 1 - dat$attr$uGC.tx[idsUGC_tx] <- 0 dat$attr$uGC.tx[txUGC] <- 1 - - dat$attr$rCT.tx[idsRCT_tx] <- 0 - dat$attr$rCT.tx[txRCT] <- 1 - - dat$attr$uCT.tx[idsUCT_tx] <- 0 - dat$attr$uCT.tx[txUCT] <- 1 - dat$attr$rGC.tx.prep[idsRGC_prep_tx] <- 0 dat$attr$rGC.tx.prep[txRGC_prep] <- 1 - + dat$attr$rGC.tx.ept[idsRGC_tx_ept] <- 0 + dat$attr$rGC.tx.ept[txRGC_ept] <- 1 + dat$attr$last.tx.time.rgc[txRGC_all] <- at + dat$attr$last.tx.time.ugc[txUGC_all] <- at + dat$attr$last.tx.time.rgc.prep[txRGC_prep] <- at + dat$attr$last.tx.time.ugc.prep[txUGC_prep] <- at dat$attr$uGC.tx.prep[idsUGC_prep_tx] <- 0 dat$attr$uGC.tx.prep[txUGC_prep] <- 1 - + dat$attr$uGC.tx.ept[idsUGC_tx_ept] <- 0 + dat$attr$uGC.tx.ept[txUGC_ept] <- 1 + dat$attr$rGC.tx[which((dat$attr$uGC.tx == 1 | dat$attr$uGC.tx.prep == 1 | dat$attr$uGC.tx.ept == 1) & dat$attr$rGC == 1)] <- 1 + dat$attr$uGC.tx[which((dat$attr$rGC.tx == 1 | dat$attr$rGC.tx.prep == 1 | dat$attr$rGC.tx.ept == 1) & dat$attr$uGC == 1)] <- 1 + dat$attr$last.diag.time.gc[txGC_sympt] <- at + dat$attr$last.neg.test.rgc[txRGC_sympt] <- NA + dat$attr$last.neg.test.ugc[txUGC_sympt] <- NA + dat$attr$time.since.last.test.rgc[txRGC_sympt] <- 0 + dat$attr$time.since.last.test.ugc[txUGC_sympt] <- 0 + dat$attr$diag.status.gc[idsGC_tx_sympt] <- 0 + dat$attr$diag.status.gc[txGC_sympt] <- 1 + + ## Correlated Gonorrhea testing + dat$attr$last.neg.test.rgc[tst.rgc.neg] <- at + dat$attr$last.neg.test.ugc[tst.ugc.neg] <- at + dat$attr$last.neg.test.rgc[tst.rgc.pos] <- NA + dat$attr$last.neg.test.ugc[tst.ugc.pos] <- NA + dat$attr$diag.status.gc[tst.gc.pos] <- 1 + dat$attr$last.diag.time.gc[tst.gc.pos] <- at + dat$attr$time.since.last.test.rgc[tst.rgc] <- 0 + dat$attr$time.since.last.test.ugc[tst.ugc] <- 0 + + # Chlamydia + dat$attr$rCT.tx[idsRCT_tx] <- 0 + dat$attr$rCT.tx[txRCT] <- 1 + dat$attr$uCT.tx[idsUCT_tx] <- 0 + dat$attr$uCT.tx[txUCT] <- 1 dat$attr$rCT.tx.prep[idsRCT_prep_tx] <- 0 dat$attr$rCT.tx.prep[txRCT_prep] <- 1 - + dat$attr$rCT.tx.ept[idsRCT_tx_ept] <- 0 + dat$attr$rCT.tx.ept[txRCT_ept] <- 1 + dat$attr$last.tx.time.rct[txRCT_all] <- at + dat$attr$last.tx.time.uct[txUCT_all] <- at + dat$attr$last.tx.time.rct.prep[txRCT_prep] <- at + dat$attr$last.tx.time.uct.prep[txUCT_prep] <- at dat$attr$uCT.tx.prep[idsUCT_prep_tx] <- 0 dat$attr$uCT.tx.prep[txUCT_prep] <- 1 - - - # add tx at other site - dat$attr$rGC.tx[which((dat$attr$uGC.tx == 1 | dat$attr$uGC.tx.prep == 1) & dat$attr$rGC == 1)] <- 1 - dat$attr$uGC.tx[which((dat$attr$rGC.tx == 1 | dat$attr$rGC.tx.prep == 1) & dat$attr$uGC == 1)] <- 1 - - dat$attr$rCT.tx[which((dat$attr$uCT.tx == 1 | dat$attr$uCT.tx.prep == 1) & dat$attr$rCT == 1)] <- 1 - dat$attr$uCT.tx[which((dat$attr$rCT.tx == 1 | dat$attr$rCT.tx.prep == 1) & dat$attr$uCT == 1)] <- 1 - - txRGC_all <- union(txRGC, txRGC_prep) - txUGC_all <- union(txUGC, txUGC_prep) - txRCT_all <- union(txRCT, txRCT_prep) - txUCT_all <- union(txUCT, txUCT_prep) - - - # summary stats + dat$attr$uCT.tx.ept[idsUCT_tx_ept] <- 0 + dat$attr$uCT.tx.ept[txUCT_ept] <- 1 + dat$attr$rCT.tx[which((dat$attr$uCT.tx == 1 | dat$attr$uCT.tx.prep == 1 | dat$attr$uCT.tx.ept == 1) & dat$attr$rCT == 1)] <- 1 + dat$attr$uCT.tx[which((dat$attr$rCT.tx == 1 | dat$attr$rCT.tx.prep == 1 | dat$attr$rCT.tx.ept == 1) & dat$attr$uCT == 1)] <- 1 + dat$attr$last.diag.time.ct[txCT_sympt] <- at + dat$attr$last.neg.test.rct[txRCT_sympt] <- NA + dat$attr$last.neg.test.uct[txUCT_sympt] <- NA + dat$attr$time.since.last.test.rct[txRCT_sympt] <- 0 + dat$attr$time.since.last.test.uct[txUCT_sympt] <- 0 + dat$attr$diag.status.ct[idsCT_tx_sympt] <- 0 + dat$attr$diag.status.ct[txCT_sympt] <- 1 + + ## Correlated Chlamydia testing + dat$attr$last.neg.test.rct[tst.rct.neg] <- at + dat$attr$last.neg.test.uct[tst.uct.neg] <- at + dat$attr$last.neg.test.rct[tst.rct.pos] <- NA + dat$attr$last.neg.test.uct[tst.uct.pos] <- NA + dat$attr$diag.status.ct[tst.ct.pos] <- 1 + dat$attr$last.diag.time.ct[tst.ct.pos] <- at + dat$attr$time.since.last.test.rct[tst.rct] <- 0 + dat$attr$time.since.last.test.uct[tst.uct] <- 0 + + # Proportion of infections treated in past year + dat$epi$tx.gc.prop[at] <- ifelse(length(which(at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.uGC.infTime <= 52)) == 0 | + is.na(length(which(at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.uGC.infTime <= 52))) | + is.nan(length(which(at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.uGC.infTime <= 52))) | + is.null(length(which(at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.uGC.infTime <= 52))), + 0, + (length(which(at - dat$attr$last.tx.time.rgc <= 52 & + at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.tx.time.ugc <= 52 & + at - dat$attr$last.uGC.infTime <= 52))) / + (length(which(at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.uGC.infTime <= 52)))) + + dat$epi$tx.ct.prop[at] <- ifelse(length(which(at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.uCT.infTime <= 52)) == 0 | + is.na(length(which(at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.uCT.infTime <= 52))) | + is.nan(length(which(at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.uCT.infTime <= 52))) | + is.null(length(which(at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.uCT.infTime <= 52))), + 0, + (length(which(at - dat$attr$last.tx.time.rct <= 52 & + at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.tx.time.uct <= 52 & + at - dat$attr$last.uCT.infTime <= 52))) / + (length(which(at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.uCTC.infTime <= 52)))) + + dat$epi$tx.gcct.prop[at] <- ifelse((length(which(at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.uGC.infTime <= 52)) + + length(which(at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.uCT.infTime <= 52))) == 0 | + is.na(length(which(at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.uGC.infTime <= 52)) + + length(which(at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.uCT.infTime <= 52))) | + is.nan(length(which(at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.uGC.infTime <= 52)) + + length(which(at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.uCT.infTime <= 52))) | + is.null(length(which(at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.uGC.infTime <= 52)) + + length(which(at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.uCT.infTime <= 52))), 0, + (length(which(at - dat$attr$last.tx.time.rgc <= 52 & + at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.tx.time.ugc <= 52 & + at - dat$attr$last.uGC.infTime <= 52)) + + length(which(at - dat$attr$last.tx.time.rct <= 52 & + at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.tx.time.uct <= 52 & + at - dat$attr$last.uCT.infTime <= 52))) / + (length(which(at - dat$attr$last.rGC.infTime <= 52)) + + length(which(at - dat$attr$last.uGC.infTime <= 52)) + + length(which(at - dat$attr$last.rCT.infTime <= 52)) + + length(which(at - dat$attr$last.uCT.infTime <= 52)))) + + dat$epi$tx.syph.prop[at] <- ifelse(length(which(at - dat$attr$last.syph.infTime <= 52)) == 0 | + is.na(length(which(at - dat$attr$last.syph.infTime <= 52))) | + is.nan(length(which(at - dat$attr$last.syph.infTime <= 52))) | + is.null(length(which(at - dat$attr$last.syph.infTime <= 52))), 0, + length(which(at - dat$attr$last.tx.time.syph <= 52 & + at - dat$attr$last.syph.infTime <= 52)) / + length(which(at - dat$attr$last.syph.infTime <= 52))) + + + # Non-index EPT-treated + dat$attr$eptpartEligTx_GC[txGC_ept] <- NA + dat$attr$eptpartEligTx_CT[txCT_ept] <- NA + dat$attr$eptpartEligTxdate[alltxEPT] <- NA + dat$attr$eptpartTx[allidsept] <- 0 + dat$attr$eptpartTx[alltxEPT] <- 1 + + # summary statistics if (is.null(dat$epi$num.asympt.tx)) { - dat$epi$num.asympt.tx <- rep(NA, length(dat$epi$num)) - dat$epi$num.asympt.cases <- rep(NA, length(dat$epi$num)) - dat$epi$num.asympt.tx.prep <- rep(NA, length(dat$epi$num)) - dat$epi$num.asympt.cases.prep <- rep(NA, length(dat$epi$num)) - dat$epi$num.rect.tx <- rep(NA, length(dat$epi$num)) - dat$epi$num.rect.cases <- rep(NA, length(dat$epi$num)) - dat$epi$num.rect.tx.prep <- rep(NA, length(dat$epi$num)) - dat$epi$num.rect.cases.prep <- rep(NA, length(dat$epi$num)) + dat$epi$num.asympt.tx <- rep(NA, length(dat$control$nsteps)) + dat$epi$num.asympt.cases <- rep(NA, length(dat$control$nsteps)) + dat$epi$num.asympt.tx.prep <- rep(NA, length(dat$control$nsteps)) + dat$epi$num.asympt.cases.prep <- rep(NA, length(dat$control$nsteps)) + dat$epi$num.rect.tx <- rep(NA, length(dat$epi$control$nsteps)) + dat$epi$num.rect.cases <- rep(NA, length(dat$epi$control$nsteps)) + dat$epi$num.rect.tx.prep <- rep(NA, length(dat$epi$control$nsteps)) + dat$epi$num.rect.cases.prep <- rep(NA, length(dat$epi$control$nsteps)) } + # Update number tested due to urethral or rectal symptoms + dat$epi$rGC_symptstidxtime[at] <- length(tst.rgc) + dat$epi$uGC_symptstidxtime[at] <- length(tst.ugc) + dat$epi$rCT_symptstidxtime[at] <- length(tst.rct) + dat$epi$uCT_symptstidxtime[at] <- length(tst.uct) + dat$epi$syph_symptstidxtime[at] <- length(tst.syph) + + # Update number testing positive for other STI due to symptoms + dat$epi$rGC_pos_symptstidxtime[at] <- length(tst.rgc.pos) + dat$epi$uGC_pos_symptstidxtime[at] <- length(tst.ugc.pos) + dat$epi$rCT_pos_symptstidxtime[at] <- length(tst.rct.pos) + dat$epi$uCT_pos_symptstidxtime[at] <- length(tst.uct.pos) + dat$epi$syph_pos_symptstidxtime[at] <- length(tst.syph.pos) + dat$epi$syph_earlypos_symptstidxtime[at] <- length(tst.earlysyph.pos) + dat$epi$syph_latepos_symptstidxtime[at] <- length(tst.latesyph.pos) + + # Update symptomatic tests to now include symptomatic STI-correlated testing + dat$epi$rGCsympttests[at] <- sum(length(unique(txRGC_sympt)), + dat$epi$rGC_symptstidxtime[at], + na.rm = TRUE) + dat$epi$uGCsympttests[at] <- sum(length(unique(txUGC_sympt)), + dat$epi$uGC_symptstidxtime[at], + na.rm = TRUE) + dat$epi$GCsympttests[at] <- sum(dat$epi$rGCsympttests[at], + dat$epi$uGCsympttests[at], + na.rm = TRUE) + + dat$epi$rGCsympttests.pos[at] <- sum(length(unique(txRGC_sympt)), + dat$epi$rGC_pos_symptstidxtime[at], + na.rm = TRUE) + dat$epi$uGCsympttests.pos[at] <- sum(length(unique(txRGC_sympt)), + dat$epi$uGC_pos_symptstidxtime[at], + na.rm = TRUE) + dat$epi$GCsympttests.pos[at] <- sum(dat$epi$rGCsympttests.pos[at], + dat$epi$uGCsympttests.pos[at], + na.rm = TRUE) + + dat$epi$rCTsympttests[at] <- sum(length(unique(txRCT_sympt)), + dat$epi$RCT_symptstidxtime[at], + na.rm = TRUE) + dat$epi$uCTsympttests[at] <- sum(length(unique(txUCT_sympt)), + dat$epi$uCT_symptstidxtime[at], + na.rm = TRUE) + dat$epi$CTsympttests[at] <- sum(dat$epi$rCTsympttests[at], + dat$epi$rCT_symptstidxtime[at], + dat$epi$uCTsympttests[at], + dat$epi$uCT_symptstidxtime[at], + na.rm = TRUE) + + dat$epi$rCTsympttests.pos[at] <- sum(length(unique(txRGC_sympt)), + dat$epi$rCT_pos_symptstidxtime[at], + na.rm = TRUE) + dat$epi$uCTsympttests.pos[at] <- sum(length(unique(txRGC_sympt)), + dat$epi$uCT_pos_symptstidxtime[at], + na.rm = TRUE) + dat$epi$CTsympttests.pos[at] <- sum(dat$epi$rCTsympttests.pos[at], + dat$epi$uCTsympttests.pos[at], + na.rm = TRUE) + + dat$epi$syphsympttests[at] <- sum(length(unique(txsyph_sympt)), + dat$epi$syph_symptstidxtime[at], + na.rm = TRUE) + dat$epi$syphsympttests.pos[at] <- sum(length(unique(txsyph_sympt)), + dat$epi$syph_pos_symptstidxtime[at], + na.rm = TRUE) + dat$epi$syphearlysympttests.pos[at] <- sum(length(unique(c(txsyph_sympt_prim, + txsyph_sympt_seco))), + dat$epi$syph_earlypos_symptstidxtime[at], + na.rm = TRUE) + + dat$epi$syphlatesympttests.pos[at] <- sum(length(unique(c(txsyph_sympt_tert))), + dat$epi$syph_latepos_symptstidxtime[at], + na.rm = TRUE) + + dat$epi$stisympttests[at] <- sum(dat$epi$GCsympttests[at], + dat$epi$rCTsympttests[at], + dat$epi$syphsympttests[at], + na.rm = TRUE) + + dat$epi$stisympttests.pos[at] <- sum(dat$epi$GCsympttests.pos[at], + dat$epi$CTsympttests.pos[at], + dat$epi$syphsympttests.pos[at], + na.rm = TRUE) + + # Asymptomatic treated asympt.tx <- c(intersect(txRGC_all, which(dat$attr$rGC.sympt == 0)), intersect(txUGC_all, which(dat$attr$uGC.sympt == 0)), intersect(txRCT_all, which(dat$attr$rCT.sympt == 0)), - intersect(txUCT_all, which(dat$attr$uCT.sympt == 0))) + intersect(txUCT_all, which(dat$attr$uCT.sympt == 0)), + intersect(txsyph_all, which(dat$attr$syph.sympt == 0))) dat$epi$num.asympt.tx[at] <- length(unique(asympt.tx)) + asympt.cases <- c(idsRGC_tx_asympt, intersect(idsRGC_prep_tx, which(dat$attr$rGC.sympt == 0)), idsUGC_tx_asympt, intersect(idsUGC_prep_tx, which(dat$attr$uGC.sympt == 0)), idsRCT_tx_asympt, intersect(idsRCT_prep_tx, which(dat$attr$rCT.sympt == 0)), - idsUCT_tx_asympt, intersect(idsUCT_prep_tx, which(dat$attr$uCT.sympt == 0))) + idsUCT_tx_asympt, intersect(idsUCT_prep_tx, which(dat$attr$uCT.sympt == 0)), + idssyph_tx_asympt, intersect(idssyph_prep_tx, which(dat$attr$syph.sympt == 0))) dat$epi$num.asympt.cases[at] <- length(unique(asympt.cases)) - asympt.tx.prep <- c(intersect(txRGC_prep, which(dat$attr$rGC.sympt == 0)), intersect(txUGC_prep, which(dat$attr$uGC.sympt == 0)), intersect(txRCT_prep, which(dat$attr$rCT.sympt == 0)), - intersect(txUCT_prep, which(dat$attr$uCT.sympt == 0))) + intersect(txUCT_prep, which(dat$attr$uCT.sympt == 0)), + intersect(txsyph_prep, which(dat$attr$syph.sympt == 0))) dat$epi$num.asympt.tx.prep[at] <- length(unique(asympt.tx.prep)) + asympt.cases.prep <- c(intersect(idsRGC_prep_tx, which(dat$attr$rGC.sympt == 0)), intersect(idsUGC_prep_tx, which(dat$attr$uGC.sympt == 0)), intersect(idsRCT_prep_tx, which(dat$attr$rCT.sympt == 0)), - intersect(idsUCT_prep_tx, which(dat$attr$uCT.sympt == 0))) + intersect(idsUCT_prep_tx, which(dat$attr$uCT.sympt == 0)), + intersect(idssyph_prep_tx, which(dat$attr$syph.sympt == 0))) dat$epi$num.asympt.cases.prep[at] <- length(unique(asympt.cases.prep)) - rect.tx <- c(txRGC_all, txRCT_all) dat$epi$num.rect.tx[at] <- length(unique(rect.tx)) rect.cases <- c(idsRGC_tx, idsRGC_prep_tx, idsRCT_tx, idsRCT_prep_tx) @@ -710,5 +1575,205 @@ sti_tx <- function(dat, at) { rect.cases.prep <- c(idsRGC_prep_tx, idsRCT_prep_tx) dat$epi$num.rect.cases.prep[at] <- length(unique(rect.cases.prep)) + # Track total number treated + dat$epi$txGC[at] <- length(unique(txRGC)) + length(unique(txUGC)) + dat$epi$txGC_asympt[at] <- length(unique(txGC_asympt)) + dat$epi$txCT[at] <- length(unique(txRCT)) + length(unique(txUCT)) + dat$epi$txCT_asympt[at] <- length(unique(txCT_asympt)) + dat$epi$txsyph[at] <- length(unique(c(txsyph))) + dat$epi$txsyph_asympt[at] <- length(unique(txsyph_asympt)) + dat$epi$txearlysyph[at] <- length(unique(c(txsyph_sympt_prim, txsyph_sympt_seco, + txsyph_asympt_prim, txsyph_asympt_seco, + txsyph_asympt_earlat))) + dat$epi$txlatesyph[at] <- length(unique(c(txsyph_asympt_latelat, txsyph_asympt_tert, + txsyph_sympt_tert))) + dat$epi$txSTI_asympt[at] <- dat$epi$txGC_asympt[at] + + dat$epi$txCT_asympt[at] + + dat$epi$txsyph_asympt[at] + dat$epi$txSTI[at] <- dat$epi$txGC[at] + dat$epi$txCT[at] + dat$epi$txsyph[at] + + # Risk group-specific treatment and test counters + dat$epi$txGC.tttraj1[at] <- length(which(tt.traj.gc.hivneg[unique(c(txRGC, txUGC))] == 1 | + tt.traj.gc.hivpos[unique(c(txRGC, txUGC))] == 1)) + dat$epi$txGC_asympt.tttraj1[at] <- length(which(tt.traj.gc.hivneg[unique(txGC_asympt)] == 1 | + tt.traj.gc.hivpos[unique(txGC_asympt)] == 1)) + dat$epi$txGC.tttraj2[at] <- length(which(tt.traj.gc.hivneg[unique(c(txRGC, txUGC))] == 2 | + tt.traj.gc.hivpos[unique(c(txRGC, txUGC))] == 2)) + dat$epi$txGC_asympt.tttraj2[at] <- length(which(tt.traj.gc.hivneg[unique(txGC_asympt)] == 2 | + tt.traj.gc.hivpos[unique(txGC_asympt)] == 2)) + + dat$epi$txCT.tttraj1[at] <- length(which(tt.traj.ct.hivpos[unique(c(txRCT, txUCT))] == 1 | + tt.traj.ct.hivneg[unique(c(txRCT, txUCT))] == 1)) + dat$epi$txCT_asympt.tttraj1[at] <- length(which(tt.traj.ct.hivpos[unique(txCT_asympt)] == 1 | + tt.traj.ct.hivneg[unique(txCT_asympt)] == 1)) + dat$epi$txCT.tttraj2[at] <- length(which(tt.traj.ct.hivpos[unique(c(txRCT, txUCT))] == 2 | + tt.traj.ct.hivneg[unique(c(txRCT, txUCT))] == 2)) + dat$epi$txCT_asympt.tttraj2[at] <- length(which(tt.traj.ct.hivpos[unique(txCT_asympt)] == 2 | + tt.traj.ct.hivneg[unique(txCT_asympt)] == 2)) + + dat$epi$txsyph.tttraj1[at] <- length(which(tt.traj.syph.hivneg[unique(txsyph)] == 1 | + tt.traj.syph.hivpos[unique(txsyph)] == 1)) + dat$epi$txsyph_asympt.tttraj1[at] <- length(which(tt.traj.syph.hivneg[unique(txsyph_asympt)] == 1 | + tt.traj.syph.hivpos[unique(txsyph_asympt)] == 1)) + dat$epi$txsyph.tttraj2[at] <- length(which(tt.traj.syph.hivneg[unique(txsyph)] == 2 | + tt.traj.syph.hivpos[unique(txsyph)] == 2)) + dat$epi$txsyph_asympt.tttraj2[at] <- length(which(tt.traj.syph.hivneg[unique(txsyph_asympt)] == 2 | + tt.traj.syph.hivpos[unique(txsyph_asympt)] == 2)) + + dat$epi$txearlysyph.tttraj1[at] <- length(which(tt.traj.syph.hivneg[unique(c(txsyph_sympt_prim, + txsyph_sympt_seco, + txsyph_asympt_prim, + txsyph_asympt_seco, + txsyph_asympt_earlat))] == 1 | + tt.traj.syph.hivpos[unique(c(txsyph_sympt_prim, + txsyph_sympt_seco, + txsyph_asympt_prim, + txsyph_asympt_seco, + txsyph_asympt_earlat))] == 1)) + dat$epi$txlatesyph.tttraj1[at] <- length(which(tt.traj.syph.hivneg[unique(c(txsyph_asympt_latelat, + txsyph_asympt_tert, + txsyph_sympt_tert))] == 1 | + tt.traj.syph.hivpos[unique(c(txsyph_asympt_latelat, + txsyph_asympt_tert, + txsyph_sympt_tert))] == 1)) + + dat$epi$txearlysyph.tttraj2[at] <- length(which(tt.traj.syph.hivneg[unique(c(txsyph_sympt_prim, + txsyph_sympt_seco, + txsyph_asympt_prim, + txsyph_asympt_seco, + txsyph_asympt_earlat))] == 2 | + tt.traj.syph.hivpos[unique(c(txsyph_sympt_prim, + txsyph_sympt_seco, + txsyph_asympt_prim, + txsyph_asympt_seco, + txsyph_asympt_earlat))] == 2)) + dat$epi$txlatesyph.tttraj2[at] <- length(which(tt.traj.syph.hivneg[unique(c(txsyph_asympt_latelat, + txsyph_asympt_tert, + txsyph_sympt_tert))] == 2 | + tt.traj.syph.hivpos[unique(c(txsyph_asympt_latelat, + txsyph_asympt_tert, + txsyph_sympt_tert))] == 2)) + + dat$epi$txSTI_asympt.tttraj1[at] <- dat$epi$txGC_asympt.tttraj1[at] + + dat$epi$txCT_asympt.tttraj1[at] + + dat$epi$txsyph_asympt.tttraj1[at] + + dat$epi$txSTI_asympt.tttraj2[at] <- dat$epi$txGC_asympt.tttraj2[at] + + dat$epi$txCT_asympt.tttraj2[at] + + dat$epi$txsyph_asympt.tttraj2[at] + + dat$epi$txSTI.tttraj1[at] <- dat$epi$txGC.tttraj1[at] + + dat$epi$txCT.tttraj1[at] + + dat$epi$txsyph.tttraj1[at] + + dat$epi$txSTI.tttraj2[at] <- dat$epi$txGC.tttraj2[at] + + dat$epi$txCT.tttraj2[at] + + dat$epi$txsyph.tttraj2[at] + + dat$epi$rGCsympttests.tttraj1[at] <- length(which(tt.traj.gc.hivpos[unique(txRGC_sympt)] == 1)) + + length(which(tt.traj.gc.hivneg[unique(txRGC_sympt)] == 1)) + dat$epi$uGCsympttests.tttraj1[at] <- length(which(tt.traj.gc.hivpos[unique(txUGC_sympt)] == 1)) + + length(which(tt.traj.gc.hivneg[unique(txUGC_sympt)] == 1)) + dat$epi$GCsympttests.tttraj1[at] <- length(which(tt.traj.gc.hivpos[unique(txRGC_sympt)] == 1)) + + length(which(tt.traj.gc.hivneg[unique(txRGC_sympt)] == 1)) + + length(which(tt.traj.gc.hivpos[unique(txUGC_sympt)] == 1)) + + length(which(tt.traj.gc.hivneg[unique(txUGC_sympt)] == 1)) + + dat$epi$rGCsympttests.tttraj2[at] <- length(which(tt.traj.gc.hivpos[unique(txRGC_sympt)] == 2)) + + length(which(tt.traj.gc.hivneg[unique(txRGC_sympt)] == 2)) + dat$epi$uGCsympttests.tttraj2[at] <- length(which(tt.traj.gc.hivpos[unique(txUGC_sympt)] == 2)) + + length(which(tt.traj.gc.hivneg[unique(txUGC_sympt)] == 2)) + dat$epi$GCsympttests.tttraj2[at] <- length(which(tt.traj.gc.hivpos[unique(txRGC_sympt)] == 2)) + + length(which(tt.traj.gc.hivneg[unique(txRGC_sympt)] == 2)) + + length(which(tt.traj.gc.hivpos[unique(txUGC_sympt)] == 2)) + + length(which(tt.traj.gc.hivneg[unique(txUGC_sympt)] == 2)) + + dat$epi$rCTsympttests.tttraj1[at] <- length(which(tt.traj.ct.hivpos[unique(txRCT_sympt)] == 1)) + + length(which(tt.traj.ct.hivneg[unique(txRCT_sympt)] == 1)) + dat$epi$uCTsympttests.tttraj1[at] <- length(which(tt.traj.ct.hivpos[unique(txUCT_sympt)] == 1)) + + length(which(tt.traj.ct.hivneg[unique(txUCT_sympt)] == 1)) + dat$epi$CTsympttests.tttraj1[at] <- length(which(tt.traj.ct.hivpos[unique(txRCT_sympt)] == 1)) + + length(which(tt.traj.ct.hivneg[unique(txRCT_sympt)] == 1)) + + length(which(tt.traj.ct.hivpos[unique(txUCT_sympt)] == 1)) + + length(which(tt.traj.ct.hivneg[unique(txUCT_sympt)] == 1)) + + dat$epi$rCTsympttests.tttraj2[at] <- length(which(tt.traj.ct.hivpos[unique(txRCT_sympt)] == 2)) + + length(which(tt.traj.ct.hivneg[unique(txRCT_sympt)] == 2)) + dat$epi$uCTsympttests.tttraj2[at] <- length(which(tt.traj.ct.hivpos[unique(txUCT_sympt)] == 2)) + + length(which(tt.traj.ct.hivneg[unique(txUCT_sympt)] == 2)) + dat$epi$CTsympttests.tttraj2[at] <- length(which(tt.traj.ct.hivpos[unique(txRCT_sympt)] == 2)) + + length(which(tt.traj.ct.hivneg[unique(txRCT_sympt)] == 2)) + + length(which(tt.traj.ct.hivpos[unique(txUCT_sympt)] == 2)) + + length(which(tt.traj.ct.hivneg[unique(txUCT_sympt)] == 2)) + + dat$epi$syphsympttests.tttraj1[at] <- length(which(tt.traj.syph.hivpos[unique(txsyph_sympt)] == 1)) + + length(which(tt.traj.syph.hivneg[unique(txsyph_sympt)] == 1)) + + dat$epi$syphsympttests.tttraj2[at] <- length(which(tt.traj.syph.hivpos[unique(txsyph_sympt)] == 2)) + + length(which(tt.traj.syph.hivneg[unique(txsyph_sympt)] == 2)) + + dat$epi$stisympttests.tttraj1[at] <- length(which(tt.traj.gc.hivpos[unique(txRGC_sympt)] == 1)) + + length(which(tt.traj.gc.hivneg[unique(txRGC_sympt)] == 1)) + + length(which(tt.traj.gc.hivpos[unique(txUGC_sympt)] == 1)) + + length(which(tt.traj.gc.hivneg[unique(txUGC_sympt)] == 1)) + + length(which(tt.traj.ct.hivpos[unique(txRCT_sympt)] == 1)) + + length(which(tt.traj.ct.hivneg[unique(txRCT_sympt)] == 1)) + + length(which(tt.traj.ct.hivpos[unique(txUCT_sympt)] == 1)) + + length(which(tt.traj.ct.hivneg[unique(txUCT_sympt)] == 1)) + + length(which(tt.traj.syph.hivpos[unique(txsyph_sympt)] == 1)) + + length(which(tt.traj.syph.hivneg[unique(txsyph_sympt)] == 1)) + + dat$epi$stisympttests.tttraj2[at] <- length(which(tt.traj.gc.hivpos[unique(txRGC_sympt)] == 2)) + + length(which(tt.traj.gc.hivneg[unique(txRGC_sympt)] == 2)) + + length(which(tt.traj.gc.hivpos[unique(txUGC_sympt)] == 2)) + + length(which(tt.traj.gc.hivneg[unique(txUGC_sympt)] == 2)) + + length(which(tt.traj.ct.hivpos[unique(txRCT_sympt)] == 2)) + + length(which(tt.traj.ct.hivneg[unique(txRCT_sympt)] == 2)) + + length(which(tt.traj.ct.hivpos[unique(txUCT_sympt)] == 2)) + + length(which(tt.traj.ct.hivneg[unique(txUCT_sympt)] == 2)) + + length(which(tt.traj.syph.hivpos[unique(txsyph_sympt)] == 2)) + + length(which(tt.traj.syph.hivneg[unique(txsyph_sympt)] == 2)) + + # Number of testing events + # dat$epi$testing.events.syph <- rep(0, num) + # dat$epi$testing.events.syph.asympt <- rep(0, num) + # dat$epi$testing.events.rgc <- rep(0, num) + # dat$epi$testing.events.rgc.asympt <- rep(0, num) + # dat$epi$testing.events.ugc <- rep(0, num) + # dat$epi$testing.events.ugc.asympt <- rep(0, num) + # dat$epi$testing.events.gc <- rep(0, num) + # dat$epi$testing.events.gc.asympt <- rep(0, num) + # dat$epi$testing.events.sti <- rep(0, num) + # dat$epi$testing.events.sti.asympt <- rep(0, num) + # dat$epi$testing.events.rct <- rep(0, num) + # dat$epi$testing.events.rct.asympt <- rep(0, num) + # dat$epi$testing.events.uct <- rep(0, num) + # dat$epi$testing.events.uct.asympt <- rep(0, num) + # dat$epi$testing.events.ct <- rep(0, num) + # dat$epi$testing.events.ct.asympt <- rep(0, num) + + + # EPT + # Number of index provided with EPT + dat$epi$eptindexprovided_gc[at] <- length(index_gc) + dat$epi$eptindexprovided_ct[at] <- length(index_ct) + + # Proportion of treated GC/CT index who have current partners - e.g. eligibility for EPT + dat$epi$propindexeptElig[at] <- ifelse(length(unique(c(txRGC_all, txUGC_all, txRCT_all, txUCT_all))) > 0, + length(unique(ept_tx_all)) / + length(unique(c(txRGC_all, txUGC_all, txRCT_all, txUCT_all))), + NA) + + # Proportion of eligible index who will receive EPT - varies by sim scenario + dat$epi$eptCov[at] <- eptCov + + # Number of non-index treated due to EPT - mix of provision, uptake, tx success + dat$epi$eptTx[at] <- length(unique(alltxEPT)) + + # Proportion of all non-index eligible to be treated who had treatment success + # dat$epi$eptprop_tx[at] <- ifelse(length(unique(allidsept)) > 0, + # length(unique(alltxEPT)) / length(unique(allidsept)), + # 0) + return(dat) } diff --git a/R/mod.test.R b/R/mod.test.R index 9567cb68..5b66eee0 100644 --- a/R/mod.test.R +++ b/R/mod.test.R @@ -8,28 +8,28 @@ #' @details #' This testing module supports two testing parameterizations, input via the #' \code{testing.pattern} parameter: memoryless for stochastic and -#' geometrically-distributed waiting times to test (constant hazard); and interval -#' for deterministic tested after defined waiting time intervals. +#' geometrically-distributed waiting times to test (constant hazard); and +#' interval for deterministic tested after defined waiting time intervals. #' #' @return -#' This function returns the \code{dat} object with updated \code{last.neg.test}, -#' \code{diag.status} and \code{diag.time} attributes. +#' This function returns the \code{dat} object with updated +#' \code{last.neg.test}, \code{diag.status} and \code{diag.time} attributes. #' #' @keywords module msm #' #' @export #' -test_msm <- function(dat, at) { +hiv_test_msm <- function(dat, at) { ## Variables # Attributes diag.status <- dat$attr$diag.status + role.class <- dat$attr$role.class race <- dat$attr$race tt.traj <- dat$attr$tt.traj status <- dat$attr$status inf.time <- dat$attr$inf.time - prepStat <- dat$attr$prepStat prep.tst.int <- dat$param$prep.tst.int @@ -46,16 +46,16 @@ test_msm <- function(dat, at) { if (testing.pattern == "memoryless") { elig.B <- which(race == "B" & - tt.traj != 1 & - (diag.status == 0 | is.na(diag.status)) & - prepStat == 0) + tt.traj != 1 & + (diag.status == 0 | is.na(diag.status)) & + prepStat == 0) rates.B <- rep(1/mean.test.B.int, length(elig.B)) tst.B <- elig.B[rbinom(length(elig.B), 1, rates.B) == 1] elig.W <- which(race == "W" & - tt.traj != 1 & - (diag.status == 0 | is.na(diag.status)) & - prepStat == 0) + tt.traj != 1 & + (diag.status == 0 | is.na(diag.status)) & + prepStat == 0) rates.W <- rep(1/mean.test.W.int, length(elig.W)) tst.W <- elig.W[rbinom(length(elig.W), 1, rates.W) == 1] tst.nprep <- c(tst.B, tst.W) @@ -63,40 +63,749 @@ test_msm <- function(dat, at) { if (testing.pattern == "interval") { tst.B <- which(race == "B" & - tt.traj != 1 & - (diag.status == 0 | is.na(diag.status)) & - tsincelntst >= 2*(mean.test.B.int) & - prepStat == 0) + tt.traj != 1 & + (diag.status == 0 | is.na(diag.status)) & + tsincelntst >= 2*(mean.test.B.int) & + prepStat == 0) tst.W <- which(race == "W" & - tt.traj != 1 & - (diag.status == 0 | is.na(diag.status)) & - tsincelntst >= 2*(mean.test.W.int) & - prepStat == 0) + tt.traj != 1 & + (diag.status == 0 | is.na(diag.status)) & + tsincelntst >= 2*(mean.test.W.int) & + prepStat == 0) tst.nprep <- c(tst.B, tst.W) } # PrEP testing tst.prep <- which((diag.status == 0 | is.na(diag.status)) & - prepStat == 1 & - tsincelntst >= prep.tst.int) + prepStat == 1 & + tsincelntst >= prep.tst.int) tst.all <- c(tst.nprep, tst.prep) tst.pos <- tst.all[status[tst.all] == 1 & inf.time[tst.all] <= at - twind.int] tst.neg <- setdiff(tst.all, tst.pos) + # Assign new STI treatment trajectory (HIV-pos) for diagnosed who will be on ART + tt.traj.new <- tst.pos[which(tt.traj[tst.pos] %in% c(3,4))] + # Attributes dat$attr$last.neg.test[tst.neg] <- at dat$attr$diag.status[tst.pos] <- 1 + dat$attr$tt.traj.syph.hivneg[tt.traj.new] <- NA + dat$attr$tt.traj.gc.hivneg[tt.traj.new] <- NA + dat$attr$tt.traj.ct.hivneg[tt.traj.new] <- NA dat$attr$diag.time[tst.pos] <- at + # Tests + dat$epi$hivtests.prep[at] <- length(tst.prep) + dat$epi$hivtests.nprep[at] <- length(tst.nprep) + dat$epi$hivtests.pos[at] <- length(tst.pos) + return(dat) } +#' @title STI Testing Module +#' +#' @description Module function for STI screening of asymptomatic persons. +#' +#' @inheritParams aging_msm +#' +#' @details +#' This testing module supports two testing parameterizations, input via the +#' \code{testing.pattern} parameter: memoryless for stochastic and +#' geometrically-distributed waiting times to test (constant hazard); and +#' interval for deterministic tested after defined waiting time intervals. +#' Symptomatic testing is handled in the STI treatment module. +#' +#' @return +#' This function returns the \code{dat} object with updated +#' \code{last.neg.test}, \code{diag.status} and \code{diag.time} attributes for +#' each STI. +#' +#' @keywords module msm +#' #' @export -#' @rdname test_msm +#' +sti_test_msm <- function(dat, at) { + + # 1. Setup ---------------------------------------------------------------- + + # Attributes + tt.traj <- dat$attr$tt.traj + tt.traj.syph.hivpos <- dat$attr$tt.traj.syph.hivpos + tt.traj.syph.hivneg <- dat$attr$tt.traj.syph.hivneg + tt.traj.gc.hivpos <- dat$attr$tt.traj.gc.hivpos + tt.traj.gc.hivneg <- dat$attr$tt.traj.gc.hivneg + tt.traj.ct.hivpos <- dat$attr$tt.traj.ct.hivpos + tt.traj.ct.hivneg <- dat$attr$tt.traj.ct.hivneg + diag.status.gc <- dat$attr$diag.status.gc + diag.status.ct <- dat$attr$diag.status.ct + diag.status.syph <- dat$attr$diag.status.syph + diag.status <- dat$attr$diag.status + syphilis <- dat$attr$syphilis + rGC <- dat$attr$rGC + uGC <- dat$attr$uGC + rCT <- dat$attr$rCT + uCT <- dat$attr$uCT + stage.syph <- dat$attr$stage.syph + role.class <- dat$attr$role.class + last.neg.test.rgc <- dat$attr$last.neg.test.rgc + last.neg.test.ugc <- dat$attr$last.neg.test.ugc + last.neg.test.rct <- dat$attr$last.neg.test.rct + last.neg.test.uct <- dat$attr$last.neg.test.uct + last.neg.test.syph <- dat$attr$last.neg.test.syph + last.diag.time.gc <- dat$attr$last.diag.time.gc + last.diag.time.ct <- dat$attr$last.diag.time.ct + last.diag.time.syph <- dat$attr$last.diag.time.syph + + tsinceltst.syph <- dat$attr$time.since.last.test.syph + 1 + tsinceltst.rgc <- dat$attr$time.since.last.test.rgc + 1 + tsinceltst.ugc <- dat$attr$time.since.last.test.ugc + 1 + tsinceltst.rct <- dat$attr$time.since.last.test.rct + 1 + tsinceltst.uct <- dat$attr$time.since.last.test.uct + 1 + tsinceltst.gc <- pmin(tsinceltst.rgc, tsinceltst.ugc) + tsinceltst.ct <- pmin(tsinceltst.rct, tsinceltst.uct) + + prepStat <- dat$attr$prepStat + stitestind1 <- dat$attr$stitest.ind.active + stitestind2 <- dat$attr$stitest.ind.recentpartners + + # Parameters + stianntest.ct.hivneg.coverage <- dat$param$stianntest.ct.hivneg.coverage + stianntest.syph.hivneg.coverage <- dat$param$stianntest.syph.hivneg.coverage + stihighrisktest.ct.hivneg.coverage <- dat$param$stihighrisktest.ct.hivneg.coverage + stihighrisktest.syph.hivneg.coverage <- dat$param$stihighrisktest.syph.hivneg.coverage + + stianntest.ct.hivpos.coverage <- dat$param$stianntest.ct.hivpos.coverage + stianntest.syph.hivpos.coverage <- dat$param$stianntest.syph.hivpos.coverage + stihighrisktest.ct.hivpos.coverage <- dat$param$stihighrisktest.ct.hivpos.coverage + stihighrisktest.syph.hivpos.coverage <- dat$param$stihighrisktest.syph.hivpos.coverage + + testing.pattern.sti <- dat$param$testing.pattern.sti + stitest.active.int <- dat$param$stitest.active.int + sti.highrisktest.int <- dat$param$sti.highrisktest.int + tst.rect.sti.rr <- dat$param$tst.rect.sti.rr + + # Eligibility and trajectory + # Annual indications- sexually active in last year + idsactive.hivpos <- which(stitestind1 == 1 & diag.status == 1 & tt.traj %in% 3:4) + idsactive.hivneg <- setdiff((which(stitestind1 == 1)), idsactive.hivpos) + + # STI testing higher-risk eligibility scenarios + idshighrisk.hivpos <- which(stitestind2 == 1 & diag.status == 1 & tt.traj %in% 3:4) + idshighrisk.hivneg <- setdiff((which(stitestind2 == 1)), idshighrisk.hivpos) + + + # 2. Indication Trajectory Stoppage --------------------------------------- + + # Reduce testing trajectory to NA if no longer indicated for more frequent high-risk testing + idsnothighriskelig.hivpos <- which((tt.traj.syph.hivpos == 2 | + tt.traj.gc.hivpos == 2 | + tt.traj.ct.hivpos == 2) & stitestind2 != 1) + tt.traj.syph.hivpos[idsnothighriskelig.hivpos] <- + tt.traj.gc.hivpos[idsnothighriskelig.hivpos] <- + tt.traj.ct.hivpos[idsnothighriskelig.hivpos] <- + NA + idsnothighriskelig.hivneg <- which((tt.traj.syph.hivneg == 2 | + tt.traj.gc.hivneg == 2 | + tt.traj.ct.hivneg == 2) & stitestind2 != 1) + tt.traj.syph.hivneg[idsnothighriskelig.hivneg] <- + tt.traj.gc.hivneg[idsnothighriskelig.hivneg] <- + tt.traj.ct.hivneg[idsnothighriskelig.hivneg] <- + NA + + # Reduce testing trajectory to NA if no longer indicated for lower-risk testing + idsnotactiveelig.hivpos <- which((tt.traj.syph.hivpos == 1 | + tt.traj.gc.hivpos == 1 | + tt.traj.ct.hivpos == 1) & stitestind1 != 1) + tt.traj.syph.hivpos[idsnotactiveelig.hivpos] <- + tt.traj.gc.hivpos[idsnotactiveelig.hivpos] <- + tt.traj.ct.hivpos[idsnotactiveelig.hivpos] <- + NA + idsnotactiveelig.hivneg <- which((tt.traj.syph.hivneg == 1 | + tt.traj.gc.hivneg == 1 | + tt.traj.ct.hivneg == 1) & stitestind1 != 1) + tt.traj.syph.hivneg[idsnotactiveelig.hivneg] <- + tt.traj.gc.hivneg[idsnotactiveelig.hivneg] <- + tt.traj.ct.hivneg[idsnotactiveelig.hivneg] <- + NA + + + + # 3. Screening for non-HIV Diagnosed -------------------------------------- + + ## 3a. High-Risk Testing ## + + ## Assume coverage and people are same for NG and CT - correlation + idsEligSt <- idshighrisk.hivneg + nEligSt <- length(idshighrisk.hivneg) + + ## Evaluate existing coverage + stihighrisktestCov.ct <- sum(tt.traj.ct.hivneg == 2, na.rm = TRUE) / nEligSt + stihighrisktestCov.ct <- ifelse(is.nan(stihighrisktestCov.ct), 0, stihighrisktestCov.ct) + stihighrisktestCov.gc <- sum(tt.traj.gc.hivneg == 2, na.rm = TRUE) / nEligSt + stihighrisktestCov.gc <- ifelse(is.nan(stihighrisktestCov.gc), 0, stihighrisktestCov.gc) + stihighrisktestCov.syph <- sum(tt.traj.syph.hivneg == 2, na.rm = TRUE) / nEligSt + stihighrisktestCov.syph <- ifelse(is.nan(stihighrisktestCov.syph), 0, stihighrisktestCov.syph) + + ## Count how many are eligible to start a new trajectory + nStart.gcct <- max(0, min(nEligSt, round((stihighrisktest.ct.hivneg.coverage - stihighrisktestCov.ct) * + length(idsEligSt)))) + nStart.syph <- max(0, min(nEligSt, round((stihighrisktest.syph.hivneg.coverage - stihighrisktestCov.syph) * + length(idsEligSt)))) + + ## Sample individuals + idsStart.gcct <- idsStart.syph <- NULL + if (nStart.gcct > 0) { + idsStart.gcct <- ssample(idsEligSt, nStart.gcct) + } + if (nStart.syph > 0) { + idsStart.syph <- ssample(idsEligSt, nStart.syph) + } + + ## Update testing trajectory for higher-risk + if (length(idsStart.gcct) > 0) { + tt.traj.gc.hivneg[idsStart.gcct] <- 2 + tt.traj.ct.hivneg[idsStart.gcct] <- 2 + } + if (length(idsStart.syph) > 0) { + tt.traj.syph.hivneg[idsStart.syph] <- 2 + } + + ## 3b. Sexually Active (non-HR) Testing ## + + ## Assume coverage and people are same for NG and CT - correlation + idsEligSt.gcct <- setdiff(idsactive.hivneg, which(tt.traj.ct.hivneg == 2)) + idsEligSt.syph <- setdiff(idsactive.hivneg, which(tt.traj.syph.hivneg == 2)) + nEligSt.gcct <- length(idsEligSt.gcct) + nEligSt.syph <- length(idsEligSt.syph) + + ## Evaluate existing coverage + stianntestCov.ct <- sum(tt.traj.ct.hivneg == 1, na.rm = TRUE) / nEligSt.gcct + stianntestCov.ct <- ifelse(is.nan(stianntestCov.ct), 0, stianntestCov.ct) + stianntestCov.gc <- sum(tt.traj.gc.hivneg == 1, na.rm = TRUE) / nEligSt.gcct + stianntestCov.gc <- ifelse(is.nan(stianntestCov.gc), 0, stianntestCov.gc) + stianntestCov.syph <- sum(tt.traj.syph.hivneg == 1, na.rm = TRUE) / nEligSt.syph + stianntestCov.syph <- ifelse(is.nan(stianntestCov.syph), 0, stianntestCov.syph) + + ## Count how many are eligible to start a new trajectory + nStart.gcct <- max(0, min(nEligSt.gcct, + round((stianntest.ct.hivneg.coverage - stianntestCov.ct) * nEligSt.gcct))) + nStart.syph <- max(0, min(nEligSt.syph, + round((stianntest.syph.hivneg.coverage - stianntestCov.syph) * nEligSt.syph))) + + ## Sample individuals + idsStart.gcct <- idsStart.syph <- NULL + if (nStart.gcct > 0) { + idsStart.gcct <- ssample(idsEligSt.gcct, nStart.gcct) + } + if (nStart.syph > 0) { + idsStart.syph <- ssample(idsEligSt.syph, nStart.syph) + } + + ## Update testing trajectory for lower-risk + if (length(idsStart.gcct) > 0) { + tt.traj.ct.hivneg[idsStart.gcct] <- 1 + tt.traj.gc.hivneg[idsStart.gcct] <- 1 + } + if (length(idsStart.syph) > 0) { + tt.traj.syph.hivneg[idsStart.syph] <- 1 + } + + + ## 3c. Asymptomatic Screening ## + + # Syphilis + if (testing.pattern.sti == "interval" ) { + tst.syph.annual.interval <- which(tt.traj.syph.hivneg == 1 & + (diag.status.syph == 0 | is.na(diag.status.syph)) & + (tsinceltst.syph >= stitest.active.int) & + prepStat == 0) + tst.syph.highrisk.interval <- which(tt.traj.syph.hivneg == 2 & + (diag.status.syph == 0 | is.na(diag.status.syph)) & + (tsinceltst.syph >= sti.highrisktest.int) & + prepStat == 0) + tst.syph.nprep.hivneg <- c(tst.syph.annual.interval, tst.syph.highrisk.interval) + } + + # GC + if (testing.pattern.sti == "interval" ) { + tst.gc.annual.interval <- which(tt.traj.gc.hivneg == 1 & + (diag.status.gc == 0 | is.na(diag.status.gc)) & + (tsinceltst.gc >= stitest.active.int | + tsinceltst.ct >= stitest.active.int) & + prepStat == 0) + tst.gc.highrisk.interval <- which(tt.traj.gc.hivneg == 2 & + (diag.status.gc == 0 | is.na(diag.status.gc)) & + (tsinceltst.gc >= sti.highrisktest.int | + tsinceltst.ct >= sti.highrisktest.int) & + prepStat == 0) + tst.gc.nprep.hivneg <- c(tst.gc.annual.interval, tst.gc.highrisk.interval) + } + + # CT + if (testing.pattern.sti == "interval" ) { + tst.ct.annual.interval <- which(tt.traj.ct.hivneg == 1 & + (diag.status.ct == 0 | is.na(diag.status.ct)) & + (tsinceltst.gc >= stitest.active.int | + tsinceltst.ct >= stitest.active.int) & + prepStat == 0) + tst.ct.highrisk.interval <- which(tt.traj.ct.hivneg == 2 & + (diag.status.ct == 0 | is.na(diag.status.ct)) & + (tsinceltst.gc >= sti.highrisktest.int | + tsinceltst.ct >= sti.highrisktest.int) & + prepStat == 0) + tst.ct.nprep.hivneg <- c(tst.ct.annual.interval, tst.ct.highrisk.interval) + } + + # Syphilis non-PrEP testing + tst.syph.pos.hivneg <- tst.syph.nprep.hivneg[which(syphilis[tst.syph.nprep.hivneg] == 1 & + stage.syph[tst.syph.nprep.hivneg] %in% 2:6)] + tst.syph.neg.hivneg <- setdiff(tst.syph.nprep.hivneg, tst.syph.pos.hivneg) + tst.earlysyph.pos.hivneg <- tst.syph.nprep.hivneg[which(syphilis[tst.syph.nprep.hivneg] == 1 & + stage.syph[tst.syph.nprep.hivneg] %in% 2:3)] + tst.latesyph.pos.hivneg <- tst.syph.nprep.hivneg[which(syphilis[tst.syph.nprep.hivneg] == 1 & + stage.syph[tst.syph.nprep.hivneg] %in% 4:6)] + + # GC non-PrEP testing + tst.rgc.hivneg <- tst.gc.nprep.hivneg[which(role.class[tst.gc.nprep.hivneg] %in% c("R", "V"))] + tst.rgc.hivneg <- sample(tst.rgc.hivneg, tst.rect.sti.rr * length(tst.rgc.hivneg)) + tst.ugc.hivneg <- tst.gc.nprep.hivneg[which(role.class[tst.gc.nprep.hivneg] %in% c("I", "V"))] + tst.rgc.pos.hivneg <- tst.rgc.hivneg[which(rGC[tst.rgc.hivneg] == 1)] + tst.ugc.pos.hivneg <- tst.ugc.hivneg[which(uGC[tst.ugc.hivneg] == 1)] + tst.rgc.neg.hivneg <- setdiff(tst.rgc.hivneg, tst.rgc.pos.hivneg) + tst.ugc.neg.hivneg <- setdiff(tst.ugc.hivneg, tst.ugc.pos.hivneg) + tst.gc.pos.hivneg <- unique(c(tst.rgc.pos.hivneg, tst.ugc.pos.hivneg)) + + # CT non-PrEP testing + tst.rct.hivneg <- tst.ct.nprep.hivneg[which(role.class[tst.ct.nprep.hivneg] %in% c("R", "V"))] + tst.rct.hivneg <- sample(tst.rct.hivneg, tst.rect.sti.rr * length(tst.rct.hivneg)) + tst.uct.hivneg <- tst.ct.nprep.hivneg[which(role.class[tst.ct.nprep.hivneg] %in% c("I", "V"))] + tst.rct.pos.hivneg <- tst.rct.hivneg[which(rCT[tst.rct.hivneg] == 1)] + tst.uct.pos.hivneg <- tst.uct.hivneg[which(uCT[tst.uct.hivneg] == 1)] + tst.rct.neg.hivneg <- setdiff(tst.rct.hivneg, tst.rct.pos.hivneg) + tst.uct.neg.hivneg <- setdiff(tst.uct.hivneg, tst.uct.pos.hivneg) + tst.ct.pos.hivneg <- unique(c(tst.rct.pos.hivneg, tst.uct.pos.hivneg)) + + # Syphilis Attributes + last.neg.test.syph[tst.syph.neg.hivneg] <- at + last.neg.test.syph[tst.syph.pos.hivneg] <- NA + diag.status.syph[tst.syph.pos.hivneg] <- 1 + last.diag.time.syph[tst.syph.pos.hivneg] <- at + tsinceltst.syph[tst.syph.nprep.hivneg] <- 0 + + # GC Attributes + last.neg.test.rgc[tst.rgc.neg.hivneg] <- at + last.neg.test.ugc[tst.ugc.neg.hivneg] <- at + last.neg.test.rgc[tst.rgc.pos.hivneg] <- NA + last.neg.test.ugc[tst.ugc.pos.hivneg] <- NA + diag.status.gc[tst.gc.pos.hivneg] <- 1 + last.diag.time.gc[tst.gc.pos.hivneg] <- at + tsinceltst.rgc[tst.rgc.hivneg] <- 0 + tsinceltst.ugc[tst.ugc.hivneg] <- 0 + + # CT Attributes + last.neg.test.rct[tst.rct.neg.hivneg] <- at + last.neg.test.uct[tst.uct.neg.hivneg] <- at + last.neg.test.rct[tst.rct.pos.hivneg] <- NA + last.neg.test.uct[tst.uct.pos.hivneg] <- NA + diag.status.ct[tst.ct.pos.hivneg] <- 1 + last.diag.time.ct[tst.ct.pos.hivneg] <- at + tsinceltst.rct[tst.rct.hivneg] <- 0 + tsinceltst.uct[tst.uct.hivneg] <- 0 + + + # 4. Screening for HIV-Diagnosed ------------------------------------------ + + ## 4a. High-Risk Testing ## + + ## Assume coverage and people are same for NG and CT - correlation + idsEligSt <- idshighrisk.hivpos + nEligSt <- length(idshighrisk.hivpos) + + ## Evaluate existing coverage + stihighrisktestCov.ct <- sum(tt.traj.ct.hivpos == 2, na.rm = TRUE) / nEligSt + stihighrisktestCov.ct <- ifelse(is.nan(stihighrisktestCov.ct), 0, stihighrisktestCov.ct) + stihighrisktestCov.gc <- sum(tt.traj.gc.hivpos == 2, na.rm = TRUE) / nEligSt + stihighrisktestCov.gc <- ifelse(is.nan(stihighrisktestCov.gc), 0, stihighrisktestCov.gc) + stihighrisktestCov.syph <- sum(tt.traj.syph.hivpos == 2, na.rm = TRUE) / nEligSt + stihighrisktestCov.syph <- ifelse(is.nan(stihighrisktestCov.syph), 0, stihighrisktestCov.syph) + + ## Count how many are eligible to start a new trajectory + nStart.gcct <- max(0, min(nEligSt, round((stihighrisktest.ct.hivpos.coverage - stihighrisktestCov.ct) * + length(idshighrisk.hivpos)))) + nStart.syph <- max(0, min(nEligSt, round((stihighrisktest.syph.hivpos.coverage - stihighrisktestCov.syph) * + length(idshighrisk.hivpos)))) + + ## Sample individuals + idsStart.gcct <- idsStart.syph <- NULL + if (nStart.gcct > 0) { + idsStart.gcct <- ssample(idsEligSt, nStart.gcct) + } + if (nStart.syph > 0) { + idsStart.syph <- ssample(idsEligSt, nStart.syph) + } + + ## Update testing trajectory for higher-risk + if (length(idsStart.gcct) > 0) { + tt.traj.ct.hivpos[idsStart.gcct] <- 2 + tt.traj.gc.hivpos[idsStart.gcct] <- 2 + } + if (length(idsStart.syph) > 0) { + tt.traj.syph.hivpos[idsStart.syph] <- 2 + } + + ## 4b. Sexually Active (non-HR) Testing ## + + ## Assume coverage and people are same for NG and CT - correlation + idsEligSt.gcct <- setdiff(idsactive.hivpos, which(tt.traj.ct.hivpos == 2)) + idsEligSt.syph <- setdiff(idsactive.hivpos, which(tt.traj.syph.hivpos == 2)) + nEligSt.gcct <- length(idsEligSt.gcct) + nEligSt.syph <- length(idsEligSt.syph) + + ## Evaluate existing coverage + stianntestCov.ct <- sum(tt.traj.ct.hivpos == 1, na.rm = TRUE) / nEligSt.gcct + stianntestCov.ct <- ifelse(is.nan(stianntestCov.ct), 0, stianntestCov.ct) + stianntestCov.gc <- sum(tt.traj.gc.hivpos == 1, na.rm = TRUE) / nEligSt.gcct + stianntestCov.gc <- ifelse(is.nan(stianntestCov.gc), 0, stianntestCov.gc) + stianntestCov.syph <- sum(tt.traj.syph.hivpos == 1, na.rm = TRUE) / nEligSt.syph + stianntestCov.syph <- ifelse(is.nan(stianntestCov.syph), 0, stianntestCov.syph) + + ## Count how many are eligible to start a new trajectory + nStart.gcct <- max(0, min(nEligSt.gcct, + round((stianntest.ct.hivpos.coverage - stianntestCov.ct) * nEligSt.gcct))) + nStart.syph <- max(0, min(nEligSt.syph, + round((stianntest.syph.hivpos.coverage - stianntestCov.syph) * nEligSt.syph))) + + ## Sample individuals + idsStart.gcct <- idsStart.syph <- NULL + if (nStart.gcct > 0) { + idsStart.gcct <- ssample(idsEligSt.gcct, nStart.gcct) + } + if (nStart.syph > 0) { + idsStart.syph <- ssample(idsEligSt.syph, nStart.syph) + } + + ## Update testing trajectory for lower-risk + if (length(idsStart.gcct) > 0) { + tt.traj.ct.hivpos[idsStart.gcct] <- 1 + tt.traj.gc.hivpos[idsStart.gcct] <- 1 + } + if (length(idsStart.syph) > 0) { + tt.traj.syph.hivpos[idsStart.syph] <- 1 + } + + ## 4c. Asymptomatic screening ## + + ## Syphilis + if (testing.pattern.sti == "interval" ) { + tst.syph.annual.interval <- which((tt.traj.syph.hivpos == 1 & + (diag.status.syph == 0 | is.na(diag.status.syph)) & + (tsinceltst.syph >= stitest.active.int) & + prepStat == 0)) + tst.syph.highrisk.interval <- which((tt.traj.syph.hivpos == 2 & + (diag.status.syph == 0 | is.na(diag.status.syph)) & + (tsinceltst.syph >= sti.highrisktest.int) & + prepStat == 0)) + tst.syph.nprep.hivpos <- c(tst.syph.annual.interval, tst.syph.highrisk.interval) + } + + ## GC + if (testing.pattern.sti == "interval" ) { + tst.gc.annual.interval <- which((tt.traj.gc.hivpos == 1 & + (diag.status.gc == 0 | is.na(diag.status.gc)) & + (tsinceltst.gc >= stitest.active.int | + tsinceltst.ct >= stitest.active.int) & + prepStat == 0)) + tst.gc.highrisk.interval <- which((tt.traj.gc.hivpos == 2 & + (diag.status.gc == 0 | is.na(diag.status.gc)) & + (tsinceltst.gc >= sti.highrisktest.int | + tsinceltst.ct >= sti.highrisktest.int) & + prepStat == 0)) + tst.gc.nprep.hivpos <- c(tst.gc.annual.interval, tst.gc.highrisk.interval) + } + + ## CT + if (testing.pattern.sti == "interval" ) { + tst.ct.annual.interval <- which((tt.traj.ct.hivpos == 1 & + (diag.status.ct == 0 | is.na(diag.status.ct)) & + (tsinceltst.gc >= stitest.active.int | + tsinceltst.ct >= stitest.active.int) & + prepStat == 0)) + tst.ct.highrisk.interval <- which((tt.traj.ct.hivpos == 2 & + (diag.status.ct == 0 | is.na(diag.status.ct)) & + (tsinceltst.gc >= sti.highrisktest.int | + tsinceltst.ct >= sti.highrisktest.int) & + prepStat == 0)) + tst.ct.nprep.hivpos <- c(tst.ct.annual.interval, tst.ct.highrisk.interval) + } + + # Syphilis non-PrEP testing + tst.syph.pos.hivpos <- tst.syph.nprep.hivpos[which(syphilis[tst.syph.nprep.hivpos] == 1 & + stage.syph[tst.syph.nprep.hivpos] %in% c(2, 3, 4, 5, 6))] + tst.syph.neg.hivpos <- setdiff(tst.syph.nprep.hivpos, tst.syph.pos.hivpos) + tst.earlysyph.pos.hivpos <- tst.syph.nprep.hivpos[which(syphilis[tst.syph.nprep.hivpos] == 1 & + stage.syph[tst.syph.nprep.hivpos] %in% c(2, 3))] + tst.latesyph.pos.hivpos <- tst.syph.nprep.hivpos[which(syphilis[tst.syph.nprep.hivpos] == 1 & + stage.syph[tst.syph.nprep.hivpos] %in% c(4, 5, 6))] + + # GC non-PrEP testing + tst.rgc.hivpos <- tst.gc.nprep.hivpos[which(role.class[tst.gc.nprep.hivpos] %in% c("R", "V"))] + tst.rgc.hivpos <- sample(tst.rgc.hivpos, tst.rect.sti.rr * length(tst.rgc.hivpos)) + tst.ugc.hivpos <- tst.gc.nprep.hivpos[which(role.class[tst.gc.nprep.hivpos] %in% c("I", "V"))] + tst.rgc.pos.hivpos <- tst.rgc.hivpos[which(rGC[tst.rgc.hivpos] == 1)] + tst.ugc.pos.hivpos <- tst.ugc.hivpos[which(uGC[tst.ugc.hivpos] == 1)] + tst.rgc.neg.hivpos <- setdiff(tst.rgc.hivpos, tst.rgc.pos.hivpos) + tst.ugc.neg.hivpos <- setdiff(tst.ugc.hivpos, tst.ugc.pos.hivpos) + tst.gc.pos.hivpos <- unique(c(tst.rgc.pos.hivpos, tst.ugc.pos.hivpos)) + + # CT non-PrEP testing + tst.rct.hivpos <- tst.ct.nprep.hivpos[which(role.class[tst.ct.nprep.hivpos] %in% c("R", "V"))] + tst.rct.hivpos <- sample(tst.rct.hivpos, tst.rect.sti.rr * length(tst.rct.hivpos)) + tst.uct.hivpos <- tst.ct.nprep.hivpos[which(role.class[tst.ct.nprep.hivpos] %in% c("I", "V"))] + tst.rct.pos.hivpos <- tst.rct.hivpos[which(rCT[tst.rct.hivpos] == 1)] + tst.uct.pos.hivpos <- tst.uct.hivpos[which(uCT[tst.uct.hivpos] == 1)] + tst.rct.neg.hivpos <- setdiff(tst.rct.hivpos, tst.rct.pos.hivpos) + tst.uct.neg.hivpos <- setdiff(tst.uct.hivpos, tst.uct.pos.hivpos) + tst.ct.pos.hivpos <- unique(c(tst.rct.pos.hivpos, tst.uct.pos.hivpos)) + + # Syphilis Attributes + last.neg.test.syph[tst.syph.neg.hivpos] <- at + last.neg.test.syph[tst.syph.pos.hivpos] <- NA + diag.status.syph[tst.syph.pos.hivpos] <- 1 + last.diag.time.syph[tst.syph.pos.hivpos] <- at + tsinceltst.syph[tst.syph.nprep.hivpos] <- 0 + + # GC Attributes + last.neg.test.rgc[tst.rgc.neg.hivpos] <- at + last.neg.test.ugc[tst.ugc.neg.hivpos] <- at + last.neg.test.rgc[tst.rgc.pos.hivpos] <- NA + last.neg.test.ugc[tst.ugc.pos.hivpos] <- NA + diag.status.gc[tst.gc.pos.hivpos] <- 1 + last.diag.time.gc[tst.gc.pos.hivpos] <- at + tsinceltst.rgc[tst.rgc.hivpos] <- 0 + tsinceltst.ugc[tst.ugc.hivpos] <- 0 + + # CT Attributes + last.neg.test.rct[tst.rct.neg.hivpos] <- at + last.neg.test.uct[tst.uct.neg.hivpos] <- at + last.neg.test.rct[tst.rct.pos.hivpos] <- NA + last.neg.test.uct[tst.uct.pos.hivpos] <- NA + diag.status.ct[tst.ct.pos.hivpos] <- 1 + last.diag.time.ct[tst.ct.pos.hivpos] <- at + tsinceltst.rct[tst.rct.hivpos] <- 0 + tsinceltst.uct[tst.uct.hivpos] <- 0 + + + ## Output ----------------------------------------------------------------- + + # Number of people on each testing trajectory by serostatus + dat$epi$tt.traj.syph1.hivneg[at] <- length(which(tt.traj.syph.hivneg == 1)) + dat$epi$tt.traj.gc1.hivneg[at] <- length(which(tt.traj.gc.hivneg == 1)) + dat$epi$tt.traj.ct1.hivneg[at] <- length(which(tt.traj.ct.hivneg == 1)) + dat$epi$tt.traj.syph2.hivneg[at] <- length(which(tt.traj.syph.hivneg == 2)) + dat$epi$tt.traj.gc2.hivneg[at] <- length(which(tt.traj.gc.hivneg == 2)) + dat$epi$tt.traj.ct2.hivneg[at] <- length(which(tt.traj.ct.hivneg == 2)) + dat$epi$tt.traj.syph1.hivpos[at] <- length(which(tt.traj.syph.hivpos == 1)) + dat$epi$tt.traj.gc1.hivpos[at] <- length(which(tt.traj.gc.hivpos == 1)) + dat$epi$tt.traj.ct1.hivpos[at] <- length(which(tt.traj.ct.hivpos == 1)) + dat$epi$tt.traj.syph2.hivpos[at] <- length(which(tt.traj.syph.hivpos == 2)) + dat$epi$tt.traj.gc2.hivpos[at] <- length(which(tt.traj.gc.hivpos == 2)) + dat$epi$tt.traj.ct2.hivpos[at] <- length(which(tt.traj.ct.hivpos == 2)) + + # Number of people on each testing trajectory + dat$epi$tt.traj.gc1[at] <- length(which(tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1)) + dat$epi$tt.traj.ct1[at] <- length(which(tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1)) + dat$epi$tt.traj.syph1[at] <- length(which(tt.traj.syph.hivneg == 1 | tt.traj.syph.hivpos == 1)) + dat$epi$tt.traj.gc2[at] <- length(which(tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2)) + dat$epi$tt.traj.ct2[at] <- length(which(tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2)) + dat$epi$tt.traj.syph2[at] <- length(which(tt.traj.syph.hivneg == 2 | tt.traj.syph.hivpos == 2)) + + dat$epi$tt.traj.sti1[at] <- length(which(tt.traj.gc.hivneg == 1 | tt.traj.gc.hivpos == 1 | + tt.traj.ct.hivneg == 1 | tt.traj.ct.hivpos == 1 | + tt.traj.syph.hivneg == 1 | tt.traj.syph.hivpos == 1)) + dat$epi$tt.traj.sti2[at] <- length(which(tt.traj.gc.hivneg == 2 | tt.traj.gc.hivpos == 2 | + tt.traj.ct.hivneg == 2 | tt.traj.ct.hivpos == 2 | + tt.traj.syph.hivneg == 2 | tt.traj.syph.hivpos == 2)) + + # Number of screening tests and number of positive results on screening tests + # GC overall + dat$epi$rGCasympttests[at] <- length(tst.rgc.hivpos) + + length(tst.rgc.hivneg) + dat$epi$uGCasympttests[at] <- length(tst.ugc.hivpos) + + length(tst.ugc.hivneg) + dat$epi$GCasympttests[at] <- length(tst.rgc.hivpos) + length(tst.ugc.hivpos) + + length(tst.rgc.hivneg) + length(tst.ugc.hivneg) + + # GC positive tests + dat$epi$rGCasympttests.pos[at] <- length(tst.rgc.pos.hivpos) + + length(tst.rgc.pos.hivneg) + dat$epi$uGCasympttests.pos[at] <- length(tst.ugc.pos.hivpos) + + length(tst.ugc.pos.hivneg) + dat$epi$GCasympttests.pos[at] <- length(tst.rgc.pos.hivpos) + length(tst.ugc.pos.hivpos) + + length(tst.rgc.pos.hivneg) + length(tst.ugc.pos.hivneg) + + # CT overall + dat$epi$rCTasympttests[at] <- length(tst.rct.hivpos) + + length(tst.rct.hivneg) + dat$epi$uCTasympttests[at] <- length(tst.uct.hivpos) + + length(tst.uct.hivneg) + dat$epi$CTasympttests[at] <- length(tst.rct.hivpos) + length(tst.uct.hivpos) + + length(tst.rct.hivneg) + length(tst.uct.hivneg) + + # CT positive tests + dat$epi$rCTasympttests.pos[at] <- length(tst.rct.pos.hivpos) + + length(tst.rct.pos.hivneg) + dat$epi$uCTasympttests.pos[at] <- length(tst.uct.pos.hivpos) + + length(tst.uct.pos.hivneg) + dat$epi$CTasympttests.pos[at] <- length(tst.rct.pos.hivpos) + + length(tst.uct.pos.hivpos) + length(tst.rct.pos.hivneg) + + length(tst.uct.pos.hivneg) + + # Syph (overall, positive, early-stage positive, late-stage positive) + dat$epi$syphasympttests[at] <- length(tst.syph.nprep.hivpos) + + length(tst.syph.nprep.hivneg) + dat$epi$syphasympttests.pos[at] <- length(tst.syph.pos.hivpos) + + length(tst.syph.pos.hivneg) + dat$epi$syphearlyasympttests.pos[at] <- length(tst.earlysyph.pos.hivpos) + + length(tst.earlysyph.pos.hivneg) + dat$epi$syphlateasympttests.pos[at] <- length(tst.latesyph.pos.hivpos) + + length(tst.latesyph.pos.hivneg) + + # Overall STI tests and positive STI tests + dat$epi$stiasympttests[at] <- length(tst.rgc.hivpos) + length(tst.ugc.hivpos) + + length(tst.rct.hivpos) + length(tst.uct.hivpos) + length(tst.syph.nprep.hivpos) + + length(tst.rgc.hivneg) + length(tst.ugc.hivneg) + + length(tst.rct.hivneg) + length(tst.uct.hivneg) + length(tst.syph.nprep.hivneg) + dat$epi$stiasympttests.pos[at] <- length(tst.rgc.pos.hivpos) + length(tst.ugc.pos.hivpos) + + length(tst.rct.pos.hivpos) + length(tst.uct.pos.hivpos) + length(tst.syph.pos.hivpos) + + length(tst.rgc.pos.hivneg) + length(tst.ugc.pos.hivneg) + + length(tst.rct.pos.hivneg) + length(tst.uct.pos.hivneg) + length(tst.syph.pos.hivneg) + + # Risk group-specific test counters + # GC lower-risk + dat$epi$rGCasympttests.tttraj1[at] <- length(which(tt.traj.gc.hivpos[tst.rgc.hivpos] == 1)) + + length(which(tt.traj.gc.hivneg[tst.rgc.hivneg] == 1)) + dat$epi$uGCasympttests.tttraj1[at] <- length(which(tt.traj.gc.hivpos[tst.ugc.hivpos] == 1)) + + length(which(tt.traj.gc.hivneg[tst.ugc.hivneg] == 1)) + dat$epi$GCasympttests.tttraj1[at] <- length(which(tt.traj.gc.hivpos[tst.rgc.hivpos] == 1)) + + length(which(tt.traj.gc.hivneg[tst.rgc.hivneg] == 1)) + + length(which(tt.traj.gc.hivpos[tst.ugc.hivpos] == 1)) + + length(which(tt.traj.gc.hivneg[tst.ugc.hivneg] == 1)) + + # GC higher-risk + dat$epi$rGCasympttests.tttraj2[at] <- length(which(tt.traj.gc.hivpos[tst.rgc.hivpos] == 2)) + + length(which(tt.traj.gc.hivneg[tst.rgc.hivneg] == 2)) + dat$epi$uGCasympttests.tttraj2[at] <- length(which(tt.traj.gc.hivpos[tst.ugc.hivpos] == 2)) + + length(which(tt.traj.gc.hivneg[tst.ugc.hivneg] == 2)) + dat$epi$GCasympttests.tttraj2[at] <- length(which(tt.traj.gc.hivpos[tst.rgc.hivpos] == 2)) + + length(which(tt.traj.gc.hivneg[tst.rgc.hivneg] == 2)) + + length(which(tt.traj.gc.hivpos[tst.ugc.hivpos] == 2)) + + length(which(tt.traj.gc.hivneg[tst.ugc.hivneg] == 2)) + + # CT lower-risk + dat$epi$rCTasympttests.tttraj1[at] <- length(which(tt.traj.ct.hivpos[tst.rct.hivpos] == 1)) + + length(which(tt.traj.ct.hivneg[tst.rct.hivneg] == 1)) + dat$epi$uCTasympttests.tttraj1[at] <- length(which(tt.traj.ct.hivpos[tst.uct.hivpos] == 1)) + + length(which(tt.traj.ct.hivneg[tst.uct.hivneg] == 1)) + dat$epi$CTasympttests.tttraj1[at] <- length(which(tt.traj.ct.hivpos[tst.rct.hivpos] == 1)) + + length(which(tt.traj.ct.hivneg[tst.rct.hivneg] == 1)) + + length(which(tt.traj.ct.hivpos[tst.uct.hivpos] == 1)) + + length(which(tt.traj.ct.hivneg[tst.uct.hivneg] == 1)) + + # CT higher-risk + dat$epi$rCTasympttests.tttraj2[at] <- length(which(tt.traj.ct.hivpos[tst.rct.hivpos] == 2)) + + length(which(tt.traj.ct.hivneg[tst.rct.hivneg] == 2)) + dat$epi$uCTasympttests.tttraj2[at] <- length(which(tt.traj.ct.hivpos[tst.uct.hivpos] == 2)) + + length(which(tt.traj.ct.hivneg[tst.uct.hivneg] == 2)) + dat$epi$CTasympttests.tttraj2[at] <- length(which(tt.traj.ct.hivpos[tst.rct.hivpos] == 2)) + + length(which(tt.traj.ct.hivneg[tst.rct.hivneg] == 2)) + + length(which(tt.traj.ct.hivpos[tst.uct.hivpos] == 2)) + + length(which(tt.traj.ct.hivneg[tst.uct.hivneg] == 2)) + + # Syph + dat$epi$syphasympttests.tttraj1[at] <- length(which(tt.traj.syph.hivpos[tst.syph.nprep.hivpos] == 1)) + + length(which(tt.traj.syph.hivneg[tst.syph.nprep.hivneg] == 1)) + + dat$epi$syphasympttests.tttraj2[at] <- length(which(tt.traj.syph.hivpos[tst.syph.nprep.hivpos] == 2)) + + length(which(tt.traj.syph.hivneg[tst.syph.nprep.hivneg] == 2)) + + # STI + dat$epi$stiasympttests.tttraj1[at] <- length(which(tt.traj.gc.hivpos[tst.rgc.hivpos] == 1)) + + length(which(tt.traj.gc.hivneg[tst.rgc.hivneg] == 1)) + + length(which(tt.traj.gc.hivpos[tst.ugc.hivpos] == 1)) + + length(which(tt.traj.gc.hivneg[tst.ugc.hivneg] == 1)) + + length(which(tt.traj.ct.hivpos[tst.rct.hivpos] == 1)) + + length(which(tt.traj.ct.hivneg[tst.rct.hivneg] == 1)) + + length(which(tt.traj.ct.hivpos[tst.uct.hivpos] == 1)) + + length(which(tt.traj.ct.hivneg[tst.uct.hivneg] == 1)) + + length(which(tt.traj.syph.hivpos[tst.syph.nprep.hivpos] == 1)) + + length(which(tt.traj.syph.hivneg[tst.syph.nprep.hivneg] == 1)) + + dat$epi$stiasympttests.tttraj2[at] <- length(which(tt.traj.gc.hivpos[tst.rgc.hivpos] == 2)) + + length(which(tt.traj.gc.hivneg[tst.rgc.hivneg] == 2)) + + length(which(tt.traj.gc.hivpos[tst.ugc.hivpos] == 2)) + + length(which(tt.traj.gc.hivneg[tst.ugc.hivneg] == 2)) + + length(which(tt.traj.ct.hivpos[tst.rct.hivpos] == 2)) + + length(which(tt.traj.ct.hivneg[tst.rct.hivneg] == 2)) + + length(which(tt.traj.ct.hivpos[tst.uct.hivpos] == 2)) + + length(which(tt.traj.ct.hivneg[tst.uct.hivneg] == 2)) + + length(which(tt.traj.syph.hivpos[tst.syph.nprep.hivpos] == 2)) + + length(which(tt.traj.syph.hivneg[tst.syph.nprep.hivneg] == 2)) + + # Update Attributes + # Stoppage attributes + dat$attr$stihighrisktestLastElig[idsnothighriskelig.hivneg] <- at + dat$attr$stianntestLastElig[idsnotactiveelig.hivneg] <- at + dat$attr$stihighrisktestLastElig[idsnothighriskelig.hivpos] <- at + dat$attr$stianntestLastElig[idsnotactiveelig.hivpos] <- at + + # Syphilis Attributes + dat$attr$last.neg.test.syph <- last.neg.test.syph + dat$attr$diag.status.syph <- diag.status.syph + dat$attr$last.diag.time.syph <- last.diag.time.syph + dat$attr$tt.traj.syph.hivneg <- tt.traj.syph.hivneg + dat$attr$tt.traj.syph.hivpos <- tt.traj.syph.hivpos + dat$attr$time.since.last.test.syph <- tsinceltst.syph + + # GC Attributes + dat$attr$last.neg.test.rgc <- last.neg.test.rgc + dat$attr$last.neg.test.ugc <- last.neg.test.ugc + dat$attr$diag.status.gc <- diag.status.gc + dat$attr$last.diag.time.gc <- last.diag.time.gc + dat$attr$tt.traj.gc.hivneg <- tt.traj.gc.hivneg + dat$attr$tt.traj.gc.hivpos <- tt.traj.gc.hivpos + dat$attr$time.since.last.test.rgc <- tsinceltst.rgc + dat$attr$time.since.last.test.ugc <- tsinceltst.ugc + + # CT Attributes + dat$attr$last.neg.test.rct <- last.neg.test.rct + dat$attr$last.neg.test.uct <- last.neg.test.uct + dat$attr$diag.status.ct <- diag.status.ct + dat$attr$last.diag.time.ct <- last.diag.time.ct + dat$attr$tt.traj.ct.hivneg <- tt.traj.ct.hivneg + dat$attr$tt.traj.ct.hivpos <- tt.traj.ct.hivpos + dat$attr$time.since.last.test.rct <- tsinceltst.rct + dat$attr$time.since.last.test.uct <- tsinceltst.uct + + return(dat) +} + + + +#' @title HIV Diagnosis Module +#' +#' @description Module function for simulating HIV diagnosis after infection, +#' currently based on diagnosis at treatment initiation. +#' +#' @inheritParams aging_het +#' +#' @keywords module het +#' +#' @export +#' dx_het <- function(dat, at) { # Variables diff --git a/R/mod.trans.R b/R/mod.trans.R index 1a71597e..bb79f2f4 100644 --- a/R/mod.trans.R +++ b/R/mod.trans.R @@ -32,7 +32,7 @@ #' #' @export #' -trans_msm <- function(dat, at) { +hiv_trans_msm <- function(dat, at) { # Variables ----------------------------------------------------------- @@ -48,10 +48,12 @@ trans_msm <- function(dat, at) { uGC <- dat$attr$uGC rCT <- dat$attr$rCT uCT <- dat$attr$uCT + stage.syph <- dat$attr$stage.syph # Parameters URAI.prob <- dat$param$URAI.prob UIAI.prob <- dat$param$UIAI.prob + acute.rr <- dat$param$acute.rr condom.rr <- dat$param$condom.rr circ.rr <- dat$param$circ.rr @@ -61,18 +63,54 @@ trans_msm <- function(dat, at) { hiv.uct.rr <- dat$param$hiv.uct.rr hiv.rgc.rr <- dat$param$hiv.rgc.rr hiv.rct.rr <- dat$param$hiv.rct.rr - hiv.dual.rr <- dat$param$hiv.dual.rr + hiv.syph.rr <- dat$param$hiv.syph.rr + hiv.rgc.rct.rr <- dat$param$hiv.rgc.rct.rr + hiv.rgc.syph.rr <- dat$param$hiv.rgc.syph.rr + hiv.rct.syph.rr <- dat$param$hiv.rct.syph.rr + hiv.ugc.uct.rr <- dat$param$hiv.ugc.uct.rr + hiv.ugc.syph.rr <- dat$param$hiv.ugc.syph.rr + hiv.uct.syph.rr <- dat$param$hiv.uct.syph.rr + hiv.all.ureth.rr <- dat$param$hiv.all.ureth.rr + hiv.all.rect.rr <- dat$param$hiv.all.rect.rr + + hiv.trans.syph.rr <- dat$param$hiv.trans.syph.rr + hiv.trans.gc.rr <- dat$param$hiv.trans.gc.rr + hiv.trans.ct.rr <- dat$param$hiv.trans.ct.rr + hiv.trans.gc.ct.rr <- dat$param$hiv.trans.ct.rr + hiv.trans.gc.syph.rr <- dat$param$hiv.trans.gc.syph.rr + hiv.trans.ct.syph.rr <- dat$param$hiv.trans.ct.syph.rr + hiv.trans.allsti.rr <- dat$param$hiv.trans.allsti.rr # Data al <- dat$temp$al - dal <- al[which(status[al[, 1]] == 1 & status[al[, 2]] == 0), ] - dal <- dal[sample(1:nrow(dal)), ] - ncols <- dim(dal)[2] - + dal <- al[which(status[al[, 1]] == 1 & status[al[, 2]] == 0), , drop = FALSE] if (nrow(dal) == 0) { return(dat) } + dal <- dal[sample(1:nrow(dal)), ] + ncols <- dim(dal)[2] + + al <- cbind(al, st1 = as.vector(dat$attr$status[al[ ,"p1"]])) + al <- cbind(al, st2 = as.vector(dat$attr$status[al[ ,"p2"]])) + + al.negneg <- al[al[, "st1"] == 0 & al[, "st2"] == 0, , drop = FALSE] + al.negpos <- al[(al[, "st1"] == 1 & al[, "st2"] == 0) | + (al[, "st1"] == 0 & al[, "st2"] == 1), , drop = FALSE] + al.pospos <- al[al[, "st1"] == 1 & al[, "st2"] == 1, , drop = FALSE] + + # Output act and edge stats before evaluating whether discordant pairs exists + dat$epi$num.acts.negneg[at] <- nrow(al.negneg) + dat$epi$num.acts.negpos[at] <- nrow(al.negpos) + dat$epi$num.acts.pospos[at] <- nrow(al.pospos) + + dat$epi$prop.uai.negneg[at] <- sum(al.negneg[, "uai"] == 1) / nrow(al.negneg) + dat$epi$prop.uai.negpos[at] <- sum(al.negpos[, "uai"] == 1) / nrow(al.negpos) + dat$epi$prop.uai.pospos[at] <- sum(al.pospos[, "uai"] == 1) / nrow(al.pospos) + + dat$epi$prop.acts.negneg[at] <- nrow(al.negneg) / (nrow(al)) + dat$epi$prop.acts.negpos[at] <- nrow(al.negpos) / (nrow(al)) + dat$epi$prop.acts.pospos[at] <- nrow(al.pospos) / (nrow(al)) ## Reorder by role: ins on the left, rec on the right, flippers represented twice disc.ip <- dal[dal[, "ins"] %in% 1:2, ] @@ -85,6 +123,9 @@ trans_msm <- function(dat, at) { # Attributes of infected ip.vl <- vl[disc.ip[, 1]] ip.stage <- stage[disc.ip[, 1]] + ip.stage.syph.infector <- stage.syph[disc.ip[, 1]] + ip.uGC.infector <- uGC[disc.ip[, 1]] + ip.uCT.infector <- uCT[disc.ip[, 1]] # Attributes of susceptible ip.ccr5 <- ccr5[disc.ip[, 2]] @@ -92,12 +133,13 @@ trans_msm <- function(dat, at) { ip.prepcl <- prepClass[disc.ip[, 2]] ip.rGC <- rGC[disc.ip[, 2]] ip.rCT <- rCT[disc.ip[, 2]] + ip.stage.syph.infectee <- stage.syph[disc.ip[, 2]] # Base TP from VL ip.tprob <- URAI.prob * 2.45^(ip.vl - 4.5) # Transform to log odds - ip.tlo <- log(ip.tprob/(1-ip.tprob)) + ip.tlo <- log(ip.tprob/(1 - ip.tprob)) # Condom use not.UAI <- which(disc.ip[, "uai"] == 0) @@ -109,7 +151,7 @@ trans_msm <- function(dat, at) { # PrEP, cycle through 4 adherence classes for (i in 1:4) { - temp.ids <- which(ip.prep == 1 & ip.prepcl == i-1) + temp.ids <- which(ip.prep == 1 & ip.prepcl == i - 1) ip.tlo[temp.ids] <- ip.tlo[temp.ids] + log(prep.hr[i]) } @@ -117,23 +159,124 @@ trans_msm <- function(dat, at) { isAcute <- which(ip.stage %in% 1:2) ip.tlo[isAcute] <- ip.tlo[isAcute] + log(acute.rr) - ## Multiplier for STI + ## Multiplier for HIV acquisition due to rectal STI in HIV-negative partner is.rGC <- which(ip.rGC == 1) - is.rCT <- which(ip.rCT == 1) + is.syph.infectee <- which(ip.stage.syph.infectee %in% c(1, 2, 3)) + + ### Single infections + # NG + is.rGC.sing <- setdiff(is.rGC, is.rCT) + is.rGC.sing <- setdiff(is.rGC.sing, is.syph.infectee) + + # CT + is.rCT.sing <- setdiff(is.rCT, is.rGC) + is.rCT.sing <- setdiff(is.rCT.sing, is.syph.infectee) - is.rect.dual <- intersect(is.rGC, is.rCT) + # Syph + is.syph.sing <- setdiff(is.syph.infectee, is.rGC) + is.syph.sing <- setdiff(is.syph.sing, is.rCT) - is.rGC.sing <- setdiff(is.rGC, is.rect.dual) - is.rCT.sing <- setdiff(is.rCT, is.rect.dual) + ### Coinfections + # NG and CT + is.rGC.rCT <- intersect(is.rGC, is.rCT) + is.rGC.rCT <- setdiff(is.rGC.rCT, is.syph.infectee) + # NG and Syph + is.rGC.syph <- intersect(is.rGC, is.syph.infectee) + is.rGC.syph <- setdiff(is.rGC.syph, is.rCT) + + # CT and Syph + is.rCT.syph <- intersect(is.rCT, is.syph.infectee) + is.rCT.syph <- setdiff(is.rCT.syph, is.rGC) + + # All three infections + is.all <- intersect(is.rGC.rCT, is.syph.infectee) + + ## Add relative risks + # Single infections ip.tlo[is.rGC.sing] <- ip.tlo[is.rGC.sing] + log(hiv.rgc.rr) ip.tlo[is.rCT.sing] <- ip.tlo[is.rCT.sing] + log(hiv.rct.rr) + ip.tlo[is.syph.sing] <- ip.tlo[is.syph.sing] + log(hiv.syph.rr) - ip.tlo[is.rect.dual] <- ip.tlo[is.rect.dual] + + # Two infections + ip.tlo[is.rGC.rCT] <- ip.tlo[is.rGC.rCT] + max(log(hiv.rgc.rr), log(hiv.rct.rr)) + - min(log(hiv.rgc.rr), log(hiv.rct.rr)) * hiv.dual.rr + min(log(hiv.rgc.rr), log(hiv.rct.rr)) * hiv.rgc.rct.rr + + ip.tlo[is.rGC.syph] <- ip.tlo[is.rGC.syph] + + max(log(hiv.rgc.rr), log(hiv.syph.rr)) + + min(log(hiv.rgc.rr), log(hiv.syph.rr)) * hiv.rgc.syph.rr + + ip.tlo[is.rCT.syph] <- ip.tlo[is.rCT.syph] + + max(log(hiv.rct.rr), log(hiv.syph.rr)) + + min(log(hiv.rct.rr), log(hiv.syph.rr)) * hiv.rct.syph.rr + + # Three infections + ip.tlo[is.all] <- ip.tlo[is.all] + + max(log(hiv.rct.rr), log(hiv.rgc.rr), log(hiv.syph.rr)) + + min(log(hiv.rct.rr), log(hiv.rgc.rr), log(hiv.syph.rr)) * hiv.all.rect.rr + + ## Multiplier for HIV transmission due to urethral STI in HIV-positive partner + is.syph.infector <- which(ip.stage.syph.infector %in% c(1, 2, 3)) + is.uGC.infector <- which(ip.uGC.infector == 1) + is.uCT.infector <- which(ip.uCT.infector == 1) + + ### Single infections + # NG + is.uGC.sing <- setdiff(is.uGC.infector, is.uCT.infector) + is.uGC.sing <- setdiff(is.uGC.sing, is.syph.infector) + + # CT + is.uCT.sing <- setdiff(is.uCT.infector, is.uGC.infector) + is.uCT.sing <- setdiff(is.uCT.sing, is.syph.infector) + + # Syph + is.syph.sing <- setdiff(is.syph.infector, is.uGC.infector) + is.syph.sing <- setdiff(is.syph.sing, is.uCT.infector) + + ### Coinfections + # NG and CT + is.uGC.uCT <- intersect(is.uGC.infector, is.uCT.infector) + is.uGC.uCT <- setdiff(is.uGC.uCT, is.syph.infector) + + # NG and Syph + is.uGC.syph <- intersect(is.uGC.infector, is.syph.infector) + is.uGC.syph <- setdiff(is.uGC.syph, is.uCT.infector) + + # CT and Syph + is.uCT.syph <- intersect(is.uCT.infector, is.syph.infector) + is.uCT.syph <- setdiff(is.uCT.syph, is.uGC.infector) + + # All three infections + is.all <- intersect(is.uGC.uCT, is.syph.infector) + ## Add relative risks + # Single infections + ip.tlo[is.uGC.sing] <- ip.tlo[is.uGC.sing] + log(hiv.trans.gc.rr) + ip.tlo[is.uCT.sing] <- ip.tlo[is.uCT.sing] + log(hiv.trans.ct.rr) + ip.tlo[is.syph.sing] <- ip.tlo[is.syph.sing] + log(hiv.trans.syph.rr) + + # Two infections + ip.tlo[is.uGC.uCT] <- ip.tlo[is.uGC.uCT] + + max(log(hiv.trans.gc.rr), log(hiv.trans.ct.rr)) + + min(log(hiv.trans.gc.rr), log(hiv.trans.ct.rr)) * hiv.trans.gc.ct.rr + + ip.tlo[is.uGC.syph] <- ip.tlo[is.uGC.syph] + + max(log(hiv.trans.gc.rr), log(hiv.trans.syph.rr)) + + min(log(hiv.trans.gc.rr), log(hiv.trans.syph.rr)) * hiv.trans.gc.syph.rr + + ip.tlo[is.uCT.syph] <- ip.tlo[is.uCT.syph] + + max(log(hiv.trans.ct.rr), log(hiv.trans.syph.rr)) + + min(log(hiv.trans.ct.rr), log(hiv.trans.syph.rr)) * hiv.trans.ct.syph.rr + + # Three infections + ip.tlo[is.all] <- ip.tlo[is.all] + + max(log(hiv.trans.ct.rr), log(hiv.trans.gc.rr), log(hiv.trans.syph.rr)) + + min(log(hiv.trans.ct.rr), log(hiv.trans.gc.rr), log(hiv.trans.syph.rr)) * hiv.trans.allsti.rr + + + ## Re-transform back to probability ip.tprob <- plogis(ip.tlo) stopifnot(ip.tprob >= 0, ip.tprob <= 1) @@ -143,6 +286,9 @@ trans_msm <- function(dat, at) { # Attributes of infected rp.vl <- vl[disc.rp[, 2]] rp.stage <- stage[disc.rp[, 2]] + rp.stage.syph.infector <- stage.syph[disc.rp[, 2]] + rp.rGC.infector <- rGC[disc.rp[, 2]] + rp.rCT.infector <- rCT[disc.rp[, 2]] # Attributes of susceptible rp.circ <- circ[disc.rp[, 1]] @@ -151,12 +297,13 @@ trans_msm <- function(dat, at) { rp.prepcl <- prepClass[disc.rp[, 1]] rp.uGC <- uGC[disc.rp[, 1]] rp.uCT <- uCT[disc.rp[, 1]] + rp.stage.syph.infectee <- stage.syph[disc.rp[, 1]] # Base TP from VL rp.tprob <- UIAI.prob * 2.45^(rp.vl - 4.5) # Transform to log odds - rp.tlo <- log(rp.tprob/(1-rp.tprob)) + rp.tlo <- log(rp.tprob/(1 - rp.tprob)) # Circumcision rp.tlo[rp.circ == 1] <- rp.tlo[rp.circ == 1] + log(circ.rr) @@ -171,7 +318,7 @@ trans_msm <- function(dat, at) { # PrEP, cycle through 4 adherence classes for (i in 1:4) { - temp.ids <- which(rp.prep == 1 & rp.prepcl == i-1) + temp.ids <- which(rp.prep == 1 & rp.prepcl == i - 1) rp.tlo[temp.ids] <- rp.tlo[temp.ids] + log(prep.hr[i]) } @@ -179,24 +326,121 @@ trans_msm <- function(dat, at) { isAcute <- which(rp.stage %in% 1:2) rp.tlo[isAcute] <- rp.tlo[isAcute] + log(acute.rr) - ## Multiplier for STI + ## Multiplier for HIV acquisition due to urethral STI in HIV-negative partner is.uGC <- which(rp.uGC == 1) - is.uCT <- which(rp.uCT == 1) + is.syph.infectee <- which(rp.stage.syph.infectee %in% c(1, 2, 3)) - is.ureth.dual <- intersect(is.uGC, is.uCT) + ### Single infections + # NG + is.uGC.sing <- setdiff(is.uGC, is.uCT) + is.uGC.sing <- setdiff(is.uGC.sing, is.syph.infectee) - is.uGC.sing <- setdiff(is.uGC, is.ureth.dual) - is.uCT.sing <- setdiff(is.uCT, is.ureth.dual) + # CT + is.uCT.sing <- setdiff(is.uCT, is.uGC) + is.uCT.sing <- setdiff(is.uCT.sing, is.syph.infectee) + # Syph + is.syph.sing <- setdiff(is.syph.infectee, is.uGC) + is.syph.sing <- setdiff(is.syph.sing, is.uCT) + + ### Coinfections + # NG and CT + is.uGC.uCT <- intersect(is.uGC, is.uCT) + is.uGC.uCT <- setdiff(is.uGC.uCT, is.syph.infectee) + + # NG and Syph + is.uGC.syph <- intersect(is.uGC, is.syph.infectee) + is.uGC.syph <- setdiff(is.uGC.syph, is.uCT) + + # CT and Syph + is.uCT.syph <- intersect(is.uCT, is.syph.infectee) + is.uCT.syph <- setdiff(is.uCT.syph, is.uGC) + + # All three infections + is.all <- intersect(is.uGC.uCT, is.syph.infectee) + + # Single infections rp.tlo[is.uGC.sing] <- rp.tlo[is.uGC.sing] + log(hiv.ugc.rr) rp.tlo[is.uCT.sing] <- rp.tlo[is.uCT.sing] + log(hiv.uct.rr) + rp.tlo[is.syph.sing] <- rp.tlo[is.syph.sing] + log(hiv.syph.rr) - rp.tlo[is.ureth.dual] <- rp.tlo[is.ureth.dual] + + # Two infections + rp.tlo[is.uGC.uCT] <- rp.tlo[is.uGC.uCT] + max(log(hiv.ugc.rr), log(hiv.uct.rr)) + - min(log(hiv.ugc.rr), log(hiv.uct.rr)) * hiv.dual.rr - - # Retransformation to probability + min(log(hiv.ugc.rr), log(hiv.uct.rr)) * hiv.ugc.uct.rr + + rp.tlo[is.uGC.syph] <- rp.tlo[is.uGC.syph] + + max(log(hiv.ugc.rr), log(hiv.syph.rr)) + + min(log(hiv.ugc.rr), log(hiv.syph.rr)) * hiv.ugc.syph.rr + + rp.tlo[is.uCT.syph] <- rp.tlo[is.uCT.syph] + + max(log(hiv.uct.rr), log(hiv.syph.rr)) + + min(log(hiv.uct.rr), log(hiv.syph.rr)) * hiv.uct.syph.rr + + # Three infections + rp.tlo[is.all] <- rp.tlo[is.all] + + max(log(hiv.uct.rr), log(hiv.ugc.rr), log(hiv.syph.rr)) + + min(log(hiv.uct.rr), log(hiv.ugc.rr), log(hiv.syph.rr)) * hiv.all.ureth.rr + + ## Multiplier for HIV transmission due to rectal STI in HIV-positive partner + is.syph.infector <- which(rp.stage.syph.infector %in% c(1, 2, 3)) + is.rGC.infector <- which(rp.rGC.infector == 1) + is.rCT.infector <- which(rp.rCT.infector == 1) + + ### Single infections + # NG + is.rGC.sing <- setdiff(is.rGC.infector, is.rCT.infector) + is.rGC.sing <- setdiff(is.rGC.sing, is.syph.infector) + + # CT + is.rCT.sing <- setdiff(is.rCT.infector, is.rGC.infector) + is.rCT.sing <- setdiff(is.rGC.sing, is.syph.infector) + + # Syph + is.syph.sing <- setdiff(is.syph.infector, is.rGC.infector) + is.syph.sing <- setdiff(is.syph.sing, is.rCT.infector) + + ### Coinfections + # NG and CT + is.rGC.rCT <- intersect(is.rGC.infector, is.rCT.infector) + is.rGC.rCT <- setdiff(is.rGC.rCT, is.syph.infector) + + # NG and Syph + is.rGC.syph <- intersect(is.rGC.infector, is.syph.infector) + is.rGC.syph <- setdiff(is.rGC.syph, is.rCT.infector) + + # CT and Syph + is.rCT.syph <- intersect(is.rCT.infector, is.syph.infector) + is.rCT.syph <- setdiff(is.rCT.syph, is.rGC.infector) + + # All three infections + is.all <- intersect(is.rGC.rCT, is.syph.infector) + + # Single infections + rp.tlo[is.rGC.sing] <- rp.tlo[is.rGC.sing] + log(hiv.trans.gc.rr) + rp.tlo[is.rCT.sing] <- rp.tlo[is.rCT.sing] + log(hiv.trans.ct.rr) + rp.tlo[is.syph.sing] <- rp.tlo[is.syph.sing] + log(hiv.trans.syph.rr) + + # Two infections + rp.tlo[is.rGC.rCT] <- rp.tlo[is.rGC.rCT] + + max(log(hiv.trans.gc.rr), log(hiv.trans.ct.rr)) + + min(log(hiv.trans.gc.rr), log(hiv.trans.ct.rr)) * hiv.trans.gc.ct.rr + + rp.tlo[is.rGC.syph] <- rp.tlo[is.rGC.syph] + + max(log(hiv.trans.gc.rr), log(hiv.trans.syph.rr)) + + min(log(hiv.trans.gc.rr), log(hiv.trans.syph.rr)) * hiv.trans.gc.syph.rr + + rp.tlo[is.rCT.syph] <- rp.tlo[is.rCT.syph] + + max(log(hiv.trans.ct.rr), log(hiv.trans.syph.rr)) + + min(log(hiv.trans.ct.rr), log(hiv.trans.syph.rr)) * hiv.trans.ct.syph.rr + + # Three infections + rp.tlo[is.all] <- rp.tlo[is.all] + + max(log(hiv.trans.ct.rr), log(hiv.trans.gc.rr), log(hiv.trans.syph.rr)) + + min(log(hiv.trans.ct.rr), log(hiv.trans.gc.rr), log(hiv.trans.syph.rr)) * hiv.trans.allsti.rr + + ## Retransformation to probability rp.tprob <- plogis(rp.tlo) stopifnot(rp.tprob >= 0, rp.tprob <= 1) @@ -216,9 +460,10 @@ trans_msm <- function(dat, at) { infected <- inf.type <- NULL if (sum(trans.ip, trans.rp) > 0) { - infected <- c(disc.ip[trans.ip == 1, 2], - disc.rp[trans.rp == 1, 1]) + infected <- unique(c(disc.ip[trans.ip == 1, 2], + disc.rp[trans.rp == 1, 1])) inf.role <- c(rep(0, sum(trans.ip)), rep(1, sum(trans.rp))) + inf.type <- c(disc.ip[trans.ip == 1, "ptype"], disc.rp[trans.rp == 1, "ptype"]) @@ -227,21 +472,221 @@ trans_msm <- function(dat, at) { dat$attr$vl[infected] <- 0 dat$attr$stage[infected] <- 1 dat$attr$stage.time[infected] <- 0 + dat$attr$stage.time.ar.ndx[infected] <- 0 dat$attr$diag.status[infected] <- 0 dat$attr$tx.status[infected] <- 0 - dat$attr$inf.role[infected] <- inf.role - dat$attr$inf.type[infected] <- inf.type + dat$attr$inf.role[infected] <- inf.role[infected] + dat$attr$inf.type[infected] <- inf.type[infected] dat$attr$cum.time.on.tx[infected] <- 0 dat$attr$cum.time.off.tx[infected] <- 0 } + dat$attr$time.hivneg[status == 0] <- dat$attr$time.hivneg[status == 0] + 1 + + trans <- rbind(disc.ip[trans.ip == 1, ], disc.rp[trans.rp == 1, ]) + dat$epi$sum_GC[at] <- length(which(((rGC[trans[, 2]] == 1 | uGC[trans[, 1]] == 1) & trans[, 6] == 1) | + ((uGC[trans[, 2]] == 1 | rGC[trans[, 1]] == 1) & trans[, 6] == 0))) + + dat$epi$sum_CT[at] <- length(which(((rCT[trans[, 2]] == 1 | uCT[trans[, 1]] == 1) & trans[, 6] == 1) | + ((uCT[trans[, 2]] == 1 | rCT[trans[, 1]] == 1) & trans[, 6] == 0))) + + dat$epi$sum_syph[at] <- length(which(stage.syph[trans[, 2]] %in% c(1,2,3) | stage.syph[trans[, 1]] %in% c(1,2,3))) + + dat$epi$sum_urethral[at] <- length(which(((uGC[trans[, 1]] == 1 | uCT[trans[, 1]] == 1) & trans[, 6] == 1) | + ((uGC[trans[, 2]] == 1 | uCT[trans[, 2]] == 1) & trans[, 6] == 0))) + + dat$epi$sum_rectal[at] <- length(which(((rGC[trans[, 2]] == 1 | rCT[trans[, 2]] == 1) & trans[, 6] == 1) | + ((rGC[trans[, 1]] == 1 | rCT[trans[, 1]] == 1) & trans[, 6] == 0))) + #2x2 for PAF + # HIV+ + # STI+ STI- + #HIV- STI + 1 2 + # STI - 3 4 + dat$epi$cell1_gc[at] <- length(which( + # P1 is infected, p1 has urethral and p2 has rectal OR + (status[trans[, 1]] == 1 & rGC[trans[, 2]] == 1 & uGC[trans[, 1]] == 1) | + # P2 is infected, p1 has urethral and p2 has rectal + (status[trans[, 2]] == 1 & rGC[trans[, 2]] == 1 & uGC[trans[, 1]] == 1))) + + dat$epi$cell2_gc[at] <- length(which( + # P1 is infected, p1 does not have urethral GC, p2 has rectal GC + (status[trans[, 1]] == 1 & uGC[trans[, 1]] == 0 & rGC[trans[, 2]] == 1) | + # P2 is infected, p1 has urethral GC, p2 does not have rectal GC + (status[trans[, 2]] == 1 & uGC[trans[, 1]] == 1 & rGC[trans[, 2]] == 0))) + + dat$epi$cell3_gc[at] <- length(which( + # P1 is infected, p1 has urethral GC, p2 does not have rectal GC + (status[trans[, 1]] == 1 & uGC[trans[, 1]] == 1 & rGC[trans[, 2]] == 0) | + # P2 is infected, p1 does not have urethral GC, p2 does have rectal GC + (status[trans[, 2]] == 1 & uGC[trans[, 1]] == 0 & rGC[trans[, 2]] == 1))) + + dat$epi$cell4_gc[at] <- length(which( + # P1 is infected, p1 does not have urethral GC, p2 does not have rectal GC + (status[trans[, 1]] == 1 & uGC[trans[, 1]] == 0 & rGC[trans[, 2]] == 0) | + # P2 is infected, p1 does not have urethral GC, p2 does not have rectal GC + (status[trans[, 2]] == 1 & uGC[trans[, 1]] == 0 & rGC[trans[, 2]] == 0))) + + dat$epi$cell1_ct[at] <- length(which( + # P1 is infected, p1 has urethral and p2 has rectal OR + (status[trans[, 1]] == 1 & rCT[trans[, 2]] == 1 & uCT[trans[, 1]] == 1) | + # P2 is infected, p1 has urethral and p2 has rectal + (status[trans[, 2]] == 1 & rCT[trans[, 2]] == 1 & uCT[trans[, 1]] == 1))) + + dat$epi$cell2_ct[at] <- length(which( + # P1 is infected, p1 does not have urethral CT, p2 has rectal CT + (status[trans[, 1]] == 1 & uCT[trans[, 1]] == 0 & rCT[trans[, 2]] == 1) | + # P2 is infected, p1 has urethral CT, p2 does not have rectal CT + (status[trans[, 2]] == 1 & uCT[trans[, 1]] == 1 & rCT[trans[, 2]] == 0))) + + dat$epi$cell3_ct[at] <- length(which( + # P1 is infected, p1 has urethral CT, p2 does not have rectal CT + (status[trans[, 1]] == 1 & uCT[trans[, 1]] == 1 & rCT[trans[, 2]] == 0) | + # P2 is infected, p1 does not have urethral CT, p2 does have rectal CT + (status[trans[, 2]] == 1 & uCT[trans[, 1]] == 0 & rCT[trans[, 2]] == 1))) + + dat$epi$cell4_ct[at] <- length(which( + # P1 is infected, p1 does not have urethral CT, p2 does not have rectal CT + (status[trans[, 1]] == 1 & uCT[trans[, 1]] == 0 & rCT[trans[, 2]] == 0) | + # P2 is infected, p1 does not have urethral CT, p2 does not have rectal CT + (status[trans[, 2]] == 1 & uCT[trans[, 1]] == 0 & rCT[trans[, 2]] == 0))) + + dat$epi$cell1_syph[at] <- length(which( + #P1 is infected, P1 has syphilis, P2 has syphilis + status[trans[, 1]] == 1 & stage.syph[trans[, 2]] %in% c(1,2,3) & stage.syph[trans[, 1]] %in% c(1,2,3) | + #P2 is infected, P1 has syphilis, P2 has syphilis + status[trans[, 2]] == 1 & stage.syph[trans[, 2]] %in% c(1,2,3) & stage.syph[trans[, 1]] %in% c(1,2,3))) + + dat$epi$cell2_syph[at] <- length(which( + #P1 is infected, P1 does not have syphilis, P2 has syphilis + status[trans[, 1]] == 1 & stage.syph[trans[, 2]] %in% c(1,2,3) & !(stage.syph[trans[, 1]] %in% c(1,2,3)) | + #P2 is infected, P1 has syphilis, P2 does not have syphilis + status[trans[, 2]] == 1 & !(stage.syph[trans[, 2]] %in% c(1,2,3)) & stage.syph[trans[, 1]] %in% c(1,2,3))) + + dat$epi$cell3_syph[at] <- length(which( + #P1 is infected, P1 has syphilis, P2 does not have syphilis OR + status[trans[, 1]] == 1 & stage.syph[trans[, 1]] %in% c(1,2,3) & !(stage.syph[trans[, 2]] %in% c(1,2,3)) | + #P2 is infected, P1 does not have syphilis, P2 has syphilis + status[trans[, 2]] == 1 & !(stage.syph[trans[, 1]] %in% c(1,2,3)) & stage.syph[trans[, 2]] %in% c(1,2,3))) + + dat$epi$cell4_syph[at] <- length(which( + #P1 is infected, P1 does not have syphilis, P2 does not have syphilis OR + status[trans[, 1]] == 1 & !(stage.syph[trans[, 1]] %in% c(1,2,3)) & !(stage.syph[trans[, 2]] %in% c(1,2,3)) | + #P2 is infected, P1 does not have syphilis, P2 does not have syphilis + status[trans[, 2]] == 1 & !(stage.syph[trans[, 1]] %in% c(1,2,3)) & !(stage.syph[trans[, 2]] %in% c(1,2,3)))) + + dat$epi$cell1_sti[at] <- length(which( + #P1 is infected, P1 has urethral STI, P2 has rectal STI OR + (status[trans[, 1]] == 1 & ((uGC[trans[, 1]] == 1 | uCT[trans[ , 1]] == 1 | stage.syph[trans[, 1]] %in% c(1,2,3))) & + (rGC[trans[, 2]] == 1 | rCT[trans[ , 2]] == 1 | stage.syph[trans[, 2]] %in% c(1,2,3))) | + #P2 is infected, P1 has urethral STI, P2 has rectal STI OR + (status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 1 | uCT[trans[ , 1]] == 1 | stage.syph[trans[, 1]] %in% c(1,2,3))) & + (rGC[trans[, 2]] == 1 | rCT[trans[ , 2]] == 1 | stage.syph[trans[, 2]] %in% c(1,2,3))))) + + dat$epi$cell2_sti[at] <- length(which( + #P1 is infected, P1 does not have urethral STI, P2 has rectal STI OR + (status[trans[, 1]] == 1 & ((uGC[trans[, 1]] == 0 & uCT[trans[, 1]] == 0 & !(stage.syph[trans[, 1]] %in% c(1,2,3)))) & + (rGC[trans[, 2]] == 1 | rCT[trans[, 2]] == 1 | stage.syph[trans[, 2]] %in% c(1,2,3))) | + #P2 is infected, P1 has urethral STI, P2 does not have rectal STI OR + (status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 1 | uCT[trans[, 1]] == 1 | stage.syph[trans[, 1]] %in% c(1,2,3))) & + (rGC[trans[, 2]] == 0 & rCT[trans[, 2]] == 0 & !(stage.syph[trans[, 2]] %in% c(1,2,3)))))) + + dat$epi$cell3_sti[at] <- length(which( + #P1 is infected, P1 has urethral STI, P2 does not have rectal STI OR + (status[trans[, 1]] == 1 & ((uGC[trans[, 1]] == 1 | uCT[trans[, 1]] == 1 | stage.syph[trans[, 1]] %in% c(1,2,3))) & + (rGC[trans[, 2]] == 0 & rCT[trans[, 2]] == 0 & !(stage.syph[trans[, 2]] %in% c(1,2,3)))) | + #P2 is infected, P1 does not have urethral STI, P2 has rectal STI OR + (status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 0 & uCT[trans[, 1]] == 0 & !(stage.syph[trans[, 1]] %in% c(1,2,3)))) & + (rGC[trans[, 2]] == 1 | rCT[trans[, 2]] == 1 | stage.syph[trans[, 2]] %in% c(1,2,3))))) + + dat$epi$cell4_sti[at] <- length(which( + #P1 is infected, P1 does not have urethral STI, P2 does not have rectal STI OR + (status[trans[, 1]] == 1 & ((uGC[trans[, 1]] == 0 & uCT[trans[, 1]] == 0 & !(stage.syph[trans[, 1]] %in% c(1,2,3)))) & + (rGC[trans[, 2]] == 0 & rCT[trans[, 2]] == 0 & !(stage.syph[trans[, 2]] %in% c(1,2,3)))) | + #P2 is infected, P1 does not have urethral STI, P2 does not have rectal STI OR + (status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 0 & uCT[trans[, 1]] == 0 & !(stage.syph[trans[, 1]] %in% c(1,2,3)))) & + (rGC[trans[, 2]] == 0 & rCT[trans[, 2]] == 0 & !(stage.syph[trans[, 2]] %in% c(1,2,3)))))) + + if (is.null(dat$epi$cell1_rectureth)) { + dat$epi$cell1_rectureth <- rep(NA, length(dat$control$nsteps)) + dat$epi$cell2_rectureth <- rep(NA, length(dat$control$nsteps)) + dat$epi$cell3_rectureth <- rep(NA, length(dat$control$nsteps)) + dat$epi$cell4_rectureth <- rep(NA, length(dat$control$nsteps)) + dat$epi$cell1_gcct_newinf <- rep(NA, length(dat$control$nsteps)) + dat$epi$cell2_gcct_newinf <- rep(NA, length(dat$control$nsteps)) + dat$epi$cell3_gcct_newinf <- rep(NA, length(dat$control$nsteps)) + dat$epi$cell4_gcct_newinf <- rep(NA, length(dat$control$nsteps)) + } + + dat$epi$cell1_rectureth[at] <- length(which( + #P1 is infected, P1 has urethral STI, P2 has rectal STI OR + (status[trans[, 1]] == 1 & ((uGC[trans[, 1]] == 1 | uCT[trans[ , 1]] == 1)) & + (rGC[trans[, 2]] == 1 | rCT[trans[ , 2]] == 1)) | + #P2 is infected, P1 has urethral STI, P2 has rectal STI OR + (status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 1 | uCT[trans[ , 1]] == 1)) & + (rGC[trans[, 2]] == 1 | rCT[trans[ , 2]] == 1)))) + + dat$epi$cell2_rectureth[at] <- length(which( + # Rectal only + #P1 is infected, P1 does not have urethral STI, P2 has rectal STI OR + (status[trans[, 1]] == 1 & ((uGC[trans[, 1]] == 0 & uCT[trans[ , 1]] == 0)) & + (rGC[trans[, 2]] == 1 | rCT[trans[ , 2]] == 1)) | + #P2 is infected, P1 does not have urethral STI, P2 has rectal STI OR + (status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 0 | uCT[trans[ , 1]] == 0)) & + (rGC[trans[, 2]] == 1 | rCT[trans[ , 2]] == 1)))) + + dat$epi$cell3_rectureth[at] <- length(which( + # Insertive only + #P1 is infected, P1 has urethral STI, P2 does not have rectal STI OR + (status[trans[, 1]] == 1 & ((uGC[trans[, 1]] == 1 | uCT[trans[ , 1]] == 1)) & + (rGC[trans[, 2]] == 0 & rCT[trans[ , 2]] == 0)) | + #P2 is infected, P1 has urethral STI, P2 does not have rectal STI OR + (status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 1 | uCT[trans[ , 1]] == 1)) & + (rGC[trans[, 2]] == 0 & rCT[trans[ , 2]] == 0)))) + + dat$epi$cell4_rectureth[at] <- length(which( + #P1 is infected, P1 does not have urethral STI, P2 does not have rectal STI OR + ((status[trans[, 1]] == 1 & ((uGC[trans[, 1]] == 0 & uCT[trans[, 1]] == 0))) & + (rGC[trans[, 2]] == 0 & rCT[trans[, 2]] == 0)) | + #P2 is infected, P1 does not have urethral STI, P2 does not have rectal STI OR + ((status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 0 & uCT[trans[, 1]] == 0))) & + (rGC[trans[, 2]] == 0 & rCT[trans[, 2]] == 0)))) + + + dat$epi$cell1_gcct_newinf[at] <- length(which( + #P1 is infected, P2 has NG and CT + (status[trans[, 1]] == 1 & (rGC[trans[, 2]] == 1 & rCT[trans[ , 2]] == 1)) | + #P2 is infected, P1 has NG and CT + (status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 1 & uCT[trans[ , 1]] == 1))))) + + dat$epi$cell2_gcct_newinf[at] <- length(which( + # GC only + #P1 is infected, P2 has NG and not CT + (status[trans[, 1]] == 1 & (rGC[trans[, 2]] == 1 & rCT[trans[ , 2]] == 0)) | + #P2 is infected, P1 has NG and not CT + (status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 1 & uCT[trans[ , 1]] == 0))))) + + dat$epi$cell3_gcct_newinf[at] <- length(which( + # CT only + #P1 is infected, P2 does not have CT and has CT + (status[trans[, 1]] == 1 & (rGC[trans[, 2]] == 0 & rCT[trans[ , 2]] == 1)) | + #P2 is infected, P1 does not have CT and has CT + (status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 0 & uCT[trans[ , 1]] == 1))))) + + dat$epi$cell4_gcct_newinf[at] <- length(which( + #P1 is infected, P1 does not have urethral STI, P2 does not have rectal STI OR + ((status[trans[, 1]] == 1 & ((uGC[trans[, 1]] == 0 & uCT[trans[, 1]] == 0))) & + (rGC[trans[, 2]] == 0 & rCT[trans[, 2]] == 0)) | + #P2 is infected, P1 does not have urethral STI, P2 does not have rectal STI OR + ((status[trans[, 2]] == 1 & ((uGC[trans[, 1]] == 0 & uCT[trans[, 1]] == 0))) & + (rGC[trans[, 2]] == 0 & rCT[trans[, 2]] == 0)))) + # Summary Output dat$epi$incid[at] <- length(infected) dat$epi$trans.main[at] <- sum(inf.type == 1) - dat$epi$trans.casl[at] <- sum(inf.type == 2) + dat$epi$trans.pers[at] <- sum(inf.type == 2) dat$epi$trans.inst[at] <- sum(inf.type == 3) return(dat) @@ -249,8 +694,20 @@ trans_msm <- function(dat, at) { +# HET ----------------------------------------------------------------- + +#' @title Infection Module +#' +#' @description Module function to simulate transmission over an active +#' discordant edgelist. +#' +#' @inheritParams aging_het +#' +#' @keywords module het +#' #' @export -#' @rdname trans_msm +#' +#' trans_het <- function(dat, at) { ## Discordant Edgelist @@ -396,7 +853,11 @@ discord_edgelist_het <- function(dat, at) { if (nInft > 0) { - el <- dat$el[[1]] + if (is.null(dat$el)) { + el <- get.dyads.active(dat$nw, at = at) + } else { + el <- dat$el + } if (nrow(el) > 0) { el <- el[sample(1:nrow(el)), , drop = FALSE] @@ -405,7 +866,6 @@ discord_edgelist_het <- function(dat, at) { if (length(disc) > 0) { tmp.del <- el[disc, ] tmp.del[status[tmp.del[, 2]] == 1, ] <- tmp.del[status[tmp.del[, 2]] == 1, 2:1] - del <- list() del$sus <- tmp.del[, 2] del$inf <- tmp.del[, 1] diff --git a/R/mod.tx.R b/R/mod.tx.R index 478afcec..e4514dea 100644 --- a/R/mod.tx.R +++ b/R/mod.tx.R @@ -18,13 +18,14 @@ #' #' @return #' This function returns the \code{dat} object with updated \code{tx.status}, -#' \code{tx.init.time}, \code{cum.time.on.tx}, \code{cum.time.off.tx} attributes. +#' \code{tx.init.time}, \code{cum.time.on.tx}, +#' \code{cum.time.off.tx} attributes. #' #' @keywords module msm #' #' @export #' -tx_msm <- function(dat, at) { +hiv_tx_msm <- function(dat, at) { ## Variables @@ -109,8 +110,17 @@ tx_msm <- function(dat, at) { } +#' @title HIV Anti-Retroviral Treatment Module +#' +#' @description Module function for simulating HIV therapy after diagnosis, +#' including adherence and non-adherence to ART. +#' +#' @inheritParams aging_het +#' +#' @keywords module het +#' #' @export -#' @rdname tx_msm +#' tx_het <- function(dat, at) { # Variables --------------------------------------------------------------- diff --git a/R/mod.verbose.R b/R/mod.verbose.R index 1a5ef1ef..79e42c75 100644 --- a/R/mod.verbose.R +++ b/R/mod.verbose.R @@ -58,6 +58,13 @@ verbose_msm <- function(x, type, s, at) { prev.ugc <- round(x$epi$prev.ugc[at], 3) prev.rct <- round(x$epi$prev.rct[at], 3) prev.uct <- round(x$epi$prev.uct[at], 3) + incid.hiv <- round(x$epi$incid[at], 3) + incid.gc <- round(x$epi$incid.gc[at], 3) + incid.ct <- round(x$epi$incid.ct[at], 3) + # incid.syph <- round(x$epi$incid.syph[at], 3) + # prev.syph <- round(x$epi$prev.syph[at], 3) + # prev.pssyph <- round(x$epi$prev.primsecosyph[at], 3) + # prev.hiv.pssyph <- round(x$epi$prev.hiv.primsecosyphpos[at], 3) cat("\014") cat("\nEpidemic Simulation") @@ -69,14 +76,23 @@ verbose_msm <- function(x, type, s, at) { cat("\n------------------------------") cat("\nTotal Pop Size:", x$epi$num[at]) cat("\n------------------------------") - cat("\nHIV Curr Incidence:", x$epi$incid[at]) - cat("\nHIV Cuml Incidence:", sum(x$epi$incid, na.rm = TRUE)) + #cat("\nHIV Curr Incidence:", x$epi$incid[at]) + #cat("\nHIV Cuml Incidence:", sum(x$epi$incid, na.rm = TRUE)) cat("\nHIV Prevalence: ", x$epi$i.num[at], " (", prev, ")", sep = "") - cat("\n------------------------------") cat("\nrGC Prevalence: ", prev.rgc, sep = "") cat("\nuGC Prevalence: ", prev.ugc, sep = "") cat("\nrCT Prevalence: ", prev.rct, sep = "") cat("\nuCT Prevalence: ", prev.uct, sep = "") + # cat("\nSyphilis Prevalence: ", prev.syph, sep = "") + # cat("\nP and S Syphilis Prevalence: ", prev.pssyph, sep = "") + # cat("\nHIV Prevalence in P and S Syphilis: ", prev.hiv.pssyph, sep = "") + cat("\n------------------------------") + cat("\nHIV Incidence: ", incid.hiv, sep = "") + cat("\nGC Incidence: ", incid.gc, sep = "") + cat("\nCT Incidence: ", incid.ct, sep = "") + # cat("\nSyph Incidence: ", incid.syph, sep = "") + + cat("\n==============================") } @@ -88,8 +104,29 @@ verbose_msm <- function(x, type, s, at) { } +#' @title Verbose Module +#' +#' @description Prints simulation model progress within the time loop. +#' +#' @param x If the \code{type} is "startup", then an object of class +#' \code{control.net}, otherwise the all master data object in \code{netsim} +#' simulations. +#' @param type Progress type, either of "startup" for starting messages before +#' all simulations, or "progress" for time step specific messages. +#' @param s Current simulation number, if type is "progress" +#' @param at Current time step, if type is "progress" +#' +#' @details +#' In interactive mode, this module function prints out a standard set of +#' demographic and epidemiologic summary statistics to the console window. In +#' non-interactive, batch mode these are saved onto \code{.txt} files in a +#' \code{verb/} subdirectory. This subdirectory will be created if it does not +#' exist. +#' +#' @keywords module het +#' #' @export -#' @rdname verbose_msm +#' verbose_het <- function(x, type, s, at) { if (type == "startup") { diff --git a/R/mod.vl.R b/R/mod.vl.R index 2ab4da61..dffcb3d4 100644 --- a/R/mod.vl.R +++ b/R/mod.vl.R @@ -16,9 +16,9 @@ #' \code{4}), VL changes depending on current ART use in that time step. #' Current use is associated with a reduction in VL, with the rates of decline #' and nadirs dependent on partial or full suppression levels. Current -#' non-adherence is associated with an equal level of increase to VL. All persons -#' who have reached AIDS, regardless of how they arrived, have a similar rate of -#' VL increase. +#' non-adherence is associated with an equal level of increase to VL. All +#' persons who have reached AIDS, regardless of how they arrived, have a +#' similar rate of VL increase. #' #' @return #' This function returns the \code{dat} object with updated \code{vl} attribute. @@ -27,7 +27,7 @@ #' #' @export #' -vl_msm <- function(dat, at) { +hiv_vl_msm <- function(dat, at) { ## Variables @@ -135,8 +135,17 @@ vl_msm <- function(dat, at) { +#' @title Viral Load Module +#' +#' @description Module function for simulating progression of HIV viral load in +#' natural disease dynamics and in the presence of ART. +#' +#' @inheritParams aging_het +#' +#' @keywords module het +#' #' @export -#' @rdname vl_msm +#' vl_het <- function(dat, at) { ## Common variables diff --git a/R/params.R b/R/params.R index 212f838b..d38442f4 100644 --- a/R/params.R +++ b/R/params.R @@ -12,13 +12,19 @@ #' 1, then race-specific parameters will be averaged. #' @param last.neg.test.B.int Time range in days for last negative test for #' black men. -#' @param mean.test.B.int Mean intertest interval in days for black MSM who test. +#' @param mean.test.B.int Mean intertest interval (days) for black MSM who test. #' @param last.neg.test.W.int Time range in days for last negative test for #' white men. -#' @param mean.test.W.int Mean intertest interval in days for white MSM who test. -#' @param testing.pattern Method for HIV testing, with options \code{"memoryless"} -#' for constant hazard without regard to time since previous test, or -#' \code{"interval"} deterministic fixed intervals. +#' @param mean.test.W.int Mean intertest interval (days) for white MSM who test. +#' @param testing.pattern Method for HIV testing, with options +#' \code{"memoryless"} for constant hazard without regard to time since +#' previous test, or \code{"interval"} deterministic fixed intervals. +#' @param testing.pattern.sti Method for STI testing, with options +#' \code{"memoryless"} for constant hazard without regard to time since +#' previous test, or \code{"interval"} deterministic fixed intervals. +#' @param sti.correlation.time Length of window lookback (weeks) for correlated +#' STI testing (e.g. value of 9 weeks means last test must have been > 9 +#' weeks prior for a particular STI) #' @param test.window.int Length of the HIV test window period in days. #' @param tt.traj.B.prob Proportion of black MSM who enter one of four #' testing/treatment trajectories: never test or treat, test and never @@ -43,8 +49,8 @@ #' @param max.time.off.tx.full.int Number of days off treatment for a full #' suppressor before onset of AIDS, including time before diagnosis. #' @param max.time.on.tx.part.int Number of days on treatment for a -#' partial suppressor beofre onset of AIDS. -#' @param max.time.off.tx.part.int Nnumber of days off treatment for a +#' partial suppressor before onset of AIDS. +#' @param max.time.off.tx.part.int Number of days off treatment for a #' partial suppressor before onset of AIDS, including time before #' diagnosis. #' @param vl.acute.rise.int Number of days to peak viremia during acute @@ -61,8 +67,8 @@ #' @param vl.full.supp Log10 viral load at full suppression on ART. #' @param vl.part.supp Log10 viral load at partial suppression on ART. #' @param full.supp.down.slope For full suppressors, number of log10 units that -#' viral load falls per time step from treatment initiation or re-initiation -#' until the level in \code{vl.full.supp}. +#' viral load falls per time step from treatment initiation or +#' re-initiation until the level in \code{vl.full.supp}. #' @param full.supp.up.slope For full suppressors, number of log10 units that #' viral load rises per time step from treatment halting until expected #' value. @@ -70,7 +76,19 @@ #' that viral load falls per time step from treatment initiation or #' re-initiation until the level in \code{vl.part.supp}. #' @param part.supp.up.slope For partial suppressors, number of log10 units that -#' viral load rises per time step from treatment halting until expected value. +#' viral load rises per time step from treatment halting until +#' expected value. +#' +#' @param incu.syph.int Number of days in incubation stage of syphilis. +#' @param prim.syph.int Number of days in primary stage of syphilis. +#' @param seco.syph.int Number of days in secondary stage of syphilis. +#' @param earlat.syph.int Number of days in early latent stage of syphilis. +#' @param latelat.syph.int Number of days in first late latent stage of syphilis. +#' @param latelatelat.syph.int Number of days in second stage of late latent +#' syphilis for those who will not progress to tertiary infection. +#' @param tert.syph.int Number of days in tertiary stage of syphilis. +#' @param syph.tert.prog.prob Probability of progression from late latent stage +#' of syphilis to tertiary stage at any point in time during late latent. #' @param b.B.rate Rate at which black MSM enter the population. #' @param b.W.rate Rate at which white MSM enter the population. #' @param birth.age Age (in years) of new arrivals. @@ -89,24 +107,24 @@ #' negative insertive partner is circumcised. #' @param condom.rr Relative risk of infection from anal sex when a condom is #' used. -#' @param disc.outset.main.B.prob Probability that an HIV-infected black MSM will -#' disclose his status at the start of a main partnership. -#' @param disc.outset.main.W.prob Probability that an HIV-infected white MSM will -#' disclose his status at the start of a main partnership. -#' @param disc.at.diag.main.B.prob Probability that a black MSM already in a main -#' partnership will disclose at the time of diagnosis. -#' @param disc.at.diag.main.W.prob Probability that a white MSM already in a main -#' partnership will disclose at the time of diagnosis. +#' @param disc.outset.main.B.prob Probability that an HIV-infected black MSM +#' will disclose his status at the start of a main partnership. +#' @param disc.outset.main.W.prob Probability that an HIV-infected white MSM +#' will disclose his status at the start of a main partnership. +#' @param disc.at.diag.main.B.prob Probability that a black MSM already in a +#' main partnership will disclose at the time of diagnosis. +#' @param disc.at.diag.main.W.prob Probability that a white MSM already in a +#' main partnership will disclose at the time of diagnosis. #' @param disc.post.diag.main.B.prob Probability that an HIV-infected black MSM #' in a main partnership will disclose his status, assuming he didn't #' at the start of the partnership or at diagnosis. #' @param disc.post.diag.main.W.prob Probability that an HIV-infected white MSM #' in a main partnership will disclose his status, assuming he didn't #' at the start of the partnership or at diagnosis. -#' @param disc.outset.pers.B.prob Probability that an HIV-infected black MSM will -#' disclose his status at the start of a casual partnership. -#' @param disc.outset.pers.W.prob Probability that an HIV-infected white MSM will -#' disclose his status at the start of a casual partnership. +#' @param disc.outset.pers.B.prob Probability that an HIV-infected black MSM +#' will disclose his status at the start of a casual partnership. +#' @param disc.outset.pers.W.prob Probability that an HIV-infected white MSM +#' will disclose his status at the start of a casual partnership. #' @param disc.at.diag.pers.B.prob Probability that a black MSM already in a #' casual partnership will disclose at the time of diagnosis. #' @param disc.at.diag.pers.W.prob Probability that a white MSM already in a @@ -131,8 +149,8 @@ #' @param ccr5.W.prob Vector of length two of frequencies of the Delta 32 #' mutation (homozygous and heterozygous, respectively) in the CCR5 gene #' among white MSM. -#' @param ccr5.heteroz.rr Relative risk of infection for men who are heterozygous -#' in the CCR5 mutation. +#' @param ccr5.heteroz.rr Relative risk of infection for men who are +#' heterozygous in the CCR5 mutation. #' @param num.inst.ai.classes Number of quantiles into which men should be #' divided in determining their levels of one-off anal intercourse. #' @param base.ai.main.BB.rate Expected coital frequency in black-black main @@ -147,7 +165,9 @@ #' partnerships (acts per day). #' @param base.ai.pers.WW.rate Expected coital frequency in white-white casual #' partnerships (acts per day). -#' @param ai.scale General relative scaler for all act rates for model +#' @param ai.scale.pospos General relative scaler for HIV-positive-concordant +#' act rates for model calibration. +#' @param ai.scale General relative scaler for all other act rates for model #' calibration. #' @param cond.main.BB.prob Probability of condom use in a black-black main #' partnership. @@ -155,24 +175,24 @@ #' partnership. #' @param cond.main.WW.prob Probability of condom use in a white-white main #' partnership. -#' @param cond.pers.always.prob Fraction of men in casual partnerships who always -#' use condoms in those partnerships. +#' @param cond.pers.always.prob Fraction of men in casual partnerships who +#' always use condoms in those partnerships. #' @param cond.pers.BB.prob Of men who are not consistent condom users, per-act #' probability of condom use in a black-black casual partnerships. #' @param cond.pers.BW.prob Of men who are not consistent condom users, per-act #' probability of condom use in a black-white casual partnerships. #' @param cond.pers.WW.prob Of men who are not consistent condom users, per-act #' probability of condom use in a white-white casual partnerships. -#' @param cond.inst.always.prob Fraction of men in instant partnerships who always -#' use condoms in those partnerships. +#' @param cond.inst.always.prob Fraction of men in instant partnerships who +#' always use condoms in those partnerships. #' @param cond.inst.BB.prob Of men who are not consistent condom users, per-act #' probability of condom use in a black-black one-off partnerships. #' @param cond.inst.BW.prob Of men who are not consistent condom users, per-act #' probability of condom use in a black-white one-off partnerships. #' @param cond.inst.WW.prob Of men who are not consistent condom users, per-act #' probability of condom use in a white-white one-off partnerships. -#' @param cond.always.prob.corr Correlation coefficient for probability of always -#' using condoms in both casual and one-off +#' @param cond.always.prob.corr Correlation coefficient for probability of +#' always using condoms in both casual and one-off #' @param cond.rr.BB Condom probability scaler for black-black partnerships for #' model calibration purposes. #' @param cond.rr.BW Condom probability scaler for black-white partnerships for @@ -212,14 +232,14 @@ #' have never been on PrEP and are disease-susceptible. #' @param prep.class.prob The probability of adherence class in non-adherent, #' low adherence, medium adherence, or high adherence groups (from Liu). -#' @param prep.class.hr The hazard ratio for infection per act associated with each -#' level of adherence (from Grant). +#' @param prep.class.hr The hazard ratio for infection per act associated with +#' each level of adherence (from Grant). #' @param prep.coverage The proportion of the eligible population who are start #' PrEP once they become eligible. #' @param prep.cov.method The method for calculating PrEP coverage, with options -#' of \code{"curr"} to base the numerator on the number of people currently -#' on PrEP and \code{"ever"} to base it on the number of people ever on -#' PrEP. +#' of \code{"curr"} to base the numerator on the number of people +#' currently on PrEP and \code{"ever"} to base it on the number of people +#' ever on PrEP. #' @param prep.cov.rate The rate at which persons initiate PrEP conditional on #' their eligibility, with 1 equal to instant start. #' @param prep.tst.int Testing interval for those who are actively on PrEP. This @@ -229,22 +249,140 @@ #' @param prep.risk.reassess If \code{TRUE}, reassess eligibility for PrEP at #' each testing visit. #' +#' @param riskhist.int Interval of look-back period in which risk history is +#' assessed for the STI testing interventions. +#' @param stitest.start Time step at which the STI testing guidelines +#' intervention should start. +#' @param stitest.active.int Intertest interval for lower-risk group in STI +#' testing intervention. +#' @param tst.rect.sti.rr Relative likelihood of rectal STI testing compared to +#' urethral testing among those selected to be tested. +#' @param sti.highrisktest.int Intertest interval for higher-risk group in STI +#' testing intervention. +#' @param stitest.elig.model Modeling approach for determining who is eligible +#' for high-risk STI testing. Current options are limited to: +#' \code{"all"}. +#' @param stianntest.gc.hivneg.coverage The proportion of the eligible population +#' (HIV-negative, HIV-positive and undiagnosed, HIV-positive and +#' diagnosed and tt.traj not equal to a treater type) and who are +#' starting annual NG testing once they become eligible. This is not +#' inclusive of those who are simultaneously indicated for more frequent +#' testing. +#' @param stianntest.ct.hivneg.coverage The proportion of the eligible +#' population (HIV-negative, HIV-positive and undiagnosed, HIV-positive +#' and diagnosed and tt.traj not equal to a treater type) and who are +#' starting annual CT testing once they become eligible. This is not +#' inclusive of those who are simultaneously indicated for more frequent +#' testing. +#' @param stianntest.syph.hivneg.coverage The proportion of the eligible +#' population (HIV-negative, HIV-positive and undiagnosed, HIV-positive +#' and diagnosed and tt.traj not equal to a treater type) and who are +#' starting annual syphilis testing once they become eligible. This is not +#' inclusive of those who are simultaneously indicated for more frequent +#' testing. +#' @param stianntest.gc.hivpos.coverage The proportion of the eligible population +#' (HIV-positive and diagnosed and tt.traj equal to a treater type) who +#' are starting annual NG testing once they become eligible. This is not +#' inclusive of those who are simultaneously indicated for more frequent +#' testing. +#' @param stianntest.ct.hivpos.coverage The proportion of the eligible population +#' (HIV-positive and diagnosed and tt.traj equal to a treater type) who +#' are starting annual CT testing once they become eligible. This is not +#' inclusive of those who are simultaneously indicated for more frequent +#' testing. +#' @param stianntest.syph.hivpos.coverage The proportion of the eligible population +#' (HIV-positive and diagnosed and tt.traj equal to a treater type) who +#' are starting annual syphilis testing once they become eligible. This is not +#' inclusive of those who are simultaneously indicated for more frequent +#' testing. +#' @param stianntest.cov.method The method for calculating STI annual testing, +#' with options of \code{"curr"} to base the numerator on the number of +#' people currently annually testing for STI and \code{"ever"} to base it +#' on the number of people who have ever been annually tested for STI. +#' This is not inclusive of those who are simultaneously indicated for +#' more frequent testing. +#' @param stihighrisktest.gc.hivneg.coverage The proportion of the non-HIV +#' diagnosed eligible population who are starting high-risk NG testing +#' once they become eligible. +#' @param stihighrisktest.ct.hivneg.coverage The proportion of the non-HIV +#' diagnosed eligible population who are starting high-risk CT testing +#' once they become eligible. +#' @param stihighrisktest.syph.hivneg.coverage The proportion of the non-HIV +#' diagnosed eligible population who are starting high-risk syphilis testing +#' once they become eligible. +#' @param stihighrisktest.gc.hivpos.coverage The proportion of the HIV +#' diagnosed eligible population who are starting high-risk NG testing +#' once they become eligible. +#' @param stihighrisktest.ct.hivpos.coverage The proportion of the HIV +#' diagnosed eligible population who are starting high-risk CT testing +#' once they become eligible. +#' @param stihighrisktest.syph.hivpos.coverage The proportion of the HIV +#' diagnosed eligible population who are starting high-risk syphilis testing +#' once they become eligible. +#' @param stihighrisktest.cov.method The method for calculating STI high-risk +#' testing, with options of \code{"curr"} to base the numerator on the +#' number of people currently high-risk testing for STI and \code{"ever"} +#' to base it on the number of people who have ever been high-risk tested +#' for STI. +#' @param partnercutoff The cutoff point for STI high-risk indication, above +#' which person would be indicated for higher-risk testing schedules. +#' +#' @param ept.start Time step at which the EPT intervention should start. +#' @param ept.risk.int Time window for assessment of risk eligibility for EPT +#' in days. +#' @param ept.coverage The proportion of the eligible population (index) who are +#' starting EPT once they become eligible. +#' @param ept.cov.method The method for calculating EPT coverage, with options +#' of \code{"curr"} to base the numerator on the number of people +#' currently on EPT and \code{"ever"} to base it on the number of people +#' ever on EPT. +#' @param ept.cov.rate The rate at which persons initiate EPT conditional on +#' their eligibility, with 1 equal to instant start. +#' @param ept.provision.partner.main.ong The likelihood of a index partner providing +#' EPT medication to a main partner when partnership is ongoing. +#' @param ept.provision.partner.pers.ong The likelihood of a index partner providing +#' EPT medication to a casual partner when partnership is ongoing. +#' @param ept.provision.partner.main.end The likelihood of a index partner providing +#' EPT medication to a main partner when partnership has ended +#' @param ept.provision.partner.pers.end The likelihood of a index partner providing +#' EPT medication to a main partner when partnership has ended. +#' @param ept.provision.partner.inst The likelihood of a index partner providing +#' EPT medication to a one-off partner. +#' @param ept.uptake.partner.main The likelihood of a partner taking medication +#' provided to them by a main index partner. +#' @param ept.uptake.partner.pers The likelihood of a partner taking medication +#' provided to them by a casual index partner. +#' @param ept.uptake.partner.inst The likelihood of a partner taking medication +#' provided to them by a one-off index partner. +#' @param ept.gc.success The probability of effective treatment for GC in a +#' partner given EPT medication. +#' @param ept.ct.success The probability of effective treatment for CT in a +#' partner given EPT medication. +#' #' @param rcomp.prob Level of risk compensation from 0 to 1, where 0 is no risk #' compensation, 0.5 is a 50% reduction in the probability of condom use #' per act, and 1 is a complete cessation of condom use following PrEP #' initiation. #' @param rcomp.adh.groups PrEP adherence groups for whom risk compensation -#' occurs, as a vector with values 0, 1, 2, 3 corresponding to non-adherent, -#' low adherence, medium adherence, and high adherence to PrEP. +#' occurs, as a vector with values 0, 1, 2, 3 corresponding to +#' non-adherent,low adherence, medium adherence, and high adherence +#' to PrEP. #' @param rcomp.main.only Logical, if risk compensation is limited to main #' partnerships only, versus all partnerships. -#' @param rcomp.discl.only Logical, if risk compensation is limited known-discordant -#' partnerships only, versus all partnerships. +#' @param rcomp.discl.only Logical, if risk compensation is limited +#' known-discordant partnerships only, versus all partnerships. #' #' @param rgc.tprob Probability of rectal gonorrhea infection per act. #' @param ugc.tprob Probability of urethral gonorrhea infection per act. #' @param rct.tprob Probability of rectal chlamydia infection per act. #' @param uct.tprob Probability of urethral chlamydia infection per act. +#' @param syph.tprob Base probability of syphilis infection per act. +#' @param syph.incub.rr Multiplier for reduced infection probability in +#' incubating stage of syphilis infection. +#' @param syph.earlat.rr Multiplier for reduced infection probability in early +#' latent stage of syphilis infection. +#' @param syph.late.rr Multiplier for reduced infection probability in late +#' stages of syphilis infection. #' @param rgc.sympt.prob Probability of symptoms given infection with rectal #' gonorrhea. #' @param ugc.sympt.prob Probability of symptoms given infection with urethral @@ -253,38 +391,131 @@ #' chlamydia. #' @param uct.sympt.prob Probability of symptoms given infection with urethral #' chlamydia. -#' @param rgc.asympt.int Average duration in days of asymptomatic rectal gonorrhea. -#' @param ugc.asympt.int Average duration in days of asymptomatic urethral gonorrhea. + +#' @param syph.incub.sympt.prob Probability of symptoms given incubating stage +#' syphilis infection. +#' @param syph.prim.sympt.prob Probability of symptoms given primary stage +#' syphilis infection. +#' @param syph.seco.sympt.prob Probability of symptoms given secondary stage +#' syphilis infection. +#' @param syph.earlat.sympt.prob Probability of symptoms given early latent +#' stage syphilis infection. +#' @param syph.latelat.sympt.prob Probability of symptoms given late latent +#' stage syphilis infection. +#' @param syph.tert.sympt.prob Probability of symptoms given tertiary stage +#' syphilis infection. +#' @param rgc.asympt.rate Average duration in days of asymptomatic rectal +#' gonorrhea. +#' @param ugc.asympt.rate Average duration in days of asymptomatic urethral +#' gonorrhea. #' @param gc.tx.int Average duration in days of treated gonorrhea (both sites). -#' @param gc.ntx.int Average duration in days of untreated, symptomatic gonorrhea (both sites). -#' If \code{NA}, uses site-specific durations for asymptomatic infections. -#' @param rct.asympt.int Average in days duration of asymptomatic rectal chlamydia. -#' @param uct.asympt.int Average in days duration of asymptomatic urethral chlamydia. +#' @param gc.ntx.int Average duration in days of untreated, symptomatic +#' gonorrhea (both sites). If \code{NA}, uses site-specific durations +#' for asymptomatic infections. +#' @param rct.asympt.rate Average in days duration of asymptomatic rectal +#' chlamydia. +#' @param uct.asympt.rate Average in days duration of asymptomatic urethral +#' chlamydia. #' @param ct.tx.int Average in days duration of treated chlamydia (both sites). -#' @param ct.ntx.int Average in days duration of untreated, symptomatic chlamydia (both sites). -#' If \code{NA}, uses site-specific durations for asymptomatic infections. -#' @param gc.prob.cease Probability of ceasing sexual activity during symptomatic -#' infection with gonorrhea. -#' @param ct.prob.cease Probability of ceasing sexual activity during symptomatic -#' infection with chlamydia. +#' @param ct.ntx.int Average in days duration of untreated, symptomatic +#' chlamydia (both sites). If \code{NA}, uses site-specific durations +#' for asymptomatic infections. +#' @param syph.early.tx.int Average in days duration of treatment for early +#' syphilis. +#' @param syph.late.tx.int Average in days duration of treatment for late +#' syphilis. #' @param gc.sympt.prob.tx Probability of treatment for symptomatic gonorrhea. #' @param ct.sympt.prob.tx Probability of treatment for symptomatic chlamydia. -#' @param gc.asympt.prob.tx Probability of treatment for asymptomatic gonorrhea. -#' @param ct.asympt.prob.tx Probability of treatment for asymptomatic chlamydia. -#' @param prep.sti.screen.int Interval in days between STI screening at PrEP visits. -#' @param prep.sti.prob.tx Probability of treatment given positive screening during -#' PrEP visit. -#' @param prep.continue.stand.tx Logical, if \code{TRUE} will continue standard -#' STI treatment of symptomatic cases even after PrEP initiation. +#' @param gc.asympt.prob.tx Probability of treatment, given diagnosis, for +#' asymptomatic gonorrhea. +#' @param ct.asympt.prob.tx Probability of treatment, given diagnosis, for +#' asymptomatic chlamydia. +#' @param syph.incub.sympt.prob.tx Probability of treatment for symptomatic +#' incubating stage syphilis infection. +#' @param syph.incub.asympt.prob.tx Probability of treatment, given diagnosis, +#' for asymptomatic incubating stage syphilis infection. +#' @param syph.prim.sympt.prob.tx Probability of treatment for symptomatic +#' primary stage syphilis infection. +#' @param syph.prim.asympt.prob.tx Probability of treatment, given diagnosis, +#' for asymptomatic primary stage syphilis infection. +#' @param syph.seco.sympt.prob.tx Probability of treatment for symptomatic +#' secondary stage syphilis infection. +#' @param syph.seco.asympt.prob.tx Probability of treatment, given diagnosis, +#' for asymptomatic secondary stage syphilis infection. +#' @param syph.earlat.sympt.prob.tx Probability of treatment for symptomatic +#' early latent stage syphilis infection. +#' @param syph.earlat.asympt.prob.tx Probability of treatment, given diagnosis, +#' for asymptomatic early latent stage syphilis infection. +#' @param syph.latelat.sympt.prob.tx Probability of treatment for symptomatic +#' late latent stage syphilis infection. +#' @param syph.latelat.asympt.prob.tx Probability of treatment, given diagnosis, +#' for asymptomatic late latent stage syphilis infection. +#' @param syph.tert.sympt.prob.tx Probability of treatment for symptomatic +#' tertiary stage syphilis infection. +#' @param syph.tert.asympt.prob.tx Probability of treatment, given diagnosis, +#' for asymptomatic tertiary stage syphilis infection. +#' @param prep.sti.screen.int Interval in days between STI screening at PrEP +#' visits. +#' @param prep.sti.prob.tx Probability of treatment given positive screening +#' during PrEP visit. #' @param sti.cond.rr Relative risk of STI infection (in either direction) given #' a condom used by the insertive partner. -#' @param hiv.rgc.rr Relative risk of HIV infection given current rectal gonorrhea. -#' @param hiv.ugc.rr Relative risk of HIV infection given current urethral gonorrhea. -#' @param hiv.rct.rr Relative risk of HIV infection given current rectal chlamydia. -#' @param hiv.uct.rr Relative risk of HIV infection given current urethral chlamydia. -#' @param hiv.dual.rr Additive proportional risk, from 0 to 1, for HIV infection -#' given dual infection with both gonorrhea and chlamydia. -#' +#' @param hiv.rgc.rr Relative risk of HIV infection given current rectal +#' gonorrhea in the HIV-negative partner. +#' @param hiv.ugc.rr Relative risk of HIV infection given current urethral +#' gonorrhea in the HIV-negative partner. +#' @param hiv.rct.rr Relative risk of HIV infection given current rectal +#' chlamydia in the HIV-negative partner. +#' @param hiv.uct.rr Relative risk of HIV infection given current urethral +#' chlamydia in the HIV-negative partner. +#' @param hiv.syph.rr Relative risk of HIV infection given current +#' syphilis infection in the HIV-negative partner. +#' @param hiv.rgc.rct.rr Additive proportional risk, from 0 to 1, for HIV +#' acquisition given dual infection with both rectal gonorrhea and +#' rectal chlamydia in the HIV-negative partner. +#' @param hiv.rgc.syph.rr Additive proportional risk, from 0 to 1, for HIV +#' acquisition given dual infection with both rectal gonorrhea and +#' syphilis in the HIV-negative partner. +#' @param hiv.rct.syph.rr Additive proportional risk, from 0 to 1, for HIV +#' acquisition given dual infection with both rectal chlamydia and +#' syphilis in the HIV-negative partner. +#' @param hiv.ugc.uct.rr Additive proportional risk, from 0 to 1, for HIV +#' acquisition given dual infection with both urethral gonorrhea and +#' urethral chlamydia in the HIV-negative partner. +#' @param hiv.ugc.syph.rr Additive proportional risk, from 0 to 1, for HIV +#' acquisition given dual infection with both urethral gonorrhea and +#' syphilis in the HIV-negative partner. +#' @param hiv.uct.syph.rr Additive proportional risk, from 0 to 1, for HIV +#' acquisition given dual infection with both urethral chlamydia and +#' syphilis in the HIV-negative partner. +#' @param hiv.all.ureth.rr Additive proportional risk, from 0 to 1, for HIV +#' acquisition given triple infection with urethral chlamydia, urethral +#' gonorrhea, and syphilis in the HIV-negative partner. +#' @param hiv.all.rect.rr Additive proportional risk, from 0 to 1, for HIV +#' acquisition given triple infection with rectal chlamydia, rectal +#' gonorrhea, and syphilis. +#' @param hiv.trans.gc.rr Relative risk for HIV transmission given prevalent +#' relevant site-specific gonorrhea infection in HIV-positive partner. +#' @param hiv.trans.ct.rr Relative risk for HIV transmission given prevalent +#' relevant site-specific chlamydia infection in HIV-positive partner. +#' @param hiv.trans.syph.rr Relative risk for HIV transmission given prevalent +#' relevant syphilis infection in HIV-positive partner. +#' @param hiv.trans.gc.ct.rr Additive proportional risk, from 0 to 1, for HIV +#' transmission given prevalent relevant site-specific gonorrhea +#' infection and relevant site-specific chlamydia infection in +#' HIV-positive partner. +#' @param hiv.trans.gc.syph.rr Additive proportional risk, from 0 to 1, for HIV +#' transmission given prevalent relevant site-specific gonorrhea +#' infection and syphilis infection in HIV-positive partner. +#' @param hiv.trans.ct.syph.rr Additive proportional risk, from 0 to 1, for HIV +#' transmission given prevalent relevant site-specific chlamydia +#' infection and syphilis infection in HIV-positive partner. +#' @param hiv.trans.allsti.rr Additive proportional risk, from 0 to 1, for HIV +#' transmission given prevalent relevant site-specific gonorrhea +#' infection, relevant site-specific chlamydia infection, and syphilis +#' infection in HIV-positive partner. +#' @param partlist.start Time step at which persisting edge list should begin +#' accumulating for eventual STI testing indications. #' @param ... Additional arguments passed to the function. #' #' @return @@ -302,6 +533,8 @@ param_msm <- function(nwstats, mean.test.B.int = 301, mean.test.W.int = 315, testing.pattern = "memoryless", + testing.pattern.sti = "interval", + sti.correlation.time = 0, test.window.int = 21, tt.traj.B.prob = c(0.077, 0.000, 0.356, 0.567), @@ -331,6 +564,17 @@ param_msm <- function(nwstats, part.supp.down.slope = 0.25, part.supp.up.slope = 0.25, + incu.syph.int = 28, + prim.syph.int = 63, + seco.syph.int = 119, + earlat.syph.int = 364 - incu.syph.int - prim.syph.int - seco.syph.int, + latelat.syph.int = 9 * 52 * 7, + latelatelat.syph.int = 20 * 52 * 7, + tert.syph.int = 20 * 52 * 7, + syph.tert.prog.prob = 0.00010776536, + #15% progress by the end of 29 years = + # 0.15 = 1 - (1 - per week prob)^(# of weeks) + b.B.rate = 1e-3 / 7, b.W.rate = 1e-3 / 7, birth.age = 18, @@ -371,7 +615,8 @@ param_msm <- function(nwstats, base.ai.pers.BB.rate = 0.11, base.ai.pers.BW.rate = 0.16, base.ai.pers.WW.rate = 0.14, - ai.scale = 1.15, + ai.scale = 1.061338, + ai.scale.pospos = 1.061338, cond.main.BB.prob = 0.38, cond.main.BW.prob = 0.10, @@ -399,6 +644,7 @@ param_msm <- function(nwstats, vv.iev.BW.prob = 0.56, vv.iev.WW.prob = 0.49, + # PrEP intervention prep.start = Inf, prep.elig.model = "base", prep.class.prob = c(0.211, 0.07, 0.1, 0.619), @@ -410,50 +656,159 @@ param_msm <- function(nwstats, prep.risk.int = 182, prep.risk.reassess = TRUE, + # STD testing intervention + riskhist.int = 182, + stitest.start = 1, + stitest.active.int = 364, + tst.rect.sti.rr = 1, + sti.highrisktest.int = 182, + stitest.elig.model = "all", + stianntest.gc.hivneg.coverage = 0.44, + stianntest.ct.hivneg.coverage = 0.44, + stianntest.syph.hivneg.coverage = 0.0, + stihighrisktest.gc.hivneg.coverage = 0.0, + stihighrisktest.ct.hivneg.coverage = 0.0, + stihighrisktest.syph.hivneg.coverage = 0.0, + stianntest.gc.hivpos.coverage = 0.61, + stianntest.ct.hivpos.coverage = 0.61, + stianntest.syph.hivpos.coverage = 0.0, + stihighrisktest.gc.hivpos.coverage = 0.0, + stihighrisktest.ct.hivpos.coverage = 0.0, + stihighrisktest.syph.hivpos.coverage = 0.0, + stianntest.cov.method = "curr", + stihighrisktest.cov.method = "curr", + partnercutoff = 1, + + # EPT intervention + ept.start = Inf, + ept.risk.int = 60, + ept.coverage = 0, + ept.cov.method = "curr", + ept.cov.rate = 1, + ept.provision.partner.main.ong = 0.5, + ept.provision.partner.pers.ong = 0.4, + ept.provision.partner.main.end = 0.4, + ept.provision.partner.pers.end = 0.3, + ept.provision.partner.inst = 0.2, + ept.uptake.partner.main = 0.8, + ept.uptake.partner.pers = 0.8, + ept.uptake.partner.inst = 0.8, + ept.gc.success = 1.0, + ept.ct.success = 1.0, + rcomp.prob = 0, rcomp.adh.groups = 0:3, rcomp.main.only = FALSE, rcomp.discl.only = FALSE, - rgc.tprob = 0.357698, - ugc.tprob = 0.248095, - rct.tprob = 0.321597, - uct.tprob = 0.212965, - - rgc.sympt.prob = 0.076975, - ugc.sympt.prob = 0.824368, - rct.sympt.prob = 0.103517, - uct.sympt.prob = 0.885045, - - rgc.asympt.int = 35.11851 * 7, - ugc.asympt.int = 35.11851 * 7, - gc.tx.int = 2 * 7, + rgc.tprob = 0.5364416, + ugc.tprob = 0.434692, + rct.tprob = 0.2493814, + uct.tprob = 0.1944415, + + syph.tprob = 0.1464, + syph.incub.rr = 0, + syph.earlat.rr = 0.25, + syph.late.rr = 0, + + rgc.sympt.prob = 0.16, # Beck + ugc.sympt.prob = 0.80, # Beck - 0.10 + rct.sympt.prob = 0.14, # Beck + uct.sympt.prob = 0.48, # Beck - 0.10 + + syph.incub.sympt.prob = 0, + syph.prim.sympt.prob = 0.50, + syph.seco.sympt.prob = 0.85, + syph.earlat.sympt.prob = 0, + syph.latelat.sympt.prob = 0, + syph.tert.sympt.prob = 1.0, + + rgc.asympt.rate = 1/(24.78753*7), + ugc.asympt.rate = 1/(24.78753*7), + gc.tx.int = 7, gc.ntx.int = NA, - rct.asympt.int = 44.24538 * 7, - uct.asympt.int = 44.24538 * 7, - ct.tx.int = 2 * 7, + rct.asympt.rate = 1/(44.28232*7), + uct.asympt.rate = 1/(44.28232*7), + ct.tx.int = 7, ct.ntx.int = NA, - gc.prob.cease = 0, - ct.prob.cease = 0, + syph.early.tx.int = 7, + syph.late.tx.int = 3*7, gc.sympt.prob.tx = 0.90, ct.sympt.prob.tx = 0.85, - gc.asympt.prob.tx = 0, - ct.asympt.prob.tx = 0, + gc.asympt.prob.tx = 1, + ct.asympt.prob.tx = 1, + + # Weighted averages to get to Tuite numbers: + # y = 10% background screening + # Primary = 0.35 overall + # 50% symptomatic + # 0.50 (x) + 0.50 (y) = 0.35 + # x = 0.60 + # + # Secondary = 0.60 overall + # 85% symptomatic + # 0.85 (x) + 0.15 (y) = 0.60 + # x = 0.688235 + # + # Latent stage = 0.10 overall + # 0% symptomatic + # 0.00 (x) + 1.00 (y) = 0.10 + # x = 0 + # + # Tertiary = 1.00 overall + # 100% symptomatic + # 1.00 (x) + 0.00 (y) = 1.0 + # x = 1.00 + + syph.incub.sympt.prob.tx = 0, + syph.incub.asympt.prob.tx = 0, + syph.prim.sympt.prob.tx = 0.60, + syph.prim.asympt.prob.tx = 1, + syph.seco.sympt.prob.tx = 0.688235, + syph.seco.asympt.prob.tx = 1, + syph.earlat.sympt.prob.tx = 0.10, + syph.earlat.asympt.prob.tx = 1, + syph.latelat.sympt.prob.tx = 0.10, + syph.latelat.asympt.prob.tx = 1, + syph.tert.sympt.prob.tx = 1, + syph.tert.asympt.prob.tx = 1, prep.sti.screen.int = 182, prep.sti.prob.tx = 1, - prep.continue.stand.tx = TRUE, sti.cond.rr = 0.3, - hiv.rgc.rr = 2.780673, - hiv.ugc.rr = 1.732363, - hiv.rct.rr = 2.780673, - hiv.uct.rr = 1.732363, - hiv.dual.rr = 0.2, + # Acquisition + hiv.rgc.rr = 2.175918, + hiv.ugc.rr = 1.564797, + hiv.rct.rr = 2.175918, + hiv.uct.rr = 1.564797, + hiv.syph.rr = 1.62, + hiv.rgc.rct.rr = 0.2, + hiv.rgc.syph.rr = 0.2, + hiv.rct.syph.rr = 0.2, + hiv.ugc.uct.rr = 0.2, + hiv.ugc.syph.rr = 0.2, + hiv.uct.syph.rr = 0.2, + hiv.all.ureth.rr = 0.2, + hiv.all.rect.rr = 0.2, + + # Transmission + hiv.trans.gc.rr = 1, + hiv.trans.ct.rr = 1, + hiv.trans.syph.rr = 1, + hiv.trans.gc.ct.rr = 0.2, + hiv.trans.gc.syph.rr = 0.2, + hiv.trans.ct.syph.rr = 0.2, + hiv.trans.allsti.rr = 0.2, + + # Cumulative partnership list + partlist.start = NULL, + + ...) { p <- get_args(formal.args = formals(sys.function()), @@ -461,7 +816,7 @@ param_msm <- function(nwstats, if (!(testing.pattern %in% c("memoryless", "interval"))) { stop("testing.pattern must be \"memoryless\" or \"interval\" ", - call. = FALSE) + call. = FALSE) } if (race.method == 1) { @@ -487,18 +842,12 @@ param_msm <- function(nwstats, p$circ.W.prob = (circ.B.prob + circ.W.prob)/2 p$ccr5.B.prob = (ccr5.B.prob + ccr5.W.prob)/2 p$ccr5.W.prob = (ccr5.B.prob + ccr5.W.prob)/2 - p$base.ai.main.BB.rate = (base.ai.main.BB.rate + base.ai.main.BW.rate + - base.ai.main.WW.rate)/3 - p$base.ai.main.BW.rate = (base.ai.main.BB.rate + base.ai.main.BW.rate + - base.ai.main.WW.rate)/3 - p$base.ai.main.WW.rate = (base.ai.main.BB.rate + base.ai.main.BW.rate + - base.ai.main.WW.rate)/3 - p$base.ai.pers.BB.rate = (base.ai.pers.BB.rate + base.ai.pers.BW.rate + - base.ai.pers.WW.rate)/3 - p$base.ai.pers.BW.rate = (base.ai.pers.BB.rate + base.ai.pers.BW.rate + - base.ai.pers.WW.rate)/3 - p$base.ai.pers.WW.rate = (base.ai.pers.BB.rate + base.ai.pers.BW.rate + - base.ai.pers.WW.rate)/3 + p$base.ai.main.BB.rate = (base.ai.main.BB.rate + base.ai.main.BW.rate + base.ai.main.WW.rate)/3 + p$base.ai.main.BW.rate = (base.ai.main.BB.rate + base.ai.main.BW.rate + base.ai.main.WW.rate)/3 + p$base.ai.main.WW.rate = (base.ai.main.BB.rate + base.ai.main.BW.rate + base.ai.main.WW.rate)/3 + p$base.ai.pers.BB.rate = (base.ai.pers.BB.rate + base.ai.pers.BW.rate + base.ai.pers.WW.rate)/3 + p$base.ai.pers.BW.rate = (base.ai.pers.BB.rate + base.ai.pers.BW.rate + base.ai.pers.WW.rate)/3 + p$base.ai.pers.WW.rate = (base.ai.pers.BB.rate + base.ai.pers.BW.rate + base.ai.pers.WW.rate)/3 p$cond.main.BB.prob = (cond.main.BB.prob + cond.main.BW.prob + cond.main.WW.prob)/3 p$cond.main.BW.prob = (cond.main.BB.prob + cond.main.BW.prob + cond.main.WW.prob)/3 p$cond.main.WW.prob = (cond.main.BB.prob + cond.main.BW.prob + cond.main.WW.prob)/3 @@ -531,7 +880,14 @@ param_msm <- function(nwstats, nrow = 3) - p$riskh.start <- max(1, prep.start - prep.risk.int - 1) + p$riskh.prep.start <- max(1, prep.start - prep.risk.int - 1) + p$riskh.stitest.start <- max(1, stitest.start - riskhist.int - 1) + p$riskh.ept.start <- max(1, ept.start - ept.risk.int - 1) + + if (is.null(p$partlist.start)) { + p$partlist.start <- min((p$riskh.stitest.start), + (p$riskh.ept.start)) + } p$method <- nwstats$method p$modes <- 1 @@ -559,6 +915,14 @@ param_msm <- function(nwstats, #' @param prev.rgc Initial prevalence of rectal gonorrhea. #' @param prev.uct Initial prevalence of urethral chlamydia. #' @param prev.rct Initial prevalence of rectal chlamydia. +#' @param prev.syph.B Initial prevalence of syphilis among black MSM +#' @param prev.syph.W Initial prevalence of syphilis among white MSM +#' @param stage.syph.B.prob Proportion of black MSM who enter one of the seven +#' active stages of syphilis: incubating, primary, secondary, early +#' latent, late latent, late late latent, and tertiary. +#' @param stage.syph.W.prob Proportion of white MSM who enter one of the seven +#' active stages of syphilis: incubating, primary, secondary, early +#' latent, late latent, late late latent, and tertiary. #' @param ... Additional arguments passed to function. #' #' @return @@ -569,12 +933,16 @@ param_msm <- function(nwstats, #' #' @export init_msm <- function(nwstats, - prev.B = 0.253, - prev.W = 0.253, - prev.ugc = 0.005, - prev.rgc = 0.005, - prev.uct = 0.013, - prev.rct = 0.013, + prev.B = 0.149006, + prev.W = 0.149006, + prev.ugc = 0.001471584, + prev.rgc = 0.001471584, + prev.uct = 0.007572175, + prev.rct = 0.007572175, + prev.syph.B = 0, + prev.syph.W = 0, + stage.syph.B.prob = c(0.40, 0.20, 0.20, 0.20, 0.00, 0.00), + stage.syph.W.prob = c(0.40, 0.20, 0.20, 0.20, 0.00, 0.00), ...) { p <- get_args(formal.args = formals(sys.function()), @@ -610,34 +978,40 @@ init_msm <- function(nwstats, #' simulation. This may also be set to 1 greater than the final time #' step of a previous simulation to resume the simulation with different #' parameters. -#' @param initialize.FUN Module function to use for initialization of the epidemic -#' model. +#' @param initialize.FUN Module function to use for initialization of the +#' epidemic model. #' @param aging.FUN Module function for aging. #' @param deaths.FUN Module function for general and disease-realted deaths. #' @param births.FUN Module function for births or entries into the population. -#' @param test.FUN Module function for diagnostic disease testing. -#' @param tx.FUN Module function for ART initiation and adherence. +#' @param hiv_test.FUN Module function for diagnostic disease testing. +#' @param sti_test.FUN Module function for diagnostic testing for STIs +#' @param hiv_tx.FUN Module function for ART initiation and adherence. #' @param prep.FUN Module function for PrEP initiation and utilization. -#' @param progress.FUN Module function for HIV disease progression. -#' @param vl.FUN Module function for HIV viral load evolution. +#' @param hiv_progress.FUN Module function for HIV disease progression. +#' @param syph_progress.FUN Module function for syphilis disease progression +#' @param hiv_vl.FUN Module function for HIV viral load evolution. #' @param aiclass.FUN Module function for one-off AI risk class transitions. #' @param roleclass.FUN Module function for transitions in sexual roles. #' @param resim_nets.FUN Module function for network resimulation at each time #' step. -#' @param disclose.FUN Module function for HIV status disclosure. +#' @param hiv_disclose.FUN Module function for HIV status disclosure. +#' @param part.FUN Module function for creating master partnership matrix. #' @param acts.FUN Module function to simulate the number of sexual acts within #' partnerships. #' @param condoms.FUN Module function to simulate condom use within acts. -#' @param riskhist.FUN Module function to calculate risk history for uninfected -#' persons in the population. +#' @param riskhist_prep.FUN Module function to calculate risk history for uninfected +#' persons in the population within a PrEP intervention. +#' @param riskhist_stitest.FUN Module function to calculate risk history for uninfected +#' persons in the population within a STI testing intervention. #' @param position.FUN Module function to simulate sexual position within acts. -#' @param trans.FUN Module function to stochastically simulate HIV transmission +#' @param hiv_trans.FUN Module function to stochastically simulate HIV transmission #' over acts given individual and dyadic attributes. -#' @param stitrans.FUN Module function to simulate GC/CT transmission over current -#' edgelist. -#' @param stirecov.FUN Module function to simulate recovery from GC/CT, heterogeneous -#' by disease, site, symptoms, and treatment status. -#' @param stitx.FUN Module function to simulate treatment of GC/CT. +#' @param sti_trans.FUN Module function to simulate GC/CT transmission over +#' current edgelist. +#' @param sti_recov.FUN Module function to simulate recovery from GC/CT, +#' heterogeneous by disease, site, symptoms, and treatment status. +#' @param sti_tx.FUN Module function to simulate treatment of GC/CT. +#' @param sti_ept.FUN Module function for EPT intervention #' @param prev.FUN Module function to calculate prevalence summary statistics. #' @param verbose.FUN Module function to print model progress to the console or #' external text files. @@ -645,8 +1019,8 @@ init_msm <- function(nwstats, #' \code{simnet} modules. #' @param verbose If \code{TRUE}, print out simulation progress to the console #' if in interactive mode or text files if in batch mode. -#' @param verbose.int Integer specifying the interval between time steps at which -#' progress is printed. +#' @param verbose.int Integer specifying the interval between time steps at +#' which progress is printed. #' @param ... Additional arguments passed to the function. #' #' @return @@ -665,24 +1039,29 @@ control_msm <- function(simno = 1, aging.FUN = aging_msm, deaths.FUN = deaths_msm, births.FUN = births_msm, - test.FUN = test_msm, - tx.FUN = tx_msm, + hiv_test.FUN = hiv_test_msm, + sti_test.FUN = sti_test_msm, + hiv_tx.FUN = hiv_tx_msm, prep.FUN = prep_msm, - progress.FUN = progress_msm, - vl.FUN = vl_msm, + hiv_progress.FUN = hiv_progress_msm, + syph_progress.FUN = NULL, #syph_progress_msm, + hiv_vl.FUN = hiv_vl_msm, aiclass.FUN = NULL, roleclass.FUN = NULL, resim_nets.FUN = simnet_msm, - disclose.FUN = disclose_msm, + hiv_disclose.FUN = hiv_disclose_msm, + part.FUN = part_msm, acts.FUN = acts_msm, condoms.FUN = condoms_msm, - riskhist.FUN = riskhist_msm, + riskhist_prep.FUN = NULL, #riskhist_prep_msm, + riskhist_stitest.FUN = riskhist_stitest_msm, position.FUN = position_msm, - trans.FUN = trans_msm, - stitrans.FUN = sti_trans, - stirecov.FUN = sti_recov, - stitx.FUN = sti_tx, - prev.FUN = prevalence_msm, + hiv_trans.FUN = hiv_trans_msm, + sti_trans.FUN = sti_trans_msm, + sti_recov.FUN = sti_recov_msm, + sti_tx.FUN = sti_tx_msm, + sti_ept.FUN = sti_ept_msm, + prev.FUN = prevalence_msm_ept, verbose.FUN = verbose_msm, save.nwstats = FALSE, verbose = TRUE, @@ -742,19 +1121,22 @@ control_msm <- function(simno = 1, #' @param act.rate.late Daily per-partnership act rate in late disease. #' @param act.rate.cd4 CD4 count at which the \code{act.rate.late} applies. #' @param acts.rand If \code{TRUE}, will draw number of total and unprotected -#' acts from a binomial distribution parameterized by the \code{act.rate}. +#' acts from a binomial distribution parameterized by the +#' \code{act.rate}. #' #' @param circ.prob.birth Proportion of men circumcised at birth. #' @param circ.eff Efficacy of circumcision per act in HIV prevention. #' -#' @param tx.elig.cd4 CD4 count at which a person becomes eligible for treatment. +#' @param tx.elig.cd4 CD4 count at which a person becomes eligible for +#' treatment. #' @param tx.init.cd4.mean Mean CD4 count at which person presents for care. #' @param tx.init.cd4.sd SD of CD4 count at which person presents for care. #' @param tx.adhere.full Proportion of people who start treatment who are fully #' adherent. -#' @param tx.adhere.part Of the not fully adherent proportion, the percent of time -#' they are on medication. -#' @param tx.vlsupp.time Time in days from treatment initiation to viral suppression. +#' @param tx.adhere.part Of the not fully adherent proportion, the percent of +#' time they are on medication. +#' @param tx.vlsupp.time Time in days from treatment initiation to +#' viral suppression. #' @param tx.vlsupp.level Log 10 viral load level at suppression. #' @param tx.cd4.recrat.feml Rate of CD4 recovery under treatment for males. #' @param tx.cd4.recrat.male Rate of CD4 recovery under treatment for females. @@ -762,19 +1144,17 @@ control_msm <- function(simno = 1, #' for females. #' @param tx.cd4.decrat.male Rate of CD4 decline under periods of non-adherence #' for males. -#' @param tx.coverage Proportion of treatment-eligible persons who have initiated -#' treatment. +#' @param tx.coverage Proportion of treatment-eligible persons who have +#' initiated treatment. #' @param tx.prev.eff Proportional amount by which treatment reduces infectivity #' of infected partner. -#' #' @param b.rate General entry rate per day for males and females specified. -#' @param b.rate.method Method for assigning birth rates, with options of "totpop" -#' for births as a function of the total population size, "fpop" for births -#' as a function of the female population size, and "stgrowth" for a constant -#' stable growth rate. +#' @param b.rate.method Method for assigning birth rates, with options of +#' "totpop" for births as a function of the total population size, +#' "fpop" for births as a function of the female population size, and +#' "stgrowth" for a constant stable growth rate. #' @param b.propmale Proportion of entries assigned as male. If NULL, then set #' adaptively based on the proportion at time 1. -#' #' @param ds.exit.age Age at which the age-specific ds.rate is set to 1, with NA #' value indicating no censoring. #' @param ds.rate.mult Simple multiplier for background death rates. @@ -918,13 +1298,15 @@ param_het <- function(time.unit = 7, #' @param ages.male initial ages of males in the population. #' @param ages.feml initial ages of females in the population. #' @param inf.time.dist Probability distribution for setting time of infection -#' for nodes infected at T1, with options of \code{"geometric"} for randomly -#' distributed on a geometric distribution with a probability of the -#' reciprocal of the average length of infection, \code{"uniform"} for a -#' uniformly distributed time over that same interval, or \code{"allacute"} for -#' placing all infections in the acute stage at the start. -#' @param max.inf.time Maximum infection time in days for infection at initialization, -#' used when \code{inf.time.dist} is \code{"geometric"} or \code{"uniform"}. +#' for nodes infected at T1, with options of \code{"geometric"} for +#' randomly distributed on a geometric distribution with a probability +#' of the reciprocal of the average length of infection, \code{"uniform"} +#' for a uniformly distributed time over that same interval, or +#' \code{"allacute"} for placing all infections in the acute stage at +#' the start. +#' @param max.inf.time Maximum infection time in days for infection at +#' initialization, used when \code{inf.time.dist} is \code{"geometric"} +#' or \code{"uniform"}. #' @param ... additional arguments to be passed into model. #' #' @details This function sets the initial conditions for the models. @@ -974,14 +1356,14 @@ init_het <- function(i.prev.male = 0.05, #' network models in the \code{epimethods} package. #' #' @param simno Simulation ID number. -#' @param nsteps Number of time steps to simulate the model over in whatever unit -#' implied by \code{time.unit}. +#' @param nsteps Number of time steps to simulate the model over in whatever +#' unit implied by \code{time.unit}. #' @param start Starting time step for simulation #' @param nsims Number of simulations. #' @param ncores Number of parallel cores to use for simulation jobs, if using #' the \code{EpiModel.hpc} package. -#' @param par.type Parallelization type, either of \code{"single"} for multi-core -#' or \code{"mpi"} for multi-node MPI threads. +#' @param par.type Parallelization type, either of \code{"single"} for +#' multi-core or \code{"mpi"} for multi-node MPI threads. #' @param initialize.FUN Module to initialize the model at time 1. #' @param aging.FUN Module to age active nodes. #' @param cd4.FUN CD4 progression module. @@ -1000,8 +1382,8 @@ init_het <- function(i.prev.male = 0.05, #' order in which they should be evaluated within each time step. If #' \code{NULL}, the modules will be evaluated as follows: first any #' new modules supplied through \code{...} in the order in which they are -#' listed, then the built-in modules in their order of the function listing. -#' The \code{initialize.FUN} will always be run first and the +#' listed, then the built-in modules in their order of the function +#' listing. The \code{initialize.FUN} will always be run first and the #' \code{verbose.FUN} always last. #' @param save.nwstats Save out network statistics. #' @param save.other Other list elements of dat to save out. diff --git a/R/utilities.R b/R/utilities.R index 6b27421a..5b5fae70 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -106,38 +106,6 @@ reallocate_pcp <- function(in.pcp = c(0.211, 0.07, 0.1, 0.619), reall = 0) { } -#' @title Truncate Simulation Time Series -#' -#' @description Left-truncates a simulation epidemiological summary statistics and -#' network statistics at a specified time step. -#' -#' @param x Object of class \code{netsim}. -#' @param at Time step at which to left-truncate the time series. -#' -#' @details -#' This function would be used when running a follow-up simulation from time steps -#' \code{b} to \code{c} after a burnin period from time \code{a} to \code{b}, -#' where the final time window of interest for data analysis is \code{b} to \code{c} -#' only. -#' -#' @export -#' -truncate_sim <- function(x, at) { - - rows <- at:(x$control$nsteps) - - # epi - x$epi <- lapply(x$epi, function(r) r[rows, ]) - - # control settings - x$control$start <- 1 - x$control$nsteps <- max(seq_along(rows)) - - return(x) -} - - - #' @title Source All Files in a Directory #' #' @description Loops over all files in a directory to source them to the diff --git a/README.md b/README.md index ea15ab3a..d51aab79 100644 --- a/README.md +++ b/README.md @@ -3,18 +3,39 @@ EpiModelHIV [![Build Status](https://travis-ci.org/statnet/EpiModelHIV.svg?branch=master)](https://travis-ci.org/statnet/EpiModelHIV) -Modules for simulating HIV/STI transmission dynamics among men who have sex with men and heterosexual populations, developed as an extension to our general network-based epidemic modeling platform **[EpiModel](http://epimodel.org)**. +An R package for simulating HIV transmission dynamics among men who have sex with men and heterosexual populations, developed as an extension to our general network-based epidemic modeling platform, [EpiModel](http://epimodel.org). -`EpiModel` and `EpiModelHIV` use the statistical framework of temporal exponential-family random graph models to fit and simulate models of dynamic networks. These **[Statistical Methods](http://onlinelibrary.wiley.com/doi/10.1111/rssb.12014/abstract)** have been developed and implemented as open-source software, building on the extensive efforts of the **[Statnet](https://statnet.org/)** research group to build software tools for the representation, analysis, and visualization of complex network data. +`EpiModel` and `EpiModelHIV` use the statistical framework of temporal exponential-family random graph models to fit and simulate models of dynamic networks. These [statistical methods](http://onlinelibrary.wiley.com/doi/10.1111/rssb.12014/abstract) have been developed and implemented as open-source software, building on the extensive efforts of the [Statnet](https://statnet.org/) research group to build software tools for the representation, analysis, and visualization of complex network data. -These packages combine these Statnet methods with an agent-based epidemic modeling engine to simulate HIV transmission over networks, allowing for complex dependencies between the network, epidemiological, and demographic changes in the simulated populations. Readers new to these methods are recommended to consult our **[EpiModel](http://epimodel.org)** resources, including EpiModel's main **[Methods Paper](http://doi.org/10.18637/jss.v084.i08)** describing the theory and implementation. +These packages combine these Statnet methods with an agent-based epidemic modeling engine to simulate HIV transmission over networks, allowing for complex dependencies between the network, epidemiological, and demographic changes in the simulated populations. Readers new to these methods are recommended to consult our [EpiModel](http://epimodel.org) resources, including our main [Vignette](http://statnet.github.io/tut/EpiModelVignette.pdf) describe the theory and implementation. ## Installation -You can install `EpiModelHIV` in R using `remotes`: +You can install `EpiModelHIV` in R using `devtools`: ``` install.packages("EpiModel", dependencies = TRUE) -remotes::install_github("statnet/tergmLite") -remotes::install_github("statnet/EpiModelHPC") -remotes::install_github("statnet/EpiModelHIV") +devtools::install_github("statnet/tergmLite") +devtools::install_github("statnet/EpiModelHIV") ``` + +Documentation on using this software package is forthcoming, although limited function documentation is provided within the package and available with the `help(package = "EpiModelHIV")` command. + +### Note on Repository and Package Name +This Github repository `EpiModelHIV` and the R package within it were previously named `EpiModelHIVmsm`. On 6/24/2016, we merged that MSM package with our `EpiModelHIVhet` (HIV models for heterosexuals) into this combined repository and package. All scripts from those separate packages should still function with this current version after changing the input to `library`. + +## Software Development Team + +Author | Department | Institution +------------------------------------------------------------- | -------------------------- | ------------------------ +[Samuel M. Jenness](http://samueljenness.org/) | Department of Epidemiology | Emory University +[Steven M. Goodreau](http://faculty.washington.edu/goodreau/) | Department of Anthropology | University of Washington + + +## Literature + +`EpiModelHIV` has been used in the following scientific articles: + +1. Jenness SM, Goodreau SM, Morris M, Cassels S. Effectiveness of Combination Packages for HIV-1 Prevention in Sub-Saharan Africa Depends on Partnership Network Structure. _Sexually Transmitted Infections._ [DOI: 10.1136/sextrans-2015-052476.](http://sti.bmj.com/content/early/2016/06/09/sextrans-2015-052476.abstract) + +2. Jenness SM, Goodreau SM, Rosenberg E, Beylerian EN, Hoover KW, Smith DK, Sullivan P. Impact of CDC’s HIV Preexposure Prophylaxis Guidelines among MSM in the United States. _Journal of Infectious Diseases._ [DOI: 10.1093/infdis/jiw223.](http://jid.oxfordjournals.org/content/early/2016/07/12/infdis.jiw223.full) + diff --git a/inst/netsim.mods.R b/inst/netsim.mods.R index a6ddd751..6058df5a 100644 --- a/inst/netsim.mods.R +++ b/inst/netsim.mods.R @@ -1,51 +1,141 @@ rm(list = ls()) suppressMessages(library("EpiModelHIV")) +suppressMessages(library("dplyr")) +devtools::load_all() -data(est) -data(st) +load("data/est.rda") +load("data/st.rda") +# data(st) +# data(est) +# load("est/nwstats.rda") +# load("est/fit.rda") +# load("data/stimod.burnin.rda") param <- param_msm(nwstats = st, - ai.scale = 1.323, - prep.coverage = 0) + + ai.scale = 1.04, + ai.scale.pospos = 1.04, + + tst.rect.sti.rr = 1, + + # STI acquisition + rgc.tprob = 0.54, #0.5161, #0.513, + ugc.tprob = 0.46, #0.4362, # 0.432 + rct.tprob = 0.315, #0.2813, #0.2797, + uct.tprob = 0.265, #0.2195, # 0.2165, + syph.tprob = 0.26, #0.1206, #0.1206, + + # HIV acquisition + hiv.rgc.rr = 1.97, #1.75, + hiv.ugc.rr = 1.48, #1.27, + hiv.rct.rr = 1.97, #1.75, + hiv.uct.rr = 1.48, #1.27, + hiv.syph.rr = 1.64, + + syph.incub.sympt.prob = 0, + syph.prim.sympt.prob = 0.82, + syph.seco.sympt.prob = 0.90, + syph.earlat.sympt.prob = 0, + syph.latelat.sympt.prob = 0, + syph.tert.sympt.prob = 1.0, + + syph.prim.sympt.prob.tx = 0.85, + syph.seco.sympt.prob.tx = 0.85, + syph.earlat.sympt.prob.tx = 0.10, + syph.latelat.sympt.prob.tx = 0.10, + syph.tert.sympt.prob.tx = 1.0, + + ept.coverage = 0.0, + stianntest.gc.hivneg.coverage = 0.34, + stianntest.ct.hivneg.coverage = 0.34, + stianntest.syph.hivneg.coverage = 0.34, #0.44, # 0.45 + stihighrisktest.gc.hivneg.coverage = 0.01, + stihighrisktest.ct.hivneg.coverage = 0.01, + stihighrisktest.syph.hivneg.coverage = 0.01, + stianntest.gc.hivpos.coverage = 0.51, + stianntest.ct.hivpos.coverage = 0.51, + stianntest.syph.hivpos.coverage = 0.51, #0.65, #0.67 + stihighrisktest.gc.hivpos.coverage = 0.01, + stihighrisktest.ct.hivpos.coverage = 0.01, + stihighrisktest.syph.hivpos.coverage = 0.01, + + prep.start = 7000, + stitest.start = 1, + ept.start = 5201, + + #partlist.start = 1, + stitest.active.int = 364, + sti.highrisktest.int = 182, + ept.risk.int = 60) + init <- init_msm(nwstats = st, - prev.B = 0.253, - prev.W = 0.253) -control <- control_msm(simno = 0.253, - nsteps = 52, - nsims = 5, - ncores = 1, - save.nwstats = TRUE, - verbose.int = 1) -# sim <- netsim(est, param, init, control) + prev.B = 0.10, + prev.W = 0.10, + prev.ugc = 0.010, + prev.rgc = 0.010, + prev.uct = 0.010, + prev.rct = 0.010, + prev.syph.B = 0, + prev.syph.W = 0) + +control <- control_msm(nsteps = 20, + prev.FUN = prevalence_msm_tnt) -# debug(stergm_prep) +# control <- control_msm(start = 5201, +# nsteps = 5210) +sim <- netsim(est, param, init, control) + +# debug(initialize_msm) +# debug(reinit_msm) +# debug(prevalence_msm) at <- 1 +# at <- 5201 + dat <- initialize_msm(est, param, init, control, s = 1) # dat <- reinit_msm(sim, param, init, control, s = 1) -# mf <- dat$p[[1]]$model.form -# mf$terms[[4]] - +# debug(sti_trans_msm) +# debug(riskhist_stitest_msm) +# debug(sti_test_msm) +# debug(sti_recov_msm) +# debug(sti_tx_msm) +# debug(sti_ept_msm) +# debug(part_msm) +# debug(acts_msm) +# debug(hiv_test_msm) +# debug(acts_msm) +# debug(hiv_trans_msm) +# debug(condoms_msm) +# debug(simnet_msm) +# debug(syph_progress_msm) at <- at + 1 -dat <- aging_msm(dat, at) ## <1 ms -dat <- deaths_msm(dat, at) ## 4 ms -dat <- births_msm(dat, at) ## 6 ms -dat <- test_msm(dat, at) ## 2 ms -dat <- tx_msm(dat, at) ## 3 ms -dat <- prep_msm(dat, at) ## 2 ms -dat <- progress_msm(dat, at) ## 2 ms -dat <- vl_msm(dat, at) ## 3 ms -dat <- simnet_msm(dat, at) ## 53 ms -dat <- disclose_msm(dat, at) ## 1 ms -dat <- acts_msm(dat, at) ## 1 ms -dat <- condoms_msm(dat, at) ## 2 ms -dat <- riskhist_msm(dat, at) ## 4 ms -dat <- position_msm(dat, at) ## 1 ms -dat <- trans_msm(dat, at) ## 1 ms -dat <- sti_trans(dat, at) ## 4 ms -dat <- sti_recov(dat, at) ## 3 ms -dat <- sti_tx(dat, at) ## 2 ms -dat <- prevalence_msm(dat, at) ## 1 ms +for (at in at:dat$control$nsteps) { + dat <- aging_msm(dat, at) + dat <- deaths_msm(dat, at) + dat <- births_msm(dat, at) + dat <- hiv_test_msm(dat, at) + dat <- sti_test_msm(dat, at) + dat <- hiv_tx_msm(dat, at) + dat <- prep_msm(dat, at) + dat <- hiv_progress_msm(dat, at) + dat <- syph_progress_msm(dat, at) + dat <- hiv_vl_msm(dat, at) + dat <- simnet_msm(dat, at) + dat <- hiv_disclose_msm(dat, at) + dat <- part_msm(dat, at) + dat <- acts_msm(dat, at) + dat <- condoms_msm(dat, at) + dat <- riskhist_prep_msm(dat, at) + dat <- riskhist_stitest_msm(dat, at) + dat <- position_msm(dat, at) + dat <- hiv_trans_msm(dat, at) + dat <- sti_trans_msm(dat, at) + dat <- sti_recov_msm(dat, at) + dat <- sti_tx_msm(dat, at) + dat <- sti_ept_msm(dat, at) + dat <- prevalence_msm_tnt(dat, at) + cat("\t", at) +} diff --git a/man/EpiModelHIV-package.Rd b/man/EpiModelHIV-package.Rd index ab477c4b..252d145f 100644 --- a/man/EpiModelHIV-package.Rd +++ b/man/EpiModelHIV-package.Rd @@ -4,13 +4,13 @@ \name{EpiModelHIV-package} \alias{EpiModelHIV-package} \alias{EpiModelHIV} -\title{Network-Based Epidemic Modeling of HIV Transmission among MSM and Heterosexual Populations} +\title{HIV Transmission Dynamics among MSM and Heterosexuals} \description{ \tabular{ll}{ Package: \tab EpiModelHIV\cr Type: \tab Package\cr - Version: \tab 1.5.0\cr - Date: \tab 2017-05-04\cr + Version: \tab 1.0.0\cr + Date: \tab 2016-06-25\cr License: \tab GPL-3\cr LazyLoad: \tab yes\cr } diff --git a/man/InitErgmTerm.absdiffby.Rd b/man/InitErgmTerm.absdiffby.Rd index 962d9e71..1ef07f2f 100644 --- a/man/InitErgmTerm.absdiffby.Rd +++ b/man/InitErgmTerm.absdiffby.Rd @@ -20,8 +20,9 @@ This function defines and initialize the absdiffby ERGM term that allows for targeting age homophily by sex. } \details{ -This ERGM user term was written to allow for age-based homophily in partnership -formation that is asymetric by sex. The absdiff component targets age homophily -while the by component allows that to be structed by a binary attribute such -as "male", in order to enforce an offset in the average difference. +This ERGM user term was written to allow for age-based homophily in +partnershipformation that is asymetric by sex. The absdiff component targets +age homophily while the by component allows that to be structed by a binary +attribute suchas "male", in order to enforce an offset in the average +difference. } diff --git a/man/InitErgmTerm.absdiffnodemix.Rd b/man/InitErgmTerm.absdiffnodemix.Rd index c8a11c2c..148939b0 100644 --- a/man/InitErgmTerm.absdiffnodemix.Rd +++ b/man/InitErgmTerm.absdiffnodemix.Rd @@ -16,15 +16,15 @@ package framework.} \code{ergm.userterms} package framework.} } \description{ -This function defines and initialize the absdiffnodemix ERGM term - that allows for targeting age homophily by race. +This function defines and initialize the absdiffnodemix ERGM + term that allows for targeting age homophily by race. } \details{ -This ERGM user term was written to allow for age-based homophily in partnership -formation that is heterogenous by race. The absdiff component allows targets -the distribution of age mixing on that continuous variable, and the nodemix -component differentiates this for black-black, black-white, and white-white -couples. +This ERGM user term was written to allow for age-based homophily in +partnership formation that is heterogenous by race. The absdiff component +allows targets the distribution of age mixing on that continuous variable, +and the nodemix component differentiates this for black-black, black-white, +and white-white couples. } \author{ Steven M. Goodreau diff --git a/man/acts_msm.Rd b/man/acts_msm.Rd index edeef57c..793a660a 100644 --- a/man/acts_msm.Rd +++ b/man/acts_msm.Rd @@ -13,21 +13,22 @@ individual-level attributes, and summary statistics.} \item{at}{Current time step.} } \value{ -This function returns the \code{dat} object with the updated discordant act -list (\code{dal}). Each element of \code{dal} is a data frame with the ids of the -discordant pair repeated the number of times they have AI. +This function returns the \code{dat} object with the updated edge +list (\code{el}). An additional column is added with the number of acts for +each partnership on the edge list (\code{el}). } \description{ Module function for setting the number of sexual acts on the discordant edgelist. } \details{ -The number of acts at each time step is specified as a function of the race of -both members in a pair and the expected values within black-black, black-white, -and white-white combinations. For one-off partnerships, this is deterministically -set at 1, whereas for main and causal partnerships it is a stochastic draw -from a Poisson distribution. The number of total acts may further be modified -by the level of HIV viral suppression in an infected person. +The number of acts at each time step is specified as a function of the race +of both members in a pair and the expected values within black-black, +black-white,and white-white combinations. For one-off partnerships, this is +deterministically set at 1, whereas for main and casual partnerships it is a +stochastic draw from a Poisson distribution. The number of total acts may +further be modified by the level of HIV viral suppression in an infected +person. } \keyword{module} \keyword{msm} diff --git a/man/aging_het.Rd b/man/aging_het.Rd new file mode 100644 index 00000000..78d8b00f --- /dev/null +++ b/man/aging_het.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.aging.R +\name{aging_het} +\alias{aging_het} +\title{Aging Module} +\usage{ +aging_het(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +This module ages all active nodes in the population by one time + unit at each time step. +} +\keyword{het} +\keyword{module} diff --git a/man/aging_msm.Rd b/man/aging_msm.Rd index 74c8a014..86d7c91d 100644 --- a/man/aging_msm.Rd +++ b/man/aging_msm.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/mod.aging.R \name{aging_msm} \alias{aging_msm} -\alias{aging_het} \title{Aging Module} \usage{ aging_msm(dat, at) - -aging_het(dat, at) } \arguments{ \item{dat}{Master data list object of class \code{dat} containing networks, diff --git a/man/assign_degree.Rd b/man/assign_degree.Rd index bd14e514..447bd64e 100644 --- a/man/assign_degree.Rd +++ b/man/assign_degree.Rd @@ -21,8 +21,8 @@ Assigns the degree vertex attributes on network objects conditional on their values from the other networks. } \details{ -This function assigns the degree of other networks as a vertex attribute on the -target network given a bivariate degree mixing matrix of main, casual, and -one-partnerships contained in the \code{nwstats} data. +This function assigns the degree of other networks as a vertex attribute on +the target network given a bivariate degree mixing matrix of main, casual, +and one-partnerships contained in the \code{nwstats} data. } \keyword{msm} diff --git a/man/base_nw_msm.Rd b/man/base_nw_msm.Rd index e0a4e708..e11507eb 100644 --- a/man/base_nw_msm.Rd +++ b/man/base_nw_msm.Rd @@ -15,10 +15,10 @@ Initializes the base network for model estimation within \code{netest}. } \details{ -This function takes the output of \code{\link{calc_nwstats_msm}} and constructs -an empty network with the necessary attributes for race, square root of age, -and sexual role class. This base network is used for all three network -estimations. +This function takes the output of \code{\link{calc_nwstats_msm}} and +constructs an empty network with the necessary attributes for race, square +root of age, and sexual role class. This base network is used for all three +network estimations. } \seealso{ The final vertex attributes on the network for cross-network degree are diff --git a/man/births_het.Rd b/man/births_het.Rd new file mode 100644 index 00000000..7d78e37b --- /dev/null +++ b/man/births_het.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.births.R +\name{births_het} +\alias{births_het} +\title{Births Module} +\usage{ +births_het(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module for simulating births/entries into the population, + including initialization of attributes for incoming nodes. +} +\keyword{het} +\keyword{module} diff --git a/man/births_msm.Rd b/man/births_msm.Rd index 35d9694f..9f3fe152 100644 --- a/man/births_msm.Rd +++ b/man/births_msm.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/mod.births.R \name{births_msm} \alias{births_msm} -\alias{births_het} \title{Births Module} \usage{ births_msm(dat, at) - -births_het(dat, at) } \arguments{ \item{dat}{Master data list object of class \code{dat} containing networks, @@ -26,10 +23,10 @@ Module function for births or entries into the sexually active \details{ New population members are added based on expected numbers of entries among black and white MSM, stochastically determined with draws from Poisson -distributions. For each new entry, a set of attributes is added for that node, -and the nodes are added onto the network objects. Only attributes that are -a part of the network model formulae are updated as vertex attributes on the -network objects. +distributions. For each new entry, a set of attributes is added for that +node, and the nodes are added onto the network objects. Only attributes that +are a part of the network model formulae are updated as vertex attributes on +the network objects. } \keyword{module} \keyword{msm} diff --git a/man/calc_nwstats_msm.Rd b/man/calc_nwstats_msm.Rd index 45282820..9a2801de 100644 --- a/man/calc_nwstats_msm.Rd +++ b/man/calc_nwstats_msm.Rd @@ -13,8 +13,8 @@ calc_nwstats_msm(time.unit = 7, method = 2, num.B, num.W, deg.mp.B, \arguments{ \item{time.unit}{Time unit relative to 1 for daily.} -\item{method}{Method for calculating target statistics by race, with options of -\code{2} for preserving race-specific statistics and \code{1} for +\item{method}{Method for calculating target statistics by race, with options +of \code{2} for preserving race-specific statistics and \code{1} for averaging over the statistics and dropping the race-specific terms.} \item{num.B}{Population size of black MSM.} @@ -39,16 +39,16 @@ for white MSM.} \item{qnts.W}{Means of one-off rates split into quintiles for black MSM. Use \code{NA} to ignore these quantiles in the target statistics.} -\item{prop.hom.mpi.B}{A vector of length 3 for the proportion of main, casual, -and one-off partnerships in same race for black MSM.} +\item{prop.hom.mpi.B}{A vector of length 3 for the proportion of main, +casual, and one-off partnerships in same race for black MSM.} -\item{prop.hom.mpi.W}{A vector of length 3 for the proportion of main, casual, -and one-off partnerships in same race for white MSM.} +\item{prop.hom.mpi.W}{A vector of length 3 for the proportion of main, +casual, and one-off partnerships in same race for white MSM.} \item{balance}{Method for balancing of edges by race for number of mixed-race -partnerships, with options of \code{"black"} to apply black MSM counts, -\code{"white"} to apply white MSM counts, and \code{"mean"} to take -the average of the two expectations.} +partnerships, with options of \code{"black"} to apply black MSM +counts, \code{"white"} to apply white MSM counts, and \code{"mean"} to +take the average of the two expectations.} \item{sqrt.adiff.BB}{Vector of length 3 with the mean absolute differences in the square root of ages in main, casual, and one-off black-black @@ -88,8 +88,9 @@ insertive, receptive, and versatile, for black MSM.} insertive, receptive, and versatile, for white MSM.} } \description{ -Calculates the target statistics for the formation and dissolution - components of the network model to be estimated with \code{netest}. +Calculates the target statistics for the formation and + dissolution components of the network model to be estimated + with \code{netest}. } \details{ This function performs basic calculations to determine the components of the diff --git a/man/condoms_msm.Rd b/man/condoms_msm.Rd index 55025a45..9f019b1c 100644 --- a/man/condoms_msm.Rd +++ b/man/condoms_msm.Rd @@ -13,18 +13,20 @@ individual-level attributes, and summary statistics.} \item{at}{Current time step.} } \value{ -Updates the discordant edgelist with a \code{uai} variable indicating whether -condoms were used in that act. +Updates the edgelist with a \code{uai} variable indicating whether +condoms were used in that act. An act list \code{al} is created. +The act list \code{al} is a data frame with the ids of the pair +repeated the number of times they have AI. } \description{ Module function stochastically simulates potential condom use - for each act on the discordant edgelist. + for each act on the edgelist. } \details{ -For each act on the discordant edgelist, condom use is stochastically simulated -based on the partnership type and racial combination of the dyad. Other -modifiers for the probability of condom use in that pair are diagnosis of -disease, disclosure of status, and full or partial HIV viral suppression +For each act on the edgelist, condom use is stochastically +simulated based on the partnership type and racial combination of the dyad. +Other modifiers for the probability of condom use in that pair are diagnosis +of disease, disclosure of status, and full or partial HIV viral suppression given HIV anti-retroviral therapy. } \keyword{module} diff --git a/man/control_het.Rd b/man/control_het.Rd index a221aaa8..f3d6a3d9 100644 --- a/man/control_het.Rd +++ b/man/control_het.Rd @@ -18,8 +18,8 @@ control_het(simno = 1, nsteps = 100, start = 1, nsims = 1, \arguments{ \item{simno}{Simulation ID number.} -\item{nsteps}{Number of time steps to simulate the model over in whatever unit -implied by \code{time.unit}.} +\item{nsteps}{Number of time steps to simulate the model over in whatever +unit implied by \code{time.unit}.} \item{start}{Starting time step for simulation} @@ -28,8 +28,8 @@ implied by \code{time.unit}.} \item{ncores}{Number of parallel cores to use for simulation jobs, if using the \code{EpiModel.hpc} package.} -\item{par.type}{Parallelization type, either of \code{"single"} for multi-core -or \code{"mpi"} for multi-node MPI threads.} +\item{par.type}{Parallelization type, either of \code{"single"} for +multi-core or \code{"mpi"} for multi-node MPI threads.} \item{initialize.FUN}{Module to initialize the model at time 1.} @@ -61,8 +61,8 @@ default function of \code{\link{verbose_het}}.} order in which they should be evaluated within each time step. If \code{NULL}, the modules will be evaluated as follows: first any new modules supplied through \code{...} in the order in which they are -listed, then the built-in modules in their order of the function listing. -The \code{initialize.FUN} will always be run first and the +listed, then the built-in modules in their order of the function +listing. The \code{initialize.FUN} will always be run first and the \code{verbose.FUN} always last.} \item{save.nwstats}{Save out network statistics.} diff --git a/man/control_msm.Rd b/man/control_msm.Rd index 02934549..d8169760 100644 --- a/man/control_msm.Rd +++ b/man/control_msm.Rd @@ -7,16 +7,19 @@ control_msm(simno = 1, nsims = 1, ncores = 1, nsteps = 100, start = 1, initialize.FUN = initialize_msm, aging.FUN = aging_msm, deaths.FUN = deaths_msm, births.FUN = births_msm, - test.FUN = test_msm, tx.FUN = tx_msm, prep.FUN = prep_msm, - progress.FUN = progress_msm, vl.FUN = vl_msm, aiclass.FUN = NULL, - roleclass.FUN = NULL, resim_nets.FUN = simnet_msm, - disclose.FUN = disclose_msm, acts.FUN = acts_msm, - condoms.FUN = condoms_msm, riskhist.FUN = riskhist_msm, - position.FUN = position_msm, trans.FUN = trans_msm, - stitrans.FUN = sti_trans, stirecov.FUN = sti_recov, - stitx.FUN = sti_tx, prev.FUN = prevalence_msm, - verbose.FUN = verbose_msm, save.nwstats = FALSE, verbose = TRUE, - verbose.int = 1, ...) + hiv_test.FUN = hiv_test_msm, sti_test.FUN = sti_test_msm, + hiv_tx.FUN = hiv_tx_msm, prep.FUN = prep_msm, + hiv_progress.FUN = hiv_progress_msm, syph_progress.FUN = NULL, + hiv_vl.FUN = hiv_vl_msm, aiclass.FUN = NULL, roleclass.FUN = NULL, + resim_nets.FUN = simnet_msm, hiv_disclose.FUN = hiv_disclose_msm, + part.FUN = part_msm, acts.FUN = acts_msm, + condoms.FUN = condoms_msm, riskhist_prep.FUN = NULL, + riskhist_stitest.FUN = riskhist_stitest_msm, + position.FUN = position_msm, hiv_trans.FUN = hiv_trans_msm, + sti_trans.FUN = sti_trans_msm, sti_recov.FUN = sti_recov_msm, + sti_tx.FUN = sti_tx_msm, sti_ept.FUN = sti_ept_msm, + prev.FUN = prevalence_msm_ept, verbose.FUN = verbose_msm, + save.nwstats = FALSE, verbose = TRUE, verbose.int = 1, ...) } \arguments{ \item{simno}{Unique ID for the simulation run, used for file naming purposes @@ -34,8 +37,8 @@ simulation. This may also be set to 1 greater than the final time step of a previous simulation to resume the simulation with different parameters.} -\item{initialize.FUN}{Module function to use for initialization of the epidemic -model.} +\item{initialize.FUN}{Module function to use for initialization of the +epidemic model.} \item{aging.FUN}{Module function for aging.} @@ -43,15 +46,19 @@ model.} \item{births.FUN}{Module function for births or entries into the population.} -\item{test.FUN}{Module function for diagnostic disease testing.} +\item{hiv_test.FUN}{Module function for diagnostic disease testing.} -\item{tx.FUN}{Module function for ART initiation and adherence.} +\item{sti_test.FUN}{Module function for diagnostic testing for STIs} + +\item{hiv_tx.FUN}{Module function for ART initiation and adherence.} \item{prep.FUN}{Module function for PrEP initiation and utilization.} -\item{progress.FUN}{Module function for HIV disease progression.} +\item{hiv_progress.FUN}{Module function for HIV disease progression.} + +\item{syph_progress.FUN}{Module function for syphilis disease progression} -\item{vl.FUN}{Module function for HIV viral load evolution.} +\item{hiv_vl.FUN}{Module function for HIV viral load evolution.} \item{aiclass.FUN}{Module function for one-off AI risk class transitions.} @@ -60,28 +67,35 @@ model.} \item{resim_nets.FUN}{Module function for network resimulation at each time step.} -\item{disclose.FUN}{Module function for HIV status disclosure.} +\item{hiv_disclose.FUN}{Module function for HIV status disclosure.} + +\item{part.FUN}{Module function for creating master partnership matrix.} \item{acts.FUN}{Module function to simulate the number of sexual acts within partnerships.} \item{condoms.FUN}{Module function to simulate condom use within acts.} -\item{riskhist.FUN}{Module function to calculate risk history for uninfected -persons in the population.} +\item{riskhist_prep.FUN}{Module function to calculate risk history for uninfected +persons in the population within a PrEP intervention.} + +\item{riskhist_stitest.FUN}{Module function to calculate risk history for uninfected +persons in the population within a STI testing intervention.} \item{position.FUN}{Module function to simulate sexual position within acts.} -\item{trans.FUN}{Module function to stochastically simulate HIV transmission +\item{hiv_trans.FUN}{Module function to stochastically simulate HIV transmission over acts given individual and dyadic attributes.} -\item{stitrans.FUN}{Module function to simulate GC/CT transmission over current -edgelist.} +\item{sti_trans.FUN}{Module function to simulate GC/CT transmission over +current edgelist.} + +\item{sti_recov.FUN}{Module function to simulate recovery from GC/CT, +heterogeneous by disease, site, symptoms, and treatment status.} -\item{stirecov.FUN}{Module function to simulate recovery from GC/CT, heterogeneous -by disease, site, symptoms, and treatment status.} +\item{sti_tx.FUN}{Module function to simulate treatment of GC/CT.} -\item{stitx.FUN}{Module function to simulate treatment of GC/CT.} +\item{sti_ept.FUN}{Module function for EPT intervention} \item{prev.FUN}{Module function to calculate prevalence summary statistics.} @@ -94,8 +108,8 @@ external text files.} \item{verbose}{If \code{TRUE}, print out simulation progress to the console if in interactive mode or text files if in batch mode.} -\item{verbose.int}{Integer specifying the interval between time steps at which -progress is printed.} +\item{verbose.int}{Integer specifying the interval between time steps at +which progress is printed.} \item{...}{Additional arguments passed to the function.} } diff --git a/man/deaths_het.Rd b/man/deaths_het.Rd new file mode 100644 index 00000000..e729c04f --- /dev/null +++ b/man/deaths_het.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.death.R +\name{deaths_het} +\alias{deaths_het} +\title{Deaths Module} +\usage{ +deaths_het(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module for simulating deaths among susceptible and infected + persons within the population. +} +\keyword{het} +\keyword{module} diff --git a/man/deaths_msm.Rd b/man/deaths_msm.Rd index 3771b1a8..0b16d6db 100644 --- a/man/deaths_msm.Rd +++ b/man/deaths_msm.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/mod.death.R \name{deaths_msm} \alias{deaths_msm} -\alias{deaths_het} \title{Death Module} \usage{ deaths_msm(dat, at) - -deaths_het(dat, at) } \arguments{ \item{dat}{Master data list object of class \code{dat} containing networks, diff --git a/man/dx_het.Rd b/man/dx_het.Rd new file mode 100644 index 00000000..b9a79bbe --- /dev/null +++ b/man/dx_het.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.test.R +\name{dx_het} +\alias{dx_het} +\title{HIV Diagnosis Module} +\usage{ +dx_het(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module function for simulating HIV diagnosis after infection, + currently based on diagnosis at treatment initiation. +} +\keyword{het} +\keyword{module} diff --git a/man/edges_correct_het.Rd b/man/edges_correct_het.Rd new file mode 100644 index 00000000..16883439 --- /dev/null +++ b/man/edges_correct_het.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.simnet.R +\name{edges_correct_het} +\alias{edges_correct_het} +\title{Adjustment for the Edges Coefficient with Changing Network Size} +\usage{ +edges_correct_het(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +The network model parameters stored in \code{dat$nwparam} are updated. +} +\description{ +Adjusts the edges coefficients in a dynamic network model + to preserve the mean degree. +} +\details{ +In HIV/STI modeling, there is typically an assumption that changes in +population size do not affect one's number of partners, specified as the +mean degree for network models. A person would not have 10 times the number +of partners should he move from a city 10 times as large. This module uses +the adjustment of Krivitsky et al. to adjust the edges coefficients on the +three network models to account for varying population size in order to +preserve that mean degree. +} +\references{ +Krivitsky PN, Handcock MS, and Morris M. "Adjusting for network size and +composition effects in exponential-family random graph models." Statistical +Methodology. 2011; 8.4: 319-339. +} +\keyword{het} +\keyword{module} diff --git a/man/edges_correct_msm.Rd b/man/edges_correct_msm.Rd index ce9caf2d..afded453 100644 --- a/man/edges_correct_msm.Rd +++ b/man/edges_correct_msm.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/mod.simnet.R \name{edges_correct_msm} \alias{edges_correct_msm} -\alias{edges_correct_het} \title{Adjustment for the Edges Coefficient with Changing Network Size} \usage{ edges_correct_msm(dat, at) - -edges_correct_het(dat, at) } \arguments{ \item{dat}{Master data list object of class \code{dat} containing networks, diff --git a/man/hiv_disclose_msm.Rd b/man/hiv_disclose_msm.Rd new file mode 100644 index 00000000..f641db93 --- /dev/null +++ b/man/hiv_disclose_msm.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.disclose.R +\name{hiv_disclose_msm} +\alias{hiv_disclose_msm} +\title{Disclosure Module} +\usage{ +hiv_disclose_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +This function returns the \code{dat} object with the updated disclosure list, +on \code{temp$discl.list}. +} +\description{ +Module function for disclosure of HIV status to partners given + non-disclosure in the past. +} +\details{ +Persons who are infected may disclose their status to partners at three +distinct time points: at relationship onset for newly formed discordant +pairs; at diagnosis for pairs starting as both negative but with one newly +infected; or post diagnosis for one recently infected. The rates of +disclosure vary at these three points, and also by the partnership type. +} +\keyword{module} +\keyword{msm} diff --git a/man/hiv_progress_msm.Rd b/man/hiv_progress_msm.Rd new file mode 100644 index 00000000..a18a6276 --- /dev/null +++ b/man/hiv_progress_msm.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.progress.R +\name{hiv_progress_msm} +\alias{hiv_progress_msm} +\title{Disease Progression Module} +\usage{ +hiv_progress_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +This function returns the \code{dat} object after updating the disease stage +of infected individuals. +} +\description{ +Module function for HIV disease progression through acute, + chronic and AIDS stages. +} +\details{ +HIV disease is divided into four stages: acute rising, acute falling, chronic +and AIDS. Acute rising is the time from infection to peak viremia, while +acute falling is the time from peak viremia to chronic stage infection with +an established set-point HIV viral load. + +The time spent in chronic stage infection, and thus the time from infection +to AIDS, depends on ART history. For ART-naive persons, time to AIDS is +established by the \code{vl.aids.onset.int} parameter. For persons ever on ART +who fall into the partially suppressed category (the \code{tt.traj} attribute +is \code{3}), time to AIDS depends on the sum of two ratios: time on +treatment over maximum time on treatment plus time off treatment over maximum +time off treatment. For persons ever on ART who fall into the fully +suppressed category (\code{tt.traj=4}), time to AIDS depends on whether the +cumulative time off treatment exceeds a time threshold specified in the +\code{max.time.off.tx.full} parameter. +} +\keyword{module} +\keyword{msm} diff --git a/man/hiv_test_msm.Rd b/man/hiv_test_msm.Rd new file mode 100644 index 00000000..3f841d01 --- /dev/null +++ b/man/hiv_test_msm.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.test.R +\name{hiv_test_msm} +\alias{hiv_test_msm} +\title{HIV Testing Module} +\usage{ +hiv_test_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +This function returns the \code{dat} object with updated +\code{last.neg.test}, \code{diag.status} and \code{diag.time} attributes. +} +\description{ +Module function for HIV diagnostic testing of infected persons. +} +\details{ +This testing module supports two testing parameterizations, input via the +\code{testing.pattern} parameter: memoryless for stochastic and +geometrically-distributed waiting times to test (constant hazard); and +interval for deterministic tested after defined waiting time intervals. +} +\keyword{module} +\keyword{msm} diff --git a/man/hiv_trans_msm.Rd b/man/hiv_trans_msm.Rd new file mode 100644 index 00000000..35319666 --- /dev/null +++ b/man/hiv_trans_msm.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.trans.R +\name{hiv_trans_msm} +\alias{hiv_trans_msm} +\title{Transmission Module} +\usage{ +hiv_trans_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +For each new infection, the disease status, infection time, and related +HIV attributes are updated for the infected node. Summary statistics for +disease incidence overall, and by race and age groups are calculated and +stored on \code{dat$epi}. +} +\description{ +Stochastically simulates disease transmission given the current + state of the discordand edgelist. +} +\details{ +This is the final substantive function that occurs within the time loop at +each time step. This function takes the discordant edgelist and calculates a +transmission probability for each row (one sexual act) between dyads on the +network. After transmission events, individual-level attributes for the infected +persons are updated and summary statistics for incidence calculated. + +The per-act transmission probability depends on the following elements: +insertive versus receptive role, viral load of the infected partner, an +acute stage infection excess risk, condom use, and the CCR5 genetic allele. +Given these transmission probabilities, transmission is stochastically +simulating by drawing from a binomial distribution for each act conditional +on the per-act probability. +} +\keyword{module} +\keyword{msm} diff --git a/man/hiv_tx_msm.Rd b/man/hiv_tx_msm.Rd new file mode 100644 index 00000000..ca768b19 --- /dev/null +++ b/man/hiv_tx_msm.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.tx.R +\name{hiv_tx_msm} +\alias{hiv_tx_msm} +\title{Treatment Module} +\usage{ +hiv_tx_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +This function returns the \code{dat} object with updated \code{tx.status}, +\code{tx.init.time}, \code{cum.time.on.tx}, +\code{cum.time.off.tx} attributes. +} +\description{ +Module function for anti-retroviral treatment initiation and + adherence over time. +} +\details{ +Persons enter into the simulation with one of four ART "patterns": never +tested, tested but never treated, treated and achieving partial HIV viral +suppression, or treated with full viral suppression (these types are stored +as individual-level attributes in \code{tt.traj}). This module initiates ART +for treatment naive persons in the latter two types, and then cycles them on +and off treatment conditional on empirical race-specific adherence rates. ART +initiation, non-adherence, and restarting are all stochastically simulated +based on binomial statistical models. +} +\keyword{module} +\keyword{msm} diff --git a/man/hiv_vl_msm.Rd b/man/hiv_vl_msm.Rd new file mode 100644 index 00000000..c9ae985e --- /dev/null +++ b/man/hiv_vl_msm.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.vl.R +\name{hiv_vl_msm} +\alias{hiv_vl_msm} +\title{Viral Load Module} +\usage{ +hiv_vl_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +This function returns the \code{dat} object with updated \code{vl} attribute. +} +\description{ +Module function for updating HIV viral load. +} +\details{ +HIV viral load varies over time as a function of time since infection and ART +history. In the absence of ART, VL rises during the acute rising stage and +falls during the acute falling stage, until it reaches a set-point value in +chronic stage infection. VL again rises during AIDS stage disease until the +point of death. + +For persons who have ever initated treatment (\code{tt.traj} is \code{3} or +\code{4}), VL changes depending on current ART use in that time step. +Current use is associated with a reduction in VL, with the rates of decline +and nadirs dependent on partial or full suppression levels. Current +non-adherence is associated with an equal level of increase to VL. All +persons who have reached AIDS, regardless of how they arrived, have a +similar rate of VL increase. +} +\keyword{module} +\keyword{msm} diff --git a/man/init_het.Rd b/man/init_het.Rd index d1c38ba4..fee1bb5c 100644 --- a/man/init_het.Rd +++ b/man/init_het.Rd @@ -19,14 +19,16 @@ init_het(i.prev.male = 0.05, i.prev.feml = 0.05, ages.male = seq(18, \item{ages.feml}{initial ages of females in the population.} \item{inf.time.dist}{Probability distribution for setting time of infection -for nodes infected at T1, with options of \code{"geometric"} for randomly -distributed on a geometric distribution with a probability of the -reciprocal of the average length of infection, \code{"uniform"} for a -uniformly distributed time over that same interval, or \code{"allacute"} for -placing all infections in the acute stage at the start.} +for nodes infected at T1, with options of \code{"geometric"} for +randomly distributed on a geometric distribution with a probability +of the reciprocal of the average length of infection, \code{"uniform"} +for a uniformly distributed time over that same interval, or +\code{"allacute"} for placing all infections in the acute stage at +the start.} -\item{max.inf.time}{Maximum infection time in days for infection at initialization, -used when \code{inf.time.dist} is \code{"geometric"} or \code{"uniform"}.} +\item{max.inf.time}{Maximum infection time in days for infection at +initialization, used when \code{inf.time.dist} is \code{"geometric"} +or \code{"uniform"}.} \item{...}{additional arguments to be passed into model.} } diff --git a/man/init_msm.Rd b/man/init_msm.Rd index 413cef0c..ab0e9405 100644 --- a/man/init_msm.Rd +++ b/man/init_msm.Rd @@ -4,8 +4,11 @@ \alias{init_msm} \title{Epidemic Model Initial Conditions} \usage{ -init_msm(nwstats, prev.B = 0.253, prev.W = 0.253, prev.ugc = 0.005, - prev.rgc = 0.005, prev.uct = 0.013, prev.rct = 0.013, ...) +init_msm(nwstats, prev.B = 0.149006, prev.W = 0.149006, + prev.ugc = 0.001471584, prev.rgc = 0.001471584, + prev.uct = 0.007572175, prev.rct = 0.007572175, prev.syph.B = 0, + prev.syph.W = 0, stage.syph.B.prob = c(0.4, 0.2, 0.2, 0.2, 0, 0), + stage.syph.W.prob = c(0.4, 0.2, 0.2, 0.2, 0, 0), ...) } \arguments{ \item{nwstats}{Target statistics for the network model. An object of class @@ -23,6 +26,18 @@ init_msm(nwstats, prev.B = 0.253, prev.W = 0.253, prev.ugc = 0.005, \item{prev.rct}{Initial prevalence of rectal chlamydia.} +\item{prev.syph.B}{Initial prevalence of syphilis among black MSM} + +\item{prev.syph.W}{Initial prevalence of syphilis among white MSM} + +\item{stage.syph.B.prob}{Proportion of black MSM who enter one of the seven +active stages of syphilis: incubating, primary, secondary, early +latent, late latent, late late latent, and tertiary.} + +\item{stage.syph.W.prob}{Proportion of white MSM who enter one of the seven +active stages of syphilis: incubating, primary, secondary, early +latent, late latent, late late latent, and tertiary.} + \item{...}{Additional arguments passed to function.} } \value{ diff --git a/man/init_status_hiv_msm.Rd b/man/init_status_hiv_msm.Rd new file mode 100644 index 00000000..5aa80482 --- /dev/null +++ b/man/init_status_hiv_msm.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.initialize.R +\name{init_status_hiv_msm} +\alias{init_status_hiv_msm} +\title{Initialize the HIV status of persons in the network} +\usage{ +init_status_hiv_msm(dat) +} +\arguments{ +\item{dat}{Data object created in initialization module.} +} +\description{ +Sets the initial individual-level disease status of persons + in the network, as well as disease-related attributes for + infected persons. +} +\keyword{initiation} +\keyword{msm} +\keyword{utility} diff --git a/man/init_status_sti_msm.Rd b/man/init_status_sti_msm.Rd new file mode 100644 index 00000000..1616610d --- /dev/null +++ b/man/init_status_sti_msm.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.initialize.R +\name{init_status_sti_msm} +\alias{init_status_sti_msm} +\title{Initialize the STI status of persons in the network} +\usage{ +init_status_sti_msm(dat) +} +\arguments{ +\item{dat}{Data object created in initialization module.} +} +\description{ +Sets the initial individual-level disease status of persons + in the network, as well as disease-related attributes for + infected persons. +} +\keyword{CT} +\keyword{GC} +\keyword{STI} +\keyword{initiation} +\keyword{msm} +\keyword{syphilis} +\keyword{utility} diff --git a/man/initialize_het.Rd b/man/initialize_het.Rd new file mode 100644 index 00000000..61f18bde --- /dev/null +++ b/man/initialize_het.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.initialize.R +\name{initialize_het} +\alias{initialize_het} +\title{Initialization Module} +\usage{ +initialize_het(x, param, init, control, s) +} +\arguments{ +\item{x}{An \code{EpiModel} object of class \code{\link{netest}}.} + +\item{param}{An \code{EpiModel} object of class \code{\link{param_het}}.} + +\item{init}{An \code{EpiModel} object of class \code{\link{init_het}}.} + +\item{control}{An \code{EpiModel} object of class \code{\link{control_het}}.} + +\item{s}{Simulation number, used for restarting dependent simulations.} +} +\value{ +This function returns the updated \code{dat} object with the initialized +values for demographics and disease-related variables. +} +\description{ +This function initializes the master \code{dat} object on which + data are stored, simulates the initial state of the network, and + simulates disease status and other attributes. +} +\keyword{het} +\keyword{module} diff --git a/man/initialize_msm.Rd b/man/initialize_msm.Rd index 2b618b90..be4e0b2b 100644 --- a/man/initialize_msm.Rd +++ b/man/initialize_msm.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/mod.initialize.R \name{initialize_msm} \alias{initialize_msm} -\alias{initialize_het} \title{Initialization Module} \usage{ initialize_msm(x, param, init, control, s) - -initialize_het(x, param, init, control, s) } \arguments{ \item{x}{An \code{EpiModel} object of class \code{\link{netest}}.} @@ -21,8 +18,8 @@ initialize_het(x, param, init, control, s) \item{s}{Simulation number, used for restarting dependent simulations.} } \value{ -This function returns the updated \code{dat} object with the initialized values -for demographics and disease-related variables. +This function returns the updated \code{dat} object with the initialized +values or demographics and disease-related variables. } \description{ This function initializes the master \code{dat} object on which diff --git a/man/param_het.Rd b/man/param_het.Rd index 8af1e1ca..9c2b9e37 100644 --- a/man/param_het.Rd +++ b/man/param_het.Rd @@ -49,13 +49,15 @@ AIDS above impact of heightened viral load.} \item{act.rate.cd4}{CD4 count at which the \code{act.rate.late} applies.} \item{acts.rand}{If \code{TRUE}, will draw number of total and unprotected -acts from a binomial distribution parameterized by the \code{act.rate}.} +acts from a binomial distribution parameterized by the +\code{act.rate}.} \item{circ.prob.birth}{Proportion of men circumcised at birth.} \item{circ.eff}{Efficacy of circumcision per act in HIV prevention.} -\item{tx.elig.cd4}{CD4 count at which a person becomes eligible for treatment.} +\item{tx.elig.cd4}{CD4 count at which a person becomes eligible for +treatment.} \item{tx.init.cd4.mean}{Mean CD4 count at which person presents for care.} @@ -64,10 +66,11 @@ acts from a binomial distribution parameterized by the \code{act.rate}.} \item{tx.adhere.full}{Proportion of people who start treatment who are fully adherent.} -\item{tx.adhere.part}{Of the not fully adherent proportion, the percent of time -they are on medication.} +\item{tx.adhere.part}{Of the not fully adherent proportion, the percent of +time they are on medication.} -\item{tx.vlsupp.time}{Time in days from treatment initiation to viral suppression.} +\item{tx.vlsupp.time}{Time in days from treatment initiation to +viral suppression.} \item{tx.vlsupp.level}{Log 10 viral load level at suppression.} @@ -81,18 +84,18 @@ for females.} \item{tx.cd4.decrat.male}{Rate of CD4 decline under periods of non-adherence for males.} -\item{tx.coverage}{Proportion of treatment-eligible persons who have initiated -treatment.} +\item{tx.coverage}{Proportion of treatment-eligible persons who have +initiated treatment.} \item{tx.prev.eff}{Proportional amount by which treatment reduces infectivity of infected partner.} \item{b.rate}{General entry rate per day for males and females specified.} -\item{b.rate.method}{Method for assigning birth rates, with options of "totpop" -for births as a function of the total population size, "fpop" for births -as a function of the female population size, and "stgrowth" for a constant -stable growth rate.} +\item{b.rate.method}{Method for assigning birth rates, with options of +"totpop" for births as a function of the total population size, +"fpop" for births as a function of the female population size, and +"stgrowth" for a constant stable growth rate.} \item{b.propmale}{Proportion of entries assigned as male. If NULL, then set adaptively based on the proportion at time 1.} diff --git a/man/param_msm.Rd b/man/param_msm.Rd index d8a87f00..25ba3ea5 100644 --- a/man/param_msm.Rd +++ b/man/param_msm.Rd @@ -7,6 +7,7 @@ param_msm(nwstats, race.method = 1, last.neg.test.B.int = 301, last.neg.test.W.int = 315, mean.test.B.int = 301, mean.test.W.int = 315, testing.pattern = "memoryless", + testing.pattern.sti = "interval", sti.correlation.time = 0, test.window.int = 21, tt.traj.B.prob = c(0.077, 0, 0.356, 0.567), tt.traj.W.prob = c(0.052, 0, 0.331, 0.617), tx.init.B.prob = 0.092, tx.init.W.prob = 0.127, tx.halt.B.prob = 0.0102, @@ -18,10 +19,14 @@ param_msm(nwstats, race.method = 1, last.neg.test.B.int = 301, * 7, vl.aids.int = 52 * 2 * 7, vl.fatal = 7, vl.full.supp = 1.5, vl.part.supp = 3.5, full.supp.down.slope = 0.25, full.supp.up.slope = 0.25, part.supp.down.slope = 0.25, - part.supp.up.slope = 0.25, b.B.rate = 0.001/7, b.W.rate = 0.001/7, - birth.age = 18, b.method = "fixed", URAI.prob = 0.0082 * 1.09, - UIAI.prob = 0.0031 * 1.09, acute.rr = 6, circ.rr = 0.4, - condom.rr = 0.295, disc.outset.main.B.prob = 0.685, + part.supp.up.slope = 0.25, incu.syph.int = 28, prim.syph.int = 63, + seco.syph.int = 119, earlat.syph.int = 364 - incu.syph.int - + prim.syph.int - seco.syph.int, latelat.syph.int = 9 * 52 * 7, + latelatelat.syph.int = 20 * 52 * 7, tert.syph.int = 20 * 52 * 7, + syph.tert.prog.prob = 0.00010776536, b.B.rate = 0.001/7, + b.W.rate = 0.001/7, birth.age = 18, b.method = "fixed", + URAI.prob = 0.0082 * 1.09, UIAI.prob = 0.0031 * 1.09, acute.rr = 6, + circ.rr = 0.4, condom.rr = 0.295, disc.outset.main.B.prob = 0.685, disc.outset.main.W.prob = 0.889, disc.at.diag.main.B.prob = 1, disc.at.diag.main.W.prob = 1, disc.post.diag.main.B.prob = 0, disc.post.diag.main.W.prob = 0, disc.outset.pers.B.prob = 0.527, @@ -34,7 +39,8 @@ param_msm(nwstats, race.method = 1, last.neg.test.B.int = 301, base.ai.main.BB.rate = 0.17, base.ai.main.BW.rate = 0.26, base.ai.main.WW.rate = 0.23, base.ai.pers.BB.rate = 0.11, base.ai.pers.BW.rate = 0.16, base.ai.pers.WW.rate = 0.14, - ai.scale = 1.15, cond.main.BB.prob = 0.38, cond.main.BW.prob = 0.1, + ai.scale = 1.061338, ai.scale.pospos = 1.061338, + cond.main.BB.prob = 0.38, cond.main.BW.prob = 0.1, cond.main.WW.prob = 0.15, cond.pers.always.prob = 0.216, cond.pers.BB.prob = 0.26, cond.pers.BW.prob = 0.26, cond.pers.WW.prob = 0.26, cond.inst.always.prob = 0.326, @@ -49,22 +55,62 @@ param_msm(nwstats, race.method = 1, last.neg.test.B.int = 301, prep.class.prob = c(0.211, 0.07, 0.1, 0.619), prep.class.hr = c(1, 0.69, 0.19, 0.05), prep.coverage = 0, prep.cov.method = "curr", prep.cov.rate = 1, prep.tst.int = 90, prep.risk.int = 182, - prep.risk.reassess = TRUE, rcomp.prob = 0, rcomp.adh.groups = 0:3, - rcomp.main.only = FALSE, rcomp.discl.only = FALSE, - rgc.tprob = 0.357698, ugc.tprob = 0.248095, rct.tprob = 0.321597, - uct.tprob = 0.212965, rgc.sympt.prob = 0.076975, - ugc.sympt.prob = 0.824368, rct.sympt.prob = 0.103517, - uct.sympt.prob = 0.885045, rgc.asympt.int = 35.11851 * 7, - ugc.asympt.int = 35.11851 * 7, gc.tx.int = 2 * 7, gc.ntx.int = NA, - rct.asympt.int = 44.24538 * 7, uct.asympt.int = 44.24538 * 7, - ct.tx.int = 2 * 7, ct.ntx.int = NA, gc.prob.cease = 0, - ct.prob.cease = 0, gc.sympt.prob.tx = 0.9, ct.sympt.prob.tx = 0.85, - gc.asympt.prob.tx = 0, ct.asympt.prob.tx = 0, - prep.sti.screen.int = 182, prep.sti.prob.tx = 1, - prep.continue.stand.tx = TRUE, sti.cond.rr = 0.3, - hiv.rgc.rr = 2.780673, hiv.ugc.rr = 1.732363, - hiv.rct.rr = 2.780673, hiv.uct.rr = 1.732363, hiv.dual.rr = 0.2, - ...) + prep.risk.reassess = TRUE, riskhist.int = 182, stitest.start = 1, + stitest.active.int = 364, tst.rect.sti.rr = 1, + sti.highrisktest.int = 182, stitest.elig.model = "all", + stianntest.gc.hivneg.coverage = 0.44, + stianntest.ct.hivneg.coverage = 0.44, + stianntest.syph.hivneg.coverage = 0, + stihighrisktest.gc.hivneg.coverage = 0, + stihighrisktest.ct.hivneg.coverage = 0, + stihighrisktest.syph.hivneg.coverage = 0, + stianntest.gc.hivpos.coverage = 0.61, + stianntest.ct.hivpos.coverage = 0.61, + stianntest.syph.hivpos.coverage = 0, + stihighrisktest.gc.hivpos.coverage = 0, + stihighrisktest.ct.hivpos.coverage = 0, + stihighrisktest.syph.hivpos.coverage = 0, + stianntest.cov.method = "curr", stihighrisktest.cov.method = "curr", + partnercutoff = 1, ept.start = Inf, ept.risk.int = 60, + ept.coverage = 0, ept.cov.method = "curr", ept.cov.rate = 1, + ept.provision.partner.main.ong = 0.5, + ept.provision.partner.pers.ong = 0.4, + ept.provision.partner.main.end = 0.4, + ept.provision.partner.pers.end = 0.3, + ept.provision.partner.inst = 0.2, ept.uptake.partner.main = 0.8, + ept.uptake.partner.pers = 0.8, ept.uptake.partner.inst = 0.8, + ept.gc.success = 1, ept.ct.success = 1, rcomp.prob = 0, + rcomp.adh.groups = 0:3, rcomp.main.only = FALSE, + rcomp.discl.only = FALSE, rgc.tprob = 0.5364416, + ugc.tprob = 0.434692, rct.tprob = 0.2493814, uct.tprob = 0.1944415, + syph.tprob = 0.1464, syph.incub.rr = 0, syph.earlat.rr = 0.25, + syph.late.rr = 0, rgc.sympt.prob = 0.16, ugc.sympt.prob = 0.8, + rct.sympt.prob = 0.14, uct.sympt.prob = 0.48, + syph.incub.sympt.prob = 0, syph.prim.sympt.prob = 0.5, + syph.seco.sympt.prob = 0.85, syph.earlat.sympt.prob = 0, + syph.latelat.sympt.prob = 0, syph.tert.sympt.prob = 1, + rgc.asympt.rate = 1/(24.78753 * 7), ugc.asympt.rate = 1/(24.78753 * + 7), gc.tx.int = 7, gc.ntx.int = NA, rct.asympt.rate = 1/(44.28232 * + 7), uct.asympt.rate = 1/(44.28232 * 7), ct.tx.int = 7, + ct.ntx.int = NA, syph.early.tx.int = 7, syph.late.tx.int = 3 * 7, + gc.sympt.prob.tx = 0.9, ct.sympt.prob.tx = 0.85, + gc.asympt.prob.tx = 1, ct.asympt.prob.tx = 1, + syph.incub.sympt.prob.tx = 0, syph.incub.asympt.prob.tx = 0, + syph.prim.sympt.prob.tx = 0.6, syph.prim.asympt.prob.tx = 1, + syph.seco.sympt.prob.tx = 0.688235, syph.seco.asympt.prob.tx = 1, + syph.earlat.sympt.prob.tx = 0.1, syph.earlat.asympt.prob.tx = 1, + syph.latelat.sympt.prob.tx = 0.1, syph.latelat.asympt.prob.tx = 1, + syph.tert.sympt.prob.tx = 1, syph.tert.asympt.prob.tx = 1, + prep.sti.screen.int = 182, prep.sti.prob.tx = 1, sti.cond.rr = 0.3, + hiv.rgc.rr = 2.175918, hiv.ugc.rr = 1.564797, + hiv.rct.rr = 2.175918, hiv.uct.rr = 1.564797, hiv.syph.rr = 1.62, + hiv.rgc.rct.rr = 0.2, hiv.rgc.syph.rr = 0.2, hiv.rct.syph.rr = 0.2, + hiv.ugc.uct.rr = 0.2, hiv.ugc.syph.rr = 0.2, hiv.uct.syph.rr = 0.2, + hiv.all.ureth.rr = 0.2, hiv.all.rect.rr = 0.2, hiv.trans.gc.rr = 1, + hiv.trans.ct.rr = 1, hiv.trans.syph.rr = 1, + hiv.trans.gc.ct.rr = 0.2, hiv.trans.gc.syph.rr = 0.2, + hiv.trans.ct.syph.rr = 0.2, hiv.trans.allsti.rr = 0.2, + partlist.start = NULL, ...) } \arguments{ \item{nwstats}{Target statistics for the network model. An object of class @@ -79,13 +125,21 @@ black men.} \item{last.neg.test.W.int}{Time range in days for last negative test for white men.} -\item{mean.test.B.int}{Mean intertest interval in days for black MSM who test.} +\item{mean.test.B.int}{Mean intertest interval (days) for black MSM who test.} -\item{mean.test.W.int}{Mean intertest interval in days for white MSM who test.} +\item{mean.test.W.int}{Mean intertest interval (days) for white MSM who test.} -\item{testing.pattern}{Method for HIV testing, with options \code{"memoryless"} -for constant hazard without regard to time since previous test, or -\code{"interval"} deterministic fixed intervals.} +\item{testing.pattern}{Method for HIV testing, with options +\code{"memoryless"} for constant hazard without regard to time since +previous test, or \code{"interval"} deterministic fixed intervals.} + +\item{testing.pattern.sti}{Method for STI testing, with options +\code{"memoryless"} for constant hazard without regard to time since +previous test, or \code{"interval"} deterministic fixed intervals.} + +\item{sti.correlation.time}{Length of window lookback (weeks) for correlated +STI testing (e.g. value of 9 weeks means last test must have been > 9 +weeks prior for a particular STI)} \item{test.window.int}{Length of the HIV test window period in days.} @@ -121,9 +175,9 @@ re-initiate treatment.} suppressor before onset of AIDS, including time before diagnosis.} \item{max.time.on.tx.part.int}{Number of days on treatment for a -partial suppressor beofre onset of AIDS.} +partial suppressor before onset of AIDS.} -\item{max.time.off.tx.part.int}{Nnumber of days off treatment for a +\item{max.time.off.tx.part.int}{Number of days off treatment for a partial suppressor before onset of AIDS, including time before diagnosis.} @@ -150,8 +204,8 @@ patient.} \item{vl.part.supp}{Log10 viral load at partial suppression on ART.} \item{full.supp.down.slope}{For full suppressors, number of log10 units that -viral load falls per time step from treatment initiation or re-initiation -until the level in \code{vl.full.supp}.} +viral load falls per time step from treatment initiation or +re-initiation until the level in \code{vl.full.supp}.} \item{full.supp.up.slope}{For full suppressors, number of log10 units that viral load rises per time step from treatment halting until expected @@ -162,7 +216,26 @@ that viral load falls per time step from treatment initiation or re-initiation until the level in \code{vl.part.supp}.} \item{part.supp.up.slope}{For partial suppressors, number of log10 units that -viral load rises per time step from treatment halting until expected value.} +viral load rises per time step from treatment halting until +expected value.} + +\item{incu.syph.int}{Number of days in incubation stage of syphilis.} + +\item{prim.syph.int}{Number of days in primary stage of syphilis.} + +\item{seco.syph.int}{Number of days in secondary stage of syphilis.} + +\item{earlat.syph.int}{Number of days in early latent stage of syphilis.} + +\item{latelat.syph.int}{Number of days in first late latent stage of syphilis.} + +\item{latelatelat.syph.int}{Number of days in second stage of late latent +syphilis for those who will not progress to tertiary infection.} + +\item{tert.syph.int}{Number of days in tertiary stage of syphilis.} + +\item{syph.tert.prog.prob}{Probability of progression from late latent stage +of syphilis to tertiary stage at any point in time during late latent.} \item{b.B.rate}{Rate at which black MSM enter the population.} @@ -191,17 +264,17 @@ negative insertive partner is circumcised.} \item{condom.rr}{Relative risk of infection from anal sex when a condom is used.} -\item{disc.outset.main.B.prob}{Probability that an HIV-infected black MSM will -disclose his status at the start of a main partnership.} +\item{disc.outset.main.B.prob}{Probability that an HIV-infected black MSM +will disclose his status at the start of a main partnership.} -\item{disc.outset.main.W.prob}{Probability that an HIV-infected white MSM will -disclose his status at the start of a main partnership.} +\item{disc.outset.main.W.prob}{Probability that an HIV-infected white MSM +will disclose his status at the start of a main partnership.} -\item{disc.at.diag.main.B.prob}{Probability that a black MSM already in a main -partnership will disclose at the time of diagnosis.} +\item{disc.at.diag.main.B.prob}{Probability that a black MSM already in a +main partnership will disclose at the time of diagnosis.} -\item{disc.at.diag.main.W.prob}{Probability that a white MSM already in a main -partnership will disclose at the time of diagnosis.} +\item{disc.at.diag.main.W.prob}{Probability that a white MSM already in a +main partnership will disclose at the time of diagnosis.} \item{disc.post.diag.main.B.prob}{Probability that an HIV-infected black MSM in a main partnership will disclose his status, assuming he didn't @@ -211,11 +284,11 @@ at the start of the partnership or at diagnosis.} in a main partnership will disclose his status, assuming he didn't at the start of the partnership or at diagnosis.} -\item{disc.outset.pers.B.prob}{Probability that an HIV-infected black MSM will -disclose his status at the start of a casual partnership.} +\item{disc.outset.pers.B.prob}{Probability that an HIV-infected black MSM +will disclose his status at the start of a casual partnership.} -\item{disc.outset.pers.W.prob}{Probability that an HIV-infected white MSM will -disclose his status at the start of a casual partnership.} +\item{disc.outset.pers.W.prob}{Probability that an HIV-infected white MSM +will disclose his status at the start of a casual partnership.} \item{disc.at.diag.pers.B.prob}{Probability that a black MSM already in a casual partnership will disclose at the time of diagnosis.} @@ -251,8 +324,8 @@ among black MSM.} mutation (homozygous and heterozygous, respectively) in the CCR5 gene among white MSM.} -\item{ccr5.heteroz.rr}{Relative risk of infection for men who are heterozygous -in the CCR5 mutation.} +\item{ccr5.heteroz.rr}{Relative risk of infection for men who are +heterozygous in the CCR5 mutation.} \item{num.inst.ai.classes}{Number of quantiles into which men should be divided in determining their levels of one-off anal intercourse.} @@ -275,9 +348,12 @@ partnerships (acts per day).} \item{base.ai.pers.WW.rate}{Expected coital frequency in white-white casual partnerships (acts per day).} -\item{ai.scale}{General relative scaler for all act rates for model +\item{ai.scale}{General relative scaler for all other act rates for model calibration.} +\item{ai.scale.pospos}{General relative scaler for HIV-positive-concordant +act rates for model calibration.} + \item{cond.main.BB.prob}{Probability of condom use in a black-black main partnership.} @@ -287,8 +363,8 @@ partnership.} \item{cond.main.WW.prob}{Probability of condom use in a white-white main partnership.} -\item{cond.pers.always.prob}{Fraction of men in casual partnerships who always -use condoms in those partnerships.} +\item{cond.pers.always.prob}{Fraction of men in casual partnerships who +always use condoms in those partnerships.} \item{cond.pers.BB.prob}{Of men who are not consistent condom users, per-act probability of condom use in a black-black casual partnerships.} @@ -299,8 +375,8 @@ probability of condom use in a black-white casual partnerships.} \item{cond.pers.WW.prob}{Of men who are not consistent condom users, per-act probability of condom use in a white-white casual partnerships.} -\item{cond.inst.always.prob}{Fraction of men in instant partnerships who always -use condoms in those partnerships.} +\item{cond.inst.always.prob}{Fraction of men in instant partnerships who +always use condoms in those partnerships.} \item{cond.inst.BB.prob}{Of men who are not consistent condom users, per-act probability of condom use in a black-black one-off partnerships.} @@ -311,8 +387,8 @@ probability of condom use in a black-white one-off partnerships.} \item{cond.inst.WW.prob}{Of men who are not consistent condom users, per-act probability of condom use in a white-white one-off partnerships.} -\item{cond.always.prob.corr}{Correlation coefficient for probability of always -using condoms in both casual and one-off} +\item{cond.always.prob.corr}{Correlation coefficient for probability of +always using condoms in both casual and one-off} \item{cond.rr.BB}{Condom probability scaler for black-black partnerships for model calibration purposes.} @@ -367,16 +443,16 @@ have never been on PrEP and are disease-susceptible.} \item{prep.class.prob}{The probability of adherence class in non-adherent, low adherence, medium adherence, or high adherence groups (from Liu).} -\item{prep.class.hr}{The hazard ratio for infection per act associated with each -level of adherence (from Grant).} +\item{prep.class.hr}{The hazard ratio for infection per act associated with +each level of adherence (from Grant).} \item{prep.coverage}{The proportion of the eligible population who are start PrEP once they become eligible.} \item{prep.cov.method}{The method for calculating PrEP coverage, with options -of \code{"curr"} to base the numerator on the number of people currently -on PrEP and \code{"ever"} to base it on the number of people ever on -PrEP.} +of \code{"curr"} to base the numerator on the number of people +currently on PrEP and \code{"ever"} to base it on the number of people +ever on PrEP.} \item{prep.cov.rate}{The rate at which persons initiate PrEP conditional on their eligibility, with 1 equal to instant start.} @@ -390,20 +466,165 @@ in days.} \item{prep.risk.reassess}{If \code{TRUE}, reassess eligibility for PrEP at each testing visit.} +\item{riskhist.int}{Interval of look-back period in which risk history is +assessed for the STI testing interventions.} + +\item{stitest.start}{Time step at which the STI testing guidelines +intervention should start.} + +\item{stitest.active.int}{Intertest interval for lower-risk group in STI +testing intervention.} + +\item{tst.rect.sti.rr}{Relative likelihood of rectal STI testing compared to +urethral testing among those selected to be tested.} + +\item{sti.highrisktest.int}{Intertest interval for higher-risk group in STI +testing intervention.} + +\item{stitest.elig.model}{Modeling approach for determining who is eligible +for high-risk STI testing. Current options are limited to: +\code{"all"}.} + +\item{stianntest.gc.hivneg.coverage}{The proportion of the eligible population +(HIV-negative, HIV-positive and undiagnosed, HIV-positive and +diagnosed and tt.traj not equal to a treater type) and who are +starting annual NG testing once they become eligible. This is not +inclusive of those who are simultaneously indicated for more frequent +testing.} + +\item{stianntest.ct.hivneg.coverage}{The proportion of the eligible +population (HIV-negative, HIV-positive and undiagnosed, HIV-positive +and diagnosed and tt.traj not equal to a treater type) and who are +starting annual CT testing once they become eligible. This is not +inclusive of those who are simultaneously indicated for more frequent +testing.} + +\item{stianntest.syph.hivneg.coverage}{The proportion of the eligible +population (HIV-negative, HIV-positive and undiagnosed, HIV-positive +and diagnosed and tt.traj not equal to a treater type) and who are +starting annual syphilis testing once they become eligible. This is not +inclusive of those who are simultaneously indicated for more frequent +testing.} + +\item{stihighrisktest.gc.hivneg.coverage}{The proportion of the non-HIV +diagnosed eligible population who are starting high-risk NG testing +once they become eligible.} + +\item{stihighrisktest.ct.hivneg.coverage}{The proportion of the non-HIV +diagnosed eligible population who are starting high-risk CT testing +once they become eligible.} + +\item{stihighrisktest.syph.hivneg.coverage}{The proportion of the non-HIV +diagnosed eligible population who are starting high-risk syphilis testing +once they become eligible.} + +\item{stianntest.gc.hivpos.coverage}{The proportion of the eligible population +(HIV-positive and diagnosed and tt.traj equal to a treater type) who +are starting annual NG testing once they become eligible. This is not +inclusive of those who are simultaneously indicated for more frequent +testing.} + +\item{stianntest.ct.hivpos.coverage}{The proportion of the eligible population +(HIV-positive and diagnosed and tt.traj equal to a treater type) who +are starting annual CT testing once they become eligible. This is not +inclusive of those who are simultaneously indicated for more frequent +testing.} + +\item{stianntest.syph.hivpos.coverage}{The proportion of the eligible population +(HIV-positive and diagnosed and tt.traj equal to a treater type) who +are starting annual syphilis testing once they become eligible. This is not +inclusive of those who are simultaneously indicated for more frequent +testing.} + +\item{stihighrisktest.gc.hivpos.coverage}{The proportion of the HIV +diagnosed eligible population who are starting high-risk NG testing +once they become eligible.} + +\item{stihighrisktest.ct.hivpos.coverage}{The proportion of the HIV +diagnosed eligible population who are starting high-risk CT testing +once they become eligible.} + +\item{stihighrisktest.syph.hivpos.coverage}{The proportion of the HIV +diagnosed eligible population who are starting high-risk syphilis testing +once they become eligible.} + +\item{stianntest.cov.method}{The method for calculating STI annual testing, +with options of \code{"curr"} to base the numerator on the number of +people currently annually testing for STI and \code{"ever"} to base it +on the number of people who have ever been annually tested for STI. +This is not inclusive of those who are simultaneously indicated for +more frequent testing.} + +\item{stihighrisktest.cov.method}{The method for calculating STI high-risk +testing, with options of \code{"curr"} to base the numerator on the +number of people currently high-risk testing for STI and \code{"ever"} +to base it on the number of people who have ever been high-risk tested +for STI.} + +\item{partnercutoff}{The cutoff point for STI high-risk indication, above +which person would be indicated for higher-risk testing schedules.} + +\item{ept.start}{Time step at which the EPT intervention should start.} + +\item{ept.risk.int}{Time window for assessment of risk eligibility for EPT +in days.} + +\item{ept.coverage}{The proportion of the eligible population (index) who are +starting EPT once they become eligible.} + +\item{ept.cov.method}{The method for calculating EPT coverage, with options +of \code{"curr"} to base the numerator on the number of people +currently on EPT and \code{"ever"} to base it on the number of people +ever on EPT.} + +\item{ept.cov.rate}{The rate at which persons initiate EPT conditional on +their eligibility, with 1 equal to instant start.} + +\item{ept.provision.partner.main.ong}{The likelihood of a index partner providing +EPT medication to a main partner when partnership is ongoing.} + +\item{ept.provision.partner.pers.ong}{The likelihood of a index partner providing +EPT medication to a casual partner when partnership is ongoing.} + +\item{ept.provision.partner.main.end}{The likelihood of a index partner providing +EPT medication to a main partner when partnership has ended} + +\item{ept.provision.partner.pers.end}{The likelihood of a index partner providing +EPT medication to a main partner when partnership has ended.} + +\item{ept.provision.partner.inst}{The likelihood of a index partner providing +EPT medication to a one-off partner.} + +\item{ept.uptake.partner.main}{The likelihood of a partner taking medication +provided to them by a main index partner.} + +\item{ept.uptake.partner.pers}{The likelihood of a partner taking medication +provided to them by a casual index partner.} + +\item{ept.uptake.partner.inst}{The likelihood of a partner taking medication +provided to them by a one-off index partner.} + +\item{ept.gc.success}{The probability of effective treatment for GC in a +partner given EPT medication.} + +\item{ept.ct.success}{The probability of effective treatment for CT in a +partner given EPT medication.} + \item{rcomp.prob}{Level of risk compensation from 0 to 1, where 0 is no risk compensation, 0.5 is a 50% reduction in the probability of condom use per act, and 1 is a complete cessation of condom use following PrEP initiation.} \item{rcomp.adh.groups}{PrEP adherence groups for whom risk compensation -occurs, as a vector with values 0, 1, 2, 3 corresponding to non-adherent, -low adherence, medium adherence, and high adherence to PrEP.} +occurs, as a vector with values 0, 1, 2, 3 corresponding to +non-adherent,low adherence, medium adherence, and high adherence +to PrEP.} \item{rcomp.main.only}{Logical, if risk compensation is limited to main partnerships only, versus all partnerships.} -\item{rcomp.discl.only}{Logical, if risk compensation is limited known-discordant -partnerships only, versus all partnerships.} +\item{rcomp.discl.only}{Logical, if risk compensation is limited +known-discordant partnerships only, versus all partnerships.} \item{rgc.tprob}{Probability of rectal gonorrhea infection per act.} @@ -413,6 +634,17 @@ partnerships only, versus all partnerships.} \item{uct.tprob}{Probability of urethral chlamydia infection per act.} +\item{syph.tprob}{Base probability of syphilis infection per act.} + +\item{syph.incub.rr}{Multiplier for reduced infection probability in +incubating stage of syphilis infection.} + +\item{syph.earlat.rr}{Multiplier for reduced infection probability in early +latent stage of syphilis infection.} + +\item{syph.late.rr}{Multiplier for reduced infection probability in late +stages of syphilis infection.} + \item{rgc.sympt.prob}{Probability of symptoms given infection with rectal gonorrhea.} @@ -425,59 +657,185 @@ chlamydia.} \item{uct.sympt.prob}{Probability of symptoms given infection with urethral chlamydia.} -\item{rgc.asympt.int}{Average duration in days of asymptomatic rectal gonorrhea.} +\item{syph.incub.sympt.prob}{Probability of symptoms given incubating stage +syphilis infection.} + +\item{syph.prim.sympt.prob}{Probability of symptoms given primary stage +syphilis infection.} + +\item{syph.seco.sympt.prob}{Probability of symptoms given secondary stage +syphilis infection.} + +\item{syph.earlat.sympt.prob}{Probability of symptoms given early latent +stage syphilis infection.} -\item{ugc.asympt.int}{Average duration in days of asymptomatic urethral gonorrhea.} +\item{syph.latelat.sympt.prob}{Probability of symptoms given late latent +stage syphilis infection.} + +\item{syph.tert.sympt.prob}{Probability of symptoms given tertiary stage +syphilis infection.} + +\item{rgc.asympt.rate}{Average duration in days of asymptomatic rectal +gonorrhea.} + +\item{ugc.asympt.rate}{Average duration in days of asymptomatic urethral +gonorrhea.} \item{gc.tx.int}{Average duration in days of treated gonorrhea (both sites).} -\item{gc.ntx.int}{Average duration in days of untreated, symptomatic gonorrhea (both sites). -If \code{NA}, uses site-specific durations for asymptomatic infections.} +\item{gc.ntx.int}{Average duration in days of untreated, symptomatic +gonorrhea (both sites). If \code{NA}, uses site-specific durations +for asymptomatic infections.} -\item{rct.asympt.int}{Average in days duration of asymptomatic rectal chlamydia.} +\item{rct.asympt.rate}{Average in days duration of asymptomatic rectal +chlamydia.} -\item{uct.asympt.int}{Average in days duration of asymptomatic urethral chlamydia.} +\item{uct.asympt.rate}{Average in days duration of asymptomatic urethral +chlamydia.} \item{ct.tx.int}{Average in days duration of treated chlamydia (both sites).} -\item{ct.ntx.int}{Average in days duration of untreated, symptomatic chlamydia (both sites). -If \code{NA}, uses site-specific durations for asymptomatic infections.} +\item{ct.ntx.int}{Average in days duration of untreated, symptomatic +chlamydia (both sites). If \code{NA}, uses site-specific durations +for asymptomatic infections.} -\item{gc.prob.cease}{Probability of ceasing sexual activity during symptomatic -infection with gonorrhea.} +\item{syph.early.tx.int}{Average in days duration of treatment for early +syphilis.} -\item{ct.prob.cease}{Probability of ceasing sexual activity during symptomatic -infection with chlamydia.} +\item{syph.late.tx.int}{Average in days duration of treatment for late +syphilis.} \item{gc.sympt.prob.tx}{Probability of treatment for symptomatic gonorrhea.} \item{ct.sympt.prob.tx}{Probability of treatment for symptomatic chlamydia.} -\item{gc.asympt.prob.tx}{Probability of treatment for asymptomatic gonorrhea.} +\item{gc.asympt.prob.tx}{Probability of treatment, given diagnosis, for +asymptomatic gonorrhea.} + +\item{ct.asympt.prob.tx}{Probability of treatment, given diagnosis, for +asymptomatic chlamydia.} + +\item{syph.incub.sympt.prob.tx}{Probability of treatment for symptomatic +incubating stage syphilis infection.} + +\item{syph.incub.asympt.prob.tx}{Probability of treatment, given diagnosis, +for asymptomatic incubating stage syphilis infection.} + +\item{syph.prim.sympt.prob.tx}{Probability of treatment for symptomatic +primary stage syphilis infection.} + +\item{syph.prim.asympt.prob.tx}{Probability of treatment, given diagnosis, +for asymptomatic primary stage syphilis infection.} + +\item{syph.seco.sympt.prob.tx}{Probability of treatment for symptomatic +secondary stage syphilis infection.} + +\item{syph.seco.asympt.prob.tx}{Probability of treatment, given diagnosis, +for asymptomatic secondary stage syphilis infection.} + +\item{syph.earlat.sympt.prob.tx}{Probability of treatment for symptomatic +early latent stage syphilis infection.} + +\item{syph.earlat.asympt.prob.tx}{Probability of treatment, given diagnosis, +for asymptomatic early latent stage syphilis infection.} + +\item{syph.latelat.sympt.prob.tx}{Probability of treatment for symptomatic +late latent stage syphilis infection.} -\item{ct.asympt.prob.tx}{Probability of treatment for asymptomatic chlamydia.} +\item{syph.latelat.asympt.prob.tx}{Probability of treatment, given diagnosis, +for asymptomatic late latent stage syphilis infection.} -\item{prep.sti.screen.int}{Interval in days between STI screening at PrEP visits.} +\item{syph.tert.sympt.prob.tx}{Probability of treatment for symptomatic +tertiary stage syphilis infection.} -\item{prep.sti.prob.tx}{Probability of treatment given positive screening during -PrEP visit.} +\item{syph.tert.asympt.prob.tx}{Probability of treatment, given diagnosis, +for asymptomatic tertiary stage syphilis infection.} -\item{prep.continue.stand.tx}{Logical, if \code{TRUE} will continue standard -STI treatment of symptomatic cases even after PrEP initiation.} +\item{prep.sti.screen.int}{Interval in days between STI screening at PrEP +visits.} + +\item{prep.sti.prob.tx}{Probability of treatment given positive screening +during PrEP visit.} \item{sti.cond.rr}{Relative risk of STI infection (in either direction) given a condom used by the insertive partner.} -\item{hiv.rgc.rr}{Relative risk of HIV infection given current rectal gonorrhea.} +\item{hiv.rgc.rr}{Relative risk of HIV infection given current rectal +gonorrhea in the HIV-negative partner.} + +\item{hiv.ugc.rr}{Relative risk of HIV infection given current urethral +gonorrhea in the HIV-negative partner.} + +\item{hiv.rct.rr}{Relative risk of HIV infection given current rectal +chlamydia in the HIV-negative partner.} + +\item{hiv.uct.rr}{Relative risk of HIV infection given current urethral +chlamydia in the HIV-negative partner.} + +\item{hiv.syph.rr}{Relative risk of HIV infection given current +syphilis infection in the HIV-negative partner.} + +\item{hiv.rgc.rct.rr}{Additive proportional risk, from 0 to 1, for HIV +acquisition given dual infection with both rectal gonorrhea and +rectal chlamydia in the HIV-negative partner.} + +\item{hiv.rgc.syph.rr}{Additive proportional risk, from 0 to 1, for HIV +acquisition given dual infection with both rectal gonorrhea and +syphilis in the HIV-negative partner.} + +\item{hiv.rct.syph.rr}{Additive proportional risk, from 0 to 1, for HIV +acquisition given dual infection with both rectal chlamydia and +syphilis in the HIV-negative partner.} + +\item{hiv.ugc.uct.rr}{Additive proportional risk, from 0 to 1, for HIV +acquisition given dual infection with both urethral gonorrhea and +urethral chlamydia in the HIV-negative partner.} + +\item{hiv.ugc.syph.rr}{Additive proportional risk, from 0 to 1, for HIV +acquisition given dual infection with both urethral gonorrhea and +syphilis in the HIV-negative partner.} + +\item{hiv.uct.syph.rr}{Additive proportional risk, from 0 to 1, for HIV +acquisition given dual infection with both urethral chlamydia and +syphilis in the HIV-negative partner.} + +\item{hiv.all.ureth.rr}{Additive proportional risk, from 0 to 1, for HIV +acquisition given triple infection with urethral chlamydia, urethral +gonorrhea, and syphilis in the HIV-negative partner.} + +\item{hiv.all.rect.rr}{Additive proportional risk, from 0 to 1, for HIV +acquisition given triple infection with rectal chlamydia, rectal +gonorrhea, and syphilis.} + +\item{hiv.trans.gc.rr}{Relative risk for HIV transmission given prevalent +relevant site-specific gonorrhea infection in HIV-positive partner.} + +\item{hiv.trans.ct.rr}{Relative risk for HIV transmission given prevalent +relevant site-specific chlamydia infection in HIV-positive partner.} + +\item{hiv.trans.syph.rr}{Relative risk for HIV transmission given prevalent +relevant syphilis infection in HIV-positive partner.} + +\item{hiv.trans.gc.ct.rr}{Additive proportional risk, from 0 to 1, for HIV +transmission given prevalent relevant site-specific gonorrhea +infection and relevant site-specific chlamydia infection in +HIV-positive partner.} -\item{hiv.ugc.rr}{Relative risk of HIV infection given current urethral gonorrhea.} +\item{hiv.trans.gc.syph.rr}{Additive proportional risk, from 0 to 1, for HIV +transmission given prevalent relevant site-specific gonorrhea +infection and syphilis infection in HIV-positive partner.} -\item{hiv.rct.rr}{Relative risk of HIV infection given current rectal chlamydia.} +\item{hiv.trans.ct.syph.rr}{Additive proportional risk, from 0 to 1, for HIV +transmission given prevalent relevant site-specific chlamydia +infection and syphilis infection in HIV-positive partner.} -\item{hiv.uct.rr}{Relative risk of HIV infection given current urethral chlamydia.} +\item{hiv.trans.allsti.rr}{Additive proportional risk, from 0 to 1, for HIV +transmission given prevalent relevant site-specific gonorrhea +infection, relevant site-specific chlamydia infection, and syphilis +infection in HIV-positive partner.} -\item{hiv.dual.rr}{Additive proportional risk, from 0 to 1, for HIV infection -given dual infection with both gonorrhea and chlamydia.} +\item{partlist.start}{Time step at which persisting edge list should begin +accumulating for eventual STI testing indications.} \item{...}{Additional arguments passed to the function.} } diff --git a/man/part_msm.Rd b/man/part_msm.Rd new file mode 100644 index 00000000..f46a959f --- /dev/null +++ b/man/part_msm.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.part.R +\name{part_msm} +\alias{part_msm} +\title{Partnership tracking Module} +\usage{ +part_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +This function returns the \code{dat} object with the updated master +partnership list, on \code{temp$part.list}. +} +\description{ +Module function for tracking partnerships for STD testing + and EPT. +} +\details{ +Partnerships are tracked in a persistent edge list that allows for easy +reference to determine if a participant has been in a particular type of +relationship within a defined time frame infected; or post diagnosis for +one recently infected. The rates of disclosure vary at these three points, +and also by the partnership type. +} +\keyword{module} +\keyword{msm} diff --git a/man/position_msm.Rd b/man/position_msm.Rd index 823faea4..8c2be970 100644 --- a/man/position_msm.Rd +++ b/man/position_msm.Rd @@ -13,8 +13,8 @@ individual-level attributes, and summary statistics.} \item{at}{Current time step.} } \value{ -This function returns the updated discordant edgelist with a \code{ins} -attribute for values of whether the infected node is insertive or the +This function returns the updated act list with a \code{ins} +attribute for values of whether the node is insertive or the susceptible node is insertive for that act. } \description{ diff --git a/man/prevalence_het.Rd b/man/prevalence_het.Rd new file mode 100644 index 00000000..223ee9b6 --- /dev/null +++ b/man/prevalence_het.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.prevalence.R +\name{prevalence_het} +\alias{prevalence_het} +\title{Prevalence Module} +\usage{ +prevalence_het(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module function to calculate and store summary statistics for + disease prevalence, demographics, and other epidemiological + outcomes. +} +\keyword{het} +\keyword{module} diff --git a/man/prevalence_msm.Rd b/man/prevalence_msm.Rd index a13ac03e..0ba22c84 100644 --- a/man/prevalence_msm.Rd +++ b/man/prevalence_msm.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/mod.prevalence.R \name{prevalence_msm} \alias{prevalence_msm} -\alias{prevalence_het} \title{Prevalence Calculations within Time Steps} \usage{ prevalence_msm(dat, at) - -prevalence_het(dat, at) } \arguments{ \item{dat}{Master data list object of class \code{dat} containing networks, @@ -16,8 +13,8 @@ individual-level attributes, and summary statistics.} \item{at}{Current time step.} } \value{ -This function returns the \code{dat} object with an updated summary of current -attributes stored in \code{dat$epi}. +This function returns the \code{dat} object with an updated summary of +current attributes stored in \code{dat$epi}. } \description{ This module calculates demographic, transmission, and clinical diff --git a/man/prevalence_msm_ept.Rd b/man/prevalence_msm_ept.Rd new file mode 100644 index 00000000..5c6e4969 --- /dev/null +++ b/man/prevalence_msm_ept.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.prevalence.R +\name{prevalence_msm_ept} +\alias{prevalence_msm_ept} +\title{Prevalence Calculations within Time Steps} +\usage{ +prevalence_msm_ept(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +This function returns the \code{dat} object with an updated summary of +current attributes stored in \code{dat$epi}. +} +\description{ +This module calculates demographic, transmission, and clinical + statistics at each time step within the simulation. +} +\details{ +Summary statistic calculations are of two broad forms: prevalence and +incidence. This function establishes the summary statistic vectors for both +prevalence and incidence at time 1, and then calculates the prevalence +statistics for times 2 onward. Incidence statistics (e.g., number of new +infections or deaths) are calculated within the modules as they depend on +vectors that are not stored external to the module. +} +\keyword{module} +\keyword{msm} diff --git a/man/prevalence_msm_tnt.Rd b/man/prevalence_msm_tnt.Rd new file mode 100644 index 00000000..18238437 --- /dev/null +++ b/man/prevalence_msm_tnt.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.prevalence.R +\name{prevalence_msm_tnt} +\alias{prevalence_msm_tnt} +\title{Prevalence Calculations within Time Steps} +\usage{ +prevalence_msm_tnt(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +This function returns the \code{dat} object with an updated summary of +current attributes stored in \code{dat$epi}. +} +\description{ +This module calculates demographic, transmission, and clinical + statistics at each time step within the simulation. +} +\details{ +Summary statistic calculations are of two broad forms: prevalence and +incidence. This function establishes the summary statistic vectors for both +prevalence and incidence at time 1, and then calculates the prevalence +statistics for times 2 onward. Incidence statistics (e.g., number of new +infections or deaths) are calculated within the modules as they depend on +vectors that are not stored external to the module. +} +\keyword{module} +\keyword{msm} diff --git a/man/reinit_het.Rd b/man/reinit_het.Rd index 2308c65a..528e31d2 100644 --- a/man/reinit_het.Rd +++ b/man/reinit_het.Rd @@ -18,13 +18,13 @@ reinit_het(x, param, init, control, s) \item{s}{Simulation number, used for restarting dependent simulations.} } \value{ -This function returns the updated \code{dat} object with the initialized values -for demographics and disease-related variables. +This function returns the updated \code{dat} object with the initialized +values for demographics and disease-related variables. } \description{ -This function reinitializes the master \code{dat} object on which - data are stored, simulates the initial state of the network, and - simulates disease status and other attributes. +This function reinitializes the master \code{dat} object on + which data are stored, simulates the initial state of the + network, and simulates disease status and other attributes. } \keyword{het} \keyword{module} diff --git a/man/riskhist_prep_msm.Rd b/man/riskhist_prep_msm.Rd new file mode 100644 index 00000000..ff6a7e23 --- /dev/null +++ b/man/riskhist_prep_msm.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.riskhist.R +\name{riskhist_prep_msm} +\alias{riskhist_prep_msm} +\title{Risk History for PrEP Module} +\usage{ +riskhist_prep_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module function to track the risk history of uninfected persons + for purpose of PrEP prevention intervention targeting. +} +\keyword{module} +\keyword{msm} diff --git a/man/riskhist_stitest_msm.Rd b/man/riskhist_stitest_msm.Rd new file mode 100644 index 00000000..b285c039 --- /dev/null +++ b/man/riskhist_stitest_msm.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.riskhist.R +\name{riskhist_stitest_msm} +\alias{riskhist_stitest_msm} +\title{Risk History for STI Testing Module} +\usage{ +riskhist_stitest_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module function to track the risk history of uninfected persons + for purpose of STI testing prevention intervention targeting. +} +\keyword{module} +\keyword{msm} diff --git a/man/setBirthAttr_het.Rd b/man/setBirthAttr_het.Rd new file mode 100644 index 00000000..6a1b7d30 --- /dev/null +++ b/man/setBirthAttr_het.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.births.R +\name{setBirthAttr_het} +\alias{setBirthAttr_het} +\title{Assign Vertex Attributes at Network Entry} +\usage{ +setBirthAttr_het(dat, at, nBirths) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} + +\item{nBirths}{Number of new births as determined by \code{\link{births_het}}.} +} +\description{ +Assigns vertex attributes to incoming nodes at birth/entry into + the network. +} +\keyword{het} diff --git a/man/simnet_het.Rd b/man/simnet_het.Rd new file mode 100644 index 00000000..8f9c9200 --- /dev/null +++ b/man/simnet_het.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.simnet.R +\name{simnet_het} +\alias{simnet_het} +\title{Network Resimulation Module} +\usage{ +simnet_het(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module function to resimulate the dynamic network forward one + time step conditional on current network structure and vertex + attributes. +} +\keyword{het} +\keyword{module} diff --git a/man/simnet_msm.Rd b/man/simnet_msm.Rd index 930eb7b7..f892f289 100644 --- a/man/simnet_msm.Rd +++ b/man/simnet_msm.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/mod.simnet.R \name{simnet_msm} \alias{simnet_msm} -\alias{simnet_het} \title{Network Resimulation Module} \usage{ simnet_msm(dat, at) - -simnet_het(dat, at) } \arguments{ \item{dat}{Master data list object of class \code{dat} containing networks, @@ -16,8 +13,8 @@ individual-level attributes, and summary statistics.} \item{at}{Current time step.} } \description{ -Module function for resimulating the sexual networks for one - time step. +Module function for resimulating the main, casual, and one-off + networks for one time step. } \keyword{module} \keyword{msm} diff --git a/man/sti_ept_msm.Rd b/man/sti_ept_msm.Rd new file mode 100644 index 00000000..a23c96d5 --- /dev/null +++ b/man/sti_ept_msm.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.ept.R +\name{sti_ept_msm} +\alias{sti_ept_msm} +\title{EPT Module} +\usage{ +sti_ept_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module function for eligibility of non-index partner, provision + of expedited partner therapy (EPT) from index partner to + non-index partner, and uptake by non-index partner to prevent + STI infection. Eligibility for index partner is handled in the + STI treatment module. +} +\keyword{module} +\keyword{msm} diff --git a/man/sti_recov_msm.Rd b/man/sti_recov_msm.Rd new file mode 100644 index 00000000..8ebcdaaa --- /dev/null +++ b/man/sti_recov_msm.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.sti.R +\name{sti_recov_msm} +\alias{sti_recov_msm} +\title{STI Recovery Module} +\usage{ +sti_recov_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Stochastically simulates GC/CT recovery. +} +\keyword{module} +\keyword{msm} diff --git a/man/sti_test_msm.Rd b/man/sti_test_msm.Rd new file mode 100644 index 00000000..c1760896 --- /dev/null +++ b/man/sti_test_msm.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.test.R +\name{sti_test_msm} +\alias{sti_test_msm} +\title{STI Testing Module} +\usage{ +sti_test_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +This function returns the \code{dat} object with updated +\code{last.neg.test}, \code{diag.status} and \code{diag.time} attributes for +each STI. +} +\description{ +Module function for STI screening of asymptomatic persons. +} +\details{ +This testing module supports two testing parameterizations, input via the +\code{testing.pattern} parameter: memoryless for stochastic and +geometrically-distributed waiting times to test (constant hazard); and +interval for deterministic tested after defined waiting time intervals. +Symptomatic testing is handled in the STI treatment module. +} +\keyword{module} +\keyword{msm} diff --git a/man/sti_trans_msm.Rd b/man/sti_trans_msm.Rd new file mode 100644 index 00000000..91f62045 --- /dev/null +++ b/man/sti_trans_msm.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.sti.R +\name{sti_trans_msm} +\alias{sti_trans_msm} +\title{STI Transmission Module} +\usage{ +sti_trans_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Stochastically simulates GC/CT transmission given the current + state of the edgelist. +} +\keyword{module} +\keyword{msm} diff --git a/man/sti_tx_msm.Rd b/man/sti_tx_msm.Rd new file mode 100644 index 00000000..6bf715c2 --- /dev/null +++ b/man/sti_tx_msm.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.sti.R +\name{sti_tx_msm} +\alias{sti_tx_msm} +\title{STI Treatment Module} +\usage{ +sti_tx_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Stochastically simulates GC/CT and syphilis diagnosis and + treatment. +} +\keyword{module} +\keyword{msm} diff --git a/man/syph_progress_msm.Rd b/man/syph_progress_msm.Rd new file mode 100644 index 00000000..213becca --- /dev/null +++ b/man/syph_progress_msm.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.progress.R +\name{syph_progress_msm} +\alias{syph_progress_msm} +\title{Disease Progression Module} +\usage{ +syph_progress_msm(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\value{ +This function returns the \code{dat} object after updating the disease stage +of infected individuals. +} +\description{ +Module function for Syphilis disease progression through + multiple stages. +} +\details{ +Syphilis disease is divided into multiple stages: incubating, primary, +secondary, early latent, late latent, tertiary, and remission. + +The time spent in chronic stage infection, and thus the time from infection +to AIDS, depends on ART history. For ART-naive persons, time to AIDS is +established by the \code{vl.aids.onset.int} parameter. For persons ever on ART +who fall into the partially suppressed category (the \code{tt.traj} attribute +is \code{3}), time to AIDS depends on the sum of two ratios: time on +treatment over maximum time on treatment plus time off treatment over maximum +time off treatment. +For persons ever on ART who fall into the fully suppressed category +(\code{tt.traj=4}), time to AIDS depends on whether the cumulative time +off treatment exceeds a time threshold specified in the +\code{max.time.off.tx.full} parameter. +} +\keyword{module} +\keyword{msm} +\keyword{syphilis} diff --git a/man/trans_het.Rd b/man/trans_het.Rd new file mode 100644 index 00000000..77b50777 --- /dev/null +++ b/man/trans_het.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.trans.R +\name{trans_het} +\alias{trans_het} +\title{Infection Module} +\usage{ +trans_het(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module function to simulate transmission over an active + discordant edgelist. +} +\keyword{het} +\keyword{module} diff --git a/man/tx_het.Rd b/man/tx_het.Rd new file mode 100644 index 00000000..8975af3b --- /dev/null +++ b/man/tx_het.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.tx.R +\name{tx_het} +\alias{tx_het} +\title{HIV Anti-Retroviral Treatment Module} +\usage{ +tx_het(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module function for simulating HIV therapy after diagnosis, + including adherence and non-adherence to ART. +} +\keyword{het} +\keyword{module} diff --git a/man/verbose_het.Rd b/man/verbose_het.Rd new file mode 100644 index 00000000..14ce4b06 --- /dev/null +++ b/man/verbose_het.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.verbose.R +\name{verbose_het} +\alias{verbose_het} +\title{Verbose Module} +\usage{ +verbose_het(x, type, s, at) +} +\arguments{ +\item{x}{If the \code{type} is "startup", then an object of class +\code{control.net}, otherwise the all master data object in \code{netsim} +simulations.} + +\item{type}{Progress type, either of "startup" for starting messages before +all simulations, or "progress" for time step specific messages.} + +\item{s}{Current simulation number, if type is "progress"} + +\item{at}{Current time step, if type is "progress"} +} +\description{ +Prints simulation model progress within the time loop. +} +\details{ +In interactive mode, this module function prints out a standard set of +demographic and epidemiologic summary statistics to the console window. In +non-interactive, batch mode these are saved onto \code{.txt} files in a +\code{verb/} subdirectory. This subdirectory will be created if it does not +exist. +} +\keyword{het} +\keyword{module} diff --git a/man/verbose_msm.Rd b/man/verbose_msm.Rd index 3cb56c1e..79bd0c3a 100644 --- a/man/verbose_msm.Rd +++ b/man/verbose_msm.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/mod.verbose.R \name{verbose_msm} \alias{verbose_msm} -\alias{verbose_het} \title{Verbose Module} \usage{ verbose_msm(x, type, s, at) - -verbose_het(x, type, s, at) } \arguments{ \item{x}{If the \code{type} is "startup", then an object of class diff --git a/man/vl_het.Rd b/man/vl_het.Rd new file mode 100644 index 00000000..910e535a --- /dev/null +++ b/man/vl_het.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod.vl.R +\name{vl_het} +\alias{vl_het} +\title{Viral Load Module} +\usage{ +vl_het(dat, at) +} +\arguments{ +\item{dat}{Master data list object of class \code{dat} containing networks, +individual-level attributes, and summary statistics.} + +\item{at}{Current time step.} +} +\description{ +Module function for simulating progression of HIV viral load in + natural disease dynamics and in the presence of ART. +} +\keyword{het} +\keyword{module} diff --git a/tests/testthat/test-aging.R b/tests/testthat/test-aging.R new file mode 100644 index 00000000..e5de47ae --- /dev/null +++ b/tests/testthat/test-aging.R @@ -0,0 +1,23 @@ +context("Aging Module") + +data(est) +data(st) + +test_that("Aging module", { + + param <- param_msm(nwstats = st) + init <- init_msm(nwstats = st) + control <- control_msm() + + at <- 1 + dat <- initialize_msm(est, param, init, control, s = 1) + + pre.age <- dat$attr$age + expect_true(all(!is.na(pre.age))) + expect_true(sum(pre.age) > 0) + + dat <- aging_msm(dat, at = 2) + post.age <- dat$attr$age + expect_true(all(post.age == pre.age + st$time.unit/365)) + +}) diff --git a/tests/testthat/test-netsim.R b/tests/testthat/test-netsim.R index 1472c176..df8fd4c7 100644 --- a/tests/testthat/test-netsim.R +++ b/tests/testthat/test-netsim.R @@ -1,45 +1,20 @@ -context("Model Runs") +context("Full netsim Simulation") -test_that("Burnin model", { +data(est) +data(st) - data(st) - data(est) +test_that("Testing netsim", { param <- param_msm(nwstats = st) init <- init_msm(nwstats = st) - control <- control_msm(simno = 1, nsteps = 10, verbose = FALSE) - - sim <- netsim(est, param, init, control) - expect_is(sim, "netsim") - -}) - -test_that("Follow-up model", { - - data(st) - data(est) - - param <- param_msm(nwstats = st, - prep.start = 10) - init <- init_msm(nwstats = st) - control <- control_msm(simno = 1, nsteps = 10, - save.other = c("attr", "temp", "riskh", "el", "p"), - verbose = FALSE) + control <- control_msm(nsteps = 5, verbose = FALSE) sim <- netsim(est, param, init, control) - param <- param_msm(nwstats = st, - prep.start = 10, - prep.elig.model = "cdc3", - prep.coverage = 0.5, - prep.risk.int = 182, - prep.class.prob = reallocate_pcp(reall = 0), - prep.class.hr = c(1, 0.69, 0.19, 0.05)) - init <- init_msm(nwstats = st) - control <- control_msm(simno = 1, start = 11, nsteps = 20, - verbose = FALSE, initialize.FUN = reinit_msm) - - sim2 <- netsim(sim, param, init, control) - expect_is(sim2, "netsim") + # expect this output on sim + nm <- c("param", "control", "nwparam", "epi", "stats", "attr", "temp", + "el", "p") + expect_identical(names(sim), nm) + expect_is(sim, "netsim") })