Added demographic cases

NAMESPACE

@@ -6,6 +6,7 @@ S3method(AvailableSugar,forced)
 S3method(AvailableSugar,static)
 S3method(BedNet,none)
 S3method(BedNetEffectSizes,none)
+S3method(Births,static)
 S3method(Births,zero)
 S3method(BloodFeeding,dynamic)
 S3method(BloodFeeding,setup)
@@ -144,6 +145,7 @@ S3method(ar2eir,pois)
 S3method(compute_Omega,dts)
 S3method(compute_Omega,xde)
 S3method(compute_Upsilon,xde)
+S3method(dHdt,matrix)
 S3method(dHdt,zero)
 S3method(dLdt,basicL)
 S3method(dLdt,trivial)
@@ -565,6 +567,7 @@ export(set_eir)
 export(setup_BLOOD_FEEDING)
 export(setup_EGG_LAYING)
 export(setup_EIP)
+export(setup_Hmatrix)
 export(setup_Hpar_static)
 export(setup_Linits)
 export(setup_Lix)
@@ -576,6 +579,7 @@ export(setup_TRANSMISSION)
 export(setup_Xinits)
 export(setup_Xix)
 export(setup_Xpar)
+export(setup_births_static)
 export(setup_care_seeking_no_behavior)
 export(setup_development)
 export(setup_development_func)

R/human-demography-births.R

@@ -7,3 +7,32 @@
 Births.zero <- function(t, y, Hpar){
   0*y
 }
+
+#' @title Derivatives of demographic changes in human populations
+#' @description Implements [Births] for static population models
+#' @inheritParams Births
+#' @return a [numeric] vector of zeros
+#' @export
+Births.static <- function(t, y, Hpar){
+  0*y + Hpar$birth_rate
+}
+
+#' @title Setup a static birth_rate
+#' @description Each model determines the compartment for
+#' births. The birth rate should be a vector of length `nStrata`
+#' where the entries are zero for all but the stratum that
+#' gets newborns.
+#' @param pars a [list]
+#' @param i the host species index
+#' @param birth_rate a birth rate vector
+#' @return an **`xds`** object
+#' @export
+setup_births_static <- function(pars, i, birth_rate) {
+  stopifnot(length(birth_rate) == pars$nStrata[i])
+  Bf <- list()
+  class(Bf) <- "static"
+  Bf$birth_rate <- birth_rate
+  pars$Hpar[[1]]$Bf <- Bf
+
+  return(pars)
+}

R/human-demography-dHdt.R

@@ -1,9 +1,39 @@
 
-#' @title Derivatives of demographic changes in human populations
-#' @description Implements [dHdt] when `y` is static
+#' @title Compute Demographic Changes
+#' @description Return a vector of zeros
 #' @inheritParams dHdt
 #' @return a [numeric] vector of 0s
 #' @export
 dHdt.zero <- function(t, y, Hpar){
   0*y
 }
+
+#' @title Derivatives of demographic changes in human populations
+#' @description Implements [dHdt] when `y` is static
+#' @inheritParams dHdt
+#' @return a [numeric] vector of 0s
+#' @export
+dHdt.matrix <- function(t, y, Hpar){
+  Hpar$Hmatrix %*% y
+}
+
+#' @title Setup a matrix for `dHdt`
+#' @description A demographic matrix should be a
+#' square with dimensions \eqn{n_h \times n_h},
+#' where \eqn{n_n=} `nStrata.` The column sums give
+#' the background death rate for individuals
+#' in the stratum.
+#' @param pars a [list]
+#' @param i the host species index
+#' @param Hmatrix a demographic matrix
+#' @return an **`xds`** object
+#' @export
+setup_Hmatrix <- function(pars, i, Hmatrix) {
+  stopifnot(dim(Hmatrix) == c(pars$nStrata[i], pars$nStrata[i]))
+  dH <- list()
+  class(dH) <- "matrix"
+  dH$Hmatrix <- Hmatrix
+  pars$Hpar[[1]]$dH <- dH
+
+  return(pars)
+}

R/human-demography-interface.R

@@ -68,4 +68,3 @@ make_parameters_demography_null <- function(pars, H) {
   return(pars)
 }
 
-

