Merge pull request #164 from dd-harp/dev

Dev
dd-harp · Feb 1, 2024 · f7d6d14 · f7d6d14
2 parents 6302f57 + d9d474b
commit f7d6d14
Show file tree

Hide file tree

Showing 37 changed files with 248 additions and 151 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -15,6 +15,7 @@ S3method(AvailableSugar,forced)
 S3method(AvailableSugar,static)
 S3method(BedNetEffectSizes,lemenach)
 S3method(BedNetEffectSizes,null)
+S3method(BedNetEffects,lemenach)
 S3method(BedNetEffects,null)
 S3method(Behavior,forced)
 S3method(Behavior,null)
@@ -87,12 +88,12 @@ S3method(HTC,SIS)
 S3method(HTC,hMoI)
 S3method(HabitatDynamics,static)
 S3method(Hydrology,null)
-S3method(IRSeffectSizes,null)
-S3method(IRSeffects,null)
+S3method(IRS_EffectSizes,null)
+S3method(IRS_Effects,null)
 S3method(LBionomics,basic)
 S3method(LBionomics,trace)
-S3method(LSMeffectSizes,null)
-S3method(LSMeffects,null)
+S3method(LSM_EffectSizes,null)
+S3method(LSM_Effects,null)
 S3method(LocalFrac,dynamic)
 S3method(LocalFrac,static)
 S3method(MBionomics,GeRM)
@@ -296,11 +297,11 @@ export(F_tau)
 export(HTC)
 export(HabitatDynamics)
 export(Hydrology)
-export(IRSeffectSizes)
-export(IRSeffects)
+export(IRS_EffectSizes)
+export(IRS_Effects)
 export(LBionomics)
-export(LSMeffectSizes)
-export(LSMeffects)
+export(LSM_EffectSizes)
+export(LSM_Effects)
 export(LocalFrac)
 export(MBionomics)
 export(MassMedical)

