Add branch files

DESCRIPTION

@@ -28,6 +28,6 @@ Suggests:
     knitr,
     testthat
 VignetteBuilder: knitr
-RoxygenNote: 6.1.1
+RoxygenNote: 7.1.1
 LazyData: true
 Encoding: UTF-8

R/mod.acts.R

@@ -23,6 +23,8 @@ acts_msm <- function(dat, at) {
   status <- dat$attr$status
   diag.status <- dat$attr$diag.status
   race <- dat$attr$race
+  geog.lvl <- dat$param$netstats$geog.lvl
+  race.flag <- dat$param$netstats$race
   age <- dat$attr$age
   stage <- dat$attr$stage
   vl <- dat$attr$vl
@@ -33,7 +35,8 @@ acts_msm <- function(dat, at) {
   # Parameters
   acts.mod <- dat$param$epistats$acts.mod
   acts.aids.vl <- dat$param$acts.aids.vl
-  acts.scale <- dat$param$acts.scale
+  acts.scale.main <- dat$param$acts.scale.main
+  acts.scale.casl <- dat$param$acts.scale.casl
 
   # Construct edgelist
   el <- rbind(dat$el[[1]], dat$el[[2]], dat$el[[3]])
@@ -72,14 +75,43 @@ acts_msm <- function(dat, at) {
   hiv.concord.pos[cp] <- 1
 
   # Model predictions
-  x <- data.frame(ptype = el.mc[, "ptype"],
-                  duration = durations,
-                  race.combo = race.combo,
-                  comb.age = comb.age,
-                  hiv.concord.pos = hiv.concord.pos,
-                  city = 1)
-  rates <- unname(predict(acts.mod, newdata = x, type = "response"))/52
-  rates <- rates * acts.scale
+  if (!is.null(geog.lvl)) {
+    if (race.flag == TRUE) {
+      x <- data.frame(ptype = el.mc[, "ptype"],
+                      duration = durations,
+                      race.combo = race.combo,
+                      comb.age = comb.age,
+                      hiv.concord.pos = hiv.concord.pos,
+                      geogYN = 1)
+      rates <- unname(predict(acts.mod, newdata = x, type = "response"))/52
+    } else {
+      x <- data.frame(ptype = el.mc[, "ptype"],
+                      duration = durations,
+                      comb.age = comb.age,
+                      hiv.concord.pos = hiv.concord.pos,
+                      geogYN = 1)
+      rates <- unname(predict(acts.mod, newdata = x, type = "response"))/52
+    }
+  } else {
+    if (race.flag == TRUE) {
+      x <- data.frame(ptype = el.mc[, "ptype"],
+                      duration = durations,
+                      race.combo = race.combo,
+                      comb.age = comb.age,
+                      hiv.concord.pos = hiv.concord.pos)
+      rates <- unname(predict(acts.mod, newdata = x, type = "response"))/52
+    } else {
+      x <- data.frame(ptype = el.mc[, "ptype"],
+                      duration = durations,
+                      comb.age = comb.age,
+                      hiv.concord.pos = hiv.concord.pos)
+      rates <- unname(predict(acts.mod, newdata = x, type = "response"))/52
+    }
+  }
+
+  rates[x$ptype == 1] <- rates[x$ptype == 1] * acts.scale.main
+  rates[x$ptype == 2] <- rates[x$ptype == 2] * acts.scale.casl
+
   ai <- rpois(length(rates), rates)
   el.mc <- cbind(el.mc, durations, ai)
 

R/mod.condoms.R

@@ -24,6 +24,8 @@ condoms_msm <- function(dat, at) {
 
   # Attributes
   race <- dat$attr$race
+  race.flag <- dat$param$netstats$race
+  geog.lvl <- dat$param$netstats$race
   age <- dat$attr$age
   diag.status <- dat$attr$diag.status
   prepStat <- dat$attr$prepStat
@@ -55,32 +57,95 @@ condoms_msm <- function(dat, at) {
 
   ## Main/casual partnerships ##
   mc.parts <- which(el[, "ptype"] != 3)
-  el.mc <- el[mc.parts, ]
-
-  x <- data.frame(ptype = el.mc[, "ptype"],
-                  duration = el.mc[, "durations"],
-                  race.combo = race.combo[mc.parts],
-                  comb.age = comb.age[mc.parts],
-                  hiv.concord.pos = hiv.concord.pos[mc.parts],
-                  prep = any.prep[mc.parts],
-                  city = 1)
-  cond.prob <- unname(predict(cond.mc.mod, newdata = x, type = "response"))
-  el.mc <- cbind(el.mc, cond.prob)
+  el.mc <- el[mc.parts, , drop = FALSE]
+
+  if (nrow(el.mc) > 0) {
+    if (!is.null(geog.lvl)) {
+      if (race.flag == TRUE){
+        x <- data.frame(ptype = el.mc[, "ptype"],
+                        duration = el.mc[, "durations"],
+                        race.combo = race.combo[mc.parts],
+                        comb.age = comb.age[mc.parts],
+                        hiv.concord.pos = hiv.concord.pos[mc.parts],
+                        prep = any.prep[mc.parts],
+                        geogYN = 1)
+        cond.prob <- unname(predict(cond.mc.mod, newdata = x, type = "response"))
+      } else {
+        x <- data.frame(ptype = el.mc[, "ptype"],
+                        duration = el.mc[, "durations"],
+                        comb.age = comb.age[mc.parts],
+                        hiv.concord.pos = hiv.concord.pos[mc.parts],
+                        prep = any.prep[mc.parts],
+                        geogYN = 1)
+        cond.prob <- unname(predict(cond.mc.mod, newdata = x, type = "response"))
+      }
+    } else {
+      if (race.flag == TRUE){
+        x <- data.frame(ptype = el.mc[, "ptype"],
+                        duration = el.mc[, "durations"],
+                        race.combo = race.combo[mc.parts],
+                        comb.age = comb.age[mc.parts],
+                        hiv.concord.pos = hiv.concord.pos[mc.parts],
+                        prep = any.prep[mc.parts])
+        cond.prob <- unname(predict(cond.mc.mod, newdata = x, type = "response"))
+      } else {
+        x <- data.frame(ptype = el.mc[, "ptype"],
+                        duration = el.mc[, "durations"],
+                        comb.age = comb.age[mc.parts],
+                        hiv.concord.pos = hiv.concord.pos[mc.parts],
+                        prep = any.prep[mc.parts])
+        cond.prob <- unname(predict(cond.mc.mod, newdata = x, type = "response"))
+      }
+    }
+    el.mc <- cbind(el.mc, cond.prob)
+  }
 
   ## One-off partnerships ##
   oo.parts <- which(el[, "ptype"] == 3)
-  el.oo <- el[oo.parts, ]
-
-  x <- data.frame(race.combo = race.combo[oo.parts],
-                  comb.age = comb.age[oo.parts],
-                  hiv.concord.pos = hiv.concord.pos[oo.parts],
-                  prep = any.prep[oo.parts],
-                  city = 1)
-  cond.prob <- unname(predict(cond.oo.mod, newdata = x, type = "response"))
-  el.oo <- cbind(el.oo, cond.prob)
-
-  ## Bind el together
-  el <- rbind(el.mc, el.oo)
+  el.oo <- el[oo.parts, , drop = FALSE]
+
+  if (nrow(el.oo) > 0) {
+    if (!is.null(geog.lvl)) {
+      if (race.flag == TRUE){
+        x <- data.frame(race.combo = race.combo[oo.parts],
+                        comb.age = comb.age[oo.parts],
+                        hiv.concord.pos = hiv.concord.pos[oo.parts],
+                        prep = any.prep[oo.parts],
+                        geogYN = 1)
+        cond.prob <- unname(predict(cond.oo.mod, newdata = x, type = "response"))
+        el.oo <- cbind(el.oo, cond.prob)
+      } else {
+        x <- data.frame(comb.age = comb.age[oo.parts],
+                        hiv.concord.pos = hiv.concord.pos[oo.parts],
+                        prep = any.prep[oo.parts],
+                        geogYN = 1)
+        cond.prob <- unname(predict(cond.oo.mod, newdata = x, type = "response"))
+        el.oo <- cbind(el.oo, cond.prob)
+      }
+    } else {
+      if (race.flag == TRUE){
+        x <- data.frame(race.combo = race.combo[oo.parts],
+                        comb.age = comb.age[oo.parts],
+                        hiv.concord.pos = hiv.concord.pos[oo.parts],
+                        prep = any.prep[oo.parts],
+                        geogYN = 1)
+        cond.prob <- unname(predict(cond.oo.mod, newdata = x, type = "response"))
+        el.oo <- cbind(el.oo, cond.prob)
+      } else {
+        x <- data.frame(comb.age = comb.age[oo.parts],
+                        hiv.concord.pos = hiv.concord.pos[oo.parts],
+                        prep = any.prep[oo.parts],
+                        geogYN = 1)
+        cond.prob <- unname(predict(cond.oo.mod, newdata = x, type = "response"))
+        el.oo <- cbind(el.oo, cond.prob)
+      }
+    }
+
+    ## Bind el together
+    el <- rbind(el.mc, el.oo)
+  } else {
+    el <- el.mc
+  }
 
   # Acts
   ai.vec <- el[, "ai"]

R/mod.dat_updater.R

@@ -0,0 +1,86 @@
+#' Update list `x` using the elements of list `new_x`
+#'
+#' @param x a list
+#' @param new_x a list
+#'
+#' @return the full `x` list with the modifications added by `new_x`
+#'
+#' @details
+#' This function updates list `x` by name. If `x` and `new_x` elements are not
+#' named, the function will not work properly.
+#' If a function is provided to replace an element that was originaly not a
+#' function, this function will be applied to the original value.
+update_list <- function(x, new_x) {
+  for (n in names(new_x)) {
+    if (is.list(new_x[[n]])) {
+      x[[n]] <- update_list(x[[n]], new_x[[n]])
+    } else if (is.function(new_x[[n]]) && ! is.function(x[[n]])) {
+      x[[n]] <- new_x[[n]](x[[n]])
+    } else {
+      x[[n]] <- new_x[[n]]
+    }
+  }
+
+  return(x)
+}
+
+#' Module to modify the `param` list at specified time steps during the simulation
+#'
+#' @inheritParams aging_msm
+#'
+#' @details
+#' if a list `dat$param$param_updaters` is present, this module will update the
+#' `param` list with new values at given timesteps.
+#' `dat$control$param_updaters` is a list containing `updaters`. An updater is a
+#' list containing an `at` element telling when the changes will happend, an
+#' optional `verbose` boolean controlling whether to output a message when a
+#' change is made (default = TRUE) and a `param` list similar
+#' to the simulation's `dat$param` list.
+#' if the updater is a function but not the value to replace, the
+#' function will be applied to the current element (see example) .
+#'
+#' @examples
+#'  ## example of a `param_updaters` list
+#'  list(
+#'    list(
+#'      at = 4860,
+#'      param = list(
+#'        hiv.test.rate = rep(0.0128, 3),
+#'        trans.scale = c(1.61, 0.836, 0.622)
+#'      )
+#'    ),
+#'    list(
+#'      at = 5160,
+#'      verbose = FALSE,
+#'      param = list(
+#'        hiv.test.rate = function(x) x * 3,
+#'        trans.scale = function(x) x^2 / 3
+#'      )
+#'    )
+#'  )
+#'
+param_updater <- function(dat, at) {
+  if (is.null(dat$param$param_updaters))
+    return(dat)
+
+  param_updaters <- dat$param$param_updaters
+
+  for (i in seq_along(param_updaters)) {
+    if (at == param_updaters[[i]][["at"]]) {
+      verbose <- param_updaters[[i]][["verbose"]]
+      verbose <- if (is.null(verbose)) TRUE else verbose
+
+      new_params <- param_updaters[[i]][["param"]]
+
+      if (verbose) {
+        message(paste0(
+          "\n\nAt time step = ", at, " the `param` list was modified: \n"))
+        message(str(new_params))
+      }
+
+      dat$param <- update_list(dat$param, new_params)
+    }
+  }
+
+  return(dat)
+}

R/mod.departure.R

@@ -33,14 +33,18 @@ departure_msm <- function(dat, at) {
 
   aids.mr <- dat$param$aids.mr
   asmr <- dat$param$netstats$demog$asmr
+  asmr.row <- apply(as.matrix(age), 1,
+                      FUN = function(x) which(asmr[,"age"] == floor(x)))
+  asmr.temp <- asmr[asmr.row,]
+
 
   idsElig <- which(active == 1)
   rates <- rep(NA, length(idsElig))
 
   races <- sort(unique(race))
   for (i in seq_along(races)) {
     ids.race <- which(race == races[i])
-    rates[ids.race] <- asmr[age[ids.race], i + 1]
+    rates[ids.race] <- asmr.temp[ids.race, i + 1]
   }
   idsDep <- idsElig[rbinom(length(rates), 1, rates) == 1]
 

R/mod.hivtest.R

@@ -87,14 +87,6 @@ hivtest_msm <- function(dat, at) {
 
   dat$epi$tot.neg.tests[at] <- length(tstNeg)
 
-  # number of new diagnoses by timing
-  dat$epi$newDx[at] <- length(tstPos)
-  diag.time <- dat$attr$diag.time
-  dat$epi$newDx45[at] <- length(intersect(tstPos, which(diag.time - inf.time <= 45/7)))
-  dat$epi$newDx140[at] <- length(intersect(tstPos, which(diag.time - inf.time <= 140/7)))
-  dat$epi$newDx200[at] <- length(intersect(tstPos, which(diag.time - inf.time <= 200/7)))
-  dat$epi$newDx2y[at] <- length(intersect(tstPos, which(diag.time - inf.time > 104)))
-
   return(dat)
 }
 

R/mod.hivtrans.R

@@ -236,38 +236,14 @@ hivtrans_msm <- function(dat, at) {
     dat$attr$cuml.time.on.tx[infected] <- 0
     dat$attr$cuml.time.off.tx[infected] <- 0
 
-    # Attributes of transmitter
-    transmitter <- as.numeric(c(disc.ip[trans.ip == 1, 1],
-                                disc.rp[trans.rp == 1, 2]))
-    tab.trans <- table(transmitter)
-    uni.trans <- as.numeric(names(tab.trans))
-    dat$attr$count.trans[uni.trans] <- dat$attr$count.trans[uni.trans] +
-                                       as.numeric(tab.trans)
-   }
+  }
 
   # Summary Output
   dat$epi$incid[at] <- length(infected)
   dat$epi$incid.B[at] <- sum(dat$attr$race[infected] == 1)
   dat$epi$incid.H[at] <- sum(dat$attr$race[infected] == 2)
   dat$epi$incid.W[at] <- sum(dat$attr$race[infected] == 3)
 
-  if (length(infected) > 0) {
-    dat$epi$incid.undx[at] <- sum(dat$attr$diag.status[transmitter] == 0)
-    dat$epi$incid.dx[at] <- sum(dat$attr$diag.status[transmitter] == 1 &
-                                dat$attr$cuml.time.on.tx[transmitter] == 0)
-    dat$epi$incid.linked[at] <- sum(dat$attr$diag.status[transmitter] == 1 &
-                                    dat$attr$cuml.time.on.tx[transmitter] > 0 &
-                                    dat$attr$vl[transmitter] > log10(200))
-    dat$epi$incid.vsupp[at] <- sum(dat$attr$diag.status[transmitter] == 1 &
-                                   dat$attr$cuml.time.on.tx[transmitter] > 0 &
-                                   dat$attr$vl[transmitter] <= log10(200))
-  } else {
-    dat$epi$incid.undx[at] <- 0
-    dat$epi$incid.dx[at] <- 0
-    dat$epi$incid.linked[at] <- 0
-    dat$epi$incid.vsupp[at] <- 0
-  }
-
   return(dat)
 }