├── .Rbuildignore ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── LICENSE.md ├── NAMESPACE ├── R ├── EpiModelHIV-package.R ├── mod.acts.R ├── mod.aging.R ├── mod.arrival.R ├── mod.condoms.R ├── mod.departure.R ├── mod.hivcd4.R ├── mod.hivprogress.R ├── mod.hivtest.R ├── mod.hivtrans.R ├── mod.hivtx.R ├── mod.hivvl.R ├── mod.initialize.R ├── mod.position.R ├── mod.prep.R ├── mod.prevalence.R ├── mod.simnet.R ├── mod.stirecov.R ├── mod.stitrans.R ├── mod.stitx.R └── params.R ├── README.md ├── inst ├── het-test-script.R └── msm-test-script.R ├── man ├── EpiModelHIV-package.Rd ├── acts_msm.Rd ├── aging_msm.Rd ├── arrival_msm.Rd ├── cd4_het.Rd ├── condoms_msm.Rd ├── control_het.Rd ├── control_msm.Rd ├── departure_msm.Rd ├── edges_correct_msm.Rd ├── hivprogress_msm.Rd ├── hivtest_msm.Rd ├── hivtrans_msm.Rd ├── hivtx_msm.Rd ├── hivvl_msm.Rd ├── init_het.Rd ├── init_msm.Rd ├── init_status_msm.Rd ├── init_sti_msm.Rd ├── initialize_msm.Rd ├── param_het.Rd ├── param_msm.Rd ├── position_msm.Rd ├── prep_msm.Rd ├── prevalence_msm.Rd ├── reallocate_pcp.Rd ├── reinit_het.Rd ├── reinit_msm.Rd ├── riskhist_msm.Rd ├── simnet_msm.Rd ├── stirecov_msm.Rd ├── stitrans_msm.Rd └── stitx_msm.Rd └── tests ├── testthat.R └── testthat ├── test-estimation.R └── test-params.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | .travis.yml 4 | LICENSE.md 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | src/*.o 6 | src/*.so 7 | src/*.dll 8 | *.Rproj 9 | .DS_Store 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | sudo: false 3 | cache: packages 4 | 5 | warnings_are_errors: true 6 | 7 | r_github_packages: 8 | - statnet/EpiModelHPC 9 | - statnet/tergmLite 10 | 11 | notifications: 12 | email: 13 | on_success: never 14 | on_failure: change 15 | slack: epimodel:ARrkdZn2p9KKRZxkcGFK9Ns0 16 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: EpiModelHIV 2 | Version: 1.5.0 3 | Date: 2017-05-04 4 | Type: Package 5 | Title: Network-Based Epidemic Modeling of HIV Transmission among MSM and Heterosexual Populations 6 | Authors@R: c(person("Samuel M.", "Jenness", role = c("cre", "aut"), email = "samuel.m.jenness@emory.edu"), 7 | person("Steven M.", "Goodreau", role="aut", email="goodeau@uw.edu"), 8 | person("Emily", "Beylerian", role = "ctb", email = "ebey@uw.edu"), 9 | person("Kevin", "Weiss", role = "aut", email = "kevin.weiss@emory.edu")) 10 | Maintainer: Samuel M. Jenness 11 | Description: EpiModelHIV provides extensions to our general EpiModel package to allow for simulating HIV transmission 12 | dynamics among two populations: men who have sex with men (MSM) in the United States and heterosexual adults in 13 | sub-Saharan Africa. 14 | License: GPL-3 15 | Depends: 16 | R (>= 3.5.0), 17 | EpiModel (>= 1.7.0), 18 | EpiModelHPC (>= 2.0.0), 19 | ergm (>= 3.9.4), 20 | tergm (>= 3.5.2), 21 | tergmLite (>= 1.2.0) 22 | Imports: 23 | bindata, 24 | network, 25 | networkDynamic, 26 | dplyr 27 | Suggests: 28 | knitr, 29 | testthat 30 | VignetteBuilder: knitr 31 | RoxygenNote: 6.1.1 32 | LazyData: true 33 | Encoding: UTF-8 34 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(acts_msm) 4 | export(aging_het) 5 | export(aging_msm) 6 | export(arrival_msm) 7 | export(births_het) 8 | export(cd4_het) 9 | export(condoms_msm) 10 | export(control_het) 11 | export(control_msm) 12 | export(deaths_het) 13 | export(departure_msm) 14 | export(dx_het) 15 | export(edges_correct_het) 16 | export(edges_correct_msm) 17 | export(hivprogress_msm) 18 | export(hivtest_msm) 19 | export(hivtrans_msm) 20 | export(hivtx_msm) 21 | export(hivvl_msm) 22 | export(init_het) 23 | export(init_msm) 24 | export(init_status_msm) 25 | export(init_sti_msm) 26 | export(initialize_het) 27 | export(initialize_msm) 28 | export(param_het) 29 | export(param_msm) 30 | export(position_msm) 31 | export(prep_msm) 32 | export(prevalence_het) 33 | export(prevalence_msm) 34 | export(reallocate_pcp) 35 | export(reinit_het) 36 | export(reinit_msm) 37 | export(riskhist_msm) 38 | export(simnet_het) 39 | export(simnet_msm) 40 | export(stirecov_msm) 41 | export(stitrans_msm) 42 | export(stitx_msm) 43 | export(trans_het) 44 | export(tx_het) 45 | export(vl_het) 46 | import(EpiModel) 47 | import(EpiModelHPC) 48 | import(bindata) 49 | import(ergm) 50 | import(network) 51 | import(networkDynamic) 52 | import(tergm) 53 | import(tergmLite) 54 | importFrom(dplyr,group_by) 55 | importFrom(dplyr,summarise) 56 | importFrom(stats,plogis) 57 | importFrom(stats,predict) 58 | importFrom(stats,rbinom) 59 | importFrom(stats,rgeom) 60 | importFrom(stats,rmultinom) 61 | importFrom(stats,rnbinom) 62 | importFrom(stats,rpois) 63 | importFrom(stats,runif) 64 | importFrom(stats,simulate) 65 | importFrom(utils,tail) 66 | -------------------------------------------------------------------------------- /R/EpiModelHIV-package.R: -------------------------------------------------------------------------------- 1 | #' Network-Based Epidemic Modeling of HIV Transmission among MSM and Heterosexual Populations 2 | #' 3 | #' \tabular{ll}{ 4 | #' Package: \tab EpiModelHIV\cr 5 | #' Type: \tab Package\cr 6 | #' Version: \tab 1.5.0\cr 7 | #' Date: \tab 2017-05-04\cr 8 | #' License: \tab GPL-3\cr 9 | #' LazyLoad: \tab yes\cr 10 | #' } 11 | #' 12 | #' @details 13 | #' EpiModelHIV provides extensions to our general EpiModel package to allow 14 | #' for simulating HIV transmission dynamics among two populations: men who 15 | #' have sex with men (MSM) in the United States and heterosexual adults in 16 | #' sub-Saharan Africa. 17 | #' 18 | #' @name EpiModelHIV-package 19 | #' @aliases EpiModelHIV 20 | #' 21 | #' @import EpiModel EpiModelHPC network networkDynamic tergmLite tergm ergm bindata 22 | #' @importFrom stats rbinom rgeom rmultinom rpois runif simulate rnbinom plogis predict 23 | #' @importFrom dplyr group_by summarise 24 | #' @importFrom utils tail 25 | #' 26 | #' @docType package 27 | #' @keywords package msm het 28 | #' 29 | NULL 30 | -------------------------------------------------------------------------------- /R/mod.acts.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Sexual Acts Module 3 | #' 4 | #' @description Module function for setting the number of sexual acts on the 5 | #' discordant edgelist. 6 | #' 7 | #' @inheritParams aging_msm 8 | #' 9 | #' @details 10 | #' The number of acts at each time step is specified as a function of the race of 11 | #' both members in a pair and the expected values within black-black, black-white, 12 | #' and white-white combinations. For one-off partnerships, this is deterministically 13 | #' set at 1, whereas for main and causal partnerships it is a stochastic draw 14 | #' from a Poisson distribution. The number of total acts may further be modified 15 | #' by the level of HIV viral suppression in an infected person. 16 | #' 17 | #' @keywords module msm 18 | #' @export 19 | #' 20 | acts_msm <- function(dat, at) { 21 | 22 | # Attributes 23 | status <- dat$attr$status 24 | diag.status <- dat$attr$diag.status 25 | race <- dat$attr$race 26 | age <- dat$attr$age 27 | stage <- dat$attr$stage 28 | vl <- dat$attr$vl 29 | uid <- dat$attr$uid 30 | 31 | plist <- dat$temp$plist 32 | 33 | # Parameters 34 | acts.mod <- dat$param$epistats$acts.mod 35 | acts.aids.vl <- dat$param$acts.aids.vl 36 | acts.scale <- dat$param$acts.scale 37 | 38 | # Construct edgelist 39 | el <- rbind(dat$el[[1]], dat$el[[2]], dat$el[[3]]) 40 | ptype <- rep(1:3, times = c(nrow(dat$el[[1]]), 41 | nrow(dat$el[[2]]), 42 | nrow(dat$el[[3]]))) 43 | st1 <- status[el[, 1]] 44 | st2 <- status[el[, 2]] 45 | 46 | el <- cbind(el, st1, st2, ptype) 47 | colnames(el) <- c("p1", "p2", "st1", "st2", "ptype") 48 | 49 | # Subset to main/casual 50 | el.mc <- el[el[, "ptype"] != 3, ] 51 | 52 | # Base AI rates based on Poisson model for main/casual 53 | race.combo <- rep(NA, nrow(el.mc)) 54 | race.combo[race[el.mc[, 1]] == 1 & race[el.mc[, 2]] == 1] <- 1 55 | race.combo[race[el.mc[, 1]] == 1 & race[el.mc[, 2]] %in% 2:3] <- 2 56 | race.combo[race[el.mc[, 1]] == 2 & race[el.mc[, 2]] %in% c(1, 3)] <- 3 57 | race.combo[race[el.mc[, 1]] == 2 & race[el.mc[, 2]] == 2] <- 4 58 | race.combo[race[el.mc[, 1]] == 3 & race[el.mc[, 2]] %in% 1:2] <- 5 59 | race.combo[race[el.mc[, 1]] == 3 & race[el.mc[, 2]] == 3] <- 6 60 | 61 | comb.age <- age[el.mc[, 1]] + age[el.mc[, 2]] 62 | 63 | # Current partnership durations 64 | pid_plist <- plist[, 1]*1e7 + plist[, 2] 65 | pid_el <- uid[el.mc[, 1]]*1e7 + uid[el.mc[, 2]] 66 | matches <- match(pid_el, pid_plist) 67 | durations <- (at - plist[, "start"])[matches] 68 | 69 | # HIV-positive concordant 70 | hiv.concord.pos <- rep(0, nrow(el.mc)) 71 | cp <- which(diag.status[el.mc[, 1]] == 1 & diag.status[el.mc[, 2]] == 1) 72 | hiv.concord.pos[cp] <- 1 73 | 74 | # Model predictions 75 | x <- data.frame(ptype = el.mc[, "ptype"], 76 | duration = durations, 77 | race.combo = race.combo, 78 | comb.age = comb.age, 79 | hiv.concord.pos = hiv.concord.pos, 80 | city = 1) 81 | rates <- unname(predict(acts.mod, newdata = x, type = "response"))/52 82 | rates <- rates * acts.scale 83 | ai <- rpois(length(rates), rates) 84 | el.mc <- cbind(el.mc, durations, ai) 85 | 86 | # Add one-time partnerships 87 | el.oo <- el[el[, "ptype"] == 3, ] 88 | ai <- durations <- rep(1, nrow(el.oo)) 89 | el.oo <- cbind(el.oo, durations, ai) 90 | 91 | # Bind el back together 92 | el <- rbind(el.mc, el.oo) 93 | 94 | # For AIDS cases with VL above acts.aids.vl, reduce their their acts to 0 95 | p1HIV <- which(el[, "st1"] == 1) 96 | p1AIDS <- stage[el[p1HIV, "p1"]] == 4 & vl[el[p1HIV, "p1"]] >= acts.aids.vl 97 | el[p1HIV[p1AIDS == TRUE], "ai"] <- 0 98 | 99 | p2HIV <- which(el[, "st2"] == 1) 100 | p2AIDS <- stage[el[p2HIV, "p2"]] == 4 & vl[el[p2HIV, "p2"]] >= acts.aids.vl 101 | el[p2HIV[p2AIDS == TRUE], "ai"] <- 0 102 | 103 | # Flip order of discordant edges 104 | disc <- abs(el[, "st1"] - el[, "st2"]) == 1 105 | disc.st2pos <- which(disc == TRUE & el[, "st2"] == 1) 106 | el[disc.st2pos, 1:4] <- el[disc.st2pos, c(2, 1, 4, 3)] 107 | 108 | # Remove inactive edges from el 109 | el <- el[-which(el[, "ai"] == 0), ] 110 | 111 | # Save out 112 | dat$temp$el <- el 113 | 114 | return(dat) 115 | } 116 | -------------------------------------------------------------------------------- /R/mod.aging.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Aging Module 3 | #' 4 | #' @description Module for aging over time for active nodes in the population. 5 | #' 6 | #' @param dat Master data list object of class \code{dat} containing networks, 7 | #' individual-level attributes, and summary statistics. 8 | #' @param at Current time step. 9 | #' 10 | #' @return 11 | #' This function returns \code{dat} after updating the nodal attribute 12 | #' \code{age} and \code{sqrt.age}. The \code{sqrt.age} vertex attribute is also 13 | #' updated on the three networks. 14 | #' 15 | #' @keywords module msm 16 | #' @export 17 | #' 18 | aging_msm <- function(dat, at) { 19 | 20 | age <- dat$attr$age 21 | active <- dat$attr$active 22 | age.grp <- dat$attr$age.grp 23 | 24 | age[active == 1] <- age[active == 1] + 7 / 365 25 | 26 | age.breaks <- dat$param$netstats$demog$age.breaks 27 | age.grp[active == 1] <- cut(age[active == 1], age.breaks, labels = FALSE) 28 | 29 | dat$attr$age.grp <- age.grp 30 | dat$attr$age <- age 31 | 32 | return(dat) 33 | } 34 | 35 | 36 | #' @export 37 | #' @rdname aging_msm 38 | aging_het <- function(dat, at) { 39 | 40 | ## Parameters 41 | time.unit <- dat$param$time.unit 42 | 43 | ## Attributes 44 | age <- dat$attr$age 45 | active <- dat$attr$active 46 | 47 | ## Updates 48 | age[active == 1] <- age[active == 1] + time.unit/365 49 | 50 | ## Save out 51 | dat$attr$age <- age 52 | 53 | return(dat) 54 | } 55 | -------------------------------------------------------------------------------- /R/mod.arrival.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Arrivals Module 3 | #' 4 | #' @description Module function for arrivals into the sexually active 5 | #' population. 6 | #' 7 | #' @inheritParams aging_msm 8 | #' 9 | #' @details 10 | #' New population members are added based on expected numbers of entries, 11 | #' stochastically determined with draws from Poisson distributions. For each new 12 | #' entry, a set of attributes is added for that node, and the nodes are added onto 13 | #' the network objects. Only attributes that are a part of the network model 14 | #' formulae are updated as vertex attributes on the network objects. 15 | #' 16 | #' @return 17 | #' This function updates the \code{attr} list with new attributes for each new 18 | #' population member, and the \code{nw} objects with new vertices. 19 | #' 20 | #' @keywords module msm 21 | #' @export 22 | #' 23 | arrival_msm <- function(dat, at){ 24 | 25 | ## Variables 26 | 27 | # Parameters 28 | a.rate <- dat$param$a.rate 29 | 30 | ## Process 31 | num <- dat$epi$num[1] 32 | 33 | nNew <- rpois(1, a.rate * num) 34 | 35 | ## Update Attr 36 | if (nNew > 0) { 37 | dat <- setNewAttr_msm(dat, at, nNew) 38 | } 39 | 40 | # Update Networks 41 | if (nNew > 0) { 42 | for (i in 1:3) { 43 | dat$el[[i]] <- tergmLite::add_vertices(dat$el[[i]], nNew) 44 | } 45 | } 46 | 47 | ## Output 48 | dat$epi$nNew[at] <- nNew 49 | 50 | return(dat) 51 | } 52 | 53 | 54 | setNewAttr_msm <- function(dat, at, nNew) { 55 | 56 | # Set all attributes NA by default 57 | dat$attr <- lapply(dat$attr, { 58 | function(x) 59 | c(x, rep(NA, nNew)) 60 | }) 61 | newIds <- which(is.na(dat$attr$active)) 62 | 63 | # Demographic 64 | dat$attr$active[newIds] <- rep(1, nNew) 65 | dat$attr$uid[newIds] <- dat$temp$max.uid + (1:nNew) 66 | dat$temp$max.uid <- dat$temp$max.uid + nNew 67 | 68 | dat$attr$arrival.time[newIds] <- rep(at, nNew) 69 | 70 | race.dist <- prop.table(table(dat$param$netstats$attr$race)) 71 | 72 | race <- sample(sort(unique(dat$attr$race)), nNew, TRUE, race.dist) 73 | dat$attr$race[newIds] <- race 74 | 75 | dat$attr$age[newIds] <- rep(dat$param$arrival.age, nNew) 76 | age.breaks <- dat$param$netstats$demog$age.breaks 77 | attr_age.grp <- cut(dat$attr$age[newIds], age.breaks, labels = FALSE) 78 | dat$attr$age.grp[newIds] <- attr_age.grp 79 | 80 | # Disease status and related 81 | dat$attr$status[newIds] <- rep(0, nNew) 82 | dat$attr$diag.status[newIds] <- rep(0, nNew) 83 | dat$attr$rGC[newIds] <- dat$attr$GC.timesInf[newIds] <- 0 84 | dat$attr$uGC[newIds] <- dat$attr$GC.timesInf[newIds] <- 0 85 | dat$attr$rCT[newIds] <- dat$attr$CT.timesInf[newIds] <- 0 86 | dat$attr$uCT[newIds] <- dat$attr$CT.timesInf[newIds] <- 0 87 | 88 | dat$attr$count.trans[newIds] <- 0 89 | 90 | rates <- dat$param$hiv.test.late.prob[race] 91 | dat$attr$late.tester[newIds] <- rbinom(length(rates), 1, rates) 92 | 93 | races <- sort(unique(dat$attr$race[newIds])) 94 | tt.traj <- rep(NA, nNew) 95 | for (i in races) { 96 | ids.race <- which(dat$attr$race[newIds] == i) 97 | tt.traj[ids.race] <- sample(1:3, length(ids.race), TRUE, 98 | c(dat$param$tt.part.supp[i], 99 | dat$param$tt.full.supp[i], 100 | dat$param$tt.dur.supp[i])) 101 | 102 | } 103 | dat$attr$tt.traj[newIds] <- tt.traj 104 | 105 | # Circumcision 106 | circ <- rep(NA, nNew) 107 | for (i in races) { 108 | ids.race <- which(dat$attr$race[newIds] == i) 109 | circ[ids.race] <- rbinom(length(ids.race), 1, dat$param$circ.prob[i]) 110 | } 111 | dat$attr$circ[newIds] <- circ 112 | 113 | # Role 114 | ns <- dat$param$netstats$attr 115 | role.class <- rep(NA, nNew) 116 | for (i in races) { 117 | ids.race <- which(dat$attr$race[newIds] == i) 118 | rc.probs <- prop.table(table(ns$role.class[ns$race == i])) 119 | role.class[ids.race] <- sample(0:2, length(ids.race), TRUE, rc.probs) 120 | } 121 | dat$attr$role.class[newIds] <- role.class 122 | 123 | ins.quot <- rep(NA, nNew) 124 | ins.quot[dat$attr$role.class[newIds] == 0] <- 1 125 | ins.quot[dat$attr$role.class[newIds] == 1] <- 0 126 | ins.quot[dat$attr$role.class[newIds] == 2] <- 127 | runif(sum(dat$attr$role.class[newIds] == 2)) 128 | dat$attr$ins.quot[newIds] <- ins.quot 129 | 130 | # Degree 131 | dat$attr$deg.main[newIds] <- 0 132 | dat$attr$deg.casl[newIds] <- 0 133 | dat$attr$deg.tot[newIds] <- 0 134 | 135 | # One-off risk group 136 | dat$attr$risk.grp[newIds] <- sample(1:5, nNew, TRUE) 137 | 138 | # PrEP 139 | dat$attr$prepStat[newIds] <- 0 140 | 141 | # HIV screening 142 | dat$attr$num.neg.tests[newIds] <- 0 143 | 144 | # Update clinical history 145 | if (dat$control$save.clin.hist == TRUE & length(newIds) > 0) { 146 | m <- dat$temp$clin.hist 147 | for (i in 1:length(m)) { 148 | new.m <- array(dim = c(length(newIds), dat$control$nsteps)) 149 | m[[i]] <- rbind(m[[i]], new.m) 150 | } 151 | dat$temp$clin.hist <- m 152 | } 153 | 154 | ## Check attributes written as expected 155 | # cbind(sapply(dat$attr, function(x) is.na(tail(x, 1)))) 156 | 157 | return(dat) 158 | } 159 | 160 | 161 | 162 | #' @export 163 | #' @rdname arrival_msm 164 | births_het <- function(dat, at) { 165 | 166 | # Variables 167 | b.rate.method <- dat$param$b.rate.method 168 | b.rate <- dat$param$b.rate 169 | active <- dat$attr$active 170 | 171 | 172 | # Process 173 | nBirths <- 0 174 | if (b.rate.method == "stgrowth") { 175 | exptPopSize <- dat$epi$num[1] * (1 + b.rate*at) 176 | numNeeded <- exptPopSize - sum(active == 1) 177 | if (numNeeded > 0) { 178 | nBirths <- rpois(1, numNeeded) 179 | } 180 | } 181 | if (b.rate.method == "totpop") { 182 | nElig <- dat$epi$num[at - 1] 183 | if (nElig > 0) { 184 | nBirths <- rpois(1, nElig * b.rate) 185 | } 186 | } 187 | if (b.rate.method == "fpop") { 188 | nElig <- dat$epi$num.feml[at - 1] 189 | if (nElig > 0) { 190 | nBirths <- rpois(1, nElig * b.rate) 191 | } 192 | } 193 | 194 | 195 | # Update Population Structure 196 | if (nBirths > 0) { 197 | dat <- setBirthAttr_het(dat, at, nBirths) 198 | dat$el[[1]] <- tergmLite::add_vertices(dat$el[[1]], nBirths) 199 | } 200 | 201 | if (unique(sapply(dat$attr, length)) != attributes(dat$el[[1]])$n) { 202 | stop("mismatch between el and attr length in births mod") 203 | } 204 | 205 | # Output 206 | dat$epi$b.flow[at] <- nBirths 207 | 208 | return(dat) 209 | } 210 | 211 | 212 | setBirthAttr_het <- function(dat, at, nBirths) { 213 | 214 | # Set attributes for new births to NA 215 | dat$attr <- lapply(dat$attr, function(x) c(x, rep(NA, nBirths))) 216 | newIds <- which(is.na(dat$attr$active)) 217 | 218 | 219 | # Network Status 220 | dat$attr$active[newIds] <- rep(1, nBirths) 221 | dat$attr$entTime[newIds] <- rep(at, nBirths) 222 | 223 | 224 | # Demography 225 | prop.male <- ifelse(is.null(dat$param$b.propmale), 226 | dat$epi$propMale[1], 227 | dat$param$b.propmale) 228 | dat$attr$male[newIds] <- rbinom(nBirths, 1, prop.male) 229 | 230 | dat$attr$age[newIds] <- rep(18, nBirths) 231 | 232 | # Circumcision 233 | entTime <- dat$attr$entTime 234 | 235 | idsNewMale <- which(dat$attr$male == 1 & entTime == at) 236 | 237 | if (length(idsNewMale) > 0) { 238 | age <- dat$attr$age[idsNewMale] 239 | newCirc <- rbinom(length(idsNewMale), 1, dat$param$circ.prob.birth) 240 | isCirc <- which(newCirc == 1) 241 | 242 | newCircTime <- rep(NA, length(idsNewMale)) 243 | newCircTime[isCirc] <- round(-age[isCirc] * (365 / dat$param$time.unit)) 244 | 245 | dat$attr$circStat[idsNewMale] <- newCirc 246 | dat$attr$circTime[idsNewMale] <- newCircTime 247 | } 248 | 249 | 250 | # Epi/Clinical 251 | dat$attr$status[newIds] <- rep(0, nBirths) 252 | 253 | if (length(unique(sapply(dat$attr, length))) != 1) { 254 | sapply(dat$attr, length) 255 | stop("Attribute dimensions not unique") 256 | } 257 | 258 | return(dat) 259 | } 260 | -------------------------------------------------------------------------------- /R/mod.condoms.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Condom Use Module 3 | #' 4 | #' @description Module function stochastically simulates potential condom use 5 | #' for each act on the discordant edgelist. 6 | #' 7 | #' @inheritParams aging_msm 8 | #' 9 | #' @details 10 | #' For each act on the discordant edgelist, condom use is stochastically simulated 11 | #' based on the partnership type and racial combination of the dyad. Other 12 | #' modifiers for the probability of condom use in that pair are diagnosis of 13 | #' disease, and full or partial HIV viral suppression 14 | #' given HIV anti-retroviral therapy. 15 | #' 16 | #' @return 17 | #' Updates the discordant edgelist with a \code{uai} variable indicating whether 18 | #' condoms were used in that act. 19 | #' 20 | #' @keywords module msm 21 | #' @export 22 | #' 23 | condoms_msm <- function(dat, at) { 24 | 25 | # Attributes 26 | race <- dat$attr$race 27 | age <- dat$attr$age 28 | diag.status <- dat$attr$diag.status 29 | prepStat <- dat$attr$prepStat 30 | 31 | # Condom Use Models 32 | cond.mc.mod <- dat$param$epistats$cond.mc.mod 33 | cond.oo.mod <- dat$param$epistats$cond.oo.mod 34 | 35 | cond.scale <- dat$param$cond.scale 36 | 37 | # Temp edgelist 38 | el <- dat$temp$el 39 | 40 | race.combo <- rep(NA, nrow(el)) 41 | race.combo[race[el[, 1]] == 1 & race[el[, 2]] == 1] <- 1 42 | race.combo[race[el[, 1]] == 1 & race[el[, 2]] %in% 2:3] <- 2 43 | race.combo[race[el[, 1]] == 2 & race[el[, 2]] %in% c(1, 3)] <- 3 44 | race.combo[race[el[, 1]] == 2 & race[el[, 2]] == 2] <- 4 45 | race.combo[race[el[, 1]] == 3 & race[el[, 2]] %in% 1:2] <- 5 46 | race.combo[race[el[, 1]] == 3 & race[el[, 2]] == 3] <- 6 47 | 48 | comb.age <- age[el[, 1]] + age[el[, 2]] 49 | 50 | hiv.concord.pos <- rep(0, nrow(el)) 51 | cp <- which(diag.status[el[, 1]] == 1 & diag.status[el[, 2]] == 1) 52 | hiv.concord.pos[cp] <- 1 53 | 54 | any.prep <- as.numeric((prepStat[el[, 1]] + prepStat[el[, 2]]) > 0) 55 | 56 | ## Main/casual partnerships ## 57 | mc.parts <- which(el[, "ptype"] != 3) 58 | el.mc <- el[mc.parts, ] 59 | 60 | x <- data.frame(ptype = el.mc[, "ptype"], 61 | duration = el.mc[, "durations"], 62 | race.combo = race.combo[mc.parts], 63 | comb.age = comb.age[mc.parts], 64 | hiv.concord.pos = hiv.concord.pos[mc.parts], 65 | prep = any.prep[mc.parts], 66 | city = 1) 67 | cond.prob <- unname(predict(cond.mc.mod, newdata = x, type = "response")) 68 | el.mc <- cbind(el.mc, cond.prob) 69 | 70 | ## One-off partnerships ## 71 | oo.parts <- which(el[, "ptype"] == 3) 72 | el.oo <- el[oo.parts, ] 73 | 74 | x <- data.frame(race.combo = race.combo[oo.parts], 75 | comb.age = comb.age[oo.parts], 76 | hiv.concord.pos = hiv.concord.pos[oo.parts], 77 | prep = any.prep[oo.parts], 78 | city = 1) 79 | cond.prob <- unname(predict(cond.oo.mod, newdata = x, type = "response")) 80 | el.oo <- cbind(el.oo, cond.prob) 81 | 82 | ## Bind el together 83 | el <- rbind(el.mc, el.oo) 84 | 85 | # Acts 86 | ai.vec <- el[, "ai"] 87 | pid <- rep(1:length(ai.vec), ai.vec) 88 | p1 <- rep(el[, "p1"], ai.vec) 89 | p2 <- rep(el[, "p2"], ai.vec) 90 | ptype <- rep(el[, "ptype"], ai.vec) 91 | cond.prob <- rep(el[, "cond.prob"], ai.vec) 92 | 93 | cond.prob <- cond.prob * cond.scale 94 | 95 | # UAI draw per act 96 | uai <- rbinom(length(cond.prob), 1, 1 - cond.prob) 97 | 98 | # Act list construction 99 | al <- cbind(p1, p2, ptype, uai, pid) 100 | dat$temp$al <- al 101 | 102 | return(dat) 103 | } 104 | -------------------------------------------------------------------------------- /R/mod.departure.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Depature Module 3 | #' 4 | #' @description Module function for simulting both general and disease-related 5 | #' departures, including deaths, among population members. 6 | #' 7 | #' @inheritParams aging_msm 8 | #' 9 | #' @details 10 | #' Deaths are divided into two categories: general deaths, for which demographic 11 | #' data on age-specific mortality rates applies; and disease-related diseases, 12 | #' for which the rate of death is a function of progression to end-stage AIDS. 13 | #' 14 | #' @return 15 | #' This function returns the updated \code{dat} object accounting for deaths. 16 | #' The deaths are deactivated from the main and casual networks, as those are in 17 | #' \code{networkDynamic} class objects; dead nodes are not deleted from the 18 | #' instant network until the \code{\link{simnet_msm}} module for bookkeeping 19 | #' purposes. 20 | #' 21 | #' @keywords module msm 22 | #' @export 23 | #' 24 | departure_msm <- function(dat, at) { 25 | 26 | ## General departures 27 | active <- dat$attr$active 28 | age <- floor(dat$attr$age) 29 | race <- dat$attr$race 30 | status <- dat$attr$status 31 | stage <- dat$attr$stage 32 | tx.status <- dat$attr$tx.status 33 | 34 | aids.mr <- dat$param$aids.mr 35 | asmr <- dat$param$netstats$demog$asmr 36 | 37 | idsElig <- which(active == 1) 38 | rates <- rep(NA, length(idsElig)) 39 | 40 | races <- sort(unique(race)) 41 | for (i in seq_along(races)) { 42 | ids.race <- which(race == races[i]) 43 | rates[ids.race] <- asmr[age[ids.race], i + 1] 44 | } 45 | idsDep <- idsElig[rbinom(length(rates), 1, rates) == 1] 46 | 47 | ## HIV-related deaths 48 | idsEligAIDS <- which(stage == 4) 49 | idsDepAIDS <- idsEligAIDS[rbinom(length(idsEligAIDS), 1, aids.mr) == 1] 50 | 51 | idsDepAll <- unique(c(idsDep, idsDepAIDS)) 52 | depHIV <- intersect(idsDepAll, which(status == 1)) 53 | depHIV.old <- intersect(depHIV, which(age >= 65)) 54 | 55 | # Cumulative R0 calculations 56 | # if (at == 2) { 57 | # dat$temp$R0 <- NA 58 | # } 59 | # if (length(depHIV) > 0) { 60 | # newR0 <- dat$attr$count.trans[depHIV] 61 | # dat$temp$R0 <- c(dat$temp$R0, newR0) 62 | # } 63 | 64 | if (length(idsDepAll) > 0) { 65 | dat$attr$active[idsDepAll] <- 0 66 | for (i in 1:3) { 67 | dat$el[[i]] <- tergmLite::delete_vertices(dat$el[[i]], idsDepAll) 68 | } 69 | dat$attr <- deleteAttr(dat$attr, idsDepAll) 70 | if (unique(sapply(dat$attr, length)) != attributes(dat$el[[1]])$n) { 71 | stop("mismatch between el and attr length in departures mod") 72 | } 73 | } 74 | 75 | # Update clinical history 76 | if (dat$control$save.clin.hist == TRUE & length(idsDepAll) > 0) { 77 | m <- dat$temp$clin.hist 78 | for (i in 1:length(m)) { 79 | m[[i]] <- m[[i]][-idsDepAll, ] 80 | } 81 | dat$temp$clin.hist <- m 82 | } 83 | 84 | ## Summary Output 85 | dat$epi$dep.gen[at] <- length(idsDep) 86 | dat$epi$dep.AIDS[at] <- length(idsDepAIDS) 87 | dat$epi$dep.HIV[at] <- length(depHIV) 88 | dat$epi$dep.HIV.old[at] <- length(depHIV.old) 89 | 90 | return(dat) 91 | } 92 | 93 | 94 | #' @export 95 | #' @rdname departure_msm 96 | deaths_het <- function(dat, at) { 97 | 98 | ### 1. Susceptible Deaths ### 99 | 100 | ## Variables 101 | male <- dat$attr$male 102 | age <- dat$attr$age 103 | cd4Count <- dat$attr$cd4Count 104 | 105 | di.cd4.aids <- dat$param$di.cd4.aids 106 | ds.exit.age <- dat$param$ds.exit.age 107 | 108 | ## Eligible are: active uninf, pre-death infected, unhealthy old 109 | idsEligSus <- which((is.na(cd4Count) | 110 | cd4Count > di.cd4.aids | 111 | (cd4Count <= di.cd4.aids & age > ds.exit.age))) 112 | nEligSus <- length(idsEligSus) 113 | 114 | # Set age-sex specific rates 115 | ds.rates <- dat$param$ds.rates 116 | if (nEligSus > 0) { 117 | rates <- ds.rates$mrate[100*male[idsEligSus] + age[idsEligSus]] 118 | } 119 | 120 | 121 | ## Process 122 | nDeathsSus <- 0; idsDeathsSus <- NULL 123 | if (nEligSus > 0) { 124 | vecDeathsSus <- which(rbinom(nEligSus, 1, rates) == 1) 125 | nDeathsSus <- length(vecDeathsSus) 126 | } 127 | 128 | 129 | ## Update Attributes 130 | if (nDeathsSus > 0) { 131 | idsDeathsSus <- idsEligSus[vecDeathsSus] 132 | dat$attr$active[idsDeathsSus] <- 0 133 | } 134 | 135 | 136 | ### 2. Infected Deaths ### 137 | 138 | ## Variables 139 | active <- dat$attr$active 140 | di.cd4.rate <- dat$param$di.cd4.rate 141 | 142 | ## Process 143 | nDeathsInf <- 0; idsDeathsInf <- NULL 144 | 145 | cd4Count <- dat$attr$cd4Count 146 | stopifnot(length(active) == length(cd4Count)) 147 | 148 | idsEligInf <- which(active == 1 & cd4Count <= di.cd4.aids) 149 | nEligInf <- length(idsEligInf) 150 | 151 | if (nEligInf > 0) { 152 | vecDeathsInf <- which(rbinom(nEligInf, 1, di.cd4.rate) == 1) 153 | if (length(vecDeathsInf) > 0) { 154 | idsDeathsInf <- idsEligInf[vecDeathsInf] 155 | nDeathsInf <- length(idsDeathsInf) 156 | } 157 | } 158 | 159 | idsDeathsDet <- which(cd4Count <= 0) 160 | if (length(idsDeathsDet) > 0) { 161 | idsDeathsInf <- c(idsDeathsInf, idsDeathsDet) 162 | nDeathsInf <- nDeathsInf + length(idsDeathsDet) 163 | } 164 | 165 | 166 | ### 3. Update Attributes ### 167 | if (nDeathsInf > 0) { 168 | dat$attr$active[idsDeathsInf] <- 0 169 | } 170 | 171 | ## 4. Update Population Structure ## 172 | inactive <- which(dat$attr$active == 0) 173 | dat$el[[1]] <- tergmLite::delete_vertices(dat$el[[1]], inactive) 174 | dat$attr <- deleteAttr(dat$attr, inactive) 175 | 176 | if (unique(sapply(dat$attr, length)) != attributes(dat$el[[1]])$n) { 177 | stop("mismatch between el and attr length in death mod") 178 | } 179 | 180 | ### 5. Summary Statistics ### 181 | dat$epi$ds.flow[at] <- nDeathsSus 182 | dat$epi$di.flow[at] <- nDeathsInf 183 | 184 | return(dat) 185 | } 186 | -------------------------------------------------------------------------------- /R/mod.hivcd4.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title CD4 Progression Module 3 | #' 4 | #' @description Module function for simulating progression of CD4 in natural 5 | #' disease dynamics and in the presence of ART. 6 | #' 7 | #' @inheritParams aging_het 8 | #' 9 | #' @keywords module het 10 | #' 11 | #' @export 12 | #' 13 | cd4_het <- function(dat, at) { 14 | 15 | status <- dat$attr$status 16 | time.unit <- dat$param$time.unit 17 | 18 | if (is.null(dat$attr$cd4Count)) { 19 | dat$attr$cd4Count <- rep(NA, length(status)) 20 | } 21 | cd4Count <- dat$attr$cd4Count 22 | 23 | 24 | # Assign CD4 for newly infected ------------------------------------------- 25 | idsAsn <- which(status == 1 & is.na(cd4Count)) 26 | if (length(idsAsn) > 0) { 27 | cd4Count[idsAsn] <- expected_cd4(method = "assign", 28 | male = dat$attr$male[idsAsn], 29 | age = dat$attr$age[idsAsn], 30 | ageInf = dat$attr$ageInf[idsAsn], 31 | time.unit = time.unit) 32 | } 33 | 34 | 35 | # CD4 natural decline ----------------------------------------------------- 36 | txStartTime <- dat$attr$txStartTime 37 | infTime <- dat$attr$infTime 38 | 39 | idsUpd <- which(status == 1 & infTime < at & is.na(txStartTime)) 40 | idsUpd <- setdiff(idsUpd, idsAsn) 41 | 42 | if (length(idsUpd) > 0) { 43 | cd4Count[idsUpd] <- expected_cd4(method = "update", 44 | cd4Count1 = cd4Count[idsUpd], 45 | male = dat$attr$male[idsUpd], 46 | age = dat$attr$age[idsUpd], 47 | ageInf = dat$attr$ageInf[idsUpd], 48 | time.unit = time.unit) 49 | } 50 | 51 | # CD4 increase with ART --------------------------------------------------- 52 | male <- dat$attr$male 53 | txStat <- dat$attr$txStat 54 | 55 | tx.cd4.recrat.feml <- dat$param$tx.cd4.recrat.feml 56 | tx.cd4.recrat.male <- dat$param$tx.cd4.recrat.male 57 | 58 | idsTxFeml <- which(status == 1 & male == 0 & txStat == 1) 59 | idsTxMale <- which(status == 1 & male == 1 & txStat == 1) 60 | 61 | if (length(idsTxFeml) > 0) { 62 | cd4Cap <- expected_cd4(method = "assign", male = 0, age = 25, ageInf = 25) 63 | cd4Count[idsTxFeml] <- pmin(cd4Count[idsTxFeml] + tx.cd4.recrat.feml, cd4Cap) 64 | } 65 | if (length(idsTxMale) > 0) { 66 | cd4Cap <- expected_cd4(method = "assign", male = 1, age = 25, ageInf = 25) 67 | cd4Count[idsTxMale] <- pmin(cd4Count[idsTxMale] + tx.cd4.recrat.male, cd4Cap) 68 | } 69 | 70 | 71 | # CD4 decline post ART ---------------------------------------------------- 72 | tx.cd4.decrat.feml <- dat$param$tx.cd4.decrat.feml 73 | tx.cd4.decrat.male <- dat$param$tx.cd4.decrat.male 74 | 75 | idsNoTxFeml <- which(status == 1 & male == 0 & 76 | !is.na(txStartTime) & txStat == 0) 77 | idsNoTxMale <- which(status == 1 & male == 1 & 78 | !is.na(txStartTime) & txStat == 0) 79 | if (length(idsNoTxFeml) > 0) { 80 | cd4Count[idsNoTxFeml] <- pmax(cd4Count[idsNoTxFeml] - tx.cd4.decrat.feml, 0) 81 | } 82 | if (length(idsNoTxMale) > 0) { 83 | cd4Count[idsNoTxMale] <- pmax(cd4Count[idsNoTxMale] - tx.cd4.decrat.male, 0) 84 | } 85 | 86 | if (any(is.na(cd4Count[status == 1]))) { 87 | stop("NA in cd4Count among infected") 88 | } 89 | 90 | dat$attr$cd4Count <- cd4Count 91 | 92 | return(dat) 93 | } 94 | 95 | 96 | expected_cd4 <- function(method, cd4Count1, cd4Count2, 97 | male, age, ageInf, 98 | at, time.unit = 7) { 99 | 100 | ## Variables 101 | timeInf <- (age - ageInf) * (365 / time.unit) 102 | catAI <- cut(ageInf, breaks = c(0, 30, 40, 50, Inf), 103 | labels = FALSE, right = FALSE) 104 | 105 | ## Model parameters 106 | base.male <- 23.53 - 0.76 107 | base.feml <- base.male + 1.11 108 | bases <- c(base.feml, base.male) 109 | ind.bases <- bases[male + 1] 110 | 111 | # Yearly slopes 112 | slope1 <- -1.49 + 0.34 113 | slope2 <- slope1 - 0.10 114 | slope3 <- slope1 - 0.34 115 | slope4 <- slope1 - 0.63 116 | slopes <- c(slope1, slope2, slope3, slope4) 117 | ind.slopes <- slopes[catAI] * (time.unit / 365) 118 | 119 | if (method == "timeto") { 120 | tt1 <- (sqrt(cd4Count1) - ind.bases)/ind.slopes 121 | if (!missing(cd4Count2)) { 122 | tt2 <- (sqrt(cd4Count2) - ind.bases)/ind.slopes 123 | return(tt2 - tt1) 124 | } else { 125 | return(tt1) 126 | } 127 | } else { 128 | if (method == "assign") { 129 | cd4CountSqrt <- ind.bases + (ind.slopes * timeInf) 130 | cd4CountSqrt <- pmax(1, cd4CountSqrt) 131 | } 132 | if (method == "update") { 133 | cd4CountSqrt <- sqrt(cd4Count1) + ind.slopes 134 | cd4CountSqrt[cd4CountSqrt < 1] <- 0 135 | } 136 | cd4Count <- cd4CountSqrt ^ 2 137 | return(cd4Count) 138 | } 139 | 140 | } 141 | -------------------------------------------------------------------------------- /R/mod.hivprogress.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Disease Progression Module 3 | #' 4 | #' @description Module function for HIV disease progression through acute, chronic 5 | #' and AIDS stages. 6 | #' 7 | #' @inheritParams aging_msm 8 | #' 9 | #' @details 10 | #' HIV disease is divided into four stages: acute rising, acute falling, chronic 11 | #' and AIDS. Acute rising is the time from infection to peak viremia, while 12 | #' acute falling is the time from peak viremia to chronic stage infection with 13 | #' an established set-point HIV viral load. 14 | #' 15 | #' The time spent in chronic stage infection, and thus the time from infection to 16 | #' AIDS, depends on ART history. For ART-naive persons, time to AIDS is established 17 | #' by the \code{vl.aids.onset} parameter. For persons ever on ART who fall into 18 | #' the partially suppressed category (the \code{tt.traj} attribute is \code{1}), 19 | #' time to AIDS depends on the sum of two ratios: time on treatment over maximum 20 | #' time on treatment plus time off treatment over maximum time off treatment. 21 | #' For persons ever on ART who fall into the fully suppressed cateogry 22 | #' (\code{tt.traj=2}), time to AIDS depends on whether the cumulative time 23 | #' off treatment exceeds a time threshold specified in the \code{max.time.off.tx.full.int} 24 | #' parameter. 25 | #' 26 | #' @return 27 | #' This function returns the \code{dat} object after updating the disease stage 28 | #' of infected individuals. 29 | #' 30 | #' @keywords module msm 31 | #' 32 | #' @export 33 | #' 34 | hivprogress_msm <- function(dat, at) { 35 | 36 | # Attributes 37 | active <- dat$attr$active 38 | status <- dat$attr$status 39 | time.since.inf <- at - dat$attr$inf.time 40 | cuml.time.on.tx <- dat$attr$cuml.time.on.tx 41 | cuml.time.off.tx <- dat$attr$cuml.time.off.tx 42 | stage <- dat$attr$stage 43 | stage.time <- dat$attr$stage.time 44 | aids.time <- dat$attr$aids.time 45 | tt.traj <- dat$attr$tt.traj 46 | tx.status <- dat$attr$tx.status 47 | 48 | # Parameters 49 | vl.acute.rise.int <- dat$param$vl.acute.rise.int 50 | vl.acute.fall.int <- dat$param$vl.acute.fall.int 51 | vl.aids.onset.int <- dat$param$vl.aids.onset.int 52 | max.time.off.tx.part.int <- dat$param$max.time.off.tx.part.int 53 | max.time.on.tx.part.int <- dat$param$max.time.on.tx.part.int 54 | max.time.off.tx.full.int <- dat$param$max.time.off.tx.full.int 55 | 56 | 57 | ## Process 58 | 59 | # Increment day 60 | stage.time[active == 1] <- stage.time[active == 1] + 1 61 | 62 | # Change stage to Acute Falling 63 | toAF <- which(active == 1 & stage == 1 & time.since.inf >= (vl.acute.rise.int + 1)) 64 | stage[toAF] <- 2 65 | stage.time[toAF] <- 1 66 | 67 | # Change stage to Chronic 68 | toC <- which(active == 1 & stage == 2 & time.since.inf >= (vl.acute.rise.int + 69 | vl.acute.fall.int + 1)) 70 | stage[toC] <- 3 71 | stage.time[toC] <- 1 72 | 73 | # Change stage to AIDS 74 | aids.tx.naive <- which(active == 1 & status == 1 & cuml.time.on.tx == 0 & 75 | (time.since.inf >= vl.aids.onset.int) & stage != 4) 76 | 77 | part.tx.score <- (cuml.time.off.tx / max.time.off.tx.part.int) + 78 | (cuml.time.on.tx / max.time.on.tx.part.int) 79 | 80 | aids.part.escape <- which(active == 1 & cuml.time.on.tx > 0 & tt.traj == 1 & 81 | stage == 3 & part.tx.score >= 1 & stage != 4) 82 | 83 | aids.off.tx.full.escape <- which(active == 1 & tx.status == 0 & tt.traj %in% 2:3 & 84 | cuml.time.on.tx > 0 & 85 | cuml.time.off.tx >= max.time.off.tx.full.int & 86 | stage != 4) 87 | 88 | isAIDS <- c(aids.tx.naive, aids.part.escape, aids.off.tx.full.escape) 89 | stage[isAIDS] <- 4 90 | stage.time[isAIDS] <- 1 91 | aids.time[isAIDS] <- at 92 | 93 | ## Output 94 | dat$attr$stage <- stage 95 | dat$attr$stage.time <- stage.time 96 | dat$attr$aids.time <- aids.time 97 | 98 | dat$epi$new.aids.tot[at] <- length(isAIDS) 99 | dat$epi$new.aids.part[at] <- length(aids.part.escape) 100 | dat$epi$new.aids.full[at] <- length(aids.off.tx.full.escape) 101 | 102 | return(dat) 103 | } 104 | -------------------------------------------------------------------------------- /R/mod.hivtest.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title HIV Testing Module 3 | #' 4 | #' @description Module function for HIV diagnostic testing of infected persons. 5 | #' 6 | #' @inheritParams aging_msm 7 | #' 8 | #' @details 9 | #' This testing module supports memoryless HIV testing for stochastic and 10 | #' geometrically-distributed waiting times to test (constant hazard). 11 | #' 12 | #' @return 13 | #' This function returns the \code{dat} object with updated \code{last.neg.test}, 14 | #' \code{diag.status} and \code{diag.time} attributes. 15 | #' 16 | #' @keywords module msm 17 | #' 18 | #' @export 19 | #' 20 | hivtest_msm <- function(dat, at) { 21 | 22 | ## Variables 23 | 24 | # Attributes 25 | diag.status <- dat$attr$diag.status 26 | race <- dat$attr$race 27 | status <- dat$attr$status 28 | inf.time <- dat$attr$inf.time 29 | stage <- dat$attr$stage 30 | late.tester <- dat$attr$late.tester 31 | 32 | prepStat <- dat$attr$prepStat 33 | prep.tst.int <- dat$param$prep.tst.int 34 | 35 | # Parameters 36 | hiv.test.rate <- dat$param$hiv.test.rate 37 | aids.test.int <- dat$param$vl.aids.int/2 38 | twind.int <- dat$param$test.window.int 39 | 40 | tsincelntst <- at - dat$attr$last.neg.test 41 | tsincelntst[is.na(tsincelntst)] <- at - dat$attr$arrival.time[is.na(tsincelntst)] 42 | 43 | # General interval testing 44 | elig <- which((diag.status == 0 | is.na(diag.status)) & 45 | prepStat == 0 & late.tester == 0) 46 | 47 | # Interval testing rates by race 48 | rates <- hiv.test.rate[race[elig]] 49 | idsTstGen <- elig[rbinom(length(elig), 1, rates) == 1] 50 | 51 | # Late testing (Neg, then AIDS) 52 | eligNeg <- which((diag.status == 0 | is.na(diag.status)) & 53 | prepStat == 0 & status == 0 & late.tester == 1) 54 | ratesNeg <- 1/(12*52) 55 | idsTstLate <- eligNeg[rbinom(length(eligNeg), 1, ratesNeg) == 1] 56 | 57 | eligAIDS <- which((diag.status == 0 | is.na(diag.status)) & 58 | prepStat == 0 & stage == 4 & late.tester == 1) 59 | ratesAIDS <- 1/aids.test.int 60 | idsTstAIDS <- eligAIDS[rbinom(length(eligAIDS), 1, ratesAIDS) == 1] 61 | 62 | # PrEP testing 63 | idsTstPrEP <- which((diag.status == 0 | is.na(diag.status)) & 64 | prepStat == 1 & 65 | tsincelntst >= prep.tst.int) 66 | 67 | tstAll <- c(idsTstGen, idsTstLate, idsTstAIDS, idsTstPrEP) 68 | 69 | tstPos <- tstAll[status[tstAll] == 1 & inf.time[tstAll] <= at - twind.int] 70 | tstNeg <- setdiff(tstAll, tstPos) 71 | 72 | # Attributes 73 | dat$attr$last.neg.test[tstNeg] <- at 74 | dat$attr$diag.status[tstPos] <- 1 75 | dat$attr$diag.time[tstPos] <- at 76 | dat$attr$diag.stage[tstPos] <- stage[tstPos] 77 | 78 | # Summary stats 79 | if (at >= 52*65) { 80 | dat$attr$num.neg.tests[tstNeg] <- dat$attr$num.neg.tests[tstNeg] + 1 81 | } 82 | dat$epi$tot.tests[at] <- length(tstAll) 83 | dat$epi$tot.tests.B[at] <- length(intersect(tstAll, which(race == 1))) 84 | dat$epi$tot.tests.H[at] <- length(intersect(tstAll, which(race == 2))) 85 | dat$epi$tot.tests.W[at] <- length(intersect(tstAll, which(race == 3))) 86 | dat$epi$tot.tests.nprep[at] <- length(c(idsTstGen, idsTstLate, idsTstAIDS)) 87 | 88 | dat$epi$tot.neg.tests[at] <- length(tstNeg) 89 | 90 | # number of new diagnoses by timing 91 | dat$epi$newDx[at] <- length(tstPos) 92 | diag.time <- dat$attr$diag.time 93 | dat$epi$newDx45[at] <- length(intersect(tstPos, which(diag.time - inf.time <= 45/7))) 94 | dat$epi$newDx140[at] <- length(intersect(tstPos, which(diag.time - inf.time <= 140/7))) 95 | dat$epi$newDx200[at] <- length(intersect(tstPos, which(diag.time - inf.time <= 200/7))) 96 | dat$epi$newDx2y[at] <- length(intersect(tstPos, which(diag.time - inf.time > 104))) 97 | 98 | return(dat) 99 | } 100 | 101 | 102 | #' @export 103 | #' @rdname hivtest_msm 104 | dx_het <- function(dat, at) { 105 | 106 | # Variables 107 | status <- dat$attr$status 108 | txCD4min <- dat$attr$txCD4min 109 | cd4Count <- dat$attr$cd4Count 110 | dxStat <- dat$attr$dxStat 111 | 112 | # Process 113 | tested <- which(status == 1 & dxStat == 0 & cd4Count <= txCD4min) 114 | 115 | 116 | # Results 117 | if (length(tested) > 0) { 118 | dat$attr$dxStat[tested] <- 1 119 | dat$attr$txStat[tested] <- 0 120 | dat$attr$dxTime[tested] <- at 121 | } 122 | 123 | return(dat) 124 | } 125 | 126 | -------------------------------------------------------------------------------- /R/mod.hivtrans.R: -------------------------------------------------------------------------------- 1 | 2 | # MSM ----------------------------------------------------------------- 3 | 4 | #' @title Transmission Module 5 | #' 6 | #' @description Stochastically simulates disease transmission given the current 7 | #' state of the discordand edgelist. 8 | #' 9 | #' @inheritParams aging_msm 10 | #' 11 | #' @details 12 | #' This is the final substantive function that occurs within the time loop at 13 | #' each time step. This function takes the discordant edgelist and calculates a 14 | #' transmission probability for each row (one sexual act) between dyads on the 15 | #' network. After transmission events, individual-level attributes for the infected 16 | #' persons are updated and summary statistics for incidence calculated. 17 | #' 18 | #' The per-act transmission probability depends on the following elements: 19 | #' insertive versus receptive role, viral load of the infected partner, an 20 | #' acute stage infection excess risk, and condom use. 21 | #' Given these transmission probabilities, transmission is stochastically 22 | #' simulating by drawing from a binomial distribution for each act conditional 23 | #' on the per-act probability. 24 | #' 25 | #' @return 26 | #' For each new infection, the disease status, infection time, and related 27 | #' HIV attributes are updated for the infected node. Summary statistics for 28 | #' disease incidence overall, and by race and age groups are calculated and 29 | #' stored on \code{dat$epi}. 30 | #' 31 | #' @keywords module msm 32 | #' 33 | #' @export 34 | #' 35 | hivtrans_msm <- function(dat, at) { 36 | 37 | # Variables ----------------------------------------------------------- 38 | 39 | # Attributes 40 | vl <- dat$attr$vl 41 | stage <- dat$attr$stage 42 | circ <- dat$attr$circ 43 | status <- dat$attr$status 44 | prepStat <- dat$attr$prepStat 45 | prepClass <- dat$attr$prepClass 46 | rGC <- dat$attr$rGC 47 | uGC <- dat$attr$uGC 48 | rCT <- dat$attr$rCT 49 | uCT <- dat$attr$uCT 50 | race <- dat$attr$race 51 | tx.status <- dat$attr$tx.status 52 | 53 | # Parameters 54 | URAI.prob <- dat$param$URAI.prob 55 | UIAI.prob <- dat$param$UIAI.prob 56 | trans.scale <- dat$param$trans.scale 57 | acute.rr <- dat$param$acute.rr 58 | 59 | cond.eff <- dat$param$cond.eff 60 | cond.fail <- dat$param$cond.fail 61 | 62 | circ.rr <- dat$param$circ.rr 63 | prep.hr <- dat$param$prep.adhr.hr 64 | hiv.ugc.rr <- dat$param$hiv.ugc.rr 65 | hiv.uct.rr <- dat$param$hiv.uct.rr 66 | hiv.rgc.rr <- dat$param$hiv.rgc.rr 67 | hiv.rct.rr <- dat$param$hiv.rct.rr 68 | hiv.dual.rr <- dat$param$hiv.dual.rr 69 | 70 | 71 | # Data 72 | al <- dat$temp$al 73 | dal <- al[which(status[al[, 1]] == 1 & status[al[, 2]] == 0), ] 74 | dal <- dal[sample(1:nrow(dal)), ] 75 | ncols <- dim(dal)[2] 76 | 77 | if (nrow(dal) == 0) { 78 | return(dat) 79 | } 80 | 81 | ## Reorder by role: ins on the left, rec on the right 82 | disc.ip <- dal[dal[, "ins"] == 1, ] 83 | disc.rp <- dal[dal[, "ins"] == 0, c(2:1, 3:ncols)] 84 | colnames(disc.ip)[1:2] <- colnames(disc.rp)[1:2] <- c("ins", "rec") 85 | 86 | 87 | # PATP: Insertive Man Infected (Col 1) -------------------------------- 88 | 89 | # Attributes of infected 90 | ip.vl <- vl[disc.ip[, 1]] 91 | ip.stage <- stage[disc.ip[, 1]] 92 | ip.txStat <- tx.status[disc.ip[, 1]] 93 | 94 | # Attributes of susceptible 95 | ip.prep <- prepStat[disc.ip[, 2]] 96 | ip.prepcl <- prepClass[disc.ip[, 2]] 97 | ip.rGC <- rGC[disc.ip[, 2]] 98 | ip.rCT <- rCT[disc.ip[, 2]] 99 | 100 | # Base TP from VL 101 | ip.tprob <- pmin(0.99, URAI.prob * 2.45^(ip.vl - 4.5)) 102 | 103 | # Adjustment (based on Supervie JAIDS) for VL Suppressed, on ART 104 | ip.noTrans <- which(ip.vl <= log10(200) & ip.txStat == 1) 105 | ip.tprob[ip.noTrans] <- 2.2/1e5 106 | 107 | # Transform to log odds 108 | ip.tlo <- log(ip.tprob/(1 - ip.tprob)) 109 | 110 | # Condom use 111 | not.UAI <- which(disc.ip[, "uai"] == 0) 112 | condom.rr <- rep(NA, nrow(disc.ip)) 113 | races <- sort(unique(race[disc.ip[, 1]])) 114 | for (i in races) { 115 | not.UAI.race <- intersect(not.UAI, which(race[disc.ip[, 1]] == i)) 116 | condom.rr[not.UAI.race] <- 1 - (cond.eff - cond.fail[i]) 117 | } 118 | ip.tlo[not.UAI] <- ip.tlo[not.UAI] + log(condom.rr[not.UAI]) 119 | 120 | # PrEP, by adherence class 121 | ip.on.prep <- which(ip.prep == 1) 122 | ip.tlo[ip.on.prep] <- ip.tlo[ip.on.prep] + log(prep.hr[ip.prepcl[ip.on.prep]]) 123 | 124 | # Acute-stage multipliers 125 | isAcute <- which(ip.stage %in% 1:2) 126 | ip.tlo[isAcute] <- ip.tlo[isAcute] + log(acute.rr) 127 | 128 | ## Multiplier for STI 129 | is.rGC <- which(ip.rGC == 1) 130 | is.rCT <- which(ip.rCT == 1) 131 | is.rect.dual <- intersect(is.rGC, is.rCT) 132 | is.rGC.sing <- setdiff(is.rGC, is.rect.dual) 133 | is.rCT.sing <- setdiff(is.rCT, is.rect.dual) 134 | ip.tlo[is.rGC.sing] <- ip.tlo[is.rGC.sing] + log(hiv.rgc.rr) 135 | ip.tlo[is.rCT.sing] <- ip.tlo[is.rCT.sing] + log(hiv.rct.rr) 136 | ip.tlo[is.rect.dual] <- ip.tlo[is.rect.dual] + 137 | max(log(hiv.rgc.rr), log(hiv.rct.rr)) + 138 | min(log(hiv.rgc.rr), log(hiv.rct.rr)) * hiv.dual.rr 139 | 140 | # Race-specific scalar for calibration 141 | races <- race[disc.ip[, 2]] 142 | ip.tlo <- ip.tlo + log(trans.scale[races]) 143 | 144 | # Convert back to probability 145 | ip.tprob <- plogis(ip.tlo) 146 | stopifnot(ip.tprob >= 0, ip.tprob <= 1) 147 | 148 | 149 | # PATP: Receptive Man Infected (Col 2) -------------------------------- 150 | 151 | # Attributes of infected 152 | rp.vl <- vl[disc.rp[, 2]] 153 | rp.stage <- stage[disc.rp[, 2]] 154 | rp.txStat <- tx.status[disc.rp[, 2]] 155 | 156 | # Attributes of susceptible 157 | rp.circ <- circ[disc.rp[, 1]] 158 | rp.prep <- prepStat[disc.rp[, 1]] 159 | rp.prepcl <- prepClass[disc.rp[, 1]] 160 | rp.uGC <- uGC[disc.rp[, 1]] 161 | rp.uCT <- uCT[disc.rp[, 1]] 162 | 163 | # Base TP from VL 164 | rp.tprob <- pmin(0.99, UIAI.prob * 2.45^(rp.vl - 4.5)) 165 | 166 | # Adjustment (based on Supervie JAIDS) for VL Suppressed, on ART 167 | rp.noTrans <- which(rp.vl <= log10(200) & rp.txStat == 1) 168 | rp.tprob[rp.noTrans] <- 2.2/1e5 169 | 170 | # Transform to log odds 171 | rp.tlo <- log(rp.tprob/(1 - rp.tprob)) 172 | 173 | # Circumcision 174 | rp.tlo[rp.circ == 1] <- rp.tlo[rp.circ == 1] + log(circ.rr) 175 | 176 | # Condom use 177 | not.UAI <- which(disc.rp[, "uai"] == 0) 178 | condom.rr <- rep(NA, nrow(disc.rp)) 179 | races <- sort(unique(race[disc.rp[, 1]])) 180 | for (i in races) { 181 | not.UAI.race <- intersect(not.UAI, which(race[disc.rp[, 1]] == i)) 182 | condom.rr[not.UAI.race] <- 1 - (cond.eff - cond.fail[i]) 183 | } 184 | rp.tlo[not.UAI] <- rp.tlo[not.UAI] + log(condom.rr[not.UAI]) 185 | 186 | # PrEP, by adherence class 187 | rp.on.prep <- which(rp.prep == 1) 188 | rp.tlo[rp.on.prep] <- rp.tlo[rp.on.prep] + log(prep.hr[rp.prepcl[rp.on.prep]]) 189 | 190 | # Acute-stage multipliers 191 | isAcute <- which(rp.stage %in% 1:2) 192 | rp.tlo[isAcute] <- rp.tlo[isAcute] + log(acute.rr) 193 | 194 | ## Multiplier for STI 195 | is.uGC <- which(rp.uGC == 1) 196 | is.uCT <- which(rp.uCT == 1) 197 | is.ureth.dual <- intersect(is.uGC, is.uCT) 198 | is.uGC.sing <- setdiff(is.uGC, is.ureth.dual) 199 | is.uCT.sing <- setdiff(is.uCT, is.ureth.dual) 200 | rp.tlo[is.uGC.sing] <- rp.tlo[is.uGC.sing] + log(hiv.ugc.rr) 201 | rp.tlo[is.uCT.sing] <- rp.tlo[is.uCT.sing] + log(hiv.uct.rr) 202 | rp.tlo[is.ureth.dual] <- rp.tlo[is.ureth.dual] + 203 | max(log(hiv.ugc.rr), log(hiv.uct.rr)) + 204 | min(log(hiv.ugc.rr), log(hiv.uct.rr)) * hiv.dual.rr 205 | 206 | # Race-specific scalar for calibration 207 | races <- race[disc.rp[, 1]] 208 | rp.tlo <- rp.tlo + log(trans.scale[races]) 209 | 210 | # Convert back to probability 211 | rp.tprob <- plogis(rp.tlo) 212 | stopifnot(rp.tprob >= 0, rp.tprob <= 1) 213 | 214 | 215 | # Transmission -------------------------------------------------------- 216 | 217 | trans.ip <- rbinom(length(ip.tprob), 1, ip.tprob) 218 | trans.rp <- rbinom(length(rp.tprob), 1, rp.tprob) 219 | 220 | 221 | # Output -------------------------------------------------------------- 222 | 223 | infected <- NULL 224 | if (sum(trans.ip, trans.rp) > 0) { 225 | infected <- c(disc.ip[trans.ip == 1, 2], 226 | disc.rp[trans.rp == 1, 1]) 227 | 228 | # Attributes of newly infected 229 | dat$attr$status[infected] <- 1 230 | dat$attr$inf.time[infected] <- at 231 | dat$attr$vl[infected] <- 0 232 | dat$attr$stage[infected] <- 1 233 | dat$attr$stage.time[infected] <- 0 234 | dat$attr$diag.status[infected] <- 0 235 | dat$attr$tx.status[infected] <- 0 236 | dat$attr$cuml.time.on.tx[infected] <- 0 237 | dat$attr$cuml.time.off.tx[infected] <- 0 238 | 239 | # Attributes of transmitter 240 | transmitter <- as.numeric(c(disc.ip[trans.ip == 1, 1], 241 | disc.rp[trans.rp == 1, 2])) 242 | tab.trans <- table(transmitter) 243 | uni.trans <- as.numeric(names(tab.trans)) 244 | dat$attr$count.trans[uni.trans] <- dat$attr$count.trans[uni.trans] + 245 | as.numeric(tab.trans) 246 | } 247 | 248 | # Summary Output 249 | dat$epi$incid[at] <- length(infected) 250 | dat$epi$incid.B[at] <- sum(dat$attr$race[infected] == 1) 251 | dat$epi$incid.H[at] <- sum(dat$attr$race[infected] == 2) 252 | dat$epi$incid.W[at] <- sum(dat$attr$race[infected] == 3) 253 | 254 | if (length(infected) > 0) { 255 | dat$epi$incid.undx[at] <- sum(dat$attr$diag.status[transmitter] == 0) 256 | dat$epi$incid.dx[at] <- sum(dat$attr$diag.status[transmitter] == 1 & 257 | dat$attr$cuml.time.on.tx[transmitter] == 0) 258 | dat$epi$incid.linked[at] <- sum(dat$attr$diag.status[transmitter] == 1 & 259 | dat$attr$cuml.time.on.tx[transmitter] > 0 & 260 | dat$attr$vl[transmitter] > log10(200)) 261 | dat$epi$incid.vsupp[at] <- sum(dat$attr$diag.status[transmitter] == 1 & 262 | dat$attr$cuml.time.on.tx[transmitter] > 0 & 263 | dat$attr$vl[transmitter] <= log10(200)) 264 | } else { 265 | dat$epi$incid.undx[at] <- 0 266 | dat$epi$incid.dx[at] <- 0 267 | dat$epi$incid.linked[at] <- 0 268 | dat$epi$incid.vsupp[at] <- 0 269 | } 270 | 271 | return(dat) 272 | } 273 | 274 | 275 | #' @export 276 | #' @rdname hivtrans_msm 277 | trans_het <- function(dat, at) { 278 | 279 | ## Discordant Edgelist 280 | del <- discord_edgelist_het(dat, at) 281 | 282 | nInf <- 0 283 | idsInf <- idsTrans <- NULL 284 | 285 | if (!is.null(del)) { 286 | 287 | ## Acts 288 | nedges <- length(del[[1]]) 289 | 290 | act.rate.early <- dat$param$act.rate.early 291 | act.rate.late <- dat$param$act.rate.late 292 | act.rate.cd4 <- dat$param$act.rate.cd4 293 | 294 | cd4Count <- dat$attr$cd4Count[del$inf] 295 | 296 | isLate <- which(cd4Count < act.rate.cd4) 297 | 298 | rates <- rep(act.rate.early, nedges) 299 | rates[isLate] <- act.rate.late 300 | 301 | 302 | # Process 303 | act.rand <- dat$param$acts.rand 304 | if (act.rand == TRUE) { 305 | numActs <- rpois(nedges, rates) 306 | } else { 307 | numActs <- rates 308 | } 309 | 310 | cond.prob <- dat$param$cond.prob 311 | cond.prob <- rep(cond.prob, nedges) 312 | 313 | del$numActs <- numActs 314 | 315 | if (act.rand == TRUE) { 316 | del$protActs <- rbinom(nedges, rpois(nedges, numActs), cond.prob) 317 | } else { 318 | del$protActs <- numActs * cond.prob 319 | } 320 | 321 | del$protActs <- pmin(numActs, del$protActs) 322 | del$unprotActs <- numActs - del$protActs 323 | 324 | stopifnot(all(del$unprotActs >= 0)) 325 | 326 | 327 | ## Transmission 328 | 329 | # Base transmission probability 330 | vlLevel <- dat$attr$vlLevel[del$inf] 331 | males <- dat$attr$male[del$sus] 332 | ages <- dat$attr$age[del$sus] 333 | circs <- dat$attr$circStat[del$sus] 334 | prop.male <- dat$epi$propMale[at - 1] 335 | base.tprob <- hughes_tp(vlLevel, males, ages, circs, prop.male) 336 | 337 | # Acute and aids stage multipliers 338 | acute.stage.mult <- dat$param$acute.stage.mult 339 | aids.stage.mult <- dat$param$aids.stage.mult 340 | 341 | isAcute <- which(at - dat$attr$infTime[del$inf] < 342 | (dat$param$vl.acute.topeak + dat$param$vl.acute.toset)) 343 | isAIDS <- which(dat$attr$cd4Count[del$inf] < 200) 344 | 345 | base.tprob[isAcute] <- base.tprob[isAcute] * acute.stage.mult 346 | base.tprob[isAIDS] <- base.tprob[isAIDS] * aids.stage.mult 347 | 348 | 349 | # Condoms 350 | # Probability as a mixture function of protected and unprotected acts 351 | cond.eff <- dat$param$cond.eff 352 | prob.stasis.protacts <- (1 - base.tprob*(1 - cond.eff)) ^ del$protActs 353 | prob.stasis.unptacts <- (1 - base.tprob) ^ del$unprotActs 354 | prob.stasis <- prob.stasis.protacts * prob.stasis.unptacts 355 | finl.tprob <- 1 - prob.stasis 356 | 357 | # Transmission 358 | del$base.tprob <- base.tprob 359 | del$finl.tprob <- finl.tprob 360 | 361 | stopifnot(length(unique(sapply(del, length))) == 1) 362 | 363 | # Random transmission given final trans prob 364 | idsTrans <- which(rbinom(nedges, 1, del$finl.tprob) == 1) 365 | 366 | # Subset discord edgelist to transmissions 367 | del <- keep.attr(del, idsTrans) 368 | 369 | 370 | ## Update Nodal Attr 371 | idsInf <- unique(del$sus) 372 | idsTrans <- unique(del$inf) 373 | nInf <- length(idsInf) 374 | 375 | if (nInf > 0) { 376 | dat$attr$status[idsInf] <- 1 377 | dat$attr$infTime[idsInf] <- at 378 | dat$attr$ageInf[idsInf] <- dat$attr$age[idsInf] 379 | dat$attr$dxStat[idsInf] <- 0 380 | dat$attr$vlLevel[idsInf] <- 0 381 | dat$attr$txCD4min[idsInf] <- 382 | pmin(rnbinom(nInf, 383 | size = nbsdtosize(dat$param$tx.init.cd4.mean, 384 | dat$param$tx.init.cd4.sd), 385 | mu = dat$param$tx.init.cd4.mean), 386 | dat$param$tx.elig.cd4) 387 | } 388 | 389 | ## Transmission data frame 390 | if (dat$control$save.transmat == TRUE) { 391 | if (nInf > 0) { 392 | if (at == 2) { 393 | dat$stats$transmat <- as.data.frame(del) 394 | } else { 395 | dat$stats$transmat <- rbind(dat$stats$transmat, as.data.frame(del)) 396 | } 397 | } 398 | } 399 | 400 | } 401 | 402 | ## Incidence vector 403 | dat$epi$si.flow[at] <- nInf 404 | dat$epi$si.flow.male[at] <- sum(dat$attr$male[idsInf] == 1, na.rm = TRUE) 405 | dat$epi$si.flow.feml[at] <- sum(dat$attr$male[idsInf] == 0, na.rm = TRUE) 406 | 407 | return(dat) 408 | } 409 | 410 | 411 | discord_edgelist_het <- function(dat, at) { 412 | 413 | status <- dat$attr$status 414 | 415 | idsInft <- which(status == 1) 416 | nInft <- length(idsInft) 417 | 418 | del <- NULL 419 | 420 | if (nInft > 0) { 421 | 422 | el <- dat$el[[1]] 423 | 424 | if (nrow(el) > 0) { 425 | el <- el[sample(1:nrow(el)), , drop = FALSE] 426 | 427 | disc <- which(abs(status[el[, 1]] - status[el[, 2]]) == 1) 428 | if (length(disc) > 0) { 429 | tmp.del <- el[disc, ] 430 | tmp.del[status[tmp.del[, 2]] == 1, ] <- tmp.del[status[tmp.del[, 2]] == 1, 2:1] 431 | 432 | del <- list() 433 | del$sus <- tmp.del[, 2] 434 | del$inf <- tmp.del[, 1] 435 | } 436 | } 437 | 438 | } 439 | 440 | return(del) 441 | } 442 | 443 | 444 | hughes_tp <- function(vls, susmales, susages, suscircs, prop.male, fmat = FALSE) { 445 | 446 | suscircs[is.na(suscircs)] <- 0 447 | 448 | sus.hsv2 <- 0.59*prop.male + 0.86*(1 - prop.male) 449 | sus.gud <- 0.039*prop.male + 0.053*(1 - prop.male) 450 | sus.tvagin <- 0.068*prop.male + 0.12*(1 - prop.male) 451 | sus.cerv <- 0.066*(1 - prop.male) 452 | 453 | interc <- -8.3067 454 | coef.vl <- 1.062566 455 | coef.male <- 0.6430989 456 | coef.age <- -0.0403451 457 | coef.hsv2 <- 0.7625081 458 | coef.circ <- -0.6377294 459 | coef.gud <- 0.9749536 460 | coef.vagin <- 0.9435334 461 | coef.cerv <- 1.288279 462 | 463 | tp.full <- exp(interc + coef.vl*(vls - 4) + 464 | coef.male*susmales + coef.age*(susages - 35) + 465 | coef.hsv2*sus.hsv2 + coef.circ*susmales*suscircs + 466 | coef.gud*sus.gud + coef.vagin*sus.tvagin + 467 | coef.cerv*sus.cerv) 468 | 469 | if (fmat == TRUE) { 470 | tp.full <- data.frame(tp.full, vls, susmales, susages, suscircs) 471 | } 472 | 473 | return(tp.full) 474 | } 475 | 476 | keep.attr <- function(attrList, keep) { 477 | lapply(attrList, function(x) x[keep]) 478 | } 479 | 480 | nbsdtosize <- function(mu, sd) { 481 | mu ^ 2 / (sd ^ 2 - mu) 482 | } 483 | -------------------------------------------------------------------------------- /R/mod.hivtx.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Treatment Module 3 | #' 4 | #' @description Module function for anti-retroviral treatment initiation and 5 | #' adherence over time. 6 | #' 7 | #' @inheritParams aging_msm 8 | #' 9 | #' @details 10 | #' Persons enter into the simulation with one of four ART "patterns": never 11 | #' tested, tested but never treated, treated and achieving partial HIV viral 12 | #' suppression, or treated with full viral suppression (these types are stored 13 | #' as individual-level attributes in \code{tt.traj}). This module initiates ART 14 | #' for treatment naive persons in the latter two types, and then cycles them on 15 | #' and off treatment conditional on empirical race-specific adherence rates. ART 16 | #' initiation, non-adherence, and restarting are all stochastically simulated 17 | #' based on binomial statistical models. 18 | #' 19 | #' @return 20 | #' This function returns the \code{dat} object with updated \code{tx.status}, 21 | #' \code{tx.init.time}, \code{cuml.time.on.tx}, \code{cuml.time.off.tx} attributes. 22 | #' 23 | #' @keywords module msm 24 | #' 25 | #' @export 26 | #' 27 | hivtx_msm <- function(dat, at) { 28 | 29 | # Attributes 30 | race <- dat$attr$race 31 | status <- dat$attr$status 32 | tx.status <- dat$attr$tx.status 33 | diag.status <- dat$attr$diag.status 34 | cuml.time.on.tx <- dat$attr$cuml.time.on.tx 35 | cuml.time.off.tx <- dat$attr$cuml.time.off.tx 36 | tx.period.first <- dat$attr$tx.period.first 37 | tx.period.last <- dat$attr$tx.period.last 38 | tx.init.time <- dat$attr$tx.init.time 39 | tt.traj <- dat$attr$tt.traj 40 | 41 | # Parameters 42 | tx.init.prob <- dat$param$tx.init.prob 43 | tx.halt.part.prob <- dat$param$tx.halt.part.prob 44 | tx.reinit.part.prob <- dat$param$tx.reinit.part.prob 45 | tx.halt.full.rr <- dat$param$tx.halt.full.rr 46 | tx.halt.dur.rr <- dat$param$tx.halt.dur.rr 47 | tx.reinit.full.rr <- dat$param$tx.reinit.full.rr 48 | tx.reinit.dur.rr <- dat$param$tx.reinit.full.rr 49 | 50 | if (at == 3381) { 51 | races <- sort(unique(race)) 52 | for (i in races) { 53 | ids.race <- which(dat$attr$race == i) 54 | tt.traj[ids.race] <- sample(1:3, length(ids.race), TRUE, 55 | c(dat$param$tt.part.supp[i], 56 | dat$param$tt.full.supp[i], 57 | dat$param$tt.dur.supp[i])) 58 | } 59 | } 60 | 61 | ## Initiation 62 | tx.init.elig <- which(status == 1 & 63 | tx.status == 0 & 64 | diag.status == 1 & 65 | cuml.time.on.tx == 0) 66 | rates <- tx.init.prob[race[tx.init.elig]] 67 | tx.init <- tx.init.elig[rbinom(length(tx.init.elig), 1, rates) == 1] 68 | 69 | ## Halting 70 | tx.halt.part.elig <- which(tx.status == 1 & tt.traj == 1) 71 | rates.part <- tx.halt.part.prob[race[tx.halt.part.elig]] 72 | tx.halt.part <- tx.halt.part.elig[rbinom(length(tx.halt.part.elig), 1, rates.part) == 1] 73 | 74 | tx.halt.full.elig <- which(tx.status == 1 & tt.traj == 2) 75 | rates.full <- tx.halt.part.prob[race[tx.halt.full.elig]] * tx.halt.full.rr[race[tx.halt.full.elig]] 76 | tx.halt.full <- tx.halt.full.elig[rbinom(length(tx.halt.full.elig), 1, rates.full) == 1] 77 | 78 | tx.halt.dur.elig <- which(tx.status == 1 & tt.traj == 3) 79 | rates.dur <- tx.halt.part.prob[race[tx.halt.dur.elig]] * tx.halt.dur.rr[race[tx.halt.dur.elig]] 80 | tx.halt.dur <- tx.halt.dur.elig[rbinom(length(tx.halt.dur.elig), 1, rates.dur) == 1] 81 | 82 | tx.halt <- c(tx.halt.part, tx.halt.full, tx.halt.dur) 83 | 84 | ## Restarting 85 | tx.reinit.part.elig <- which(tx.status == 0 & tt.traj == 1 & 86 | cuml.time.on.tx > 0) 87 | rates.part <- tx.reinit.part.prob[race[tx.reinit.part.elig]] 88 | tx.reinit.part <- tx.reinit.part.elig[rbinom(length(tx.reinit.part.elig), 1, rates.part) == 1] 89 | 90 | tx.reinit.full.elig <- which(tx.status == 0 & tt.traj == 2 & 91 | cuml.time.on.tx > 0) 92 | rates.full <- tx.reinit.part.prob[race[tx.reinit.full.elig]] * tx.reinit.full.rr[race[tx.reinit.full.elig]] 93 | tx.reinit.full <- tx.reinit.full.elig[rbinom(length(tx.reinit.full.elig), 1, rates.full) == 1] 94 | 95 | tx.reinit.dur.elig <- which(tx.status == 0 & tt.traj == 3 & 96 | cuml.time.on.tx > 0) 97 | rates.dur <- tx.reinit.part.prob[race[tx.reinit.dur.elig]] * tx.reinit.dur.rr[race[tx.reinit.dur.elig]] 98 | tx.reinit.dur <- tx.reinit.dur.elig[rbinom(length(tx.reinit.dur.elig), 1, rates.dur) == 1] 99 | 100 | tx.reinit <- c(tx.reinit.part, tx.reinit.full, tx.reinit.dur) 101 | 102 | ## Update Attributes 103 | tx.status[tx.init] <- 1 104 | tx.status[tx.halt] <- 0 105 | tx.status[tx.reinit] <- 1 106 | 107 | cuml.time.on.tx[which(tx.status == 1)] <- cuml.time.on.tx[which(tx.status == 1)] + 1 108 | cuml.time.off.tx[which(tx.status == 0)] <- cuml.time.off.tx[which(tx.status == 0)] + 1 109 | 110 | tx.init.time[tx.init] <- at 111 | 112 | idsSetPeriod <- union(tx.init, tx.reinit) 113 | tx.period.first[idsSetPeriod] <- at 114 | tx.period.last[idsSetPeriod] <- at 115 | 116 | idsContPeriod <- setdiff(which(tx.status == 1), idsSetPeriod) 117 | tx.period.last[idsContPeriod] <- at 118 | 119 | dat$attr$tt.traj <- tt.traj 120 | dat$attr$tx.status <- tx.status 121 | dat$attr$cuml.time.on.tx <- cuml.time.on.tx 122 | dat$attr$cuml.time.off.tx <- cuml.time.off.tx 123 | dat$attr$tx.period.first <- tx.period.first 124 | dat$attr$tx.period.last <- tx.period.last 125 | dat$attr$tx.init.time <- tx.init.time 126 | 127 | dat$epi$mean.tx.on[at] <- mean(cuml.time.on.tx, na.rm = TRUE) 128 | dat$epi$mean.tx.off[at] <- mean(cuml.time.off.tx, na.rm = TRUE) 129 | 130 | dat$epi$mean.tx.on.part[at] <- mean(cuml.time.on.tx[tt.traj == 1], na.rm = TRUE) 131 | dat$epi$mean.tx.off.part[at] <- mean(cuml.time.off.tx[tt.traj == 1], na.rm = TRUE) 132 | 133 | return(dat) 134 | } 135 | 136 | 137 | #' @export 138 | #' @rdname hivtx_msm 139 | tx_het <- function(dat, at) { 140 | 141 | # Variables --------------------------------------------------------------- 142 | dxStat <- dat$attr$dxStat 143 | txStat <- dat$attr$txStat 144 | txStartTime <- dat$attr$txStartTime 145 | txStops <- dat$attr$txStops 146 | txTimeOn <- dat$attr$txTimeOn 147 | txTimeOff <- dat$attr$txTimeOff 148 | txCD4start <- dat$attr$txCD4start 149 | 150 | cd4Count <- dat$attr$cd4Count 151 | tx.elig.cd4 <- dat$param$tx.elig.cd4 152 | tx.coverage <- dat$param$tx.coverage 153 | 154 | txType <- dat$attr$txType 155 | tx.adhere.full <- dat$param$tx.adhere.full 156 | tx.adhere.part <- dat$param$tx.adhere.part 157 | 158 | 159 | # Start tx for tx naive --------------------------------------------------- 160 | 161 | ## Calculate tx coverage 162 | allElig <- which((cd4Count < tx.elig.cd4 | !is.na(txStartTime))) 163 | txCov <- sum(!is.na(txStartTime[allElig]))/length(allElig) 164 | if (is.nan(txCov)) { 165 | txCov <- 0 166 | } 167 | 168 | idsElig <- which(dxStat == 1 & txStat == 0 & 169 | is.na(txStartTime) & cd4Count < tx.elig.cd4) 170 | nElig <- length(idsElig) 171 | idsTx <- NULL 172 | 173 | 174 | ## Treatment coverage 175 | nStart <- max(0, min(nElig, round((tx.coverage - txCov) * length(allElig)))) 176 | if (nStart > 0) { 177 | idsTx <- ssample(idsElig, nStart) 178 | } 179 | 180 | 181 | ## Treatment type assignment 182 | if (length(idsTx) > 0) { 183 | needtxType <- which(is.na(txType[idsTx])) 184 | if (length(needtxType) > 0) { 185 | txType[idsTx[needtxType]] <- rbinom(length(needtxType), 1, tx.adhere.full) 186 | } 187 | if (tx.adhere.part == 0) { 188 | idsTx <- intersect(idsTx, which(txType == 1)) 189 | } 190 | } 191 | 192 | if (length(idsTx) > 0) { 193 | txStat[idsTx] <- 1 194 | txStartTime[idsTx] <- at 195 | txStops[idsTx] <- 0 196 | txTimeOn[idsTx] <- 0 197 | txTimeOff[idsTx] <- 0 198 | txCD4start[idsTx] <- cd4Count[idsTx] 199 | } 200 | 201 | 202 | # Stop tx ----------------------------------------------------------------- 203 | idsStop <- NULL 204 | idsEligStop <- which(dat$attr$txStat == 1 & txType == 0) 205 | nEligStop <- length(idsEligStop) 206 | if (nEligStop > 0) { 207 | vecStop <- which(rbinom(nEligStop, 1, (1 - tx.adhere.part)) == 1) 208 | if (length(vecStop) > 0) { 209 | idsStop <- idsEligStop[vecStop] 210 | txStat[idsStop] <- 0 211 | txStops[idsStop] <- txStops[idsStop] + 1 212 | } 213 | } 214 | 215 | 216 | # Restart tx -------------------------------------------------------------- 217 | idsRest <- NULL 218 | idsEligRest <- which(dat$attr$txStat == 0 & txStops > 0) 219 | nEligRest <- length(idsEligRest) 220 | if (nEligRest > 0) { 221 | vecRes <- which(rbinom(nEligRest, 1, tx.adhere.part) == 1) 222 | if (length(vecRes) > 0) { 223 | idsRest <- idsEligRest[vecRes] 224 | txStat[idsRest] <- 1 225 | dat$attr$vlSlope[idsRest] <- NA 226 | } 227 | } 228 | 229 | 230 | # Output ------------------------------------------------------------------ 231 | idsOnTx <- which(txStat == 1) 232 | idsOffTx <- which(txStat == 0 & !is.na(txStartTime)) 233 | txTimeOn[idsOnTx] <- txTimeOn[idsOnTx] + 1 234 | txTimeOff[idsOffTx] <- txTimeOff[idsOffTx] + 1 235 | 236 | dat$attr$txStat <- txStat 237 | dat$attr$txStartTime <- txStartTime 238 | dat$attr$txStops <- txStops 239 | dat$attr$txTimeOn <- txTimeOn 240 | dat$attr$txTimeOff <- txTimeOff 241 | dat$attr$txType <- txType 242 | dat$attr$txCD4start <- txCD4start 243 | 244 | return(dat) 245 | } 246 | 247 | -------------------------------------------------------------------------------- /R/mod.hivvl.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Viral Load Module 3 | #' 4 | #' @description Module function for updating HIV viral load. 5 | #' 6 | #' @inheritParams aging_msm 7 | #' 8 | #' @details 9 | #' HIV viral load varies over time as a function of time since infection and ART 10 | #' history. In the absence of ART, VL rises during the acute rising stage and 11 | #' falls during the acute falling stage, until it reaches a set-point value in 12 | #' chronic stage infection. VL again rises during AIDS stage disease until the 13 | #' point of death. 14 | #' 15 | #' For persons who have ever initated treatment (\code{tt.traj} is \code{3} or 16 | #' \code{4}), VL changes depending on current ART use in that time step. 17 | #' Current use is associated with a reduction in VL, with the rates of decline 18 | #' and nadirs dependent on partial or full suppression levels. Current 19 | #' non-adherence is associated with an equal level of increase to VL. All persons 20 | #' who have reached AIDS, regardless of how they arrived, have a similar rate of 21 | #' VL increase. 22 | #' 23 | #' @return 24 | #' This function returns the \code{dat} object with updated \code{vl} attribute. 25 | #' 26 | #' @keywords module msm 27 | #' 28 | #' @export 29 | #' 30 | hivvl_msm <- function(dat, at) { 31 | 32 | # Attributes 33 | time.inf <- at - dat$attr$inf.time 34 | cuml.time.on.tx <- dat$attr$cuml.time.on.tx 35 | status <- dat$attr$status 36 | tt.traj <- dat$attr$tt.traj 37 | stage <- dat$attr$stage 38 | vl <- dat$attr$vl 39 | tx.status <- dat$attr$tx.status 40 | 41 | # Parameters 42 | acute.rise.int <- dat$param$vl.acute.rise.int 43 | acute.peak <- dat$param$vl.acute.peak 44 | acute.fall.int <- dat$param$vl.acute.fall.int 45 | vl.set.point <- dat$param$vl.set.point 46 | aids.onset <- dat$param$vl.aids.onset 47 | aids.int <- dat$param$vl.aids.int 48 | vl.aids.peak <- dat$param$vl.aids.peak 49 | vl.full.supp <- dat$param$vl.full.supp 50 | vl.tx.down.slope <- dat$param$vl.tx.down.slope 51 | vl.tx.aids.down.slope <- dat$param$vl.tx.aids.down.slope 52 | vl.part.supp <- dat$param$vl.part.supp 53 | vl.tx.up.slope <- dat$param$vl.tx.up.slope 54 | vl.aids.slope <- (vl.aids.peak - vl.set.point) / aids.int 55 | 56 | ## Process ## 57 | 58 | # 1. TX-naive 59 | idsElig1 <- which(status == 1 & cuml.time.on.tx == 0) 60 | time.inf1 <- time.inf[idsElig1] 61 | new.vl <- rep(NA, length(idsElig1)) 62 | 63 | # Acute rising 64 | idsElig1.AR <- which(stage[idsElig1] == 1) 65 | new.vl[idsElig1.AR] <- pmin(acute.peak, acute.peak * time.inf1[idsElig1.AR] / acute.rise.int) 66 | 67 | # Acute falling 68 | idsElig1.AF <- which(stage[idsElig1] == 2) 69 | new.vl[idsElig1.AF] <- ((vl.set.point - acute.peak) * 70 | (time.inf1[idsElig1.AF] - acute.rise.int) / acute.fall.int + acute.peak) 71 | 72 | # Chronic 73 | idsElig1.C <- which(stage[idsElig1] == 3) 74 | new.vl[idsElig1.C] <- vl.set.point 75 | 76 | # AIDS 77 | idsElig1.A <- which(stage[idsElig1] == 4) 78 | new.vl[idsElig1.A] <- vl.set.point + (time.inf1[idsElig1.A] - aids.onset) * vl.aids.slope 79 | 80 | vl[idsElig1] <- new.vl 81 | 82 | 83 | # 2. On tx, tt.traj=full/dur, not AIDS 84 | idsElig2 <- which(tx.status == 1 & tt.traj %in% 2:3 & stage != 4) 85 | current.vl <- vl[idsElig2] 86 | new.vl <- pmax(current.vl - vl.tx.down.slope, vl.full.supp) 87 | vl[idsElig2] <- new.vl 88 | 89 | 90 | # 3. On tx, tt.traj=part, not AIDS 91 | idsElig3 <- which(tx.status == 1 & tt.traj == 1 & stage != 4) 92 | current.vl <- vl[idsElig3] 93 | new.vl <- pmax(current.vl - vl.tx.down.slope, vl.part.supp) 94 | vl[idsElig3] <- new.vl 95 | 96 | 97 | # 4a. Off tx, not naive, tt.traj=part/full/dur, Acute rising 98 | idsElig4a <- which(tx.status == 0 & cuml.time.on.tx > 0 & stage == 1) 99 | current.vl <- vl[idsElig4a] 100 | max.vl <- acute.peak * time.inf[idsElig4a] / acute.rise.int 101 | new.vl <- pmin(current.vl + vl.tx.up.slope, max.vl) 102 | vl[idsElig4a] <- new.vl 103 | 104 | 105 | # 4b. Off tx, not naive, tt.traj=part/full/dur, Acute falling 106 | idsElig4b <- which(tx.status == 0 & cuml.time.on.tx > 0 & stage == 2) 107 | current.vl <- vl[idsElig4b] 108 | max.vl <- ((vl.set.point - acute.peak) * 109 | (time.inf[idsElig4b] - acute.rise.int) / acute.fall.int + acute.peak) 110 | new.vl <- pmin(current.vl + vl.tx.up.slope, max.vl) 111 | vl[idsElig4b] <- new.vl 112 | 113 | 114 | # 5. Off tx, not naive, tt.traj=part/full/dur, Chronic 115 | idsElig5 <- which(tx.status == 0 & cuml.time.on.tx > 0 & stage == 3) 116 | current.vl <- vl[idsElig5] 117 | new.vl <- pmin(current.vl + vl.tx.up.slope, vl.set.point) 118 | vl[idsElig5] <- new.vl 119 | 120 | 121 | # 6. On tx, tt.traj=full/dur, AIDS 122 | idsElig6 <- which(tx.status == 1 & tt.traj %in% 2:3 & stage == 4) 123 | current.vl <- vl[idsElig6] 124 | new.vl <- pmax(current.vl - vl.tx.aids.down.slope, vl.full.supp) 125 | vl[idsElig6] <- new.vl 126 | 127 | 128 | # 7. On tx, tt.traj=part, AIDS 129 | idsElig7 <- which(tx.status == 1 & tt.traj == 1 & stage == 4) 130 | current.vl <- vl[idsElig7] 131 | new.vl <- pmax(current.vl - vl.tx.aids.down.slope, vl.part.supp) 132 | vl[idsElig7] <- new.vl 133 | 134 | 135 | # 8a. Off tx, tt.traj=part/full/dur and AIDS, VL < set.point 136 | idsElig8 <- which(tx.status == 0 & cuml.time.on.tx > 0 & stage == 4 & vl < vl.set.point) 137 | current.vl <- vl[idsElig8] 138 | new.vl <- current.vl + vl.tx.up.slope 139 | vl[idsElig8] <- new.vl 140 | 141 | 142 | # 8b. Off tx, tt.traj=part/full/dur and AIDS, VL >= set.point 143 | idsElig8 <- which(tx.status == 0 & cuml.time.on.tx > 0 & stage == 4 & vl >= vl.set.point) 144 | current.vl <- vl[idsElig8] 145 | new.vl <- pmin(current.vl + vl.aids.slope, vl.aids.peak) 146 | vl[idsElig8] <- new.vl 147 | 148 | 149 | ## Output 150 | dat$attr$vl <- vl 151 | 152 | idsSupp <- which(vl <= log10(200)) 153 | idsUsupp <- which(vl > log10(200)) 154 | dat$attr$vl.last.usupp[idsUsupp] <- at 155 | dat$attr$vl.last.supp[idsSupp] <- at 156 | 157 | if (dat$control$save.clin.hist == TRUE) { 158 | dat <- save_clin_hist(dat, at) 159 | } 160 | 161 | return(dat) 162 | } 163 | 164 | save_clin_hist <- function(dat, at) { 165 | 166 | if (is.null(dat$temp$clin.hist)) { 167 | m <- list() 168 | for (i in 1:3) { 169 | m[[i]] <- array(dim = c(length(dat$attr$active), dat$control$nsteps)) 170 | } 171 | } else { 172 | m <- dat$temp$clin.hist 173 | } 174 | m[[1]][, at] <- dat$attr$vl 175 | m[[2]][, at] <- dat$attr$stage 176 | m[[3]][, at] <- dat$attr$tx.status 177 | 178 | dat$temp$clin.hist <- m 179 | return(dat) 180 | } 181 | 182 | 183 | #' @export 184 | #' @rdname hivvl_msm 185 | vl_het <- function(dat, at) { 186 | 187 | ## Common variables 188 | status <- dat$attr$status 189 | infTime <- dat$attr$infTime 190 | 191 | 192 | # Assign base VL ---------------------------------------------------------- 193 | if (is.null(dat$attr$vlLevel)) { 194 | dat$attr$vlLevel <- rep(NA, length(status)) 195 | dat$attr$vlSlope <- rep(NA, length(status)) 196 | } 197 | vlLevel <- dat$attr$vlLevel 198 | 199 | idsEligAsn <- which(status == 1 & is.na(vlLevel)) 200 | if (length(idsEligAsn) > 0) { 201 | vlLevel[idsEligAsn] <- expected_vl(male = dat$attr$male[idsEligAsn], 202 | age = dat$attr$age[idsEligAsn], 203 | ageInf = dat$attr$ageInf[idsEligAsn], 204 | param = dat$param) 205 | } 206 | 207 | 208 | # Update natural VL ------------------------------------------------------- 209 | txStartTime <- dat$attr$txStartTime 210 | idsEligUpd <- which(status == 1 & 211 | infTime < at & is.na(txStartTime)) 212 | 213 | if (length(idsEligUpd) > 0) { 214 | vlLevel[idsEligUpd] <- expected_vl(male = dat$attr$male[idsEligUpd], 215 | age = dat$attr$age[idsEligUpd], 216 | ageInf = dat$attr$ageInf[idsEligUpd], 217 | param = dat$param) 218 | } 219 | 220 | # VL decline with ART ----------------------------------------------------- 221 | txStat <- dat$attr$txStat 222 | idsEligTx <- which(status == 1 & infTime < at & txStat == 1) 223 | if (length(idsEligTx) > 0) { 224 | tx.vlsupp.time <- dat$param$tx.vlsupp.time 225 | tx.vlsupp.level <- dat$param$tx.vlsupp.level 226 | 227 | vlSlope <- dat$attr$vlSlope 228 | needSlope <- intersect(idsEligTx, which(is.na(vlSlope))) 229 | 230 | vl.slope <- vlSlope 231 | if (length(needSlope) > 0) { 232 | vl.diff <- pmin(tx.vlsupp.level - vlLevel[needSlope], 0) 233 | vl.slope[needSlope] <- vl.diff / tx.vlsupp.time 234 | dat$attr$vlSlope[needSlope] <- vl.slope[needSlope] 235 | } 236 | 237 | vlLevel[idsEligTx] <- pmax(vlLevel[idsEligTx] + vl.slope[idsEligTx], tx.vlsupp.level) 238 | } 239 | 240 | 241 | # VL rebound post ART ----------------------------------------------------- 242 | idsEligNoTx <- which(status == 1 & 243 | txStat == 0 & !is.na(txStartTime)) 244 | if (length(idsEligNoTx) > 0) { 245 | tx.vlsupp.time <- dat$param$tx.vlsupp.time 246 | 247 | expVl <- expected_vl(male = dat$attr$male[idsEligNoTx], 248 | age = dat$attr$age[idsEligNoTx], 249 | ageInf = dat$attr$ageInf[idsEligNoTx], 250 | param = dat$param) 251 | 252 | vl.slope <- dat$attr$vlSlope 253 | 254 | vlLevel[idsEligNoTx] <- pmin(vlLevel[idsEligNoTx] - vl.slope[idsEligNoTx], expVl) 255 | } 256 | 257 | dat$attr$vlLevel <- vlLevel 258 | 259 | return(dat) 260 | } 261 | 262 | 263 | expected_vl <- function(male, age, ageInf, param) { 264 | 265 | timeInf <- (age - ageInf) * (365 / param$time.unit) 266 | 267 | slope1 <- param$vl.acute.peak / param$vl.acute.topeak 268 | slope2 <- (param$vl.setpoint - param$vl.acute.peak) / 269 | (param$vl.acute.toset - param$vl.acute.topeak) 270 | 271 | sl3denom <- expected_cd4(method = "timeto", 272 | cd4Count1 = 200, cd4Count2 = 25, 273 | male = male, age = age, ageInf = ageInf, 274 | time.unit = param$time.unit) 275 | slope3 <- (param$vl.aidsmax - param$vl.setpoint) / sl3denom 276 | 277 | setptTime <- param$vl.acute.topeak + param$vl.acute.toset 278 | aidsTime <- expected_cd4(method = "timeto", cd4Count1 = 200, 279 | male = male, age = age, ageInf = ageInf, 280 | time.unit = param$time.unit) 281 | 282 | gp <- 1 * (timeInf <= param$vl.acute.topeak) + 283 | 2 * (timeInf > param$vl.acute.topeak & timeInf <= setptTime) + 284 | 3 * (timeInf > setptTime & timeInf <= aidsTime) + 285 | 4 * (timeInf > aidsTime) 286 | 287 | vlLevel <- rep(NA, length(timeInf)) 288 | vlLevel[gp == 1] <- timeInf[gp == 1] * slope1 289 | vlLevel[gp == 2] <- pmax(param$vl.setpoint, 290 | param$vl.acute.peak + 291 | (timeInf[gp == 2] - param$vl.acute.topeak) * slope2) 292 | vlLevel[gp == 3] <- param$vl.setpoint 293 | vlLevel[gp == 4] <- pmin(param$vl.aidsmax, 294 | param$vl.setpoint + 295 | (timeInf[gp == 4] - aidsTime[gp == 4]) * slope3[gp == 4]) 296 | 297 | return(vlLevel) 298 | } 299 | -------------------------------------------------------------------------------- /R/mod.initialize.R: -------------------------------------------------------------------------------- 1 | 2 | # MSM ----------------------------------------------------------------- 3 | 4 | #' @title Initialization Module 5 | #' 6 | #' @description This function initializes the master \code{dat} object on which 7 | #' data are stored, simulates the initial state of the network, and 8 | #' simulates disease status and other attributes. 9 | #' 10 | #' @param x An \code{EpiModel} object of class \code{\link{netest}}. 11 | #' @param param An \code{EpiModel} object of class \code{\link{param_msm}}. 12 | #' @param init An \code{EpiModel} object of class \code{\link{init_msm}}. 13 | #' @param control An \code{EpiModel} object of class \code{\link{control_msm}}. 14 | #' @param s Simulation number, used for restarting dependent simulations. 15 | #' 16 | #' @return 17 | #' This function returns the updated \code{dat} object with the initialized values 18 | #' for demographics and disease-related variables. 19 | #' 20 | #' @export 21 | #' @keywords module msm 22 | #' 23 | initialize_msm <- function(x, param, init, control, s) { 24 | 25 | ## Master Data List Setup ## 26 | dat <- list() 27 | dat$param <- param 28 | dat$init <- init 29 | dat$control <- control 30 | 31 | 32 | ## Network Setup ## 33 | # Initial network simulations 34 | dat$nw <- list() 35 | for (i in 1:3) { 36 | dat$nw[[i]] <- simulate(x[[i]]$fit, basis = x[[i]]$fit$newnetwork) 37 | } 38 | nw <- dat$nw 39 | 40 | # Pull Network parameters 41 | dat$nwparam <- list() 42 | for (i in 1:3) { 43 | dat$nwparam[i] <- list(x[[i]][-which(names(x[[i]]) == "fit")]) 44 | } 45 | 46 | # Convert to tergmLite method 47 | dat <- init_tergmLite(dat) 48 | 49 | ## Nodal Attributes Setup ## 50 | dat$attr <- param$netstats$attr 51 | 52 | num <- network.size(nw[[1]]) 53 | dat$attr$active <- rep(1, num) 54 | dat$attr$arrival.time <- rep(1, num) 55 | dat$attr$uid <- 1:num 56 | 57 | # Circumcision 58 | rates <- param$circ.prob[dat$attr$race] 59 | dat$attr$circ <- rbinom(length(rates), 1, rates) 60 | 61 | # Insertivity Quotient 62 | ins.quot <- rep(NA, num) 63 | role.class <- dat$attr$role.class 64 | ins.quot[role.class == 0] <- 1 65 | ins.quot[role.class == 1] <- 0 66 | ins.quot[role.class == 2] <- runif(sum(role.class == 2)) 67 | dat$attr$ins.quot <- ins.quot 68 | 69 | # HIV-related attributes 70 | dat <- init_status_msm(dat) 71 | 72 | # STI Status 73 | dat <- init_sti_msm(dat) 74 | 75 | # PrEP-related attributes 76 | dat$attr$prepClass <- rep(NA, num) 77 | dat$attr$prepElig <- rep(NA, num) 78 | dat$attr$prepStat <- rep(0, num) 79 | dat$attr$prepStartTime <- rep(NA, num) 80 | dat$attr$prepLastRisk <- rep(NA, num) 81 | dat$attr$prepLastStiScreen <- rep(NA, num) 82 | 83 | ## Other Setup ## 84 | dat$stats <- list() 85 | dat$stats$nwstats <- list() 86 | dat$temp <- list() 87 | dat$epi <- list() 88 | 89 | # Prevalence Tracking 90 | dat$temp$max.uid <- num 91 | dat <- prevalence_msm(dat, at = 1) 92 | 93 | # Setup Partner List 94 | plist <- cbind(dat$el[[1]], ptype = 1) 95 | plist <- rbind(plist, cbind(dat$el[[2]], ptype = 2)) 96 | plist <- cbind(plist, start = 1, stop = NA) 97 | colnames(plist)[1:2] <- c("p1", "p2") 98 | dat$temp$plist <- plist 99 | 100 | # Clinical history 101 | if (dat$control$save.clin.hist == TRUE) { 102 | dat <- save_clin_hist(dat, at = 1) 103 | } 104 | 105 | # Network statistics 106 | if (dat$control$save.nwstats == TRUE) { 107 | dat <- calc_nwstats(dat, at = 1) 108 | } 109 | 110 | # dat$param$netstats <- NULL 111 | class(dat) <- "dat" 112 | return(dat) 113 | } 114 | 115 | 116 | #' @title Initialize the HIV status of persons in the network 117 | #' 118 | #' @description Sets the initial individual-level disease status of persons 119 | #' in the network, as well as disease-related attributes for 120 | #' infected persons. 121 | #' 122 | #' @param dat Data object created in initialization module. 123 | #' 124 | #' @export 125 | #' @keywords initiation utility msm 126 | #' 127 | init_status_msm <- function(dat) { 128 | 129 | num <- sum(dat$attr$active == 1) 130 | 131 | # Sub in diag.status from model for status 132 | status <- dat$attr$diag.status 133 | 134 | # Late (AIDS-stage) tester type 135 | rates <- dat$param$hiv.test.late.prob[dat$attr$race] 136 | dat$attr$late.tester <- rbinom(length(rates), 1, rates) 137 | 138 | # Treatment trajectory 139 | tt.traj <- rep(NA, num) 140 | races <- sort(unique(dat$attr$race)) 141 | for (i in races) { 142 | ids.race <- which(dat$attr$race == i) 143 | tt.traj[ids.race] <- sample(1:3, length(ids.race), TRUE, 144 | c(dat$param$tt.part.supp[i], 145 | dat$param$tt.full.supp[i], 146 | dat$param$tt.dur.supp[i])) 147 | 148 | } 149 | dat$attr$tt.traj <- tt.traj 150 | 151 | ## Infection-related attributes 152 | dat$attr$status <- status 153 | idsInf <- which(status == 1) 154 | 155 | age <- dat$attr$age 156 | min.ages <- min(dat$param$netstats$demog$ages) 157 | time.sex.active <- pmax(1, round((365/7)*age[idsInf] - (365/7)*min.ages, 0)) 158 | min.hiv.time <- round(dat$param$vl.acute.rise.int + dat$param$vl.acute.fall.int) 159 | max.hiv.time <- dat$param$vl.aids.onset.int 160 | 161 | time.infected <- round(pmax(min.hiv.time, 162 | pmin(time.sex.active, 163 | sample(min.hiv.time:max.hiv.time, length(idsInf), TRUE)))) 164 | 165 | dat$attr$inf.time <- rep(NA, num) 166 | dat$attr$inf.time[idsInf] <- -time.infected 167 | 168 | dat$attr$stage <- rep(NA, num) 169 | dat$attr$stage.time <- rep(NA, num) 170 | dat$attr$aids.time <- rep(NA, num) 171 | dat$attr$stage[idsInf] <- 3 172 | dat$attr$stage.time[idsInf] <- time.infected - min.hiv.time 173 | 174 | dat$attr$diag.stage <- rep(NA, num) 175 | dat$attr$diag.stage[idsInf] <- dat$attr$stage[idsInf] 176 | 177 | dat$attr$vl <- rep(NA, num) 178 | dat$attr$vl[idsInf] <- dat$param$vl.set.point 179 | dat$attr$vl.last.usupp <- rep(NA, num) 180 | dat$attr$vl.last.supp <- rep(NA, num) 181 | 182 | dat$attr$diag.time <- rep(NA, num) 183 | dat$attr$diag.time[idsInf] <- dat$attr$inf.time[idsInf] + round(mean(1/dat$param$hiv.test.rate)) 184 | dat$attr$last.neg.test <- rep(NA, num) 185 | 186 | dat$attr$tx.status <- rep(NA, num) 187 | dat$attr$tx.status[idsInf] <- 0 188 | dat$attr$cuml.time.on.tx <- rep(NA, num) 189 | dat$attr$cuml.time.on.tx[idsInf] <- 0 190 | dat$attr$cuml.time.off.tx <- rep(NA, num) 191 | dat$attr$cuml.time.off.tx[idsInf] <- time.infected 192 | dat$attr$tx.period.first <- rep(NA, num) 193 | dat$attr$tx.period.last <- rep(NA, num) 194 | dat$attr$tx.init.time <- rep(NA, num) 195 | 196 | dat$attr$count.trans <- rep(0, num) 197 | dat$attr$num.neg.tests <- rep(0, length(status)) 198 | 199 | return(dat) 200 | } 201 | 202 | 203 | 204 | #' @title Initialize the STI status of persons in the network 205 | #' 206 | #' @description Sets the initial individual-level disease status of persons 207 | #' in the network, as well as disease-related attributes for 208 | #' infected persons. 209 | #' 210 | #' @param dat Data object created in initialization module. 211 | #' 212 | #' @export 213 | #' @keywords initiation utility msm 214 | #' 215 | init_sti_msm <- function(dat) { 216 | 217 | role.class <- dat$attr$role.class 218 | num <- length(role.class) 219 | 220 | idsUreth <- which(role.class %in% c(0, 2)) 221 | idsRect <- which(role.class %in% c(1, 2)) 222 | 223 | uGC <- rGC <- rep(0, num) 224 | uCT <- rCT <- rep(0, num) 225 | 226 | # Initialize GC infection at both sites 227 | idsUGC <- sample(idsUreth, size = round(dat$init$prev.ugc * num), FALSE) 228 | uGC[idsUGC] <- 1 229 | 230 | idsRGC <- sample(setdiff(idsRect, idsUGC), size = round(dat$init$prev.rgc * num), FALSE) 231 | rGC[idsRGC] <- 1 232 | 233 | dat$attr$rGC <- rGC 234 | dat$attr$uGC <- uGC 235 | 236 | dat$attr$rGC.sympt <- dat$attr$uGC.sympt <- rep(NA, num) 237 | dat$attr$rGC.sympt[rGC == 1] <- rbinom(sum(rGC == 1), 1, dat$param$rgc.sympt.prob) 238 | dat$attr$uGC.sympt[uGC == 1] <- rbinom(sum(uGC == 1), 1, dat$param$ugc.sympt.prob) 239 | 240 | dat$attr$rGC.infTime <- dat$attr$uGC.infTime <- rep(NA, length(dat$attr$active)) 241 | dat$attr$rGC.infTime[rGC == 1] <- 1 242 | dat$attr$uGC.infTime[uGC == 1] <- 1 243 | 244 | dat$attr$rGC.timesInf <- rep(0, num) 245 | dat$attr$rGC.timesInf[rGC == 1] <- 1 246 | dat$attr$uGC.timesInf <- rep(0, num) 247 | dat$attr$uGC.timesInf[uGC == 1] <- 1 248 | 249 | dat$attr$rGC.tx <- dat$attr$uGC.tx <- rep(NA, num) 250 | dat$attr$rGC.tx.prep <- dat$attr$uGC.tx.prep <- rep(NA, num) 251 | 252 | # Initialize CT infection at both sites 253 | idsUCT <- sample(idsUreth, size = round(dat$init$prev.uct * num), FALSE) 254 | uCT[idsUCT] <- 1 255 | 256 | idsRCT <- sample(setdiff(idsRect, idsUCT), size = round(dat$init$prev.rct * num), FALSE) 257 | rCT[idsRCT] <- 1 258 | 259 | dat$attr$rCT <- rCT 260 | dat$attr$uCT <- uCT 261 | 262 | dat$attr$rCT.sympt <- dat$attr$uCT.sympt <- rep(NA, num) 263 | dat$attr$rCT.sympt[rCT == 1] <- rbinom(sum(rCT == 1), 1, dat$param$rct.sympt.prob) 264 | dat$attr$uCT.sympt[uCT == 1] <- rbinom(sum(uCT == 1), 1, dat$param$uct.sympt.prob) 265 | 266 | dat$attr$rCT.infTime <- dat$attr$uCT.infTime <- rep(NA, num) 267 | dat$attr$rCT.infTime[dat$attr$rCT == 1] <- 1 268 | dat$attr$uCT.infTime[dat$attr$uCT == 1] <- 1 269 | 270 | dat$attr$rCT.timesInf <- rep(0, num) 271 | dat$attr$rCT.timesInf[rCT == 1] <- 1 272 | dat$attr$uCT.timesInf <- rep(0, num) 273 | dat$attr$uCT.timesInf[uCT == 1] <- 1 274 | 275 | dat$attr$rCT.tx <- dat$attr$uCT.tx <- rep(NA, num) 276 | dat$attr$rCT.tx.prep <- dat$attr$uCT.tx.prep <- rep(NA, num) 277 | 278 | return(dat) 279 | 280 | } 281 | 282 | 283 | #' @title Re-Initialization Module 284 | #' 285 | #' @description This function reinitializes an epidemic model to restart at a 286 | #' specified time step given an input \code{netsim} object. 287 | #' 288 | #' @param x An \code{EpiModel} object of class \code{\link{netsim}}. 289 | #' @inheritParams initialize_msm 290 | #' 291 | #' @details 292 | #' Currently, the necessary components that must be on \code{x} for a simulation 293 | #' to be restarted must be: param, control, nwparam, epi, attr, temp, el, p. 294 | #' TODO: describe this more. 295 | #' 296 | #' @return 297 | #' This function resets the data elements on the \code{dat} master data object 298 | #' in the needed ways for the time loop to function. 299 | #' 300 | #' @export 301 | #' @keywords module msm 302 | #' 303 | reinit_msm <- function(x, param, init, control, s) { 304 | 305 | need.for.reinit <- c("param", "control", "nwparam", "epi", "attr", "temp", "el", "p") 306 | if (!all(need.for.reinit %in% names(x))) { 307 | stop("x must contain the following elements for restarting: ", 308 | "param, control, nwparam, epi, attr, temp, el, p", 309 | call. = FALSE) 310 | } 311 | 312 | if (length(x$el) == 1) { 313 | s <- 1 314 | } 315 | 316 | dat <- list() 317 | 318 | dat$param <- param 319 | dat$param$modes <- 1 320 | dat$control <- control 321 | dat$nwparam <- x$nwparam 322 | 323 | dat$epi <- sapply(x$epi, function(var) var[s]) 324 | names(dat$epi) <- names(x$epi) 325 | 326 | dat$el <- x$el[[s]] 327 | dat$p <- x$p[[s]] 328 | 329 | dat$attr <- x$attr[[s]] 330 | 331 | if (!is.null(x$stats)) { 332 | dat$stats <- list() 333 | if (!is.null(x$stats$nwstats)) { 334 | dat$stats$nwstats <- x$stats$nwstats[[s]] 335 | } 336 | } 337 | 338 | dat$temp <- x$temp[[s]] 339 | 340 | class(dat) <- "dat" 341 | return(dat) 342 | } 343 | 344 | 345 | 346 | # HET ----------------------------------------------------------------- 347 | 348 | 349 | #' @export 350 | #' @rdname initialize_msm 351 | initialize_het <- function(x, param, init, control, s) { 352 | 353 | dat <- list() 354 | dat$temp <- list() 355 | nw <- simulate(x$fit, control = control.simulate.ergm(MCMC.burnin = 1e6)) 356 | 357 | dat$el <- list() 358 | dat$el[[1]] <- as.edgelist(nw) 359 | attributes(dat$el)$vnames <- NULL 360 | p <- tergmLite::stergm_prep(nw, x$formation, x$coef.diss$dissolution, x$coef.form, 361 | x$coef.diss$coef.adj, x$constraints) 362 | p$model.form$formula <- NULL 363 | p$model.diss$formula <- NULL 364 | dat$p <- list() 365 | dat$p[[1]] <- p 366 | 367 | ## Network Model Parameters 368 | dat$nwparam <- list(x[-which(names(x) == "fit")]) 369 | 370 | ## Simulation Parameters 371 | dat$param <- param 372 | dat$param$modes <- 1 373 | 374 | dat$init <- init 375 | dat$control <- control 376 | 377 | ## Nodal Attributes 378 | dat$attr <- list() 379 | 380 | dat$attr$male <- get.vertex.attribute(nw, "male") 381 | 382 | n <- network.size(nw) 383 | dat$attr$active <- rep(1, n) 384 | dat$attr$entTime <- rep(1, n) 385 | 386 | dat <- initStatus_het(dat) 387 | 388 | age <- rep(NA, n) 389 | age[dat$attr$male == 0] <- sample(init$ages.feml, sum(dat$attr$male == 0), TRUE) 390 | age[dat$attr$male == 1] <- sample(init$ages.male, sum(dat$attr$male == 1), TRUE) 391 | dat$attr$age <- age 392 | 393 | dat <- initInfTime_het(dat) 394 | dat <- initDx_het(dat) 395 | dat <- initTx_het(dat) 396 | 397 | # Circumcision 398 | male <- dat$attr$male 399 | nMales <- sum(male == 1) 400 | age <- dat$attr$age 401 | 402 | circStat <- circTime <- rep(NA, n) 403 | 404 | circStat[male == 1] <- rbinom(nMales, 1, dat$param$circ.prob.birth) 405 | 406 | isCirc <- which(circStat == 1) 407 | circTime[isCirc] <- round(-age[isCirc] * (365 / dat$param$time.unit)) 408 | 409 | dat$attr$circStat <- circStat 410 | dat$attr$circTime <- circTime 411 | 412 | 413 | ## Stats List 414 | dat$stats <- list() 415 | 416 | ## Final steps 417 | dat$epi <- list() 418 | dat <- prevalence_het(dat, at = 1) 419 | 420 | } 421 | 422 | 423 | #' @title Reinitialization Module 424 | #' 425 | #' @description This function reinitializes the master \code{dat} object on which 426 | #' data are stored, simulates the initial state of the network, and 427 | #' simulates disease status and other attributes. 428 | #' 429 | #' @param x An \code{EpiModel} object of class \code{\link{netest}}. 430 | #' @param param An \code{EpiModel} object of class \code{\link{param_het}}. 431 | #' @param init An \code{EpiModel} object of class \code{\link{init_het}}. 432 | #' @param control An \code{EpiModel} object of class \code{\link{control_het}}. 433 | #' @param s Simulation number, used for restarting dependent simulations. 434 | #' 435 | #' @return 436 | #' This function returns the updated \code{dat} object with the initialized values 437 | #' for demographics and disease-related variables. 438 | #' 439 | #' @keywords module het 440 | #' 441 | #' @export 442 | #' 443 | reinit_het <- function(x, param, init, control, s) { 444 | 445 | need.for.reinit <- c("param", "control", "nwparam", "epi", 446 | "attr", "temp", "el", "p") 447 | if (!all(need.for.reinit %in% names(x))) { 448 | stop("x must contain the following elements for restarting: ", 449 | "param, control, nwparam, epi, attr, temp, el, p", 450 | call. = FALSE) 451 | } 452 | 453 | if (length(x$el) == 1) { 454 | s <- 1 455 | } 456 | 457 | dat <- list() 458 | 459 | dat$param <- param 460 | dat$param$modes <- 1 461 | dat$control <- control 462 | dat$nwparam <- x$nwparam 463 | 464 | dat$epi <- sapply(x$epi, function(var) var[s]) 465 | names(dat$epi) <- names(x$epi) 466 | 467 | dat$el <- x$el[[s]] 468 | dat$p <- x$p[[s]] 469 | 470 | dat$attr <- x$attr[[s]] 471 | 472 | if (!is.null(x$stats)) { 473 | dat$stats <- list() 474 | if (!is.null(x$stats$nwstats)) { 475 | dat$stats$nwstats <- x$stats$nwstats[[s]] 476 | } 477 | } 478 | 479 | dat$temp <- x$temp[[s]] 480 | 481 | class(dat) <- "dat" 482 | 483 | return(dat) 484 | } 485 | 486 | 487 | initStatus_het <- function(dat) { 488 | 489 | ## Variables 490 | i.prev.male <- dat$init$i.prev.male 491 | i.prev.feml <- dat$init$i.prev.feml 492 | 493 | male <- dat$attr$male 494 | idsMale <- which(male == 1) 495 | idsFeml <- which(male == 0) 496 | nMale <- length(idsMale) 497 | nFeml <- length(idsFeml) 498 | n <- nMale + nFeml 499 | 500 | ## Process 501 | status <- rep(0, n) 502 | status[sample(idsMale, round(i.prev.male * nMale))] <- 1 503 | status[sample(idsFeml, round(i.prev.feml * nFeml))] <- 1 504 | 505 | dat$attr$status <- status 506 | 507 | return(dat) 508 | } 509 | 510 | 511 | initInfTime_het <- function(dat) { 512 | 513 | status <- dat$attr$status 514 | n <- length(status) 515 | 516 | infecteds <- which(status == 1) 517 | infTime <- rep(NA, n) 518 | 519 | inf.time.dist <- dat$init$inf.time.dist 520 | 521 | if (inf.time.dist == "allacute") { 522 | max.inf.time <- dat$param$vl.acute.topeak + dat$param$vl.acute.toset 523 | infTime[infecteds] <- sample(0:(-max.inf.time), length(infecteds), TRUE) 524 | } else { 525 | max.inf.time <- dat$init$max.inf.time / dat$param$time.unit 526 | if (inf.time.dist == "geometric") { 527 | total.d.rate <- 1/max.inf.time 528 | infTime[infecteds] <- -rgeom(length(infecteds), total.d.rate) 529 | } 530 | if (inf.time.dist == "uniform") { 531 | infTime[infecteds] <- sample(0:(-max.inf.time), length(infecteds), TRUE) 532 | } 533 | } 534 | 535 | ## Enforce that time infected < age 536 | infTime[infecteds] <- pmax(infTime[infecteds], 537 | 1 - dat$attr$age[infecteds] * (365 / dat$param$time.unit)) 538 | 539 | dat$attr$infTime <- infTime 540 | 541 | timeInf <- 1 - infTime 542 | dat$attr$ageInf <- pmax(0, dat$attr$age - round(timeInf) * (dat$param$time.unit / 365)) 543 | 544 | stopifnot(all(dat$attr$ageInf[infecteds] <= dat$attr$age[infecteds]), 545 | all(dat$attr$ageInf[infecteds] >= 0)) 546 | 547 | return(dat) 548 | } 549 | 550 | 551 | initDx_het <- function(dat) { 552 | 553 | n <- sum(dat$attr$active == 1) 554 | status <- dat$attr$status 555 | 556 | dxStat <- rep(NA, n) 557 | dxStat[status == 1] <- 0 558 | 559 | dxTime <- rep(NA, n) 560 | 561 | dat$attr$dxStat <- dxStat 562 | dat$attr$dxTime <- dxTime 563 | 564 | return(dat) 565 | } 566 | 567 | 568 | initTx_het <- function(dat) { 569 | 570 | ## Variables 571 | status <- dat$attr$status 572 | n <- sum(dat$attr$active == 1) 573 | nInf <- sum(status == 1) 574 | 575 | tx.init.cd4.mean <- dat$param$tx.init.cd4.mean 576 | tx.init.cd4.sd <- dat$param$tx.init.cd4.sd 577 | tx.elig.cd4 <- dat$param$tx.elig.cd4 578 | 579 | 580 | ## Process 581 | dat$attr$txStat <- rep(NA, n) 582 | dat$attr$txStartTime <- rep(NA, n) 583 | dat$attr$txStops <- rep(NA, n) 584 | dat$attr$txTimeOn <- rep(NA, n) 585 | dat$attr$txTimeOff <- rep(NA, n) 586 | 587 | txCD4min <- rep(NA, n) 588 | txCD4min[status == 1] <- pmin(rnbinom(nInf, 589 | size = nbsdtosize(tx.init.cd4.mean, 590 | tx.init.cd4.sd), 591 | mu = tx.init.cd4.mean), tx.elig.cd4) 592 | dat$attr$txCD4min <- txCD4min 593 | dat$attr$txCD4start <- rep(NA, n) 594 | dat$attr$txType <- rep(NA, n) 595 | 596 | return(dat) 597 | } 598 | 599 | -------------------------------------------------------------------------------- /R/mod.position.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Position Module 3 | #' 4 | #' @description Module function for establishing sexual role or position in each 5 | #' act on the discordant edgelist. 6 | #' 7 | #' @inheritParams aging_msm 8 | #' 9 | #' @details 10 | #' The sexual role within each act is determined by each nodes "role identity" 11 | #' as exclusively receptive, exclusively insertive, or versatile. This function 12 | #' determines whether the infected or the susceptible partner is the insertive 13 | #' partner for that act. For the first two role identity types, that is 14 | #' deterministic based on identity. For versatile-versatile pairs, this is 15 | #' determined stochastically for each act. 16 | #' 17 | #' @return 18 | #' This function returns the updated discordant edgelist with a \code{ins} 19 | #' attribute for values of whether the infected node is insertive or the 20 | #' susceptible node is insertive for that act. 21 | #' 22 | #' @keywords module msm 23 | #' 24 | #' @export 25 | #' 26 | position_msm <- function(dat, at) { 27 | 28 | al <- dat$temp$al 29 | if (nrow(al) == 0) { 30 | return(dat) 31 | } 32 | 33 | # Attributes 34 | role.class <- dat$attr$role.class 35 | ins.quot <- dat$attr$ins.quot 36 | 37 | # Parameters 38 | 39 | ## Process 40 | p1.role.class <- role.class[al[, "p1"]] 41 | p2.role.class <- role.class[al[, "p2"]] 42 | 43 | ins <- rep(NA, length(p1.role.class)) 44 | ins[which(p1.role.class == 0)] <- 1 45 | ins[which(p1.role.class == 1)] <- 0 46 | ins[which(p2.role.class == 0)] <- 0 47 | ins[which(p2.role.class == 1)] <- 1 48 | 49 | # Versatile MSM 50 | vv <- which(p1.role.class == 2 & p2.role.class == 2) 51 | p1.ins.prob <- ins.quot[al[, 1][vv]] / 52 | (ins.quot[al[, 1][vv]] + ins.quot[al[, 2][vv]]) 53 | p1.ins <- rbinom(length(vv), 1, p1.ins.prob) 54 | ins[vv[p1.ins == 1]] <- 1 55 | ins[vv[p1.ins == 0]] <- 0 56 | 57 | ## Output 58 | dat$temp$al <- cbind(al, ins) 59 | 60 | return(dat) 61 | } 62 | -------------------------------------------------------------------------------- /R/mod.prep.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title PrEP Module 3 | #' 4 | #' @description Module function for implementation and uptake of pre-exposure 5 | #' prophylaxis (PrEP) to prevent HIV infection. 6 | #' 7 | #' @inheritParams aging_msm 8 | #' 9 | #' @keywords module msm 10 | #' 11 | #' @export 12 | #' 13 | prep_msm <- function(dat, at) { 14 | 15 | # Function Selection ------------------------------------------------------ 16 | 17 | if (at >= dat$param$riskh.start) { 18 | dat <- riskhist_msm(dat, at) 19 | } else { 20 | return(dat) 21 | } 22 | 23 | if (at < dat$param$prep.start) { 24 | return(dat) 25 | } 26 | 27 | 28 | # Attributes -------------------------------------------------------------- 29 | 30 | # Core Attributes 31 | active <- dat$attr$active 32 | status <- dat$attr$status 33 | diag.status <- dat$attr$diag.status 34 | lnt <- dat$attr$last.neg.test 35 | 36 | # PrEP Attributes 37 | prepElig <- dat$attr$prepElig 38 | prepStat <- dat$attr$prepStat 39 | prepClass <- dat$attr$prepClass 40 | prepLastRisk <- dat$attr$prepLastRisk 41 | prepStartTime <- dat$attr$prepStartTime 42 | prepLastStiScreen <- dat$attr$prepLastStiScreen 43 | 44 | 45 | # Parameters -------------------------------------------------------------- 46 | 47 | prep.start.prob <- dat$param$prep.start.prob 48 | prep.adhr.dist <- dat$param$prep.adhr.dist 49 | prep.require.lnt <- dat$param$prep.require.lnt 50 | prep.risk.reassess.method <- dat$param$prep.risk.reassess.method 51 | prep.discont.rate <- dat$param$prep.discont.rate 52 | 53 | 54 | # Indications ------------------------------------------------------------- 55 | 56 | ind1 <- dat$attr$prep.ind.uai.mono 57 | # ind2 <- dat$attr$prep.ind.uai.nmain 58 | ind2 <- dat$attr$prep.ind.uai.conc 59 | ind3 <- dat$attr$prep.ind.sti 60 | 61 | twind <- at - dat$param$prep.risk.int 62 | 63 | # No indications in window 64 | idsNoIndic <- which((ind1 < twind | is.na(ind1)) & 65 | (ind2 < twind | is.na(ind2)) & 66 | (ind3 < twind | is.na(ind3))) 67 | base.cond.no <- which(active == 0 | diag.status == 1) 68 | idsNoIndic <- union(idsNoIndic, base.cond.no) 69 | 70 | # Indications in window 71 | idsIndic <- which(ind1 >= twind | ind2 >= twind | ind3 >= twind) 72 | base.cond.yes <- which(active == 1 & diag.status == 0) 73 | idsIndic <- intersect(idsIndic, base.cond.yes) 74 | 75 | # Set eligibility to 1 if indications 76 | prepElig[idsIndic] <- 1 77 | 78 | # Set eligibility to 0 if no indications 79 | prepElig[idsNoIndic] <- 0 80 | 81 | 82 | ## Stoppage ------------------------------------------------------------------ 83 | 84 | # Indication lapse 85 | # Rules = None, instant, yearly (CDC guidelines) 86 | if (prep.risk.reassess.method == "none") { 87 | idsStpInd <- NULL 88 | } else if (prep.risk.reassess.method == "inst") { 89 | idsRiskAssess <- which(active == 1 & prepStat == 1) 90 | prepLastRisk[idsRiskAssess] <- at 91 | idsStpInd <- intersect(idsNoIndic, idsRiskAssess) 92 | } else if (prep.risk.reassess.method == "year") { 93 | idsRiskAssess <- which(active == 1 & 94 | prepStat == 1 & 95 | lnt == at & 96 | (at - prepLastRisk) >= 52) 97 | prepLastRisk[idsRiskAssess] <- at 98 | idsStpInd <- intersect(idsNoIndic, idsRiskAssess) 99 | } 100 | 101 | # Random discontinuation 102 | idsEligStpRand <- which(active == 1 & prepStat == 1) 103 | vecStpRand <- rbinom(length(idsEligStpRand), 1, prep.discont.rate) 104 | idsStpRand <- idsEligStpRand[which(vecStpRand == 1)] 105 | 106 | # Diagnosis 107 | idsStpDx <- which(active == 1 & prepStat == 1 & diag.status == 1) 108 | 109 | # Death 110 | idsStpDth <- which(active == 0 & prepStat == 1) 111 | 112 | # Reset PrEP status 113 | idsStp <- c(idsStpInd, idsStpRand, idsStpDx, idsStpDth) 114 | 115 | # Update attributes for stoppers 116 | prepStat[idsStp] <- 0 117 | prepLastRisk[idsStp] <- NA 118 | prepStartTime[idsStp] <- NA 119 | prepLastStiScreen[idsStp] <- NA 120 | 121 | 122 | ## Initiation ---------------------------------------------------------------- 123 | 124 | ## Eligibility ## 125 | 126 | # Indications to start 127 | if (prep.require.lnt == TRUE) { 128 | idsEligStart <- which(prepStat == 0 & lnt == at) 129 | } else { 130 | idsEligStart <- which(prepStat == 0) 131 | } 132 | 133 | idsEligStart <- intersect(idsIndic, idsEligStart) 134 | prepElig[idsEligStart] <- 1 135 | 136 | vecStart <- rbinom(length(idsEligStart), 1, prep.start.prob) 137 | idsStart <- idsEligStart[which(vecStart == 1)] 138 | 139 | # Set attributes for starters 140 | if (length(idsStart) > 0) { 141 | prepStat[idsStart] <- 1 142 | prepStartTime[idsStart] <- at 143 | prepLastRisk[idsStart] <- at 144 | 145 | # PrEP adherence class 146 | needPC <- which(is.na(prepClass[idsStart])) 147 | prepClass[idsStart[needPC]] <- sample(x = 1:3, size = length(needPC), 148 | replace = TRUE, prob = prep.adhr.dist) 149 | } 150 | 151 | 152 | ## Output -------------------------------------------------------------------- 153 | 154 | # Random discontinuation 155 | dat$epi$prep.rand.stop[at] <- length(idsStpRand) 156 | 157 | # Attributes 158 | dat$attr$prepElig <- prepElig 159 | dat$attr$prepStat <- prepStat 160 | dat$attr$prepClass <- prepClass 161 | 162 | dat$attr$prepStartTime <- prepStartTime 163 | dat$attr$prepLastRisk <- prepLastRisk 164 | dat$attr$prepLastStiScreen <- prepLastStiScreen 165 | 166 | return(dat) 167 | } 168 | 169 | 170 | #' @title Risk History Sub-Module 171 | #' 172 | #' @description Sub-Module function to track the risk history of uninfected persons 173 | #' for purpose of PrEP targeting. 174 | #' 175 | #' @inheritParams aging_msm 176 | #' 177 | #' @keywords module msm 178 | #' 179 | #' @export 180 | #' 181 | riskhist_msm <- function(dat, at) { 182 | 183 | ## Attributes 184 | n <- length(dat$attr$active) 185 | dx <- dat$attr$diag.status 186 | since.test <- at - dat$attr$last.neg.test 187 | rGC.tx <- dat$attr$rGC.tx 188 | uGC.tx <- dat$attr$uGC.tx 189 | rCT.tx <- dat$attr$rCT.tx 190 | uCT.tx <- dat$attr$uCT.tx 191 | 192 | ## Parameters 193 | 194 | ## Edgelist, adds uai summation per partnership from act list 195 | pid <- NULL # For R CMD Check 196 | al <- as.data.frame(dat$temp$al) 197 | by_pid <- group_by(al, pid) 198 | uai <- summarise(by_pid, uai = sum(uai))[, 2] 199 | el <- as.data.frame(cbind(dat$temp$el, uai)) 200 | 201 | if (max(el[, 1:2]) > n) stop("riskhist max(el) > n") 202 | 203 | # Remove concordant positive edges 204 | el2 <- el[el$st2 == 0, ] 205 | 206 | # Initialize attributes 207 | if (is.null(dat$attr$prep.ind.uai.mono)) { 208 | dat$attr$prep.ind.uai.mono <- rep(NA, n) 209 | dat$attr$prep.ind.uai.nmain <- rep(NA, n) 210 | dat$attr$prep.ind.sti <- rep(NA, n) 211 | } 212 | if (is.null(dat$attr$prep.ind.uai.conc)) { 213 | dat$attr$prep.ind.uai.conc <- rep(NA, n) 214 | } 215 | 216 | ## Degree ## 217 | main.deg <- get_degree(dat$el[[1]]) 218 | casl.deg <- get_degree(dat$el[[2]]) 219 | inst.deg <- get_degree(dat$el[[3]]) 220 | 221 | 222 | ## Preconditions ## 223 | 224 | # Any UAI 225 | uai.any <- unique(c(el2$p1[el2$uai > 0], 226 | el2$p2[el2$uai > 0])) 227 | 228 | # Monogamous partnerships: 1-sided 229 | tot.deg <- main.deg + casl.deg + inst.deg 230 | uai.mono1 <- intersect(which(tot.deg == 1), uai.any) 231 | 232 | # "Negative" partnerships 233 | tneg <- unique(c(el2$p1[el2$st1 == 0], el2$p2[el2$st1 == 0])) 234 | fneg <- unique(c(el2$p1[which(dx[el2$p1] == 0)], el2$p2[which(dx[el2$p1] == 0)])) 235 | all.neg <- c(tneg, fneg) 236 | 237 | ## Condition 1b: UAI in 1-sided "monogamous" "negative" partnership, 238 | ## partner not tested in past 6 months 239 | uai.mono1.neg <- intersect(uai.mono1, all.neg) 240 | part.id1 <- c(el2[el2$p1 %in% uai.mono1.neg, 2], el2[el2$p2 %in% uai.mono1.neg, 1]) 241 | not.tested.6mo <- since.test[part.id1] > (180/7) 242 | part.not.tested.6mo <- uai.mono1.neg[which(not.tested.6mo == TRUE)] 243 | dat$attr$prep.ind.uai.mono[part.not.tested.6mo] <- at 244 | 245 | ## Condition 2a: UAI + concurrency 246 | el2.uai <- el2[el2$uai > 0, ] 247 | vec <- c(el2.uai[, 1], el2.uai[, 2]) 248 | uai.conc <- unique(vec[duplicated(vec)]) 249 | dat$attr$prep.ind.uai.conc[uai.conc] <- at 250 | 251 | ## Condition 2b: UAI in non-main partnerships 252 | uai.nmain <- unique(c(el2$p1[el2$st1 == 0 & el2$uai > 0 & el2$ptype %in% 2:3], 253 | el2$p2[el2$uai > 0 & el2$ptype %in% 2:3])) 254 | dat$attr$prep.ind.uai.nmain[uai.nmain] <- at 255 | 256 | ## Condition 4, any STI diagnosis 257 | idsDx <- which(rGC.tx == 1 | uGC.tx == 1 | rCT.tx == 1 | uCT.tx == 1) 258 | dat$attr$prep.ind.sti[idsDx] <- at 259 | 260 | return(dat) 261 | } 262 | 263 | 264 | #' @title Proportionally Reallocate PrEP Adherence Class Probability 265 | #' 266 | #' @description Shifts probabilities from the high-adherence category to the lower 267 | #' three adherence categories while maintaining the proportional 268 | #' distribution of those lower categories. 269 | #' 270 | #' @param in.pcp Input vector of length four for the \code{prep.adhr.dist} 271 | #' parameters. 272 | #' @param reall The pure percentage points to shift from the high adherence 273 | #' group to the lower three groups. 274 | #' 275 | #' @export 276 | #' 277 | reallocate_pcp <- function(in.pcp = c(0.089, 0.127, 0.784), reall = 0) { 278 | 279 | dist <- in.pcp[1]/sum(in.pcp[1:2]) 280 | dist[2] <- in.pcp[2]/sum(in.pcp[1:2]) 281 | 282 | out.pcp <- rep(NA, 3) 283 | out.pcp[1:2] <- in.pcp[1:2] - (dist * reall) 284 | out.pcp[3] <- 1 - sum(out.pcp[1:2]) 285 | 286 | return(out.pcp) 287 | } 288 | -------------------------------------------------------------------------------- /R/mod.prevalence.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Prevalence Calculations within Time Steps 3 | #' 4 | #' @description This module calculates demographic, transmission, and clinical 5 | #' statistics at each time step within the simulation. 6 | #' 7 | #' @inheritParams aging_msm 8 | #' 9 | #' @details 10 | #' Summary statistic calculations are of two broad forms: prevalence and 11 | #' incidence. This function establishes the summary statistic vectors for both 12 | #' prevalence and incidence at time 1, and then calculates the prevalence 13 | #' statistics for times 2 onward. Incidence statistics (e.g., number of new 14 | #' infections or deaths) are calculated within the modules as they depend on 15 | #' vectors that are not stored external to the module. 16 | #' 17 | #' @return 18 | #' This function returns the \code{dat} object with an updated summary of current 19 | #' attributes stored in \code{dat$epi}. 20 | #' 21 | #' @keywords module msm 22 | #' 23 | #' @export 24 | #' 25 | prevalence_msm <- function(dat, at) { 26 | 27 | active <- dat$attr$active 28 | status <- dat$attr$status 29 | diag.status <- dat$attr$diag.status 30 | diag.stage <- dat$attr$diag.stage 31 | diag.time <- dat$attr$diag.time 32 | aids.time <- dat$attr$aids.time 33 | inf.time <- dat$attr$inf.time 34 | race <- dat$attr$race 35 | age <- dat$attr$age 36 | tx.init.time <- dat$attr$tx.init.time 37 | vl <- dat$attr$vl 38 | vl.last.usupp <- dat$attr$vl.last.usupp 39 | last.neg.test <- dat$attr$last.neg.test 40 | stage <- dat$attr$stage 41 | 42 | prepElig <- dat$attr$prepElig 43 | prepStat <- dat$attr$prepStat 44 | prepClass <- dat$attr$prepClass 45 | 46 | rGC <- dat$attr$rGC 47 | uGC <- dat$attr$uGC 48 | rCT <- dat$attr$rCT 49 | uCT <- dat$attr$uCT 50 | 51 | # Pop Size / Demog 52 | dat$epi$num[at] <- sum(active == 1, na.rm = TRUE) 53 | dat$epi$num.B[at] <- sum(race == 1, na.rm = TRUE) 54 | dat$epi$num.H[at] <- sum(race == 2, na.rm = TRUE) 55 | dat$epi$num.W[at] <- sum(race == 3, na.rm = TRUE) 56 | dat$epi$age.mean[at] <- mean(age, na.rm = TRUE) 57 | dat$epi$s.num[at] <- sum(status == 0, na.rm = TRUE) 58 | dat$epi$i.num[at] <- sum(status == 1, na.rm = TRUE) 59 | dat$epi$i.num.B[at] <- sum(status == 1 & race == 1, na.rm = TRUE) 60 | dat$epi$i.num.H[at] <- sum(status == 1 & race == 2, na.rm = TRUE) 61 | dat$epi$i.num.W[at] <- sum(status == 1 & race == 3, na.rm = TRUE) 62 | 63 | dat$epi$i.num.dx[at] <- sum(diag.status == 1, na.rm = TRUE) 64 | 65 | # Prev / Incid 66 | dat$epi$i.prev[at] <- dat$epi$i.num[at] / dat$epi$num[at] 67 | dat$epi$i.prev.B[at] <- sum(race == 1 & status == 1, na.rm = TRUE) / sum(race == 1, na.rm = TRUE) 68 | dat$epi$i.prev.H[at] <- sum(race == 2 & status == 1, na.rm = TRUE) / sum(race == 2, na.rm = TRUE) 69 | dat$epi$i.prev.W[at] <- sum(race == 3 & status == 1, na.rm = TRUE) / sum(race == 3, na.rm = TRUE) 70 | 71 | dat$epi$i.prev.dx[at] <- sum(diag.status == 1, na.rm = TRUE) / dat$epi$num[at] 72 | dat$epi$i.prev.dx.B[at] <- sum(race == 1 & diag.status == 1, na.rm = TRUE) / sum(race == 1, na.rm = TRUE) 73 | dat$epi$i.prev.dx.H[at] <- sum(race == 2 & diag.status == 1, na.rm = TRUE) / sum(race == 2, na.rm = TRUE) 74 | dat$epi$i.prev.dx.W[at] <- sum(race == 3 & diag.status == 1, na.rm = TRUE) / sum(race == 3, na.rm = TRUE) 75 | 76 | dat$epi$ir100[at] <- (dat$epi$incid[at] / sum(status == 0, dat$epi$incid[at], na.rm = TRUE)) * 5200 77 | dat$epi$ir100.B[at] <- (dat$epi$incid.B[at] / sum(status == 0 & race == 1, dat$epi$incid.B[at], na.rm = TRUE)) * 5200 78 | dat$epi$ir100.H[at] <- (dat$epi$incid.H[at] / sum(status == 0 & race == 2, dat$epi$incid.H[at], na.rm = TRUE)) * 5200 79 | dat$epi$ir100.W[at] <- (dat$epi$incid.W[at] / sum(status == 0 & race == 3, dat$epi$incid.W[at], na.rm = TRUE)) * 5200 80 | 81 | 82 | # Care continuum stats (primary) 83 | dat$epi$cc.dx[at] <- sum(diag.status == 1 & inf.time >= 2, na.rm = TRUE) / 84 | sum(status == 1 & inf.time >= 2, na.rm = TRUE) 85 | dat$epi$cc.dx.B[at] <- sum(diag.status == 1 & inf.time >= 2 & race == 1, na.rm = TRUE) / 86 | sum(status == 1 & inf.time >= 2 & race == 1, na.rm = TRUE) 87 | dat$epi$cc.dx.H[at] <- sum(diag.status == 1 & inf.time >= 2 & race == 2, na.rm = TRUE) / 88 | sum(status == 1 & inf.time >= 2 & race == 2, na.rm = TRUE) 89 | dat$epi$cc.dx.W[at] <- sum(diag.status == 1 & inf.time >= 2 & race == 3, na.rm = TRUE) / 90 | sum(status == 1 & inf.time >= 2 & race == 3, na.rm = TRUE) 91 | 92 | dat$epi$cc.dx.aids[at] <- sum(diag.status == 1 & stage == 4 & inf.time >= 2 & 93 | aids.time - diag.time <= 52, na.rm = TRUE) / 94 | sum(diag.status == 1 & inf.time >= 2, na.rm = TRUE) 95 | dat$epi$cc.dx.aids.B[at] <- sum(diag.status == 1 & stage == 4 & inf.time >= 2 & 96 | aids.time - diag.time <= 52 & race == 1, na.rm = TRUE) / 97 | sum(diag.status == 1 & inf.time >= 2 & race == 1, na.rm = TRUE) 98 | dat$epi$cc.dx.aids.H[at] <- sum(diag.status == 1 & stage == 4 & inf.time >= 2 & 99 | aids.time - diag.time <= 52 & race == 2, na.rm = TRUE) / 100 | sum(diag.status == 1 & inf.time >= 2 & race == 2, na.rm = TRUE) 101 | dat$epi$cc.dx.aids.W[at] <- sum(diag.status == 1 & stage == 4 & inf.time >= 2 & 102 | aids.time - diag.time <= 52 & race == 3, na.rm = TRUE) / 103 | sum(diag.status == 1 & inf.time >= 2 & race == 3, na.rm = TRUE) 104 | 105 | dat$epi$cc.linked1m[at] <- sum(tx.init.time - diag.time <= 4 & diag.time >= 2, na.rm = TRUE) / 106 | sum(dat$attr$diag.status == 1 & diag.time >= 2, na.rm = TRUE) 107 | dat$epi$cc.linked1m.B[at] <- sum(tx.init.time - diag.time <= 4 & diag.time >= 2 & race == 1, na.rm = TRUE) / 108 | sum(diag.status == 1 & diag.time >= 2 & race == 1, na.rm = TRUE) 109 | dat$epi$cc.linked1m.H[at] <- sum(tx.init.time - diag.time <= 4 & diag.time >= 2 & race == 2, na.rm = TRUE) / 110 | sum(diag.status == 1 & diag.time >= 2 & race == 2, na.rm = TRUE) 111 | dat$epi$cc.linked1m.W[at] <- sum(tx.init.time - diag.time <= 4 & diag.time >= 2 & race == 3, na.rm = TRUE) / 112 | sum(diag.status == 1 & diag.time >= 2 & race == 3, na.rm = TRUE) 113 | 114 | dat$epi$cc.linked1m.int[at] <- sum(tx.init.time - diag.time <= 4 & diag.time >= 3380, na.rm = TRUE) / 115 | sum(dat$attr$diag.status == 1 & diag.time >= 3380, na.rm = TRUE) 116 | dat$epi$cc.linked1m.int.B[at] <- sum(tx.init.time - diag.time <= 4 & diag.time >= 3380 & race == 1, na.rm = TRUE) / 117 | sum(diag.status == 1 & diag.time >= 3380 & race == 1, na.rm = TRUE) 118 | dat$epi$cc.linked1m.int.H[at] <- sum(tx.init.time - diag.time <= 4 & diag.time >= 3380 & race == 2, na.rm = TRUE) / 119 | sum(diag.status == 1 & diag.time >= 3380 & race == 2, na.rm = TRUE) 120 | dat$epi$cc.linked1m.int.W[at] <- sum(tx.init.time - diag.time <= 4 & diag.time >= 3380 & race == 3, na.rm = TRUE) / 121 | sum(diag.status == 1 & diag.time >= 3380 & race == 3, na.rm = TRUE) 122 | 123 | dat$epi$cc.vsupp[at] <- sum(vl <= log10(200) & diag.status == 1 & diag.time >= 2, na.rm = TRUE) / 124 | sum(diag.status == 1 & diag.time >= 2, na.rm = TRUE) 125 | dat$epi$cc.vsupp.B[at] <- sum(vl <= log10(200) & diag.status == 1 & 126 | diag.time >= 2 & race == 1, na.rm = TRUE) / 127 | sum(diag.status == 1 & diag.time >= 2 & race == 1, na.rm = TRUE) 128 | dat$epi$cc.vsupp.H[at] <- sum(vl <= log10(200) & diag.status == 1 & 129 | diag.time >= 2 & race == 2, na.rm = TRUE) / 130 | sum(diag.status == 1 & diag.time >= 2 & race == 2, na.rm = TRUE) 131 | dat$epi$cc.vsupp.W[at] <- sum(vl <= log10(200) & diag.status == 1 & 132 | diag.time >= 2 & race == 3, na.rm = TRUE) / 133 | sum(diag.status == 1 & diag.time >= 2 & race == 3, na.rm = TRUE) 134 | 135 | dat$epi$cc.vsupp.all[at] <- sum(vl <= log10(200) & status == 1 & inf.time >= 2, na.rm = TRUE) / 136 | sum(status == 1 & inf.time >= 2, na.rm = TRUE) 137 | dat$epi$cc.vsupp.all.B[at] <- sum(vl <= log10(200) & status == 1 & inf.time >= 2 & race == 1, na.rm = TRUE) / 138 | sum(status == 1 & inf.time >= 2 & race == 1, na.rm = TRUE) 139 | dat$epi$cc.vsupp.all.H[at] <- sum(vl <= log10(200) & status == 1 & inf.time >= 2 & race == 2, na.rm = TRUE) / 140 | sum(status == 1 & inf.time >= 2 & race == 2, na.rm = TRUE) 141 | dat$epi$cc.vsupp.all.W[at] <- sum(vl <= log10(200) & status == 1 & inf.time >= 2 & race == 3, na.rm = TRUE) / 142 | sum(status == 1 & inf.time >= 2 & race == 3, na.rm = TRUE) 143 | 144 | dat$epi$cc.vsupp.dur1y[at] <- 1 - (sum((at - vl.last.usupp) <= 52 & diag.time >= 2 & 145 | diag.status == 1, na.rm = TRUE) / 146 | sum(diag.status == 1 & diag.time >= 2, na.rm = TRUE)) 147 | dat$epi$cc.vsupp.dur1y.B[at] <- 1 - (sum((at - vl.last.usupp) <= 52 & diag.time >= 2 & 148 | diag.status == 1 & race == 1, na.rm = TRUE) / 149 | sum(diag.status == 1 & diag.time >= 2 & race == 1, na.rm = TRUE)) 150 | dat$epi$cc.vsupp.dur1y.H[at] <- 1 - (sum((at - vl.last.usupp) <= 52 & diag.time >= 2 & 151 | diag.status == 1 & race == 2, na.rm = TRUE) / 152 | sum(diag.status == 1 & diag.time >= 2 & race == 2, na.rm = TRUE)) 153 | dat$epi$cc.vsupp.dur1y.W[at] <- 1 - (sum((at - vl.last.usupp) <= 52 & diag.time >= 2 & 154 | diag.status == 1 & race == 3, na.rm = TRUE) / 155 | sum(diag.status == 1 & diag.time >= 2 & race == 3, na.rm = TRUE)) 156 | 157 | dat$epi$cc.HIV.mr[at] <- (dat$epi$dep.HIV[at]/dat$epi$i.num[at])*52 158 | 159 | # Care continuum stats (secondary) 160 | dat$epi$cc.test.int[at] <- mean(at - last.neg.test[diag.status == 0], na.rm = TRUE) 161 | dat$epi$cc.test.int.B[at] <- mean(at - last.neg.test[diag.status == 0 & race == 1], na.rm = TRUE) 162 | dat$epi$cc.test.int.H[at] <- mean(at - last.neg.test[diag.status == 0 & race == 2], na.rm = TRUE) 163 | dat$epi$cc.test.int.W[at] <- mean(at - last.neg.test[diag.status == 0 & race == 3], na.rm = TRUE) 164 | 165 | dat$epi$cc.dx.delay[at] <- mean(diag.time[diag.time >= 2] - inf.time[diag.time >= 2], na.rm = TRUE) 166 | dat$epi$cc.dx.delay.B[at] <- mean(diag.time[diag.time >= 2 & race == 1] - 167 | inf.time[diag.time >= 2 & race == 1], na.rm = TRUE) 168 | dat$epi$cc.dx.delay.H[at] <- mean(diag.time[diag.time >= 2 & race == 2] - 169 | inf.time[diag.time >= 2 & race == 2], na.rm = TRUE) 170 | dat$epi$cc.dx.delay.W[at] <- mean(diag.time[diag.time >= 2 & race == 3] - 171 | inf.time[diag.time >= 2 & race == 3], na.rm = TRUE) 172 | 173 | dat$epi$cc.dx.delay.int[at] <- mean(diag.time[diag.time >= 3380] - inf.time[diag.time >= 3380], na.rm = TRUE) 174 | dat$epi$cc.dx.delay.int.B[at] <- mean(diag.time[diag.time >= 3380 & race == 1] - 175 | inf.time[diag.time >= 3380 & race == 1], na.rm = TRUE) 176 | dat$epi$cc.dx.delay.int.H[at] <- mean(diag.time[diag.time >= 3380 & race == 2] - 177 | inf.time[diag.time >= 3380 & race == 2], na.rm = TRUE) 178 | dat$epi$cc.dx.delay.int.W[at] <- mean(diag.time[diag.time >= 3380 & race == 3] - 179 | inf.time[diag.time >= 3380 & race == 3], na.rm = TRUE) 180 | 181 | # same as above, but with medians 182 | dat$epi$cc.dx.delay.med[at] <- median(diag.time[diag.time >= 2] - inf.time[diag.time >= 2], na.rm = TRUE) 183 | dat$epi$cc.dx.delay.B.med[at] <- median(diag.time[diag.time >= 2 & race == 1] - 184 | inf.time[diag.time >= 2 & race == 1], na.rm = TRUE) 185 | dat$epi$cc.dx.delay.H.med[at] <- median(diag.time[diag.time >= 2 & race == 2] - 186 | inf.time[diag.time >= 2 & race == 2], na.rm = TRUE) 187 | dat$epi$cc.dx.delay.W.med[at] <- median(diag.time[diag.time >= 2 & race == 3] - 188 | inf.time[diag.time >= 2 & race == 3], na.rm = TRUE) 189 | 190 | dat$epi$cc.dx.delay.int.med[at] <- median(diag.time[diag.time >= 3380] - inf.time[diag.time >= 3380], na.rm = TRUE) 191 | dat$epi$cc.dx.delay.int.B.med[at] <- median(diag.time[diag.time >= 3380 & race == 1] - 192 | inf.time[diag.time >= 3380 & race == 1], na.rm = TRUE) 193 | dat$epi$cc.dx.delay.int.H.med[at] <- median(diag.time[diag.time >= 3380 & race == 2] - 194 | inf.time[diag.time >= 3380 & race == 2], na.rm = TRUE) 195 | dat$epi$cc.dx.delay.int.W.med[at] <- median(diag.time[diag.time >= 3380 & race == 3] - 196 | inf.time[diag.time >= 3380 & race == 3], na.rm = TRUE) 197 | 198 | # dat$epi$cc.tx.any1y[at] <- sum((at - dat$attr$tx.period.last <= 52), na.rm = TRUE) / 199 | # sum(dat$attr$diag.status == 1, na.rm = TRUE) 200 | # dat$epi$cc.tx.any1y.B[at] <- sum((at - dat$attr$tx.period.last <= 52) & race == 1, na.rm = TRUE) / 201 | # sum(dat$attr$diag.status == 1 & race == 1, na.rm = TRUE) 202 | # dat$epi$cc.tx.any1y.H[at] <- sum((at - dat$attr$tx.period.last <= 52) & race == 2, na.rm = TRUE) / 203 | # sum(dat$attr$diag.status == 1 & race == 2, na.rm = TRUE) 204 | # dat$epi$cc.tx.any1y.W[at] <- sum((at - dat$attr$tx.period.last <= 52) & race == 3, na.rm = TRUE) / 205 | # sum(dat$attr$diag.status == 1 & race == 3, na.rm = TRUE) 206 | 207 | # dat$epi$cc.dx.delay[at] <- mean(dat$attr$diag.time - dat$attr$inf.time, na.rm = TRUE) 208 | # dat$epi$cc.testpy[at] <- 1-sum((at - dat$attr$last.neg.test) > 52 & status == 0, 209 | # is.na(dat$attr$last.neg.test) & status == 0, na.rm = TRUE) / 210 | # sum(status == 0) 211 | # dat$epi$cc.linked[at] <- sum(dat$attr$cuml.time.on.tx > 0, na.rm = TRUE) / 212 | # sum(dat$attr$diag.status == 1, na.rm = TRUE) 213 | # dat$epi$cc.tx[at] <- sum(dat$attr$tx.status == 1, na.rm = TRUE) / 214 | # sum(dat$attr$diag.status == 1, na.rm = TRUE) 215 | # dat$epi$cc.tx.ret3m[at] <- sum((at - dat$attr$tx.period.last) <= 52 & 216 | # (dat$attr$tx.period.last - dat$attr$tx.period.first) > 13, na.rm = TRUE) / 217 | # sum(dat$attr$diag.status == 1, na.rm = TRUE) 218 | # dat$epi$cc.vsupp.tt1[at] <- sum(dat$attr$vl <= log10(200) & dat$attr$tt.traj == 1, na.rm = TRUE) / 219 | # sum(dat$attr$diag.status == 1 & dat$attr$tt.traj == 1, na.rm = TRUE) 220 | # dat$epi$cc.vsupp.tt2[at] <- sum(dat$attr$vl <= log10(200) & dat$attr$tt.traj == 2, na.rm = TRUE) / 221 | # sum(dat$attr$diag.status == 1 & dat$attr$tt.traj == 2, na.rm = TRUE) 222 | # dat$epi$cc.vsupp.tt3[at] <- sum(dat$attr$vl <= log10(200) & dat$attr$tt.traj == 3, na.rm = TRUE) / 223 | # sum(dat$attr$diag.status == 1 & dat$attr$tt.traj == 3, na.rm = TRUE) 224 | 225 | 226 | # HIV screening outcomes 227 | dat$epi$mean.neg.tests[at] <- mean(dat$attr$num.neg.tests[diag.status == 0], na.rm = TRUE) 228 | dat$epi$mean.neg.tests.B[at] <- mean(dat$attr$num.neg.tests[diag.status == 0 & race == 1], na.rm = TRUE) 229 | dat$epi$mean.neg.tests.H[at] <- mean(dat$attr$num.neg.tests[diag.status == 0 & race == 2], na.rm = TRUE) 230 | dat$epi$mean.neg.tests.W[at] <- mean(dat$attr$num.neg.tests[diag.status == 0 & race == 3], na.rm = TRUE) 231 | 232 | dat$epi$test.past.year[at] <- sum(at - dat$attr$last.neg.test <= 52 & diag.status == 0, na.rm = TRUE) / 233 | sum(diag.status == 0, na.rm = TRUE) 234 | dat$epi$test.past.year.B[at] <- sum(at - dat$attr$last.neg.test <= 52 & diag.status == 0 & race == 1, na.rm = TRUE) / 235 | sum(diag.status == 0 & race == 1, na.rm = TRUE) 236 | dat$epi$test.past.year.H[at] <- sum(at - dat$attr$last.neg.test <= 52 & diag.status == 0 & race == 2, na.rm = TRUE) / 237 | sum(diag.status == 0 & race == 2, na.rm = TRUE) 238 | dat$epi$test.past.year.W[at] <- sum(at - dat$attr$last.neg.test <= 52 & diag.status == 0 & race == 3, na.rm = TRUE) / 239 | sum(diag.status == 0 & race == 3, na.rm = TRUE) 240 | 241 | # HIV stage 242 | dat$epi$hstage.acute[at] <- sum(stage %in% 1:2 & diag.time >= 2, na.rm = TRUE) / 243 | sum(status == 1 & diag.time >= 2, na.rm = TRUE) 244 | dat$epi$hstage.chronic[at] <- sum(stage == 3 & diag.time >= 2, na.rm = TRUE) / 245 | sum(status == 1 & diag.time >= 2, na.rm = TRUE) 246 | dat$epi$hstage.aids[at] <- sum(stage == 4 & diag.time >= 2, na.rm = TRUE) / 247 | sum(status == 1 & diag.time >= 2, na.rm = TRUE) 248 | 249 | dat$epi$prepElig[at] <- sum(prepElig == 1, na.rm = TRUE) 250 | dat$epi$prepElig.B[at] <- sum(prepElig == 1 & race == 1, na.rm = TRUE) 251 | dat$epi$prepElig.H[at] <- sum(prepElig == 1 & race == 2, na.rm = TRUE) 252 | dat$epi$prepElig.W[at] <- sum(prepElig == 1 & race == 3, na.rm = TRUE) 253 | 254 | dat$epi$prepCurr[at] <- sum(prepStat == 1, na.rm = TRUE) 255 | dat$epi$prepCurr.B[at] <- sum(prepStat == 1 & race == 1, na.rm = TRUE) 256 | dat$epi$prepCurr.H[at] <- sum(prepStat == 1 & race == 2, na.rm = TRUE) 257 | dat$epi$prepCurr.W[at] <- sum(prepStat == 1 & race == 3, na.rm = TRUE) 258 | 259 | dat$epi$prepCurr.hadr[at] <- sum(prepStat == 1 & prepClass == 3, na.rm = TRUE) 260 | 261 | # STIs 262 | dat$epi$prev.gc[at] <- sum((rGC == 1 | uGC == 1), na.rm = TRUE) / dat$epi$num[at] 263 | dat$epi$prev.ct[at] <- sum((rCT == 1 | uCT == 1), na.rm = TRUE) / dat$epi$num[at] 264 | ir100.rgc <- (dat$epi$incid.rgc[at]/sum(rGC == 0, dat$epi$incid.rgc[at], na.rm = TRUE))*5200 265 | ir100.ugc <- (dat$epi$incid.ugc[at]/sum(uGC == 0, dat$epi$incid.ugc[at], na.rm = TRUE))*5200 266 | dat$epi$ir100.gc[at] <- ir100.rgc + ir100.ugc 267 | ir100.rct <- (dat$epi$incid.rct[at]/sum(rCT == 0, dat$epi$incid.rct[at], na.rm = TRUE))*5200 268 | ir100.uct <- (dat$epi$incid.uct[at]/sum(uCT == 0, dat$epi$incid.uct[at], na.rm = TRUE))*5200 269 | dat$epi$ir100.ct[at] <- ir100.rct + ir100.uct 270 | dat$epi$ir100.sti[at] <- dat$epi$ir100.gc[at] + dat$epi$ir100.ct[at] 271 | 272 | return(dat) 273 | } 274 | 275 | #' @export 276 | #' @rdname prevalence_msm 277 | prevalence_het <- function(dat, at) { 278 | 279 | status <- dat$attr$status 280 | male <- dat$attr$male 281 | age <- dat$attr$age 282 | 283 | nsteps <- dat$control$nsteps 284 | rNA <- rep(NA, nsteps) 285 | 286 | # Initialize vectors 287 | if (at == 1) { 288 | dat$epi$i.num <- rNA 289 | dat$epi$num <- rNA 290 | 291 | dat$epi$i.num.male <- rNA 292 | dat$epi$i.num.feml <- rNA 293 | dat$epi$i.prev.male <- rNA 294 | dat$epi$i.prev.feml <- rNA 295 | 296 | dat$epi$num.male <- rNA 297 | dat$epi$num.feml <- rNA 298 | dat$epi$meanAge <- rNA 299 | dat$epi$propMale <- rNA 300 | 301 | dat$epi$si.flow <- rNA 302 | dat$epi$si.flow.male <- rNA 303 | dat$epi$si.flow.feml <- rNA 304 | 305 | dat$epi$b.flow <- rNA 306 | dat$epi$ds.flow <- dat$epi$di.flow <- rNA 307 | } 308 | 309 | dat$epi$i.num[at] <- sum(status == 1, na.rm = TRUE) 310 | dat$epi$num[at] <- length(status) 311 | 312 | dat$epi$i.num.male[at] <- sum(status == 1 & male == 1, na.rm = TRUE) 313 | dat$epi$i.num.feml[at] <- sum(status == 1 & male == 0, na.rm = TRUE) 314 | dat$epi$i.prev.male[at] <- sum(status == 1 & male == 1, na.rm = TRUE) / 315 | sum(male == 1, na.rm = TRUE) 316 | dat$epi$i.prev.feml[at] <- sum(status == 1 & male == 0, na.rm = TRUE) / 317 | sum(male == 0, na.rm = TRUE) 318 | 319 | dat$epi$num.male[at] <- sum(male == 1, na.rm = TRUE) 320 | dat$epi$num.feml[at] <- sum(male == 0, na.rm = TRUE) 321 | dat$epi$meanAge[at] <- mean(age, na.rm = TRUE) 322 | dat$epi$propMale[at] <- mean(male, na.rm = TRUE) 323 | 324 | return(dat) 325 | } 326 | 327 | 328 | whichVlSupp <- function(attr, param) { 329 | which(attr$status == 1 & 330 | attr$vlLevel <= log10(50) & 331 | (attr$age - attr$ageInf) * (365 / param$time.unit) > 332 | (param$vl.acute.topeak + param$vl.acute.toset)) 333 | } 334 | -------------------------------------------------------------------------------- /R/mod.simnet.R: -------------------------------------------------------------------------------- 1 | 2 | # MSM ----------------------------------------------------------------- 3 | 4 | #' @title Network Resimulation Module 5 | #' 6 | #' @description Module function for resimulating the sexual networks for one 7 | #' time step. 8 | #' 9 | #' @inheritParams aging_msm 10 | #' 11 | #' @keywords module msm 12 | #' 13 | #' @export 14 | #' 15 | simnet_msm <- function(dat, at) { 16 | 17 | ## Edges correction 18 | dat <- edges_correct_msm(dat, at) 19 | 20 | ## Main network 21 | nwparam.m <- EpiModel::get_nwparam(dat, network = 1) 22 | 23 | dat$attr$deg.casl <- get_degree(dat$el[[2]]) 24 | dat <- tergmLite::updateModelTermInputs(dat, network = 1) 25 | 26 | dat$el[[1]] <- tergmLite::simulate_network(p = dat$p[[1]], 27 | el = dat$el[[1]], 28 | coef.form = nwparam.m$coef.form, 29 | coef.diss = nwparam.m$coef.diss$coef.adj, 30 | save.changes = TRUE) 31 | 32 | plist1 <- update_plist(dat, at, ptype = 1) 33 | 34 | 35 | ## Casual network 36 | nwparam.p <- EpiModel::get_nwparam(dat, network = 2) 37 | 38 | dat$attr$deg.main <- get_degree(dat$el[[1]]) 39 | dat <- tergmLite::updateModelTermInputs(dat, network = 2) 40 | 41 | dat$el[[2]] <- tergmLite::simulate_network(p = dat$p[[2]], 42 | el = dat$el[[2]], 43 | coef.form = nwparam.p$coef.form, 44 | coef.diss = nwparam.p$coef.diss$coef.adj, 45 | save.changes = TRUE) 46 | 47 | plist2 <- update_plist(dat, at, ptype = 2) 48 | 49 | dat$temp$plist <- rbind(plist1, plist2) 50 | if (dat$control$truncate.plist == TRUE) { 51 | to.keep <- which(is.na(dat$temp$plist[, "stop"])) 52 | dat$temp$plist <- dat$temp$plist[to.keep, ] 53 | } 54 | 55 | ## One-off network 56 | nwparam.i <- EpiModel::get_nwparam(dat, network = 3) 57 | 58 | dat$attr$deg.tot <- pmin(dat$attr$deg.main + get_degree(dat$el[[2]]), 3) 59 | dat <- tergmLite::updateModelTermInputs(dat, network = 3) 60 | 61 | dat$el[[3]] <- tergmLite::simulate_ergm(p = dat$p[[3]], 62 | el = dat$el[[3]], 63 | coef = nwparam.i$coef.form) 64 | 65 | if (dat$control$save.nwstats == TRUE) { 66 | dat <- calc_nwstats(dat, at) 67 | } 68 | 69 | return(dat) 70 | } 71 | 72 | # updates the partnership list 73 | update_plist <- function(dat, at, ptype) { 74 | # pull existing partner type specific list 75 | plist1 <- dat$temp$plist[dat$temp$plist[, "ptype"] == ptype, ] 76 | 77 | # look up dissolutions, update stop time 78 | uid <- dat$attr$uid 79 | news <- attr(dat$el[[ptype]], "changes") 80 | news_uid <- cbind(matrix(uid[news[, 1:2]], ncol = 2), news[, 3]) 81 | news_uid_stop <- news_uid[news_uid[, 3] == 0, , drop = FALSE] 82 | pid_plist1 <- plist1[, 1]*1e7 + plist1[, 2] 83 | pid_stop <- news_uid_stop[, 1]*1e7 + news_uid_stop[, 2] 84 | matches_stop <- match(pid_stop, pid_plist1) 85 | plist1[matches_stop, "stop"] <- at 86 | 87 | # look up new formations, row bind them 88 | news_uid_start <- news_uid[news_uid[, 3] == 1, , drop = FALSE] 89 | plist1 <- rbind(plist1, cbind(news_uid_start[, 1:2, drop = FALSE], ptype, at, NA)) 90 | 91 | return(plist1) 92 | } 93 | 94 | 95 | calc_nwstats <- function(dat, at) { 96 | 97 | for (nw in 1:3) { 98 | n <- attr(dat$el[[nw]], "n") 99 | edges <- nrow(dat$el[[nw]]) 100 | meandeg <- round(edges * (2/n), 3) 101 | concurrent <- round(mean(get_degree(dat$el[[nw]]) > 1), 3) 102 | mat <- matrix(c(edges, meandeg, concurrent), ncol = 3, nrow = 1) 103 | if (at == 1) { 104 | dat$stats$nwstats[[nw]] <- mat 105 | colnames(dat$stats$nwstats[[nw]]) <- c("edges", "mdeg", "conc") 106 | } 107 | if (at > 1) { 108 | dat$stats$nwstats[[nw]] <- rbind(dat$stats$nwstats[[nw]], mat) 109 | } 110 | } 111 | 112 | return(dat) 113 | } 114 | 115 | 116 | 117 | #' @title Adjustment for the Edges Coefficient with Changing Network Size 118 | #' 119 | #' @description Adjusts the edges coefficients in a dynamic network model 120 | #' to preserve the mean degree. 121 | #' 122 | #' @inheritParams aging_msm 123 | #' 124 | #' @details 125 | #' In HIV/STI modeling, there is typically an assumption that changes in 126 | #' population size do not affect one's number of partners, specified as the 127 | #' mean degree for network models. A person would not have 10 times the number 128 | #' of partners should he move from a city 10 times as large. This module uses 129 | #' the adjustment of Krivitsky et al. to adjust the edges coefficients on the 130 | #' three network models to account for varying population size in order to 131 | #' preserve that mean degree. 132 | #' 133 | #' @return 134 | #' The network model parameters stored in \code{dat$nwparam} are updated for 135 | #' each of the three network models. 136 | #' 137 | #' @references 138 | #' Krivitsky PN, Handcock MS, and Morris M. "Adjusting for network size and 139 | #' composition effects in exponential-family random graph models." Statistical 140 | #' Methodology. 2011; 8.4: 319-339. 141 | #' 142 | #' @keywords module msm 143 | #' 144 | #' @export 145 | #' 146 | edges_correct_msm <- function(dat, at) { 147 | 148 | old.num <- dat$epi$num[at - 1] 149 | new.num <- sum(dat$attr$active == 1, na.rm = TRUE) 150 | adjust <- log(old.num) - log(new.num) 151 | 152 | coef.form.m <- get_nwparam(dat, network = 1)$coef.form 153 | coef.form.m[1] <- coef.form.m[1] + adjust 154 | dat$nwparam[[1]]$coef.form <- coef.form.m 155 | 156 | coef.form.p <- get_nwparam(dat, network = 2)$coef.form 157 | coef.form.p[1] <- coef.form.p[1] + adjust 158 | dat$nwparam[[2]]$coef.form <- coef.form.p 159 | 160 | coef.form.i <- get_nwparam(dat, network = 3)$coef.form 161 | coef.form.i[1] <- coef.form.i[1] + adjust 162 | dat$nwparam[[3]]$coef.form <- coef.form.i 163 | 164 | return(dat) 165 | } 166 | 167 | 168 | 169 | 170 | # HET ----------------------------------------------------------------- 171 | 172 | 173 | #' @export 174 | #' @rdname simnet_msm 175 | simnet_het <- function(dat, at) { 176 | 177 | # Update edges coefficients 178 | dat <- edges_correct_het(dat, at) 179 | 180 | # Update internal ergm data 181 | dat <- tergmLite::updateModelTermInputs(dat, network = 1) 182 | 183 | # Pull network parameters 184 | nwparam <- get_nwparam(dat, network = 1) 185 | 186 | # Simulate edgelist 187 | dat$el[[1]] <- tergmLite::simulate_network(p = dat$p[[1]], 188 | el = dat$el[[1]], 189 | coef.form = nwparam$coef.form, 190 | coef.diss = nwparam$coef.diss$coef.adj) 191 | 192 | return(dat) 193 | } 194 | 195 | 196 | #' @export 197 | #' @rdname edges_correct_msm 198 | edges_correct_het <- function(dat, at) { 199 | 200 | # Popsize 201 | old.num <- dat$epi$num[at - 1] 202 | new.num <- sum(dat$attr$active == 1, na.rm = TRUE) 203 | 204 | # New Coefs 205 | coef.form <- get_nwparam(dat)$coef.form 206 | coef.form[1] <- coef.form[1] + log(old.num) - log(new.num) 207 | dat$nwparam[[1]]$coef.form <- coef.form 208 | 209 | return(dat) 210 | } 211 | 212 | -------------------------------------------------------------------------------- /R/mod.stirecov.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title STI Recovery Module 3 | #' 4 | #' @description Stochastically simulates GC/CT recovery. 5 | #' 6 | #' @inheritParams aging_msm 7 | #' 8 | #' @keywords module msm 9 | #' 10 | #' @export 11 | #' 12 | stirecov_msm <- function(dat, at) { 13 | 14 | # Parameters ---------------------------------------------------------- 15 | 16 | rgc.ntx.int <- dat$param$rgc.ntx.int 17 | ugc.ntx.int <- dat$param$ugc.ntx.int 18 | gc.tx.int <- dat$param$gc.tx.int 19 | 20 | rct.ntx.int <- dat$param$rct.ntx.int 21 | uct.ntx.int <- dat$param$uct.ntx.int 22 | ct.tx.int <- dat$param$ct.tx.int 23 | 24 | # GC Recovery --------------------------------------------------------- 25 | 26 | # Untreated (asymptomatic and symptomatic) 27 | idsRGC_ntx <- which(dat$attr$rGC == 1 & 28 | dat$attr$rGC.infTime < at & 29 | (is.na(dat$attr$rGC.tx) | dat$attr$rGC.tx == 0) & 30 | (is.na(dat$attr$rGC.tx.prep) | dat$attr$rGC.tx.prep == 0)) 31 | idsUGC_ntx <- which(dat$attr$uGC == 1 & 32 | dat$attr$uGC.infTime < at & 33 | (is.na(dat$attr$uGC.tx) | dat$attr$uGC.tx == 0) & 34 | (is.na(dat$attr$uGC.tx.prep) | dat$attr$uGC.tx.prep == 0)) 35 | 36 | # recovRGC_ntx <- idsRGC_ntx[which(rbinom(length(idsRGC_ntx), 1, 37 | # 1/rgc.ntx.int) == 1)] 38 | # recovUGC_ntx <- idsUGC_ntx[which(rbinom(length(idsUGC_ntx), 1, 39 | # 1/ugc.ntx.int) == 1)] 40 | recovRGC_ntx <- idsRGC_ntx[at - dat$attr$rGC.infTime[idsRGC_ntx] >= rgc.ntx.int] 41 | recovUGC_ntx <- idsUGC_ntx[at - dat$attr$uGC.infTime[idsUGC_ntx] >= ugc.ntx.int] 42 | 43 | 44 | # Treated (asymptomatic and symptomatic) 45 | idsRGC_tx <- which(dat$attr$rGC == 1 & 46 | dat$attr$rGC.infTime < at & 47 | (dat$attr$rGC.tx == 1 | dat$attr$rGC.tx.prep == 1)) 48 | idsUGC_tx <- which(dat$attr$uGC == 1 & 49 | dat$attr$uGC.infTime < at & 50 | (dat$attr$uGC.tx == 1 | dat$attr$uGC.tx.prep == 1)) 51 | 52 | # recovRGC_tx <- idsRGC_tx[which(rbinom(length(idsRGC_tx), 1, 53 | # 1/gc.tx.int) == 1)] 54 | # recovUGC_tx <- idsUGC_tx[which(rbinom(length(idsUGC_tx), 1, 55 | # 1/gc.tx.int) == 1)] 56 | recovRGC_tx <- idsRGC_tx[at - dat$attr$rGC.infTime[idsRGC_tx] >= gc.tx.int] 57 | recovUGC_tx <- idsUGC_tx[at - dat$attr$uGC.infTime[idsUGC_tx] >= gc.tx.int] 58 | 59 | recovRGC <- c(recovRGC_ntx, recovRGC_tx) 60 | recovUGC <- c(recovUGC_ntx, recovUGC_tx) 61 | 62 | dat$attr$rGC[recovRGC] <- 0 63 | dat$attr$rGC.sympt[recovRGC] <- NA 64 | dat$attr$rGC.infTime[recovRGC] <- NA 65 | dat$attr$rGC.tx[recovRGC] <- NA 66 | dat$attr$rGC.tx.prep[recovRGC] <- NA 67 | 68 | dat$attr$uGC[recovUGC] <- 0 69 | dat$attr$uGC.sympt[recovUGC] <- NA 70 | dat$attr$uGC.infTime[recovUGC] <- NA 71 | dat$attr$uGC.tx[recovUGC] <- NA 72 | dat$attr$uGC.tx.prep[recovUGC] <- NA 73 | 74 | 75 | 76 | # CT Recovery --------------------------------------------------------- 77 | 78 | # Untreated (asymptomatic and symptomatic) 79 | idsRCT_ntx <- which(dat$attr$rCT == 1 & 80 | dat$attr$rCT.infTime < at & 81 | (is.na(dat$attr$rCT.tx) | dat$attr$rCT.tx == 0) & 82 | (is.na(dat$attr$rCT.tx.prep) | dat$attr$rCT.tx.prep == 0)) 83 | idsUCT_ntx <- which(dat$attr$uCT == 1 & 84 | dat$attr$uCT.infTime < at & 85 | (is.na(dat$attr$uCT.tx) | dat$attr$uCT.tx == 0) & 86 | (is.na(dat$attr$uCT.tx.prep) | dat$attr$uCT.tx.prep == 0)) 87 | 88 | # recovRCT_ntx <- idsRCT_ntx[which(rbinom(length(idsRCT_ntx), 89 | # 1, 1/rct.ntx.int) == 1)] 90 | # recovUCT_ntx <- idsUCT_ntx[which(rbinom(length(idsUCT_ntx), 91 | # 1, 1/uct.ntx.int) == 1)] 92 | recovRCT_ntx <- idsRCT_ntx[at - dat$attr$rCT.infTime[idsRCT_ntx] >= rct.ntx.int] 93 | recovUCT_ntx <- idsUCT_ntx[at - dat$attr$uCT.infTime[idsUCT_ntx] >= uct.ntx.int] 94 | 95 | # Treated (asymptomatic and symptomatic) 96 | idsRCT_tx <- which(dat$attr$rCT == 1 & 97 | dat$attr$rCT.infTime < at & 98 | (dat$attr$rCT.tx == 1 | dat$attr$rCT.tx.prep == 1)) 99 | idsUCT_tx <- which(dat$attr$uCT == 1 & 100 | dat$attr$uCT.infTime < at & 101 | (dat$attr$uCT.tx == 1 | dat$attr$uCT.tx.prep == 1)) 102 | 103 | # recovRCT_tx <- idsRCT_tx[which(rbinom(length(idsRCT_tx), 104 | # 1, 1/ct.tx.int) == 1)] 105 | # recovUCT_tx <- idsUCT_tx[which(rbinom(length(idsUCT_tx), 106 | # 1, 1/ct.tx.int) == 1)] 107 | recovRCT_tx <- idsRCT_tx[at - dat$attr$rCT.infTime[idsRCT_tx] >= ct.tx.int] 108 | recovUCT_tx <- idsUCT_tx[at - dat$attr$uCT.infTime[idsUCT_tx] >= ct.tx.int] 109 | 110 | recovRCT <- c(recovRCT_ntx, recovRCT_tx) 111 | recovUCT <- c(recovUCT_ntx, recovUCT_tx) 112 | 113 | 114 | # Output ------------------------------------------------------------------ 115 | 116 | dat$attr$rCT[recovRCT] <- 0 117 | dat$attr$rCT.sympt[recovRCT] <- NA 118 | dat$attr$rCT.infTime[recovRCT] <- NA 119 | dat$attr$rCT.tx[recovRCT] <- NA 120 | dat$attr$rCT.tx.prep[recovRCT] <- NA 121 | 122 | dat$attr$uCT[recovUCT] <- 0 123 | dat$attr$uCT.sympt[recovUCT] <- NA 124 | dat$attr$uCT.infTime[recovUCT] <- NA 125 | dat$attr$uCT.tx[recovUCT] <- NA 126 | dat$attr$uCT.tx.prep[recovUCT] <- NA 127 | 128 | # dat$epi$recov.rgc[at] <- length(recovRGC) 129 | # dat$epi$recov.ugc[at] <- length(recovUGC) 130 | # dat$epi$recov.rct[at] <- length(recovRCT) 131 | # dat$epi$recov.uct[at] <- length(recovUCT) 132 | 133 | return(dat) 134 | } 135 | -------------------------------------------------------------------------------- /R/mod.stitrans.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title STI Transmission Module 3 | #' 4 | #' @description Stochastically simulates GC/CT transmission given the current 5 | #' state of the edgelist. 6 | #' 7 | #' @inheritParams aging_msm 8 | #' 9 | #' @keywords module msm 10 | #' 11 | #' @export 12 | #' 13 | stitrans_msm <- function(dat, at) { 14 | 15 | # Parameters ---------------------------------------------------------- 16 | 17 | # Acquisition probabilities given contact with infected man 18 | rgc.tprob <- dat$param$rgc.tprob 19 | ugc.tprob <- dat$param$ugc.tprob 20 | rct.tprob <- dat$param$rct.tprob 21 | uct.tprob <- dat$param$uct.tprob 22 | 23 | # Probability of symptoms given infection 24 | rgc.sympt.prob <- dat$param$rgc.sympt.prob 25 | ugc.sympt.prob <- dat$param$ugc.sympt.prob 26 | rct.sympt.prob <- dat$param$rct.sympt.prob 27 | uct.sympt.prob <- dat$param$uct.sympt.prob 28 | 29 | # Relative risk of infection given condom use during act 30 | sti.cond.eff <- dat$param$sti.cond.eff 31 | sti.cond.fail <- dat$param$sti.cond.fail 32 | 33 | 34 | # Attributes ---------------------------------------------------------- 35 | 36 | race <- dat$attr$race 37 | 38 | # Current infection state 39 | rGC <- dat$attr$rGC 40 | uGC <- dat$attr$uGC 41 | rCT <- dat$attr$rCT 42 | uCT <- dat$attr$uCT 43 | 44 | # n Times infected 45 | rGC.timesInf <- dat$attr$rGC.timesInf 46 | uGC.timesInf <- dat$attr$uGC.timesInf 47 | rCT.timesInf <- dat$attr$rCT.timesInf 48 | uCT.timesInf <- dat$attr$uCT.timesInf 49 | 50 | # Infection time 51 | rGC.infTime <- dat$attr$rGC.infTime 52 | uGC.infTime <- dat$attr$uGC.infTime 53 | rCT.infTime <- dat$attr$rCT.infTime 54 | uCT.infTime <- dat$attr$uCT.infTime 55 | 56 | # Infection symptoms (non-varying) 57 | rGC.sympt <- dat$attr$rGC.sympt 58 | uGC.sympt <- dat$attr$uGC.sympt 59 | rCT.sympt <- dat$attr$rCT.sympt 60 | uCT.sympt <- dat$attr$uCT.sympt 61 | 62 | 63 | # Pull act list 64 | al <- dat$temp$al 65 | 66 | ## ins variable coding 67 | # ins = 0 : p2 is insertive 68 | # ins = 1 : p1 is insertive 69 | # ins = 2 : both p1 and p2 are insertive 70 | 71 | 72 | # Rectal GC ----------------------------------------------------------- 73 | 74 | # Requires: uGC in insertive man, and no rGC in receptive man 75 | p1Inf_rgc <- which(uGC[al[, "p1"]] == 1 & uGC.infTime[al[, "p1"]] < at & 76 | rGC[al[, "p2"]] == 0 & al[, "ins"] %in% c(1, 2)) 77 | p2Inf_rgc <- which(uGC[al[, "p2"]] == 1 & uGC.infTime[al[, "p2"]] < at & 78 | rGC[al[, "p1"]] == 0 & al[, "ins"] %in% c(0, 2)) 79 | allActs_rgc <- c(p1Inf_rgc, p2Inf_rgc) 80 | 81 | # UAI modifier 82 | uai_rgc <- al[allActs_rgc, "uai"] 83 | tprob_rgc <- rep(rgc.tprob, length(allActs_rgc)) 84 | 85 | # Transform to log odds 86 | tlo_rgc <- log(tprob_rgc/(1 - tprob_rgc)) 87 | 88 | # Modify log odds by race-specific condom effectiveness 89 | races <- c(race[al[p1Inf_rgc, "p1"]], race[al[p2Inf_rgc, "p2"]]) 90 | condom.rr <- rep(NA, length(races)) 91 | for (i in sort(unique(races))) { 92 | ids.race <- which(races == i) 93 | condom.rr[ids.race] <- 1 - (sti.cond.eff - sti.cond.fail[i]) 94 | } 95 | 96 | tlo_rgc[uai_rgc == 0] <- tlo_rgc[uai_rgc == 0] + log(condom.rr[uai_rgc == 0]) 97 | 98 | # Back-transform to probability 99 | tprob_rgc <- plogis(tlo_rgc) 100 | 101 | # Stochastic transmission 102 | trans_rgc <- rbinom(length(allActs_rgc), 1, tprob_rgc) 103 | 104 | # Determine the infected partner 105 | idsInf_rgc <- NULL 106 | if (sum(trans_rgc) > 0) { 107 | transAL_rgc <- al[allActs_rgc[trans_rgc == 1], , drop = FALSE] 108 | idsInf_rgc <- c(intersect(al[p1Inf_rgc, "p2"], transAL_rgc[, "p2"]), 109 | intersect(al[p2Inf_rgc, "p1"], transAL_rgc[, "p1"])) 110 | stopifnot(all(rGC[idsInf_rgc] == 0)) 111 | } 112 | 113 | # Update attributes 114 | rGC[idsInf_rgc] <- 1 115 | rGC.infTime[idsInf_rgc] <- at 116 | rGC.sympt[idsInf_rgc] <- rbinom(length(idsInf_rgc), 1, rgc.sympt.prob) 117 | rGC.timesInf[idsInf_rgc] <- rGC.timesInf[idsInf_rgc] + 1 118 | 119 | 120 | # Urethral GC --------------------------------------------------------- 121 | 122 | # Requires: rGC in receptive man, and no uGC in insertive man 123 | p1Inf_ugc <- which(rGC[al[, "p1"]] == 1 & rGC.infTime[al[, "p1"]] < at & 124 | uGC[al[, "p2"]] == 0 & al[, "ins"] %in% c(0, 2)) 125 | p2Inf_ugc <- which(rGC[al[, "p2"]] == 1 & rGC.infTime[al[, "p2"]] < at & 126 | uGC[al[, "p1"]] == 0 & al[, "ins"] %in% c(1, 2)) 127 | allActs_ugc <- c(p1Inf_ugc, p2Inf_ugc) 128 | 129 | # UAI modifier 130 | uai_ugc <- al[allActs_ugc, "uai"] 131 | tprob_ugc <- rep(ugc.tprob, length(allActs_ugc)) 132 | 133 | # Transform to log odds 134 | tlo_ugc <- log(tprob_ugc/(1 - tprob_ugc)) 135 | 136 | # Modify log odds by race-specific condom effectiveness 137 | races <- c(race[al[p1Inf_ugc, "p2"]], race[al[p2Inf_ugc, "p1"]]) 138 | condom.rr <- rep(NA, length(races)) 139 | for (i in sort(unique(races))) { 140 | ids.race <- which(races == i) 141 | condom.rr[ids.race] <- 1 - (sti.cond.eff - sti.cond.fail[i]) 142 | } 143 | 144 | tlo_ugc[uai_ugc == 0] <- tlo_ugc[uai_ugc == 0] + log(condom.rr[uai_ugc == 0]) 145 | 146 | # Back-transform to probability 147 | tprob_ugc <- plogis(tlo_ugc) 148 | 149 | # Stochastic transmission 150 | trans_ugc <- rbinom(length(allActs_ugc), 1, tprob_ugc) 151 | 152 | # Determine the newly infected partner 153 | idsInf_ugc <- NULL 154 | if (sum(trans_ugc) > 0) { 155 | transAL_ugc <- al[allActs_ugc[trans_ugc == 1], , drop = FALSE] 156 | idsInf_ugc <- c(intersect(al[p1Inf_ugc, "p2"], transAL_ugc[, "p2"]), 157 | intersect(al[p2Inf_ugc, "p1"], transAL_ugc[, "p1"])) 158 | stopifnot(all(uGC[idsInf_ugc] == 0)) 159 | } 160 | 161 | # Update attributes 162 | uGC[idsInf_ugc] <- 1 163 | uGC.infTime[idsInf_ugc] <- at 164 | uGC.sympt[idsInf_ugc] <- rbinom(length(idsInf_ugc), 1, ugc.sympt.prob) 165 | uGC.timesInf[idsInf_ugc] <- uGC.timesInf[idsInf_ugc] + 1 166 | 167 | 168 | # Rectal CT ----------------------------------------------------------- 169 | 170 | # Requires: uCT in insertive man, and no rCT in receptive man 171 | p1Inf_rct <- which(uCT[al[, "p1"]] == 1 & uCT.infTime[al[, "p1"]] < at & 172 | rCT[al[, "p2"]] == 0 & al[, "ins"] %in% c(1, 2)) 173 | p2Inf_rct <- which(uCT[al[, "p2"]] == 1 & uCT.infTime[al[, "p2"]] < at & 174 | rCT[al[, "p1"]] == 0 & al[, "ins"] %in% c(0, 2)) 175 | allActs_rct <- c(p1Inf_rct, p2Inf_rct) 176 | 177 | # UAI modifier 178 | uai_rct <- al[allActs_rct, "uai"] 179 | tprob_rct <- rep(rct.tprob, length(allActs_rct)) 180 | 181 | # Transform to log odds 182 | tlo_rct <- log(tprob_rct/(1 - tprob_rct)) 183 | 184 | # Modify log odds by race-specific condom effectiveness 185 | races <- c(race[al[p1Inf_rct, "p1"]], race[al[p2Inf_rct, "p2"]]) 186 | condom.rr <- rep(NA, length(races)) 187 | for (i in sort(unique(races))) { 188 | ids.race <- which(races == i) 189 | condom.rr[ids.race] <- 1 - (sti.cond.eff - sti.cond.fail[i]) 190 | } 191 | 192 | tlo_rct[uai_rct == 0] <- tlo_rct[uai_rct == 0] + log(condom.rr[uai_rct == 0]) 193 | 194 | # Back-transform to probability 195 | tprob_rct <- plogis(tlo_rct) 196 | 197 | # Stochastic transmission 198 | trans_rct <- rbinom(length(allActs_rct), 1, tprob_rct) 199 | 200 | # Determine the newly infected partner 201 | idsInf_rct <- NULL 202 | if (sum(trans_rct) > 0) { 203 | transAL_rct <- al[allActs_rct[trans_rct == 1], , drop = FALSE] 204 | idsInf_rct <- c(intersect(al[p1Inf_rct, "p2"], transAL_rct[, "p2"]), 205 | intersect(al[p2Inf_rct, "p1"], transAL_rct[, "p1"])) 206 | stopifnot(all(rCT[idsInf_rct] == 0)) 207 | } 208 | 209 | # Update attributes 210 | rCT[idsInf_rct] <- 1 211 | rCT.infTime[idsInf_rct] <- at 212 | rCT.sympt[idsInf_rct] <- rbinom(length(idsInf_rct), 1, rct.sympt.prob) 213 | rCT.timesInf[idsInf_rct] <- rCT.timesInf[idsInf_rct] + 1 214 | 215 | 216 | # Urethral CT --------------------------------------------------------- 217 | 218 | # Requires: rCT in receptive man, and no uCT in insertive man 219 | p1Inf_uct <- which(rCT[al[, "p1"]] == 1 & rCT.infTime[al[, "p1"]] < at & 220 | uCT[al[, "p2"]] == 0 & al[, "ins"] %in% c(0, 2)) 221 | p2Inf_uct <- which(rCT[al[, "p2"]] == 1 & rCT.infTime[al[, "p2"]] < at & 222 | uCT[al[, "p1"]] == 0 & al[, "ins"] %in% c(1, 2)) 223 | allActs_uct <- c(p1Inf_uct, p2Inf_uct) 224 | 225 | # UAI modifier 226 | uai_uct <- al[allActs_uct, "uai"] 227 | tprob_uct <- rep(uct.tprob, length(allActs_uct)) 228 | 229 | # Transform to log odds 230 | tlo_uct <- log(tprob_uct/(1 - tprob_uct)) 231 | 232 | # Modify log odds by race-specific condom effectiveness 233 | races <- c(race[al[p1Inf_uct, "p2"]], race[al[p2Inf_uct, "p1"]]) 234 | condom.rr <- rep(NA, length(races)) 235 | for (i in sort(unique(races))) { 236 | ids.race <- which(races == i) 237 | condom.rr[ids.race] <- 1 - (sti.cond.eff - sti.cond.fail[i]) 238 | } 239 | 240 | tlo_uct[uai_uct == 0] <- tlo_uct[uai_uct == 0] + log(condom.rr[uai_uct == 0]) 241 | 242 | # Back-transform to probability 243 | tprob_uct <- plogis(tlo_uct) 244 | 245 | # Stochastic transmission 246 | trans_uct <- rbinom(length(allActs_uct), 1, tprob_uct) 247 | 248 | # Determine the newly infected partner 249 | idsInf_uct <- NULL 250 | if (sum(trans_uct) > 0) { 251 | transAL_uct <- al[allActs_uct[trans_uct == 1], , drop = FALSE] 252 | idsInf_uct <- c(intersect(al[p1Inf_uct, "p2"], transAL_uct[, "p2"]), 253 | intersect(al[p2Inf_uct, "p1"], transAL_uct[, "p1"])) 254 | stopifnot(all(uCT[idsInf_uct] == 0)) 255 | } 256 | 257 | # Update attributes 258 | uCT[idsInf_uct] <- 1 259 | uCT.infTime[idsInf_uct] <- at 260 | uCT.sympt[idsInf_uct] <- rbinom(length(idsInf_uct), 1, uct.sympt.prob) 261 | uCT.timesInf[idsInf_uct] <- uCT.timesInf[idsInf_uct] + 1 262 | 263 | 264 | # Output -------------------------------------------------------------- 265 | 266 | # attributes 267 | dat$attr$rGC <- rGC 268 | dat$attr$uGC <- uGC 269 | dat$attr$rCT <- rCT 270 | dat$attr$uCT <- uCT 271 | 272 | dat$attr$rGC.infTime <- rGC.infTime 273 | dat$attr$uGC.infTime <- uGC.infTime 274 | dat$attr$rCT.infTime <- rCT.infTime 275 | dat$attr$uCT.infTime <- uCT.infTime 276 | 277 | dat$attr$rGC.timesInf <- rGC.timesInf 278 | dat$attr$uGC.timesInf <- uGC.timesInf 279 | dat$attr$rCT.timesInf <- rCT.timesInf 280 | dat$attr$uCT.timesInf <- uCT.timesInf 281 | 282 | dat$attr$rGC.sympt <- rGC.sympt 283 | dat$attr$uGC.sympt <- uGC.sympt 284 | dat$attr$rCT.sympt <- rCT.sympt 285 | dat$attr$uCT.sympt <- uCT.sympt 286 | 287 | 288 | # Summary stats 289 | dat$epi$incid.gc[at] <- length(idsInf_rgc) + length(idsInf_ugc) 290 | dat$epi$incid.rgc[at] <- length(idsInf_rgc) 291 | dat$epi$incid.ugc[at] <- length(idsInf_ugc) 292 | dat$epi$incid.gc.B[at] <- length(intersect(union(idsInf_rgc, idsInf_ugc), which(race == 1))) 293 | dat$epi$incid.gc.H[at] <- length(intersect(union(idsInf_rgc, idsInf_ugc), which(race == 2))) 294 | dat$epi$incid.gc.W[at] <- length(intersect(union(idsInf_rgc, idsInf_ugc), which(race == 3))) 295 | 296 | dat$epi$incid.ct[at] <- length(idsInf_rct) + length(idsInf_uct) 297 | dat$epi$incid.rct[at] <- length(idsInf_rct) 298 | dat$epi$incid.uct[at] <- length(idsInf_uct) 299 | dat$epi$incid.ct.B[at] <- length(intersect(union(idsInf_rct, idsInf_uct), which(race == 1))) 300 | dat$epi$incid.ct.B[at] <- length(intersect(union(idsInf_rct, idsInf_uct), which(race == 2))) 301 | dat$epi$incid.ct.W[at] <- length(intersect(union(idsInf_rct, idsInf_uct), which(race == 3))) 302 | 303 | # Check all infected have all STI attributes 304 | stopifnot(all(!is.na(rGC.infTime[rGC == 1])), 305 | all(!is.na(rGC.sympt[rGC == 1])), 306 | all(!is.na(uGC.infTime[uGC == 1])), 307 | all(!is.na(uGC.sympt[uGC == 1])), 308 | all(!is.na(rCT.infTime[rCT == 1])), 309 | all(!is.na(rCT.sympt[rCT == 1])), 310 | all(!is.na(uCT.infTime[uCT == 1])), 311 | all(!is.na(uCT.sympt[uCT == 1]))) 312 | 313 | return(dat) 314 | } 315 | -------------------------------------------------------------------------------- /R/mod.stitx.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title STI Treatment Module 3 | #' 4 | #' @description Stochastically simulates GC/CT diagnosis and treatment. 5 | #' 6 | #' @inheritParams aging_msm 7 | #' 8 | #' @keywords module msm 9 | #' 10 | #' @export 11 | #' 12 | stitx_msm <- function(dat, at) { 13 | 14 | # Parameters 15 | gc.sympt.prob.tx <- dat$param$gc.sympt.prob.tx 16 | ct.sympt.prob.tx <- dat$param$ct.sympt.prob.tx 17 | gc.asympt.prob.tx <- dat$param$gc.asympt.prob.tx 18 | ct.asympt.prob.tx <- dat$param$ct.asympt.prob.tx 19 | 20 | prep.sti.screen.int <- dat$param$prep.sti.screen.int 21 | prep.sti.prob.tx <- dat$param$prep.sti.prob.tx 22 | 23 | # Attributes 24 | race <- dat$attr$race 25 | 26 | ## Symptomatic GC Treatment ## 27 | idsRGC_tx_sympt <- which(dat$attr$rGC == 1 & 28 | dat$attr$rGC.infTime < at & 29 | dat$attr$rGC.sympt == 1 & 30 | is.na(dat$attr$rGC.tx)) 31 | idsUGC_tx_sympt <- which(dat$attr$uGC == 1 & 32 | dat$attr$uGC.infTime < at & 33 | dat$attr$uGC.sympt == 1 & 34 | is.na(dat$attr$uGC.tx)) 35 | 36 | # Subset by race 37 | idsGC_tx_sympt <- union(idsRGC_tx_sympt, idsUGC_tx_sympt) 38 | races <- sort(unique(race[idsGC_tx_sympt])) 39 | txGC_sympt <- rep(NA, length(idsGC_tx_sympt)) 40 | for (i in races) { 41 | ids.race <- which(race[idsGC_tx_sympt] == i) 42 | txGC_sympt[ids.race] <- rbinom(length(ids.race), 1, gc.sympt.prob.tx[i]) 43 | } 44 | ids_txGC_sympt <- idsGC_tx_sympt[which(txGC_sympt == 1)] 45 | 46 | # Subset by site 47 | txRGC_sympt <- intersect(idsRGC_tx_sympt, ids_txGC_sympt) 48 | txUGC_sympt <- intersect(idsUGC_tx_sympt, ids_txGC_sympt) 49 | 50 | ## Asymptomatic GC Treatment ## 51 | idsRGC_tx_asympt <- which(dat$attr$rGC == 1 & 52 | dat$attr$rGC.infTime < at & 53 | dat$attr$rGC.sympt == 0 & 54 | is.na(dat$attr$rGC.tx) & 55 | dat$attr$prepStat == 0) 56 | idsUGC_tx_asympt <- which(dat$attr$uGC == 1 & 57 | dat$attr$uGC.infTime < at & 58 | dat$attr$uGC.sympt == 0 & 59 | is.na(dat$attr$uGC.tx) & 60 | dat$attr$prepStat == 0) 61 | 62 | # Subset by race 63 | idsGC_tx_asympt <- union(idsRGC_tx_asympt, idsUGC_tx_asympt) 64 | races <- sort(unique(race[idsGC_tx_asympt])) 65 | txGC_asympt <- rep(NA, length(idsGC_tx_asympt)) 66 | for (i in races) { 67 | ids.race <- which(race[idsGC_tx_asympt] == i) 68 | txGC_asympt[ids.race] <- rbinom(length(ids.race), 1, gc.asympt.prob.tx[i]) 69 | } 70 | ids_txGC_asympt <- idsGC_tx_asympt[which(txGC_asympt == 1)] 71 | 72 | # Subset by site 73 | txRGC_asympt <- intersect(idsRGC_tx_asympt, ids_txGC_asympt) 74 | txUGC_asympt <- intersect(idsUGC_tx_asympt, ids_txGC_asympt) 75 | 76 | ## All Treated GC ## 77 | 78 | # IDs of men sucessfully treated 79 | txRGC <- union(txRGC_sympt, txRGC_asympt) 80 | txUGC <- union(txUGC_sympt, txUGC_asympt) 81 | 82 | # IDs of men eligible for treatment 83 | idsRGC_tx <- union(idsRGC_tx_sympt, idsRGC_tx_asympt) 84 | idsUGC_tx <- union(idsUGC_tx_sympt, idsUGC_tx_asympt) 85 | 86 | 87 | ## Symptomatic CT Treatment ## 88 | idsRCT_tx_sympt <- which(dat$attr$rCT == 1 & 89 | dat$attr$rCT.infTime < at & 90 | dat$attr$rCT.sympt == 1 & 91 | is.na(dat$attr$rCT.tx)) 92 | idsUCT_tx_sympt <- which(dat$attr$uCT == 1 & 93 | dat$attr$uCT.infTime < at & 94 | dat$attr$uCT.sympt == 1 & 95 | is.na(dat$attr$uCT.tx)) 96 | 97 | # Subset by race 98 | idsCT_tx_sympt <- union(idsRCT_tx_sympt, idsUCT_tx_sympt) 99 | races <- sort(unique(race[idsCT_tx_sympt])) 100 | txCT_sympt <- rep(NA, length(idsCT_tx_sympt)) 101 | for (i in races) { 102 | ids.race <- which(race[idsCT_tx_sympt] == i) 103 | txCT_sympt[ids.race] <- rbinom(length(ids.race), 1, ct.sympt.prob.tx[i]) 104 | } 105 | ids_txCT_sympt <- idsCT_tx_sympt[which(txCT_sympt == 1)] 106 | 107 | # Subset by site 108 | txRCT_sympt <- intersect(idsRCT_tx_sympt, ids_txCT_sympt) 109 | txUCT_sympt <- intersect(idsUCT_tx_sympt, ids_txCT_sympt) 110 | 111 | 112 | ## Asymptomatic CT Treatment ## 113 | idsRCT_tx_asympt <- which(dat$attr$rCT == 1 & 114 | dat$attr$rCT.infTime < at & 115 | dat$attr$rCT.sympt == 0 & 116 | is.na(dat$attr$rCT.tx) & 117 | dat$attr$prepStat == 0) 118 | idsUCT_tx_asympt <- which(dat$attr$uCT == 1 & 119 | dat$attr$uCT.infTime < at & 120 | dat$attr$uCT.sympt == 0 & 121 | is.na(dat$attr$uCT.tx) & 122 | dat$attr$prepStat == 0) 123 | 124 | # Subset by race 125 | idsCT_tx_asympt <- union(idsRCT_tx_asympt, idsUCT_tx_asympt) 126 | races <- sort(unique(race[idsCT_tx_asympt])) 127 | txCT_asympt <- rep(NA, length(idsCT_tx_asympt)) 128 | for (i in races) { 129 | ids.race <- which(race[idsCT_tx_asympt] == i) 130 | txCT_asympt[ids.race] <- rbinom(length(ids.race), 1, ct.asympt.prob.tx[i]) 131 | } 132 | ids_txCT_asympt <- idsCT_tx_asympt[which(txCT_asympt == 1)] 133 | 134 | # Subset by site 135 | txRCT_asympt <- intersect(idsRCT_tx_asympt, ids_txCT_asympt) 136 | txUCT_asympt <- intersect(idsUCT_tx_asympt, ids_txCT_asympt) 137 | 138 | ## All Treated CT ## 139 | txRCT <- union(txRCT_sympt, txRCT_asympt) 140 | txUCT <- union(txUCT_sympt, txUCT_asympt) 141 | 142 | idsRCT_tx <- union(idsRCT_tx_sympt, idsRCT_tx_asympt) 143 | idsUCT_tx <- union(idsUCT_tx_sympt, idsUCT_tx_asympt) 144 | 145 | 146 | ## Interval-based treatment for MSM on PrEP ## 147 | idsSTI_screen <- which(dat$attr$prepStartTime == at | 148 | (at - dat$attr$prepLastStiScreen >= prep.sti.screen.int)) 149 | 150 | dat$attr$prepLastStiScreen[idsSTI_screen] <- at 151 | 152 | 153 | idsRGC_prep_tx <- intersect(idsSTI_screen, 154 | which(dat$attr$rGC == 1 & 155 | dat$attr$rGC.infTime < at & 156 | is.na(dat$attr$rGC.tx.prep))) 157 | idsUGC_prep_tx <- intersect(idsSTI_screen, 158 | which(dat$attr$uGC == 1 & 159 | dat$attr$uGC.infTime < at & 160 | is.na(dat$attr$uGC.tx.prep))) 161 | idsRCT_prep_tx <- intersect(idsSTI_screen, 162 | which(dat$attr$rCT == 1 & 163 | dat$attr$rCT.infTime < at & 164 | is.na(dat$attr$rCT.tx.prep))) 165 | idsUCT_prep_tx <- intersect(idsSTI_screen, 166 | which(dat$attr$uCT == 1 & 167 | dat$attr$uCT.infTime < at & 168 | is.na(dat$attr$uCT.tx.prep))) 169 | 170 | txRGC_prep <- idsRGC_prep_tx[which(rbinom(length(idsRGC_prep_tx), 1, 171 | prep.sti.prob.tx) == 1)] 172 | txUGC_prep <- idsUGC_prep_tx[which(rbinom(length(idsUGC_prep_tx), 1, 173 | prep.sti.prob.tx) == 1)] 174 | txRCT_prep <- idsRCT_prep_tx[which(rbinom(length(idsRCT_prep_tx), 1, 175 | prep.sti.prob.tx) == 1)] 176 | txUCT_prep <- idsUCT_prep_tx[which(rbinom(length(idsUCT_prep_tx), 1, 177 | prep.sti.prob.tx) == 1)] 178 | 179 | 180 | ## Update Attributes ## 181 | dat$attr$rGC.tx[idsRGC_tx] <- 0 182 | dat$attr$rGC.tx[txRGC] <- 1 183 | 184 | dat$attr$uGC.tx[idsUGC_tx] <- 0 185 | dat$attr$uGC.tx[txUGC] <- 1 186 | 187 | dat$attr$rCT.tx[idsRCT_tx] <- 0 188 | dat$attr$rCT.tx[txRCT] <- 1 189 | 190 | dat$attr$uCT.tx[idsUCT_tx] <- 0 191 | dat$attr$uCT.tx[txUCT] <- 1 192 | 193 | dat$attr$rGC.tx.prep[idsRGC_prep_tx] <- 0 194 | dat$attr$rGC.tx.prep[txRGC_prep] <- 1 195 | 196 | dat$attr$uGC.tx.prep[idsUGC_prep_tx] <- 0 197 | dat$attr$uGC.tx.prep[txUGC_prep] <- 1 198 | 199 | dat$attr$rCT.tx.prep[idsRCT_prep_tx] <- 0 200 | dat$attr$rCT.tx.prep[txRCT_prep] <- 1 201 | 202 | dat$attr$uCT.tx.prep[idsUCT_prep_tx] <- 0 203 | dat$attr$uCT.tx.prep[txUCT_prep] <- 1 204 | 205 | 206 | ## Add tx at other anatomical site ## 207 | dat$attr$rGC.tx[which((dat$attr$uGC.tx == 1 | dat$attr$uGC.tx.prep == 1) & 208 | dat$attr$rGC == 1)] <- 1 209 | dat$attr$uGC.tx[which((dat$attr$rGC.tx == 1 | dat$attr$rGC.tx.prep == 1) & 210 | dat$attr$uGC == 1)] <- 1 211 | 212 | dat$attr$rCT.tx[which((dat$attr$uCT.tx == 1 | dat$attr$uCT.tx.prep == 1) & 213 | dat$attr$rCT == 1)] <- 1 214 | dat$attr$uCT.tx[which((dat$attr$rCT.tx == 1 | dat$attr$rCT.tx.prep == 1) & 215 | dat$attr$uCT == 1)] <- 1 216 | 217 | return(dat) 218 | } 219 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | EpiModelHIV 2 | =============== 3 | 4 | [![Build Status](https://travis-ci.org/statnet/EpiModelHIV.svg?branch=master)](https://travis-ci.org/statnet/EpiModelHIV) 5 | 6 | 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). 7 | 8 | `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. 9 | 10 | 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 methods paper [Vignette](http://doi.org/10.18637/jss.v084.i08) describing the theory and implementation. 11 | 12 | ## Installation 13 | 14 | You can install `EpiModelHIV` in R using `remotes`: 15 | ``` 16 | install.packages("EpiModel", dependencies = TRUE) 17 | remotes::install_github("statnet/tergmLite") 18 | remotes::install_github("statnet/EpiModelHPC") 19 | remotes::install_github("statnet/EpiModelHIV") 20 | ``` 21 | 22 | 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. 23 | -------------------------------------------------------------------------------- /inst/het-test-script.R: -------------------------------------------------------------------------------- 1 | 2 | ## Heterosexual model test script 3 | 4 | library(EpiModelHIV) 5 | 6 | st <- make_nw_het(part.dur = 2013) 7 | est <- netest(st$nw, 8 | formation = st$formation, 9 | target.stats = st$stats, 10 | coef.form = -Inf, 11 | coef.diss = st$coef.diss, 12 | constraints = ~bd(maxout = 3), 13 | set.control.ergm = control.ergm(MCMLE.maxit = 500, MPLE.type = "penalized")) 14 | 15 | dx <- netdx(est, nsims = 5, nsteps = 250, 16 | set.control.ergm = control.simulate.ergm(MCMC.burnin = 1e6)) 17 | print(dx) 18 | plot(dx) 19 | 20 | param <- param_het() 21 | init <- init_het(i.prev.male = 0.25, i.prev.feml = 0.25) 22 | control <- control_het(nsteps = 2600) 23 | 24 | sim <- netsim(est, param, init, control) 25 | -------------------------------------------------------------------------------- /inst/msm-test-script.R: -------------------------------------------------------------------------------- 1 | 2 | rm(list = ls()) 3 | suppressMessages(library("EpiModelHIV")) 4 | devtools::load_all("~/Dropbox/Dev/EpiModelHIV/EpiModelHIV-p") 5 | 6 | scr.dir <- "~/Dropbox/Dev/ARTnet/" 7 | netstats <- readRDS(file.path(scr.dir, "data/artnet.NetStats.Atlanta.rda")) 8 | epistats <- readRDS(file.path(scr.dir, "data/artnet.EpiStats.Atlanta.rda")) 9 | est <- readRDS(file.path(scr.dir, "data/artnet.NetEst.Atlanta.rda")) 10 | 11 | param <- param_msm(netstats = netstats, 12 | epistats = epistats, 13 | hiv.test.int = c(43, 43, 45), 14 | a.rate = 0.00055, 15 | riskh.start = 2, 16 | prep.start = 30, 17 | prep.start.prob = 0.10, 18 | tt.part.supp = c(0.20, 0.20, 0.20), 19 | tt.full.supp = c(0.40, 0.40, 0.40), 20 | tt.dur.supp = c(0.40, 0.40, 0.40), 21 | tx.halt.full.rr = 0.8, 22 | tx.halt.dur.rr = 0.1, 23 | tx.reinit.full.rr = 2.0, 24 | tx.reinit.dur.rr = 5.0, 25 | hiv.rgc.rr = 2.5, 26 | hiv.ugc.rr = 1.5, 27 | hiv.rct.rr = 2.5, 28 | hiv.uct.rr = 1.5, 29 | hiv.dual.rr = 0.0, 30 | rgc.tprob = 0.35, 31 | ugc.tprob = 0.25, 32 | rct.tprob = 0.20, 33 | uct.tprob = 0.16, 34 | rgc.ntx.int = 16.8, 35 | ugc.ntx.int = 16.8, 36 | rct.ntx.int = 32, 37 | uct.ntx.int = 32, 38 | acts.aids.vl = 5.75) 39 | init <- init_msm() 40 | control <- control_msm(simno = 1, 41 | nsteps = 52 * 2, 42 | nsims = 1, 43 | ncores = 1, 44 | save.nwstats = FALSE, 45 | save.clin.hist = FALSE) 46 | 47 | sim <- netsim(est, param, init, control) 48 | 49 | # Explore clinical history 50 | par(mar = c(3,3,1,1), mgp = c(2,1,0)) 51 | m1 <- sim$temp[[1]]$clin.hist[[1]] 52 | m2 <- sim$temp[[1]]$clin.hist[[2]] 53 | m3 <- sim$temp[[1]]$clin.hist[[3]] 54 | a <- sim$attr[[1]] 55 | h <- which(a$status == 1) 56 | 57 | m1[h[1:10], 95:104] 58 | aids <- which(a$stage == 4) 59 | id <- h[58] 60 | plot(m1[id, ], type = "o", ylim = c(1, 7)) 61 | data.frame(vl = m1[id, ], stage = m2[id, ], tx = m3[id, ]) 62 | a$tt.traj[id] 63 | matplot(t(m1[h[1:500], ]), type = "l", lty = 1, ylim = c(1, 7)) 64 | 65 | 66 | df <- as.data.frame(sim) 67 | names(df) 68 | 69 | par(mar = c(3,3,1,1), mgp = c(2,1,0)) 70 | plot(sim, y = "i.prev", mean.smooth = FALSE, ylim = c(0, 1)) 71 | plot(sim, y = "num") 72 | plot(sim, y = "dep.gen", mean.smooth = TRUE) 73 | plot(sim, y = "dep.AIDS", mean.smooth = FALSE) 74 | plot(sim, y = "prepCurr") 75 | plot(sim, y = "cc.dx", mean.smooth = FALSE) 76 | plot(sim, y = "cc.linked", mean.smooth = FALSE, ylim = c(0.8, 1)) 77 | plot(sim, y = "cc.linked1m", mean.smooth = FALSE) 78 | plot(sim, y = "cc.tx", mean.smooth = FALSE) 79 | plot(sim, y = "cc.tx.any1y", mean.smooth = FALSE) 80 | plot(sim, y = "cc.vsupp", mean.smooth = FALSE) 81 | plot(sim, y = "cc.vsupp.tt1", mean.smooth = FALSE) 82 | plot(sim, y = "cc.vsupp.tt2", mean.smooth = FALSE) 83 | plot(sim, y = "cc.vsupp.tt3", mean.smooth = FALSE) 84 | plot(sim, y = "cc.vsupp.dur1y", mean.smooth = FALSE) 85 | 86 | plot(sim, y = "hstage.acute", mean.smooth = TRUE) 87 | plot(sim, y = "hstage.chronic", mean.smooth = FALSE) 88 | plot(sim, y = "hstage.aids", mean.smooth = FALSE) 89 | 90 | plot(sim, y = "ir100.gc", mean.smooth = FALSE) 91 | plot(sim, y = "ir100.ct", mean.smooth = FALSE) 92 | plot(sim, y = "ir100.sti", mean.smooth = FALSE) 93 | plot(sim, y = "prev.gc", mean.smooth = FALSE) 94 | plot(sim, y = "prev.ct", mean.smooth = FALSE) 95 | 96 | plot(sim, type = "formation", network = 1, plots.joined = FALSE) 97 | plot(sim, type = "formation", network = 2, plots.joined = FALSE) 98 | plot(sim, type = "formation", network = 3, plots.joined = FALSE) 99 | 100 | 101 | # Testing/Timing ------------------------------------------------------ 102 | 103 | m <- microbenchmark::microbenchmark(hivvl_msm(dat, at)) 104 | print(m, unit = "ms") 105 | 106 | dat <- initialize_msm(est, param, init, control, s = 1) 107 | 108 | for (at in 2:200) { 109 | dat <- aging_msm(dat, at) 110 | dat <- departure_msm(dat, at) 111 | dat <- arrival_msm(dat, at) 112 | dat <- hivtest_msm(dat, at) 113 | dat <- hivtx_msm(dat, at) 114 | dat <- hivprogress_msm(dat, at) 115 | dat <- hivvl_msm(dat, at) 116 | dat <- simnet_msm(dat, at) 117 | dat <- acts_msm(dat, at) 118 | dat <- condoms_msm(dat, at) 119 | dat <- position_msm(dat, at) 120 | dat <- prep_msm(dat, at) 121 | dat <- hivtrans_msm(dat, at) 122 | dat <- stitrans_msm(dat, at) 123 | dat <- stirecov_msm(dat, at) 124 | dat <- stitx_msm(dat, at) 125 | dat <- prevalence_msm(dat, at) 126 | verbose.net(dat, "progress", at = at) 127 | } 128 | 129 | nrow(dat$temp$plist) 130 | table(dat$temp$plist[, "start"]) 131 | table(dat$temp$plist[, "stop"]) 132 | head(dat$temp$plist) 133 | 134 | plist <- as.data.frame(dat$temp$plist) 135 | pmain <- filter(plist, ptype == 2) 136 | table(pmain$start) 137 | hist(pmain$start) 138 | -------------------------------------------------------------------------------- /man/EpiModelHIV-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/EpiModelHIV-package.R 3 | \docType{package} 4 | \name{EpiModelHIV-package} 5 | \alias{EpiModelHIV-package} 6 | \alias{EpiModelHIV} 7 | \title{Network-Based Epidemic Modeling of HIV Transmission among MSM and Heterosexual Populations} 8 | \description{ 9 | \tabular{ll}{ 10 | Package: \tab EpiModelHIV\cr 11 | Type: \tab Package\cr 12 | Version: \tab 1.5.0\cr 13 | Date: \tab 2017-05-04\cr 14 | License: \tab GPL-3\cr 15 | LazyLoad: \tab yes\cr 16 | } 17 | } 18 | \details{ 19 | EpiModelHIV provides extensions to our general EpiModel package to allow 20 | for simulating HIV transmission dynamics among two populations: men who 21 | have sex with men (MSM) in the United States and heterosexual adults in 22 | sub-Saharan Africa. 23 | } 24 | \keyword{het} 25 | \keyword{msm} 26 | \keyword{package} 27 | -------------------------------------------------------------------------------- /man/acts_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.acts.R 3 | \name{acts_msm} 4 | \alias{acts_msm} 5 | \title{Sexual Acts Module} 6 | \usage{ 7 | acts_msm(dat, at) 8 | } 9 | \arguments{ 10 | \item{dat}{Master data list object of class \code{dat} containing networks, 11 | individual-level attributes, and summary statistics.} 12 | 13 | \item{at}{Current time step.} 14 | } 15 | \description{ 16 | Module function for setting the number of sexual acts on the 17 | discordant edgelist. 18 | } 19 | \details{ 20 | The number of acts at each time step is specified as a function of the race of 21 | both members in a pair and the expected values within black-black, black-white, 22 | and white-white combinations. For one-off partnerships, this is deterministically 23 | set at 1, whereas for main and causal partnerships it is a stochastic draw 24 | from a Poisson distribution. The number of total acts may further be modified 25 | by the level of HIV viral suppression in an infected person. 26 | } 27 | \keyword{module} 28 | \keyword{msm} 29 | -------------------------------------------------------------------------------- /man/aging_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.aging.R 3 | \name{aging_msm} 4 | \alias{aging_msm} 5 | \alias{aging_het} 6 | \title{Aging Module} 7 | \usage{ 8 | aging_msm(dat, at) 9 | 10 | aging_het(dat, at) 11 | } 12 | \arguments{ 13 | \item{dat}{Master data list object of class \code{dat} containing networks, 14 | individual-level attributes, and summary statistics.} 15 | 16 | \item{at}{Current time step.} 17 | } 18 | \value{ 19 | This function returns \code{dat} after updating the nodal attribute 20 | \code{age} and \code{sqrt.age}. The \code{sqrt.age} vertex attribute is also 21 | updated on the three networks. 22 | } 23 | \description{ 24 | Module for aging over time for active nodes in the population. 25 | } 26 | \keyword{module} 27 | \keyword{msm} 28 | -------------------------------------------------------------------------------- /man/arrival_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.arrival.R 3 | \name{arrival_msm} 4 | \alias{arrival_msm} 5 | \alias{births_het} 6 | \title{Arrivals Module} 7 | \usage{ 8 | arrival_msm(dat, at) 9 | 10 | births_het(dat, at) 11 | } 12 | \arguments{ 13 | \item{dat}{Master data list object of class \code{dat} containing networks, 14 | individual-level attributes, and summary statistics.} 15 | 16 | \item{at}{Current time step.} 17 | } 18 | \value{ 19 | This function updates the \code{attr} list with new attributes for each new 20 | population member, and the \code{nw} objects with new vertices. 21 | } 22 | \description{ 23 | Module function for arrivals into the sexually active 24 | population. 25 | } 26 | \details{ 27 | New population members are added based on expected numbers of entries, 28 | stochastically determined with draws from Poisson distributions. For each new 29 | entry, a set of attributes is added for that node, and the nodes are added onto 30 | the network objects. Only attributes that are a part of the network model 31 | formulae are updated as vertex attributes on the network objects. 32 | } 33 | \keyword{module} 34 | \keyword{msm} 35 | -------------------------------------------------------------------------------- /man/cd4_het.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.hivcd4.R 3 | \name{cd4_het} 4 | \alias{cd4_het} 5 | \title{CD4 Progression Module} 6 | \usage{ 7 | cd4_het(dat, at) 8 | } 9 | \arguments{ 10 | \item{dat}{Master data list object of class \code{dat} containing networks, 11 | individual-level attributes, and summary statistics.} 12 | 13 | \item{at}{Current time step.} 14 | } 15 | \description{ 16 | Module function for simulating progression of CD4 in natural 17 | disease dynamics and in the presence of ART. 18 | } 19 | \keyword{het} 20 | \keyword{module} 21 | -------------------------------------------------------------------------------- /man/condoms_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.condoms.R 3 | \name{condoms_msm} 4 | \alias{condoms_msm} 5 | \title{Condom Use Module} 6 | \usage{ 7 | condoms_msm(dat, at) 8 | } 9 | \arguments{ 10 | \item{dat}{Master data list object of class \code{dat} containing networks, 11 | individual-level attributes, and summary statistics.} 12 | 13 | \item{at}{Current time step.} 14 | } 15 | \value{ 16 | Updates the discordant edgelist with a \code{uai} variable indicating whether 17 | condoms were used in that act. 18 | } 19 | \description{ 20 | Module function stochastically simulates potential condom use 21 | for each act on the discordant edgelist. 22 | } 23 | \details{ 24 | For each act on the discordant edgelist, condom use is stochastically simulated 25 | based on the partnership type and racial combination of the dyad. Other 26 | modifiers for the probability of condom use in that pair are diagnosis of 27 | disease, and full or partial HIV viral suppression 28 | given HIV anti-retroviral therapy. 29 | } 30 | \keyword{module} 31 | \keyword{msm} 32 | -------------------------------------------------------------------------------- /man/control_het.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/params.R 3 | \name{control_het} 4 | \alias{control_het} 5 | \title{Control Settings for Stochastic Network Model of HIV-1 Infection in 6 | Sub-Saharan Africa} 7 | \usage{ 8 | control_het(simno = 1, nsteps = 100, start = 1, nsims = 1, 9 | ncores = 1, par.type = "single", initialize.FUN = initialize_het, 10 | aging.FUN = aging_het, cd4.FUN = cd4_het, vl.FUN = vl_het, 11 | dx.FUN = dx_het, tx.FUN = tx_het, deaths.FUN = deaths_het, 12 | births.FUN = births_het, resim_nets.FUN = simnet_het, 13 | trans.FUN = trans_het, prev.FUN = prevalence_het, 14 | verbose.FUN = verbose.net, module.order = NULL, 15 | save.nwstats = FALSE, save.other = c("el", "attr"), verbose = TRUE, 16 | skip.check = TRUE, ...) 17 | } 18 | \arguments{ 19 | \item{simno}{Simulation ID number.} 20 | 21 | \item{nsteps}{Number of time steps to simulate the model over in whatever unit 22 | implied by \code{time.unit}.} 23 | 24 | \item{start}{Starting time step for simulation} 25 | 26 | \item{nsims}{Number of simulations.} 27 | 28 | \item{ncores}{Number of parallel cores to use for simulation jobs, if using 29 | the \code{EpiModel.hpc} package.} 30 | 31 | \item{par.type}{Parallelization type, either of \code{"single"} for multi-core 32 | or \code{"mpi"} for multi-node MPI threads.} 33 | 34 | \item{initialize.FUN}{Module to initialize the model at time 1.} 35 | 36 | \item{aging.FUN}{Module to age active nodes.} 37 | 38 | \item{cd4.FUN}{CD4 progression module.} 39 | 40 | \item{vl.FUN}{HIV viral load progression module.} 41 | 42 | \item{dx.FUN}{HIV diagnosis module.} 43 | 44 | \item{tx.FUN}{HIV treatment module.} 45 | 46 | \item{deaths.FUN}{Module to simulate death or exit.} 47 | 48 | \item{births.FUN}{Module to simulate births or entries.} 49 | 50 | \item{resim_nets.FUN}{Module to resimulate the network at each time step.} 51 | 52 | \item{trans.FUN}{Module to simulate disease infection.} 53 | 54 | \item{prev.FUN}{Module to calculate disease prevalence at each time step, 55 | with the default function of \code{\link{prevalence_het}}.} 56 | 57 | \item{verbose.FUN}{Module to print simulation progress to screen, with the 58 | default function of \code{verbose.net}.} 59 | 60 | \item{module.order}{A character vector of module names that lists modules the 61 | order in which they should be evaluated within each time step. If 62 | \code{NULL}, the modules will be evaluated as follows: first any 63 | new modules supplied through \code{...} in the order in which they are 64 | listed, then the built-in modules in their order of the function listing. 65 | The \code{initialize.FUN} will always be run first and the 66 | \code{verbose.FUN} always last.} 67 | 68 | \item{save.nwstats}{Save out network statistics.} 69 | 70 | \item{save.other}{Other list elements of dat to save out.} 71 | 72 | \item{verbose}{If \code{TRUE}, print progress to console.} 73 | 74 | \item{skip.check}{If \code{TRUE}, skips the error check for parameter values, 75 | initial conditions, and control settings before running the models.} 76 | 77 | \item{...}{Additional arguments passed to the function.} 78 | } 79 | \description{ 80 | This function sets the control settings for the stochastic 81 | network models in the \code{epimethods} package. 82 | } 83 | \details{ 84 | This function sets the parameters for the models. 85 | } 86 | \keyword{het} 87 | -------------------------------------------------------------------------------- /man/control_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/params.R 3 | \name{control_msm} 4 | \alias{control_msm} 5 | \title{Epidemic Model Control Settings} 6 | \usage{ 7 | control_msm(simno = 1, nsims = 1, ncores = 1, nsteps = 100, 8 | start = 1, initialize.FUN = initialize_msm, aging.FUN = aging_msm, 9 | departure.FUN = departure_msm, arrival.FUN = arrival_msm, 10 | hivtest.FUN = hivtest_msm, hivtx.FUN = hivtx_msm, 11 | hivprogress.FUN = hivprogress_msm, hivvl.FUN = hivvl_msm, 12 | resim_nets.FUN = simnet_msm, acts.FUN = acts_msm, 13 | condoms.FUN = condoms_msm, position.FUN = position_msm, 14 | prep.FUN = prep_msm, hivtrans.FUN = hivtrans_msm, 15 | stitrans.FUN = stitrans_msm, stirecov.FUN = stirecov_msm, 16 | stitx.FUN = stitx_msm, prev.FUN = prevalence_msm, 17 | verbose.FUN = verbose.net, save.nwstats = FALSE, 18 | save.clin.hist = FALSE, truncate.plist = TRUE, verbose = TRUE, ...) 19 | } 20 | \arguments{ 21 | \item{simno}{Unique ID for the simulation run, used for file naming purposes 22 | if used in conjunction with the \code{EpiModelHPC} package.} 23 | 24 | \item{nsims}{Number of simulations.} 25 | 26 | \item{ncores}{Number of cores per run, if parallelization is used within the 27 | \code{EpiModelHPC} package.} 28 | 29 | \item{nsteps}{Number of time steps per simulation.} 30 | 31 | \item{start}{Starting time step for simulation, with default to 1 to run new 32 | simulation. This may also be set to 1 greater than the final time 33 | step of a previous simulation to resume the simulation with different 34 | parameters.} 35 | 36 | \item{initialize.FUN}{Module function to use for initialization of the epidemic 37 | model.} 38 | 39 | \item{aging.FUN}{Module function for aging.} 40 | 41 | \item{departure.FUN}{Module function for general and disease-realted depatures.} 42 | 43 | \item{arrival.FUN}{Module function for entries into the sexually active population.} 44 | 45 | \item{hivtest.FUN}{Module function for HIV diagnostic disease testing.} 46 | 47 | \item{hivtx.FUN}{Module function for ART initiation and adherence.} 48 | 49 | \item{hivprogress.FUN}{Module function for HIV disease progression.} 50 | 51 | \item{hivvl.FUN}{Module function for HIV viral load evolution.} 52 | 53 | \item{resim_nets.FUN}{Module function for network resimulation at each time 54 | step.} 55 | 56 | \item{acts.FUN}{Module function to simulate the number of sexual acts within 57 | partnerships.} 58 | 59 | \item{condoms.FUN}{Module function to simulate condom use within acts.} 60 | 61 | \item{position.FUN}{Module function to simulate sexual position within acts.} 62 | 63 | \item{prep.FUN}{Module function for PrEP initiation and utilization.} 64 | 65 | \item{hivtrans.FUN}{Module function to stochastically simulate HIV transmission 66 | over acts given individual and dyadic attributes.} 67 | 68 | \item{stitrans.FUN}{Module function to simulate GC/CT transmission over current 69 | edgelist.} 70 | 71 | \item{stirecov.FUN}{Module function to simulate recovery from GC/CT, heterogeneous 72 | by disease, site, symptoms, and treatment status.} 73 | 74 | \item{stitx.FUN}{Module function to simulate treatment of GC/CT.} 75 | 76 | \item{prev.FUN}{Module function to calculate prevalence summary statistics.} 77 | 78 | \item{verbose.FUN}{Module function to print model progress to the console or 79 | external text files.} 80 | 81 | \item{save.nwstats}{Calculate and save network statistics as defined in the 82 | \code{simnet} modules.} 83 | 84 | \item{save.clin.hist}{Save individual-level clinical history matrices.} 85 | 86 | \item{truncate.plist}{Truncate the cumulative partnership list to only include 87 | active partnerships.} 88 | 89 | \item{verbose}{If \code{TRUE}, print out simulation progress to the console 90 | if in interactive mode or text files if in batch mode.} 91 | 92 | \item{...}{Additional arguments passed to the function.} 93 | } 94 | \value{ 95 | A list object of class \code{control_msm}, which can be passed to the 96 | EpiModel function \code{netsim}. 97 | } 98 | \description{ 99 | Sets the controls for stochastic network models simulated with 100 | \code{\link{netsim}}. 101 | } 102 | \keyword{msm} 103 | -------------------------------------------------------------------------------- /man/departure_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.departure.R 3 | \name{departure_msm} 4 | \alias{departure_msm} 5 | \alias{deaths_het} 6 | \title{Depature Module} 7 | \usage{ 8 | departure_msm(dat, at) 9 | 10 | deaths_het(dat, at) 11 | } 12 | \arguments{ 13 | \item{dat}{Master data list object of class \code{dat} containing networks, 14 | individual-level attributes, and summary statistics.} 15 | 16 | \item{at}{Current time step.} 17 | } 18 | \value{ 19 | This function returns the updated \code{dat} object accounting for deaths. 20 | The deaths are deactivated from the main and casual networks, as those are in 21 | \code{networkDynamic} class objects; dead nodes are not deleted from the 22 | instant network until the \code{\link{simnet_msm}} module for bookkeeping 23 | purposes. 24 | } 25 | \description{ 26 | Module function for simulting both general and disease-related 27 | departures, including deaths, among population members. 28 | } 29 | \details{ 30 | Deaths are divided into two categories: general deaths, for which demographic 31 | data on age-specific mortality rates applies; and disease-related diseases, 32 | for which the rate of death is a function of progression to end-stage AIDS. 33 | } 34 | \keyword{module} 35 | \keyword{msm} 36 | -------------------------------------------------------------------------------- /man/edges_correct_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.simnet.R 3 | \name{edges_correct_msm} 4 | \alias{edges_correct_msm} 5 | \alias{edges_correct_het} 6 | \title{Adjustment for the Edges Coefficient with Changing Network Size} 7 | \usage{ 8 | edges_correct_msm(dat, at) 9 | 10 | edges_correct_het(dat, at) 11 | } 12 | \arguments{ 13 | \item{dat}{Master data list object of class \code{dat} containing networks, 14 | individual-level attributes, and summary statistics.} 15 | 16 | \item{at}{Current time step.} 17 | } 18 | \value{ 19 | The network model parameters stored in \code{dat$nwparam} are updated for 20 | each of the three network models. 21 | } 22 | \description{ 23 | Adjusts the edges coefficients in a dynamic network model 24 | to preserve the mean degree. 25 | } 26 | \details{ 27 | In HIV/STI modeling, there is typically an assumption that changes in 28 | population size do not affect one's number of partners, specified as the 29 | mean degree for network models. A person would not have 10 times the number 30 | of partners should he move from a city 10 times as large. This module uses 31 | the adjustment of Krivitsky et al. to adjust the edges coefficients on the 32 | three network models to account for varying population size in order to 33 | preserve that mean degree. 34 | } 35 | \references{ 36 | Krivitsky PN, Handcock MS, and Morris M. "Adjusting for network size and 37 | composition effects in exponential-family random graph models." Statistical 38 | Methodology. 2011; 8.4: 319-339. 39 | } 40 | \keyword{module} 41 | \keyword{msm} 42 | -------------------------------------------------------------------------------- /man/hivprogress_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.hivprogress.R 3 | \name{hivprogress_msm} 4 | \alias{hivprogress_msm} 5 | \title{Disease Progression Module} 6 | \usage{ 7 | hivprogress_msm(dat, at) 8 | } 9 | \arguments{ 10 | \item{dat}{Master data list object of class \code{dat} containing networks, 11 | individual-level attributes, and summary statistics.} 12 | 13 | \item{at}{Current time step.} 14 | } 15 | \value{ 16 | This function returns the \code{dat} object after updating the disease stage 17 | of infected individuals. 18 | } 19 | \description{ 20 | Module function for HIV disease progression through acute, chronic 21 | and AIDS stages. 22 | } 23 | \details{ 24 | HIV disease is divided into four stages: acute rising, acute falling, chronic 25 | and AIDS. Acute rising is the time from infection to peak viremia, while 26 | acute falling is the time from peak viremia to chronic stage infection with 27 | an established set-point HIV viral load. 28 | 29 | The time spent in chronic stage infection, and thus the time from infection to 30 | AIDS, depends on ART history. For ART-naive persons, time to AIDS is established 31 | by the \code{vl.aids.onset} parameter. For persons ever on ART who fall into 32 | the partially suppressed category (the \code{tt.traj} attribute is \code{1}), 33 | time to AIDS depends on the sum of two ratios: time on treatment over maximum 34 | time on treatment plus time off treatment over maximum time off treatment. 35 | For persons ever on ART who fall into the fully suppressed cateogry 36 | (\code{tt.traj=2}), time to AIDS depends on whether the cumulative time 37 | off treatment exceeds a time threshold specified in the \code{max.time.off.tx.full.int} 38 | parameter. 39 | } 40 | \keyword{module} 41 | \keyword{msm} 42 | -------------------------------------------------------------------------------- /man/hivtest_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.hivtest.R 3 | \name{hivtest_msm} 4 | \alias{hivtest_msm} 5 | \alias{dx_het} 6 | \title{HIV Testing Module} 7 | \usage{ 8 | hivtest_msm(dat, at) 9 | 10 | dx_het(dat, at) 11 | } 12 | \arguments{ 13 | \item{dat}{Master data list object of class \code{dat} containing networks, 14 | individual-level attributes, and summary statistics.} 15 | 16 | \item{at}{Current time step.} 17 | } 18 | \value{ 19 | This function returns the \code{dat} object with updated \code{last.neg.test}, 20 | \code{diag.status} and \code{diag.time} attributes. 21 | } 22 | \description{ 23 | Module function for HIV diagnostic testing of infected persons. 24 | } 25 | \details{ 26 | This testing module supports memoryless HIV testing for stochastic and 27 | geometrically-distributed waiting times to test (constant hazard). 28 | } 29 | \keyword{module} 30 | \keyword{msm} 31 | -------------------------------------------------------------------------------- /man/hivtrans_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.hivtrans.R 3 | \name{hivtrans_msm} 4 | \alias{hivtrans_msm} 5 | \alias{trans_het} 6 | \title{Transmission Module} 7 | \usage{ 8 | hivtrans_msm(dat, at) 9 | 10 | trans_het(dat, at) 11 | } 12 | \arguments{ 13 | \item{dat}{Master data list object of class \code{dat} containing networks, 14 | individual-level attributes, and summary statistics.} 15 | 16 | \item{at}{Current time step.} 17 | } 18 | \value{ 19 | For each new infection, the disease status, infection time, and related 20 | HIV attributes are updated for the infected node. Summary statistics for 21 | disease incidence overall, and by race and age groups are calculated and 22 | stored on \code{dat$epi}. 23 | } 24 | \description{ 25 | Stochastically simulates disease transmission given the current 26 | state of the discordand edgelist. 27 | } 28 | \details{ 29 | This is the final substantive function that occurs within the time loop at 30 | each time step. This function takes the discordant edgelist and calculates a 31 | transmission probability for each row (one sexual act) between dyads on the 32 | network. After transmission events, individual-level attributes for the infected 33 | persons are updated and summary statistics for incidence calculated. 34 | 35 | The per-act transmission probability depends on the following elements: 36 | insertive versus receptive role, viral load of the infected partner, an 37 | acute stage infection excess risk, and condom use. 38 | Given these transmission probabilities, transmission is stochastically 39 | simulating by drawing from a binomial distribution for each act conditional 40 | on the per-act probability. 41 | } 42 | \keyword{module} 43 | \keyword{msm} 44 | -------------------------------------------------------------------------------- /man/hivtx_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.hivtx.R 3 | \name{hivtx_msm} 4 | \alias{hivtx_msm} 5 | \alias{tx_het} 6 | \title{Treatment Module} 7 | \usage{ 8 | hivtx_msm(dat, at) 9 | 10 | tx_het(dat, at) 11 | } 12 | \arguments{ 13 | \item{dat}{Master data list object of class \code{dat} containing networks, 14 | individual-level attributes, and summary statistics.} 15 | 16 | \item{at}{Current time step.} 17 | } 18 | \value{ 19 | This function returns the \code{dat} object with updated \code{tx.status}, 20 | \code{tx.init.time}, \code{cuml.time.on.tx}, \code{cuml.time.off.tx} attributes. 21 | } 22 | \description{ 23 | Module function for anti-retroviral treatment initiation and 24 | adherence over time. 25 | } 26 | \details{ 27 | Persons enter into the simulation with one of four ART "patterns": never 28 | tested, tested but never treated, treated and achieving partial HIV viral 29 | suppression, or treated with full viral suppression (these types are stored 30 | as individual-level attributes in \code{tt.traj}). This module initiates ART 31 | for treatment naive persons in the latter two types, and then cycles them on 32 | and off treatment conditional on empirical race-specific adherence rates. ART 33 | initiation, non-adherence, and restarting are all stochastically simulated 34 | based on binomial statistical models. 35 | } 36 | \keyword{module} 37 | \keyword{msm} 38 | -------------------------------------------------------------------------------- /man/hivvl_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.hivvl.R 3 | \name{hivvl_msm} 4 | \alias{hivvl_msm} 5 | \alias{vl_het} 6 | \title{Viral Load Module} 7 | \usage{ 8 | hivvl_msm(dat, at) 9 | 10 | vl_het(dat, at) 11 | } 12 | \arguments{ 13 | \item{dat}{Master data list object of class \code{dat} containing networks, 14 | individual-level attributes, and summary statistics.} 15 | 16 | \item{at}{Current time step.} 17 | } 18 | \value{ 19 | This function returns the \code{dat} object with updated \code{vl} attribute. 20 | } 21 | \description{ 22 | Module function for updating HIV viral load. 23 | } 24 | \details{ 25 | HIV viral load varies over time as a function of time since infection and ART 26 | history. In the absence of ART, VL rises during the acute rising stage and 27 | falls during the acute falling stage, until it reaches a set-point value in 28 | chronic stage infection. VL again rises during AIDS stage disease until the 29 | point of death. 30 | 31 | For persons who have ever initated treatment (\code{tt.traj} is \code{3} or 32 | \code{4}), VL changes depending on current ART use in that time step. 33 | Current use is associated with a reduction in VL, with the rates of decline 34 | and nadirs dependent on partial or full suppression levels. Current 35 | non-adherence is associated with an equal level of increase to VL. All persons 36 | who have reached AIDS, regardless of how they arrived, have a similar rate of 37 | VL increase. 38 | } 39 | \keyword{module} 40 | \keyword{msm} 41 | -------------------------------------------------------------------------------- /man/init_het.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/params.R 3 | \name{init_het} 4 | \alias{init_het} 5 | \title{Initial Conditions for Stochastic Network Model of HIV-1 Infection in 6 | Sub-Saharan Africa} 7 | \usage{ 8 | init_het(i.prev.male = 0.05, i.prev.feml = 0.05, ages.male = seq(18, 9 | 55, 7/365), ages.feml = seq(18, 55, 7/365), 10 | inf.time.dist = "geometric", max.inf.time = 5 * 365, ...) 11 | } 12 | \arguments{ 13 | \item{i.prev.male}{Prevalence of initially infected males.} 14 | 15 | \item{i.prev.feml}{Prevalence of initially infected females.} 16 | 17 | \item{ages.male}{initial ages of males in the population.} 18 | 19 | \item{ages.feml}{initial ages of females in the population.} 20 | 21 | \item{inf.time.dist}{Probability distribution for setting time of infection 22 | for nodes infected at T1, with options of \code{"geometric"} for randomly 23 | distributed on a geometric distribution with a probability of the 24 | reciprocal of the average length of infection, \code{"uniform"} for a 25 | uniformly distributed time over that same interval, or \code{"allacute"} for 26 | placing all infections in the acute stage at the start.} 27 | 28 | \item{max.inf.time}{Maximum infection time in days for infection at initialization, 29 | used when \code{inf.time.dist} is \code{"geometric"} or \code{"uniform"}.} 30 | 31 | \item{...}{additional arguments to be passed into model.} 32 | } 33 | \description{ 34 | This function sets the initial conditions for the stochastic 35 | network models in the \code{epimethods} package. 36 | } 37 | \details{ 38 | This function sets the initial conditions for the models. 39 | } 40 | \keyword{het} 41 | -------------------------------------------------------------------------------- /man/init_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/params.R 3 | \name{init_msm} 4 | \alias{init_msm} 5 | \title{Epidemic Model Initial Conditions} 6 | \usage{ 7 | init_msm(prev.ugc = 0.005, prev.rgc = 0.005, prev.uct = 0.013, 8 | prev.rct = 0.013, ...) 9 | } 10 | \arguments{ 11 | \item{prev.ugc}{Initial prevalence of urethral gonorrhea.} 12 | 13 | \item{prev.rgc}{Initial prevalence of rectal gonorrhea.} 14 | 15 | \item{prev.uct}{Initial prevalence of urethral chlamydia.} 16 | 17 | \item{prev.rct}{Initial prevalence of rectal chlamydia.} 18 | 19 | \item{...}{Additional arguments passed to function.} 20 | } 21 | \value{ 22 | A list object of class \code{init_msm}, which can be passed to EpiModel 23 | function \code{\link{netsim}}. 24 | } 25 | \description{ 26 | Sets the initial conditions for a stochastic epidemic models 27 | simulated with \code{\link{netsim}}. 28 | } 29 | \keyword{msm} 30 | -------------------------------------------------------------------------------- /man/init_status_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.initialize.R 3 | \name{init_status_msm} 4 | \alias{init_status_msm} 5 | \title{Initialize the HIV status of persons in the network} 6 | \usage{ 7 | init_status_msm(dat) 8 | } 9 | \arguments{ 10 | \item{dat}{Data object created in initialization module.} 11 | } 12 | \description{ 13 | Sets the initial individual-level disease status of persons 14 | in the network, as well as disease-related attributes for 15 | infected persons. 16 | } 17 | \keyword{initiation} 18 | \keyword{msm} 19 | \keyword{utility} 20 | -------------------------------------------------------------------------------- /man/init_sti_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.initialize.R 3 | \name{init_sti_msm} 4 | \alias{init_sti_msm} 5 | \title{Initialize the STI status of persons in the network} 6 | \usage{ 7 | init_sti_msm(dat) 8 | } 9 | \arguments{ 10 | \item{dat}{Data object created in initialization module.} 11 | } 12 | \description{ 13 | Sets the initial individual-level disease status of persons 14 | in the network, as well as disease-related attributes for 15 | infected persons. 16 | } 17 | \keyword{initiation} 18 | \keyword{msm} 19 | \keyword{utility} 20 | -------------------------------------------------------------------------------- /man/initialize_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.initialize.R 3 | \name{initialize_msm} 4 | \alias{initialize_msm} 5 | \alias{initialize_het} 6 | \title{Initialization Module} 7 | \usage{ 8 | initialize_msm(x, param, init, control, s) 9 | 10 | initialize_het(x, param, init, control, s) 11 | } 12 | \arguments{ 13 | \item{x}{An \code{EpiModel} object of class \code{\link{netest}}.} 14 | 15 | \item{param}{An \code{EpiModel} object of class \code{\link{param_msm}}.} 16 | 17 | \item{init}{An \code{EpiModel} object of class \code{\link{init_msm}}.} 18 | 19 | \item{control}{An \code{EpiModel} object of class \code{\link{control_msm}}.} 20 | 21 | \item{s}{Simulation number, used for restarting dependent simulations.} 22 | } 23 | \value{ 24 | This function returns the updated \code{dat} object with the initialized values 25 | for demographics and disease-related variables. 26 | } 27 | \description{ 28 | This function initializes the master \code{dat} object on which 29 | data are stored, simulates the initial state of the network, and 30 | simulates disease status and other attributes. 31 | } 32 | \keyword{module} 33 | \keyword{msm} 34 | -------------------------------------------------------------------------------- /man/param_het.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/params.R 3 | \name{param_het} 4 | \alias{param_het} 5 | \title{Parameters for Stochastic Network Model of HIV-1 Infection in 6 | Sub-Saharan Africa} 7 | \usage{ 8 | param_het(time.unit = 7, acute.stage.mult = 5, aids.stage.mult = 1, 9 | vl.acute.topeak = 14, vl.acute.toset = 107, vl.acute.peak = 6.7, 10 | vl.setpoint = 4.5, vl.aidsmax = 7, cond.prob = 0.09, 11 | cond.eff = 0.78, act.rate.early = 0.362, act.rate.late = 0.197, 12 | act.rate.cd4 = 50, acts.rand = TRUE, circ.prob.birth = 0.9, 13 | circ.eff = 0.53, tx.elig.cd4 = 350, tx.init.cd4.mean = 120, 14 | tx.init.cd4.sd = 40, tx.adhere.full = 0.76, tx.adhere.part = 0.5, 15 | tx.vlsupp.time = 365/3, tx.vlsupp.level = 1.5, 16 | tx.cd4.recrat.feml = 11.6/30, tx.cd4.recrat.male = 9.75/30, 17 | tx.cd4.decrat.feml = 11.6/30, tx.cd4.decrat.male = 9.75/30, 18 | tx.coverage = 0.3, tx.prev.eff = 0.96, b.rate = 0.03/365, 19 | b.rate.method = "totpop", b.propmale = NULL, ds.exit.age = 55, 20 | ds.rate.mult = 1, di.cd4.aids = 50, di.cd4.rate = 2/365, ...) 21 | } 22 | \arguments{ 23 | \item{time.unit}{Unit of time relative to one day.} 24 | 25 | \item{acute.stage.mult}{Acute stage multiplier for increased infectiousness 26 | above impact of heightened viral load.} 27 | 28 | \item{aids.stage.mult}{AIDS stage multiplier for increased infectiousness in 29 | AIDS above impact of heightened viral load.} 30 | 31 | \item{vl.acute.topeak}{Time in weeks to peak viremia during acute infection.} 32 | 33 | \item{vl.acute.toset}{Time in weeks to viral set point following peak viremia.} 34 | 35 | \item{vl.acute.peak}{Log 10 viral load at acute peak.} 36 | 37 | \item{vl.setpoint}{Log 10 viral load at set point.} 38 | 39 | \item{vl.aidsmax}{Maximum log 10 viral load during AIDS.} 40 | 41 | \item{cond.prob}{Probability of condoms per act with partners.} 42 | 43 | \item{cond.eff}{Efficacy of condoms per act in HIV prevention.} 44 | 45 | \item{act.rate.early}{Daily per-partnership act rate in early disease.} 46 | 47 | \item{act.rate.late}{Daily per-partnership act rate in late disease.} 48 | 49 | \item{act.rate.cd4}{CD4 count at which the \code{act.rate.late} applies.} 50 | 51 | \item{acts.rand}{If \code{TRUE}, will draw number of total and unprotected 52 | acts from a binomial distribution parameterized by the \code{act.rate}.} 53 | 54 | \item{circ.prob.birth}{Proportion of men circumcised at birth.} 55 | 56 | \item{circ.eff}{Efficacy of circumcision per act in HIV prevention.} 57 | 58 | \item{tx.elig.cd4}{CD4 count at which a person becomes eligible for treatment.} 59 | 60 | \item{tx.init.cd4.mean}{Mean CD4 count at which person presents for care.} 61 | 62 | \item{tx.init.cd4.sd}{SD of CD4 count at which person presents for care.} 63 | 64 | \item{tx.adhere.full}{Proportion of people who start treatment who are fully 65 | adherent.} 66 | 67 | \item{tx.adhere.part}{Of the not fully adherent proportion, the percent of time 68 | they are on medication.} 69 | 70 | \item{tx.vlsupp.time}{Time in weeks from treatment initiation to viral suppression.} 71 | 72 | \item{tx.vlsupp.level}{Log 10 viral load level at suppression.} 73 | 74 | \item{tx.cd4.recrat.feml}{Rate of CD4 recovery under treatment for males.} 75 | 76 | \item{tx.cd4.recrat.male}{Rate of CD4 recovery under treatment for females.} 77 | 78 | \item{tx.cd4.decrat.feml}{Rate of CD4 decline under periods of non-adherence 79 | for females.} 80 | 81 | \item{tx.cd4.decrat.male}{Rate of CD4 decline under periods of non-adherence 82 | for males.} 83 | 84 | \item{tx.coverage}{Proportion of treatment-eligible persons who have initiated 85 | treatment.} 86 | 87 | \item{tx.prev.eff}{Proportional amount by which treatment reduces infectivity 88 | of infected partner.} 89 | 90 | \item{b.rate}{General entry rate per day for males and females specified.} 91 | 92 | \item{b.rate.method}{Method for assigning birth rates, with options of "totpop" 93 | for births as a function of the total population size, "fpop" for births 94 | as a function of the female population size, and "stgrowth" for a constant 95 | stable growth rate.} 96 | 97 | \item{b.propmale}{Proportion of entries assigned as male. If NULL, then set 98 | adaptively based on the proportion at time 1.} 99 | 100 | \item{ds.exit.age}{Age at which the age-specific ds.rate is set to 1, with NA 101 | value indicating no censoring.} 102 | 103 | \item{ds.rate.mult}{Simple multiplier for background death rates.} 104 | 105 | \item{di.cd4.aids}{CD4 count at which late-stage AIDS occurs and the risk of 106 | mortality is governed by \code{di.cd4.rate}.} 107 | 108 | \item{di.cd4.rate}{Mortality in late-stage AIDS after hitting a nadir CD4 of 109 | \code{di.cd4.aids}.} 110 | 111 | \item{...}{additional arguments to be passed into model.} 112 | } 113 | \description{ 114 | Sets the simulation parameters for the stochastic 115 | network model of HIV-1 Infection among Heterosexuals in 116 | Sub-Saharan Africa for the \code{EpiModelHIV} package. 117 | } 118 | \details{ 119 | This function sets the parameters for the models. 120 | } 121 | \keyword{het} 122 | -------------------------------------------------------------------------------- /man/param_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/params.R 3 | \name{param_msm} 4 | \alias{param_msm} 5 | \title{Epidemic Model Parameters} 6 | \usage{ 7 | param_msm(netstats, hiv.test.rate = c(0.01325, 0.0125, 0.0124), 8 | hiv.test.late.prob = c(0.25, 0.25, 0.25), test.window.int = 21/7, 9 | tt.part.supp = c(0.2, 0.2, 0.2), tt.full.supp = c(0.4, 0.4, 0.4), 10 | tt.dur.supp = c(0.4, 0.4, 0.4), tx.init.prob = c(0.092, 0.092, 11 | 0.127), tx.halt.part.prob = c(0.0102, 0.0102, 0.0071), 12 | tx.halt.full.rr = c(0.9, 0.9, 0.9), tx.halt.dur.rr = c(0.5, 0.5, 13 | 0.5), tx.reinit.part.prob = c(0.00066, 0.00066, 0.00291), 14 | tx.reinit.full.rr = c(1, 1, 1), tx.reinit.dur.rr = c(1, 1, 1), 15 | max.time.off.tx.full.int = 52 * 15, max.time.on.tx.part.int = 52 * 16 | 10, max.time.off.tx.part.int = 52 * 10, vl.acute.rise.int = 6.4, 17 | vl.acute.peak = 6.886, vl.acute.fall.int = 6.4, vl.set.point = 4.5, 18 | vl.aids.onset.int = 520, vl.aids.int = 104, vl.aids.peak = 7, 19 | vl.full.supp = 1.5, vl.part.supp = 3.5, vl.tx.down.slope = 0.25, 20 | vl.tx.aids.down.slope = 0.25, vl.tx.up.slope = 0.25, 21 | aids.mr = 1/104, a.rate = 0.00052, arrival.age = 15, 22 | URAI.prob = 0.008938, UIAI.prob = 0.003379, trans.scale = c(1, 1, 23 | 1), acute.rr = 6, circ.rr = 0.4, cond.eff = 0.95, 24 | cond.fail = c(0.25, 0.25, 0.25), circ.prob = c(0.874, 0.874, 0.918), 25 | epistats, acts.aids.vl = 5.75, acts.scale = 1, cond.scale = 1, 26 | rgc.tprob = 0.35, ugc.tprob = 0.25, rct.tprob = 0.2, 27 | uct.tprob = 0.16, rgc.sympt.prob = 0.16, ugc.sympt.prob = 0.8, 28 | rct.sympt.prob = 0.14, uct.sympt.prob = 0.58, rgc.ntx.int = 16.8, 29 | ugc.ntx.int = 16.8, gc.tx.int = 1.4, rct.ntx.int = 32, 30 | uct.ntx.int = 32, ct.tx.int = 1.4, gc.sympt.prob.tx = c(0.95, 0.95, 31 | 0.95), ct.sympt.prob.tx = c(0.9, 0.9, 0.9), 32 | gc.asympt.prob.tx = c(0.15, 0.15, 0.15), ct.asympt.prob.tx = c(0.15, 33 | 0.15, 0.15), sti.cond.eff = 0.9, sti.cond.fail = c(0.2, 0.2, 0.2), 34 | hiv.rgc.rr = 2.78, hiv.ugc.rr = 1.73, hiv.rct.rr = 2.78, 35 | hiv.uct.rr = 1.73, hiv.dual.rr = 0.2, riskh.start = Inf, 36 | prep.start = Inf, prep.start.prob = 0.2, prep.adhr.dist = c(0.089, 37 | 0.127, 0.784), prep.adhr.hr = c(0.69, 0.19, 0.01), 38 | prep.discont.rate = 1 - (2^(-1/(224.4237/7))), prep.tst.int = 90/7, 39 | prep.risk.int = 182/7, prep.sti.screen.int = 182/7, 40 | prep.sti.prob.tx = 1, prep.risk.reassess.method = "year", 41 | prep.require.lnt = TRUE, ...) 42 | } 43 | \arguments{ 44 | \item{netstats}{Target statistics and related network initialization data from 45 | the standard ARTnet workflow.} 46 | 47 | \item{hiv.test.rate}{Mean probability of HIV testing per week for 48 | black/hispanic/white MSM (vector of length 3).} 49 | 50 | \item{hiv.test.late.prob}{Proportion of black/hispanic/white MSM who test only 51 | during AIDS stage infection (vector of length 3).} 52 | 53 | \item{test.window.int}{Length of the HIV test window period in weeks.} 54 | 55 | \item{tt.part.supp}{Proportion of black/hispanic/white MSM who enter partial viral 56 | suppression category after ART initiation (vector of length 3).} 57 | 58 | \item{tt.full.supp}{Proportion of black/hispanic/white MSM who enter full viral 59 | suppression category after ART initiation (vector of length 3).} 60 | 61 | \item{tt.dur.supp}{Proportion of black/hispanic/white MSM who enter durable viral 62 | suppression category after ART initiation (vector of length 3).} 63 | 64 | \item{tx.init.prob}{Probability per time step that a black/hispanic/white MSM who has 65 | tested positive will initiate treatment (vector of length 3).} 66 | 67 | \item{tx.halt.part.prob}{Probability per time step that black/hispanic/white 68 | MSM who have started treatment and assigned to the partial VL suppression 69 | category will stop treatment (vector of length 3).} 70 | 71 | \item{tx.halt.full.rr}{Relative reduction in \code{tx.halt.part.prob} for 72 | black/hispanic/white MSM in the full VL suppression category (vector of length 3).} 73 | 74 | \item{tx.halt.dur.rr}{Relative reduction in \code{tx.halt.part.prob} for 75 | black/hispanic/white MSM in the durable VL suppression category (vector of length 3).} 76 | 77 | \item{tx.reinit.part.prob}{Probability per time step that a black/hispanic/white 78 | MSM who has stopped treatment and assigned to the partial VL suppression 79 | category will restart treatment (vector of length 3).} 80 | 81 | \item{tx.reinit.full.rr}{Relative reduction in \code{tx.reinit.part.prob} for 82 | black/hispanic/white MSM in the full VL suppression category (vector of length 3).} 83 | 84 | \item{tx.reinit.dur.rr}{Relative reduction in \code{tx.reinit.part.prob} for 85 | black/hispanic/white MSM in the durable VL suppression category (vector of length 3).} 86 | 87 | \item{max.time.off.tx.full.int}{Number of weeks off treatment for a full 88 | suppressor before onset of AIDS, including time before diagnosis.} 89 | 90 | \item{max.time.on.tx.part.int}{Number of weeks on treatment for a 91 | partial suppressor beofre onset of AIDS.} 92 | 93 | \item{max.time.off.tx.part.int}{Nnumber of weeks off treatment for a 94 | partial suppressor before onset of AIDS, including time before 95 | diagnosis.} 96 | 97 | \item{vl.acute.rise.int}{Number of weeks to peak viremia during acute 98 | infection.} 99 | 100 | \item{vl.acute.peak}{Peak viral load (in log10 units) at the height of acute 101 | infection.} 102 | 103 | \item{vl.acute.fall.int}{Number of weeks from peak viremia to set-point 104 | viral load during the acute infection period.} 105 | 106 | \item{vl.set.point}{Set point viral load (in log10 units).} 107 | 108 | \item{vl.aids.onset.int}{Number of weeks to AIDS for a treatment-naive 109 | patient.} 110 | 111 | \item{vl.aids.int}{Duration of AIDS stage infection in weeks.} 112 | 113 | \item{vl.aids.peak}{Maximum viral load during AIDS stage.} 114 | 115 | \item{vl.full.supp}{Log10 viral load at full suppression on ART.} 116 | 117 | \item{vl.part.supp}{Log10 viral load at partial suppression on ART.} 118 | 119 | \item{vl.tx.down.slope}{Number of log10 units that viral load falls per time 120 | step from treatment initiation or re-initiation until the suppression 121 | level is reached (pre-AIDS stages).} 122 | 123 | \item{vl.tx.aids.down.slope}{Number of log10 units that viral load falls per time 124 | step from treatment initiation or re-initiation until the suppression 125 | level is reached (AIDS stage).} 126 | 127 | \item{vl.tx.up.slope}{Number of log10 units that viral load rises per time 128 | step from treatment halting until expected value.} 129 | 130 | \item{aids.mr}{Mortality rate of persons in the AIDS stage who are currently 131 | off ART.} 132 | 133 | \item{a.rate}{Rate at which MSM enter the population.} 134 | 135 | \item{arrival.age}{Age (in years) of new arrivals.} 136 | 137 | \item{URAI.prob}{Probability of transmission for a man having unprotected 138 | receptive anal intercourse with an infected man at set point viral 139 | load.} 140 | 141 | \item{UIAI.prob}{Probability of transmission for an uncircumcised man having 142 | unprotected insertive anal intercourse with an infected man at set 143 | point viral load.} 144 | 145 | \item{trans.scale}{Relative scalar on base infection probabilities for model 146 | calibration for black/hispanic/white men (vector of length 3).} 147 | 148 | \item{acute.rr}{Relative risk of infection (compared to that predicted by 149 | elevated viral load) when positive partner is in the acute stage.} 150 | 151 | \item{circ.rr}{Relative risk of infection from insertive anal sex when the 152 | negative insertive partner is circumcised.} 153 | 154 | \item{cond.eff}{Relative risk of HIV infection from anal sex when a condom is 155 | used properly (biological efficacy).} 156 | 157 | \item{cond.fail}{Condom failure rates for HIV for black/hispanic/white MSM, as a reduction 158 | in the cond.eff parameter (vector of length 3).} 159 | 160 | \item{circ.prob}{Probablity that a black/hispanic/white new arrival in the population 161 | will be circumcised (vector of length 3).} 162 | 163 | \item{epistats}{GLMs for epidemiological parameter from the standard ARTnet workflow.} 164 | 165 | \item{acts.aids.vl}{Viral load level after which sexual act rate goes to zero.} 166 | 167 | \item{acts.scale}{Scalar for main/casual act rate for model calibration.} 168 | 169 | \item{cond.scale}{Scalar for condom use probability for model calibration.} 170 | 171 | \item{rgc.tprob}{Probability of rectal gonorrhea infection per act.} 172 | 173 | \item{ugc.tprob}{Probability of urethral gonorrhea infection per act.} 174 | 175 | \item{rct.tprob}{Probability of rectal chlamydia infection per act.} 176 | 177 | \item{uct.tprob}{Probability of urethral chlamydia infection per act.} 178 | 179 | \item{rgc.sympt.prob}{Probability of symptoms given infection with rectal 180 | gonorrhea.} 181 | 182 | \item{ugc.sympt.prob}{Probability of symptoms given infection with urethral 183 | gonorrhea.} 184 | 185 | \item{rct.sympt.prob}{Probability of symptoms given infection with rectal 186 | chlamydia.} 187 | 188 | \item{uct.sympt.prob}{Probability of symptoms given infection with urethral 189 | chlamydia.} 190 | 191 | \item{rgc.ntx.int}{Average duration in weeks of untreated rectal gonorrhea.} 192 | 193 | \item{ugc.ntx.int}{Average duration in weeks of untreated urethral gonorrhea.} 194 | 195 | \item{gc.tx.int}{Average duration in weeks of treated gonorrhea (both sites).} 196 | 197 | \item{rct.ntx.int}{Average in weeks duration of untreated rectal chlamydia.} 198 | 199 | \item{uct.ntx.int}{Average in weeks duration of untreated urethral chlamydia.} 200 | 201 | \item{ct.tx.int}{Average in weeks duration of treated chlamydia (both sites).} 202 | 203 | \item{gc.sympt.prob.tx}{Probability of treatment for symptomatic gonorrhea 204 | for black/hispanic/white men (vector of length 3).} 205 | 206 | \item{ct.sympt.prob.tx}{Probability of treatment for symptomatic chlamydia 207 | for black/hispanic/white men (vector of length 3).} 208 | 209 | \item{gc.asympt.prob.tx}{Probability of treatment for asymptomatic gonorrhea 210 | for black/hispanic/white men (vector of length 3).} 211 | 212 | \item{ct.asympt.prob.tx}{Probability of treatment for asymptomatic chlamydia 213 | for black/hispanic/white men (vector of length 3).} 214 | 215 | \item{sti.cond.eff}{Relative risk of STI infection from anal sex when a condom is 216 | used properly (biological efficacy).} 217 | 218 | \item{sti.cond.fail}{Condom failure rates for STI for black/hispanic/white MSM, as 219 | a reduction in the cond.eff parameter (vector of length 3).} 220 | 221 | \item{hiv.rgc.rr}{Relative risk of HIV infection given current rectal gonorrhea.} 222 | 223 | \item{hiv.ugc.rr}{Relative risk of HIV infection given current urethral gonorrhea.} 224 | 225 | \item{hiv.rct.rr}{Relative risk of HIV infection given current rectal chlamydia.} 226 | 227 | \item{hiv.uct.rr}{Relative risk of HIV infection given current urethral chlamydia.} 228 | 229 | \item{hiv.dual.rr}{Additive proportional risk, from 0 to 1, for HIV infection 230 | given dual infection with both gonorrhea and chlamydia.} 231 | 232 | \item{riskh.start}{Time step at which behavioral risk history assessment occurs.} 233 | 234 | \item{prep.start}{Time step at which the PrEP intervention should start.} 235 | 236 | \item{prep.start.prob}{Probability of starting PrEP given current indications.} 237 | 238 | \item{prep.adhr.dist}{Proportion of men who are low, medium, and high 239 | adherent to PrEP.} 240 | 241 | \item{prep.adhr.hr}{The hazard ratio for infection per act associated with each 242 | level of adherence (from Grant).} 243 | 244 | \item{prep.discont.rate}{Rate of random discontinuation from PrEP.} 245 | 246 | \item{prep.tst.int}{Testing interval for those who are actively on PrEP. This 247 | overrides the mean testing interval parameters.} 248 | 249 | \item{prep.risk.int}{Time window for assessment of risk eligibility for PrEP 250 | in weeks.} 251 | 252 | \item{prep.sti.screen.int}{Interval in weeks between STI screening at PrEP visits.} 253 | 254 | \item{prep.sti.prob.tx}{Probability of treatment given positive screening during 255 | PrEP visit.} 256 | 257 | \item{prep.risk.reassess.method}{Interval for reassessment of risk indications 258 | of active PrEP users, either \code{"none"} for no reassessment, 259 | \code{"inst"} for weekly, or \code{"year"} for year.} 260 | 261 | \item{prep.require.lnt}{If \code{TRUE}, only start on PrEP if current time step is 262 | equal to the last negative test.} 263 | 264 | \item{...}{Additional arguments passed to the function.} 265 | } 266 | \value{ 267 | A list object of class \code{param_msm}, which can be passed to 268 | EpiModel function \code{netsim}. 269 | } 270 | \description{ 271 | Sets the epidemic parameters for stochastic network models 272 | simulated with \code{\link{netsim}} for EpiModelHIV 273 | } 274 | \keyword{msm} 275 | -------------------------------------------------------------------------------- /man/position_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.position.R 3 | \name{position_msm} 4 | \alias{position_msm} 5 | \title{Position Module} 6 | \usage{ 7 | position_msm(dat, at) 8 | } 9 | \arguments{ 10 | \item{dat}{Master data list object of class \code{dat} containing networks, 11 | individual-level attributes, and summary statistics.} 12 | 13 | \item{at}{Current time step.} 14 | } 15 | \value{ 16 | This function returns the updated discordant edgelist with a \code{ins} 17 | attribute for values of whether the infected node is insertive or the 18 | susceptible node is insertive for that act. 19 | } 20 | \description{ 21 | Module function for establishing sexual role or position in each 22 | act on the discordant edgelist. 23 | } 24 | \details{ 25 | The sexual role within each act is determined by each nodes "role identity" 26 | as exclusively receptive, exclusively insertive, or versatile. This function 27 | determines whether the infected or the susceptible partner is the insertive 28 | partner for that act. For the first two role identity types, that is 29 | deterministic based on identity. For versatile-versatile pairs, this is 30 | determined stochastically for each act. 31 | } 32 | \keyword{module} 33 | \keyword{msm} 34 | -------------------------------------------------------------------------------- /man/prep_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.prep.R 3 | \name{prep_msm} 4 | \alias{prep_msm} 5 | \title{PrEP Module} 6 | \usage{ 7 | prep_msm(dat, at) 8 | } 9 | \arguments{ 10 | \item{dat}{Master data list object of class \code{dat} containing networks, 11 | individual-level attributes, and summary statistics.} 12 | 13 | \item{at}{Current time step.} 14 | } 15 | \description{ 16 | Module function for implementation and uptake of pre-exposure 17 | prophylaxis (PrEP) to prevent HIV infection. 18 | } 19 | \keyword{module} 20 | \keyword{msm} 21 | -------------------------------------------------------------------------------- /man/prevalence_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.prevalence.R 3 | \name{prevalence_msm} 4 | \alias{prevalence_msm} 5 | \alias{prevalence_het} 6 | \title{Prevalence Calculations within Time Steps} 7 | \usage{ 8 | prevalence_msm(dat, at) 9 | 10 | prevalence_het(dat, at) 11 | } 12 | \arguments{ 13 | \item{dat}{Master data list object of class \code{dat} containing networks, 14 | individual-level attributes, and summary statistics.} 15 | 16 | \item{at}{Current time step.} 17 | } 18 | \value{ 19 | This function returns the \code{dat} object with an updated summary of current 20 | attributes stored in \code{dat$epi}. 21 | } 22 | \description{ 23 | This module calculates demographic, transmission, and clinical 24 | statistics at each time step within the simulation. 25 | } 26 | \details{ 27 | Summary statistic calculations are of two broad forms: prevalence and 28 | incidence. This function establishes the summary statistic vectors for both 29 | prevalence and incidence at time 1, and then calculates the prevalence 30 | statistics for times 2 onward. Incidence statistics (e.g., number of new 31 | infections or deaths) are calculated within the modules as they depend on 32 | vectors that are not stored external to the module. 33 | } 34 | \keyword{module} 35 | \keyword{msm} 36 | -------------------------------------------------------------------------------- /man/reallocate_pcp.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.prep.R 3 | \name{reallocate_pcp} 4 | \alias{reallocate_pcp} 5 | \title{Proportionally Reallocate PrEP Adherence Class Probability} 6 | \usage{ 7 | reallocate_pcp(in.pcp = c(0.089, 0.127, 0.784), reall = 0) 8 | } 9 | \arguments{ 10 | \item{in.pcp}{Input vector of length four for the \code{prep.adhr.dist} 11 | parameters.} 12 | 13 | \item{reall}{The pure percentage points to shift from the high adherence 14 | group to the lower three groups.} 15 | } 16 | \description{ 17 | Shifts probabilities from the high-adherence category to the lower 18 | three adherence categories while maintaining the proportional 19 | distribution of those lower categories. 20 | } 21 | -------------------------------------------------------------------------------- /man/reinit_het.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.initialize.R 3 | \name{reinit_het} 4 | \alias{reinit_het} 5 | \title{Reinitialization Module} 6 | \usage{ 7 | reinit_het(x, param, init, control, s) 8 | } 9 | \arguments{ 10 | \item{x}{An \code{EpiModel} object of class \code{\link{netest}}.} 11 | 12 | \item{param}{An \code{EpiModel} object of class \code{\link{param_het}}.} 13 | 14 | \item{init}{An \code{EpiModel} object of class \code{\link{init_het}}.} 15 | 16 | \item{control}{An \code{EpiModel} object of class \code{\link{control_het}}.} 17 | 18 | \item{s}{Simulation number, used for restarting dependent simulations.} 19 | } 20 | \value{ 21 | This function returns the updated \code{dat} object with the initialized values 22 | for demographics and disease-related variables. 23 | } 24 | \description{ 25 | This function reinitializes the master \code{dat} object on which 26 | data are stored, simulates the initial state of the network, and 27 | simulates disease status and other attributes. 28 | } 29 | \keyword{het} 30 | \keyword{module} 31 | -------------------------------------------------------------------------------- /man/reinit_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.initialize.R 3 | \name{reinit_msm} 4 | \alias{reinit_msm} 5 | \title{Re-Initialization Module} 6 | \usage{ 7 | reinit_msm(x, param, init, control, s) 8 | } 9 | \arguments{ 10 | \item{x}{An \code{EpiModel} object of class \code{\link{netsim}}.} 11 | 12 | \item{param}{An \code{EpiModel} object of class \code{\link{param_msm}}.} 13 | 14 | \item{init}{An \code{EpiModel} object of class \code{\link{init_msm}}.} 15 | 16 | \item{control}{An \code{EpiModel} object of class \code{\link{control_msm}}.} 17 | 18 | \item{s}{Simulation number, used for restarting dependent simulations.} 19 | } 20 | \value{ 21 | This function resets the data elements on the \code{dat} master data object 22 | in the needed ways for the time loop to function. 23 | } 24 | \description{ 25 | This function reinitializes an epidemic model to restart at a 26 | specified time step given an input \code{netsim} object. 27 | } 28 | \details{ 29 | Currently, the necessary components that must be on \code{x} for a simulation 30 | to be restarted must be: param, control, nwparam, epi, attr, temp, el, p. 31 | TODO: describe this more. 32 | } 33 | \keyword{module} 34 | \keyword{msm} 35 | -------------------------------------------------------------------------------- /man/riskhist_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.prep.R 3 | \name{riskhist_msm} 4 | \alias{riskhist_msm} 5 | \title{Risk History Sub-Module} 6 | \usage{ 7 | riskhist_msm(dat, at) 8 | } 9 | \arguments{ 10 | \item{dat}{Master data list object of class \code{dat} containing networks, 11 | individual-level attributes, and summary statistics.} 12 | 13 | \item{at}{Current time step.} 14 | } 15 | \description{ 16 | Sub-Module function to track the risk history of uninfected persons 17 | for purpose of PrEP targeting. 18 | } 19 | \keyword{module} 20 | \keyword{msm} 21 | -------------------------------------------------------------------------------- /man/simnet_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.simnet.R 3 | \name{simnet_msm} 4 | \alias{simnet_msm} 5 | \alias{simnet_het} 6 | \title{Network Resimulation Module} 7 | \usage{ 8 | simnet_msm(dat, at) 9 | 10 | simnet_het(dat, at) 11 | } 12 | \arguments{ 13 | \item{dat}{Master data list object of class \code{dat} containing networks, 14 | individual-level attributes, and summary statistics.} 15 | 16 | \item{at}{Current time step.} 17 | } 18 | \description{ 19 | Module function for resimulating the sexual networks for one 20 | time step. 21 | } 22 | \keyword{module} 23 | \keyword{msm} 24 | -------------------------------------------------------------------------------- /man/stirecov_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.stirecov.R 3 | \name{stirecov_msm} 4 | \alias{stirecov_msm} 5 | \title{STI Recovery Module} 6 | \usage{ 7 | stirecov_msm(dat, at) 8 | } 9 | \arguments{ 10 | \item{dat}{Master data list object of class \code{dat} containing networks, 11 | individual-level attributes, and summary statistics.} 12 | 13 | \item{at}{Current time step.} 14 | } 15 | \description{ 16 | Stochastically simulates GC/CT recovery. 17 | } 18 | \keyword{module} 19 | \keyword{msm} 20 | -------------------------------------------------------------------------------- /man/stitrans_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.stitrans.R 3 | \name{stitrans_msm} 4 | \alias{stitrans_msm} 5 | \title{STI Transmission Module} 6 | \usage{ 7 | stitrans_msm(dat, at) 8 | } 9 | \arguments{ 10 | \item{dat}{Master data list object of class \code{dat} containing networks, 11 | individual-level attributes, and summary statistics.} 12 | 13 | \item{at}{Current time step.} 14 | } 15 | \description{ 16 | Stochastically simulates GC/CT transmission given the current 17 | state of the edgelist. 18 | } 19 | \keyword{module} 20 | \keyword{msm} 21 | -------------------------------------------------------------------------------- /man/stitx_msm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod.stitx.R 3 | \name{stitx_msm} 4 | \alias{stitx_msm} 5 | \title{STI Treatment Module} 6 | \usage{ 7 | stitx_msm(dat, at) 8 | } 9 | \arguments{ 10 | \item{dat}{Master data list object of class \code{dat} containing networks, 11 | individual-level attributes, and summary statistics.} 12 | 13 | \item{at}{Current time step.} 14 | } 15 | \description{ 16 | Stochastically simulates GC/CT diagnosis and treatment. 17 | } 18 | \keyword{module} 19 | \keyword{msm} 20 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(EpiModelHIV) 3 | 4 | test_check("EpiModelHIV") 5 | -------------------------------------------------------------------------------- /tests/testthat/test-estimation.R: -------------------------------------------------------------------------------- 1 | context("Network Initialization and Summary Statistics") 2 | -------------------------------------------------------------------------------- /tests/testthat/test-params.R: -------------------------------------------------------------------------------- 1 | context("Assigning Epidemic Parameters, Initial Conditions and Model Controls") 2 | --------------------------------------------------------------------------------