R/xde_cohort.R

@@ -71,10 +71,14 @@ xds_solve_cohort = function(pars, bday=0, A = 10, da = 10){
   xde_cohort_desolve(bday, y0, age, pars) -> deout
   de_vars <- deout[,-1]
 
-  pars$outputs$cohort <- parse_orbits(de_vars, pars)$XH[[1]]
-  pars$outputs$cohort$age <- age
-  pars$outputs$cohort$time <- age+bday
-  pars$outputs$cohort$eir <- with(pars, F_eir(age, bday))
+  pars$outputs$orbits <- list()
+  pars$outputs$orbits$XH <- list()
+  pars$outputs$orbits$XH[[1]] <- parse_orbits(de_vars, pars)$XH[[1]]
+  pars$outputs$last_y <- tail(de_vars, 1)
+  pars$outputs$orbits$age <- age
+  pars$outputs$orbits$time <- age+bday
+  pars$outputs$orbits$terms <- list()
+  pars$outputs$orbits$terms$EIR<- with(pars, F_eir(age, bday))
   return(pars)
 }
 

_pkgdown.yml

@@ -671,21 +671,20 @@ reference:
   - add_lines_X_SIS
   - xde_steady_state_X.SIS
   - dts_steady_state_X.SIS
-
 - title: Human Population Dynamics
   desc: |
-    Generic methods for the human demography and aging
+    Methods for the human demography and aging
   contents:
   - dHdt
   - setup_Hpar_static
   - Births
   - make_parameters_demography_null
-- subtitle: static
-  desc: |
-    Specialized methods for the static (constant) demographic model
-  contents:
   - Births.zero
   - dHdt.zero
+  - Births.static
+  - setup_births_static
+  - dHdt.matrix
+  - setup_Hmatrix
 - subtitle: Care Seeking
   desc: |
     Methods to implement care seeking

docs/pkgdown.yml

@@ -25,7 +25,7 @@ articles:
   Understanding_ramp.xds: Understanding_ramp.xds.html
   VectorControl: VectorControl.html
   Working: Working.html
-last_built: 2024-10-04T00:38Z
+last_built: 2024-10-09T14:34Z
 urls:
   reference: https://dd-harp.github.io/ramp.xds/reference
   article: https://dd-harp.github.io/ramp.xds/articles

vignettes/human_hmoi.Rmd

@@ -139,21 +139,22 @@ y0
 
 
 ```{r}
-out1 <- xds_solve_cohort(params)$outputs$cohort
+params <- xds_solve_cohort(params) 
+out1 <- params$outputs$orbits
 ```
 
 
 ```{r, out.width = "100%"}
+XH <- out1$XH[[1]] 
+age <- out1$age
 clrs = turbo(5)
-with(out1,{
-  plot(age, m1[,1], col = clrs[1], ylim = range(m1), type = "l")
-  lines(age, m1[,2], col = clrs[2])
-  lines(age, m1[,3], col =clrs[5])
+plot(age, XH$m1[,1], col = clrs[1], ylim = range(XH$m1), type = "l")
+lines(age, XH$m1[,2], col = clrs[2])
+lines(age, XH$m1[,3], col =clrs[5])
 
-  lines(age, m2[,1], col = clrs[1], lty = 2)
-  lines(age, m2[,2], col = clrs[2], lty=2)
-  lines(age, m2[,3], col =clrs[5], lty=2)
-})
+lines(age, XH$m2[,1], col = clrs[1], lty = 2)
+lines(age, XH$m2[,2], col = clrs[2], lty=2)
+lines(age, XH$m2[,3], col =clrs[5], lty=2)
 ```
 
 # Using Setup
@@ -165,8 +166,9 @@ xds_setup_cohort(eir, Xname="hMoI", HPop=H, Xopts = Xo) ->test_hMoI
 ```
 
 ```{r}
-xds_solve_cohort(test_hMoI)$outputs$cohort -> out2
-sum((out2$XH[[1]]$m1-out1$XH[[1]]$m1)^2)
+xds_solve_cohort(test_hMoI)-> test_hMoI 
+XH2 <- params$outputs$orbits$XH[[1]]
+sum((XH$m1-XH$m1)^2)
 ```