diff --git a/R/area_spray.R b/R/area_spray.R
@@ -63,7 +63,6 @@ AreaSprayEffectSizes.null <- function(t, pars) {
 #' @return [list]
 #' @export
 setup_area_spray_null <- function(pars) {
-  pars = setup_vc_control(pars)
   AREA_SPRAY <- list()
   class(AREA_SPRAY) <- 'null'
   pars$AREA_SPRAY <- AREA_SPRAY

diff --git a/R/bednet-interface.R b/R/bednet-interface.R
@@ -36,18 +36,20 @@ UseBedNet <- function(t, y, pars) {
 #' @description This method dispatches on the type of `pars$ITNeff`.
 #' @param t current simulation time
 #' @param pars a [list]
+#' @param s the vector species index
 #' @return a [list]
 #' @export
-BedNetEffects <- function(t, pars) {
+BedNetEffects <- function(t, pars, s) {
   UseMethod("BedNetEffects", pars$ITNeff)
 }
 
 #' @title Modify baseline bionomic parameters, called from VectorControlEffectSizes
 #' @description This method dispatches on the type of `pars$ITNefsz`.
 #' @param t current simulation time
 #' @param pars a [list]
+#' @param s the vector species index
 #' @return a [list]
 #' @export
-BedNetEffectSizes <- function(t, pars) {
+BedNetEffectSizes <- function(t, pars, s) {
   UseMethod("BedNetEffectSizes", pars$ITNefsz)
 }
diff --git a/R/bednet-lemenach.R b/R/bednet-lemenach.R
@@ -1,45 +1,44 @@
 # specialized methods for the Le Menach model of ITN based vector control
-# https://malariajournal.biomedcentral.com/articles/10.1186/1475-2875-6-10
 
+# https://malariajournal.biomedcentral.com/articles/10.1186/1475-2875-6-10
 #' @title Modify baseline values due to vector control
 #' @description Implements [BedNetEffectSizes] for the Le Menach ITN model of vector control
 #' @inheritParams BedNetEffectSizes
 #' @return a named [list]
 #' @importFrom stats pexp
 #' @export
-BedNetEffectSizes.lemenach <- function(t, pars) {
+BedNetEffectSizes.lemenach <- function(t, pars, s){
+  with(pars$ITNefsz, with(pars$MYZpar[[s]],{
+    n <- length(f)
 
-  n <- length(pars$MYZpar$f)
+    for (i in seq_len(n)) {
+      tau0 <- (1/f[i]) * tau0_frac
 
-  for (i in seq_len(n)) {
+      p0 <- pexp(q = g[i]*tau0, lower.tail = FALSE)
+      Q0 <- q[i]
+      W <- (1-Q0) + Q0*(1-phi) + Q0*phi*ss
+      Z <- Q0*phi*r
 
-    phi <- pars$ITNpar$cover(t)
+      tau_phi <- tau0
+      tau_phi[1] <- tau0[1]/(1-Z)
 
-    tau0 <- (1/pars$MYZpar$f[i]) * pars$ITNpar$tau0_frac
+      f_phi <- 1 / sum(tau_phi) # feeding rate under control
 
-    p0 <- pexp(q = pars$MYZpar$g[i] * tau0, lower.tail = FALSE)
-    Q0 <- pars$MYZpar$q[i]
-    W <- (1-Q0) + Q0*(1-phi) + Q0*phi*pars$ITNpar$s
-    Z <- Q0*phi*pars$ITNpar$r
+      p_phi <- p0
+      p_phi[1] <- (p0[1] * W) / (1 - Z*p0[1])
 
-    tau_phi <- tau0
-    tau_phi[1] <- tau0[1]/(1-Z)
+      g_phi <- -f_phi*log(prod(p_phi)) # mortality under control
+      q_phi <- (Q0*(1-phi) + Q0*phi*ss)/W # human feeding fraction under control
 
-    f_phi <- 1 / sum(tau_phi) # feeding rate under control
+      pars$MYZpar[[s]]$f[i] <- f_phi
+      pars$MYZpar[[s]]$q[i] <- q_phi
+      pars$MYZpar[[s]]$g[i] <- g_phi
+    }
 
-    p_phi <- p0
-    p_phi[1] <- (p0[1] * W) / (1 - Z*p0[1])
+    return(pars)
+}))}
 
-    g_phi <- -f_phi*log(prod(p_phi)) # mortality under control
-    q_phi <- (Q0*(1-phi) + Q0*phi*pars$ITNpar$s) / W # human feeding fraction under control
 
-    pars$MYZpar$f[i] <- f_phi
-    pars$MYZpar$q[i] <- q_phi
-    pars$MYZpar$g[i] <- g_phi
-  }
-
-  return(pars)
-}
 
 #' @title Make parameters for Le Menach ITN model of vector control
 #' @description This model of ITN based vector control was originally described in \url{https://malariajournal.biomedcentral.com/articles/10.1186/1475-2875-6-10}.
@@ -48,22 +47,37 @@ BedNetEffectSizes.lemenach <- function(t, pars) {
 #' in host seeking/bloodfeeding and resting/oviposition
 #' @param r probability of mosquito being repelled upon contact with ITN
 #' @param s probability of mosquito successfully feeding upon contact with ITN
-#' @param phi a [function] that takes a single argument `t` and returns the level of ITN coverage at that time
+#' @param F_phi a [function] that takes as argument `t` and `pars` and returns the level of ITN coverage at that time
 #' @return none
 #' @export
-setup_itn_lemenach <- function(pars, tau0_frac = c(0.68/3, 2.32/3), r = 0.56, s = 0.03, phi = function(t) {.8} ) {
+setup_itn_lemenach <- function(pars, tau0_frac = c(0.68/3, 2.32/3), r = 0.56, s = 0.03, F_phi = function(t, pars){.8} ) {
   stopifnot(sum(tau0_frac) == 1)
-  stopifnot(phi(0) >= 0)
-  stopifnot(phi(0) <= 1)
+  stopifnot(F_phi(0, pars) >= 0)
+  stopifnot(F_phi(0, pars) <= 1)
 
-  ITNpar <- list()
-  class(ITNpar) <- 'lemenach'
+  efsz <- list()
+  class(efsz) <- 'lemenach'
+  efsz$tau0_frac <- tau0_frac
+  efsz$r <- r
+  efsz$ss <- s
+  pars$ITNefsz <- efsz
 
-  ITNpar$tau0_frac <- tau0_frac
-  ITNpar$r <- r
-  ITNpar$s <- s
-  ITNpar$cover <- phi
+  coverage = list()
+  class(coverage) <- "lemenach"
+  coverage$F_phi = F_phi
+  pars$ITNeff = coverage
 
-  pars$ITNefsz <- ITNpar
   return(pars)
 }
+
+#' @title Modify baseline values due to vector control
+#' @description Implements [BedNetEffectSizes] for the Le Menach ITN model of vector control
+#' @inheritParams BedNetEffectSizes
+#' @return a named [list]
+#' @importFrom stats pexp
+#' @export
+BedNetEffects.lemenach <- function(t, pars, s){
+  pars$ITNefsz$phi <- pars$ITNeff$F_phi(t, pars)
+  return(pars)
+}
+
diff --git a/R/bednet-null.R b/R/bednet-null.R
@@ -32,7 +32,7 @@ UseBedNet.null <- function(t, y, pars) {
 #' @inheritParams BedNetEffects
 #' @return a [list]
 #' @export
-BedNetEffects.null <- function(t, pars) {
+BedNetEffects.null <- function(t, pars, s) {
   pars
 }
 
@@ -41,7 +41,7 @@ BedNetEffects.null <- function(t, pars) {
 #' @inheritParams BedNetEffectSizes
 #' @return a [list]
 #' @export
-BedNetEffectSizes.null <- function(t, pars) {
+BedNetEffectSizes.null <- function(t, pars,s) {
   pars
 }
 
@@ -51,11 +51,11 @@ BedNetEffectSizes.null <- function(t, pars) {
 #' @export
 setup_itn_null <- function(pars) {
   ITN<- list()
-  class(ITN) <- 'null'
-  pars$ITNdist<- ITN
-  pars$ITNown<- ITN
-  pars$ITNuse<- ITN
-  pars$ITNeff<- ITN
-  pars$ITNefsz<- ITN
+  class(ITN)   <- 'null'
+  pars$ITNdist <- ITN
+  pars$ITNown  <- ITN
+  pars$ITNuse  <- ITN
+  pars$ITNeff  <- ITN
+  pars$ITNefsz <- ITN
   return(pars)
 }
diff --git a/R/irs-interface.R b/R/irs-interface.R
@@ -16,8 +16,8 @@ SprayHouses <- function(t, pars) {
 #' @param pars a [list]
 #' @return a [list]
 #' @export
-IRSeffects <- function(t, pars) {
-  UseMethod("IRS_effects", pars$IRS)
+IRS_Effects <- function(t, pars) {
+  UseMethod("IRS_Effects", pars$IRS)
 }
 
 #' @title Model IRS effect sizes
@@ -26,6 +26,6 @@ IRSeffects <- function(t, pars) {
 #' @param pars a [list]
 #' @return a [list]
 #' @export
-IRSeffectSizes <- function(t, pars) {
-  UseMethod("IRSeffectSizes", pars$IRS)
+IRS_EffectSizes <- function(t, pars) {
+  UseMethod("IRS_EffectSizes", pars$IRS)
 }
diff --git a/R/irs-null.R b/R/irs-null.R
@@ -15,15 +15,15 @@ SprayHouses.null <- function(t, pars) {pars}
 #' @param pars a [list]
 #' @return a [list]
 #' @export
-IRSeffects.null <- function(t, pars){pars}
+IRS_Effects.null <- function(t, pars){pars}
 
 #' @title Model IRS effect sizes
 #' @description This method dispatches on the type of `pars$IRS`.
 #' @param t current simulation time
 #' @param pars a [list]
 #' @return a [list]
 #' @export
-IRSeffectSizes.null <- function(t, pars){pars}
+IRS_EffectSizes.null <- function(t, pars){pars}
 
 #' @title Make parameters for the null model of IRS (do nothing)
 #' @param pars a [list]

diff --git a/R/lsm-interface.R b/R/lsm-interface.R
@@ -14,21 +14,19 @@ TreatHabitats <- function(t, pars) {
 #' @title Modify effects of LSM
 #' @description This method dispatches on the type of `pars$LSM`.
 #' @param t current simulation time
-#' @param y the state of the system
 #' @param pars a [list]
 #' @return a [list]
 #' @export
-LSMeffects <- function(t, y, pars) {
-  UseMethod("LSM_effects", pars$LSM)
+LSM_Effects <- function(t, pars) {
+  UseMethod("LSM_Effects", pars$LSM)
 }
 
 #' @title Compute effect sizes of LSM
 #' @description This method dispatches on the type of `pars$LSM`.
 #' @param t current simulation time
-#' @param y the state of the system
 #' @param pars a [list]
 #' @return a [list]
 #' @export
-LSMeffectSizes <- function(t, y, pars) {
-  UseMethod("LSM_effect_size", pars$LSM)
+LSM_EffectSizes <- function(t, pars) {
+  UseMethod("LSM_EffectSizes", pars$LSM)
 }
diff --git a/R/lsm-null.R b/R/lsm-null.R
@@ -11,19 +11,19 @@ TreatHabitats.null <- function(t, pars) {
 
 #' @title Modify effects of LSM, the null model
 #' @description This method dispatches on the type of `pars$LSM`
-#' @inheritParams LSMeffects
+#' @inheritParams LSM_Effects
 #' @return a [list]
 #' @export
-LSMeffects.null <- function(t, y, pars) {
+LSM_Effects.null <- function(t, pars) {
    pars
 }
 
 #' @title Modify effects of LSM, the null model
 #' @description This method dispatches on the type of `pars$LSM`
-#' @inheritParams LSMeffectSizes
+#' @inheritParams LSM_EffectSizes
 #' @return a [list]
 #' @export
-LSMeffectSizes.null <- function(t, y, pars) {
+LSM_EffectSizes.null <- function(t, pars) {
    pars
 }
 
@@ -33,6 +33,7 @@ LSMeffectSizes.null <- function(t, y, pars) {
 #' @export
 setup_lsm_null <- function(pars) {
   LSM <- list()
-  class(LSM) <- 'null'
+  class(LSM) <- "null"
+  pars$LSM <- LSM
   return(pars)
 }
diff --git a/R/sugar_baits-interface.R b/R/sugar_baits-interface.R
@@ -13,22 +13,20 @@ SugarBaits <- function(t, pars) {
 #' @title Methods for the durability and effects of the sugar baits
 #' @description This method dispatches on the type of `pars$SUGAR_BAITS`.
 #' @param t current simulation time
-#' @param y vector of state variables
 #' @param pars a [list]
 #' @return [list]
 #' @export
-SugarBaitEffects <- function(t, y, pars) {
+SugarBaitEffects <- function(t, pars) {
   UseMethod("SugarBaitEffects", pars$SUGAR_BAITS)
 }
 
 #' @title Methods for the effect sizes of the sugar baits
 #' @description This method dispatches on the type of `pars$SUGAR_BAITS`.
 #' @param t current simulation time
-#' @param y vector of state variables
 #' @param pars a [list]
 #' @return [list]
 #' @export
-SugarBaitEffectSizes <- function(t, y, pars) {
+SugarBaitEffectSizes <- function(t, pars) {
   UseMethod("SugarBaitEffectSizes", pars$SUGAR_BAITS)
 }
 

diff --git a/R/sugar_baits-null.R b/R/sugar_baits-null.R
@@ -13,7 +13,7 @@ SugarBaits.null <- function(t, pars) {
 #' @inheritParams SugarBaitEffects
 #' @return [list]
 #' @export
-SugarBaitEffects.null <- function(t, y, pars) {
+SugarBaitEffects.null <- function(t, pars) {
   return(pars)
 }
 
@@ -22,6 +22,6 @@ SugarBaitEffects.null <- function(t, y, pars) {
 #' @inheritParams SugarBaitEffectSizes
 #' @return [list]
 #' @export
-SugarBaitEffectSizes.null <- function(t, y, pars) {
+SugarBaitEffectSizes.null <- function(t, pars) {
   return(pars)
 }