Merge pull request #145 from dd-harp/dev

output formats changed

NAMESPACE

@@ -446,6 +446,7 @@ export(setup_visitors_basic)
 export(setup_visitors_null)
 export(setup_weather_forced)
 export(setup_weather_null)
+export(shapeIt)
 export(travel_malaria)
 export(update_inits)
 export(update_inits_H)

R/adult-GeRM.R

@@ -312,17 +312,18 @@ make_indices_MYZ.GeRM_dde <- function(pars) {
 #' @title Parse the output of deSolve and return variables for the GeRM model
 #' @description Implements [parse_deout_MYZ] for the GeRM model.
 #' @inheritParams parse_deout_MYZ
-#' @return none
+#' @return [list]
 #' @export
 parse_deout_MYZ.GeRM <- function(deout, pars) {
+  time = deout[,1]
   M = deout[,pars$MYZpar$M_ix+1]
   G = deout[,pars$MYZpar$G_ix+1]
   Y = deout[,pars$MYZpar$Y_ix+1]
   Z = deout[,pars$MYZpar$Z_ix+1]
   y = Y/M
   z = Z/M
   gravid = G/M
-  return(list(M=M,G=G,Y=Y,Z=Z,y=y,z=z, gravid=gravid))
+  return(list(time=time, M=M,G=G,Y=Y,Z=Z,y=y,z=z, gravid=gravid))
 }
 
 #' @title Make parameters for a GeRM ODE adult mosquito model

R/adult-Gtrace.R

@@ -90,7 +90,7 @@ make_indices_MYZ.Gtrace <- function(pars) {
 #' @title Parse the output of deSolve and return variables for the Gtrace model
 #' @description Implements [parse_deout_MYZ] for Gtrace
 #' @inheritParams parse_deout_MYZ
-#' @return none
+#' @return [list]
 #' @export
 parse_deout_MYZ.Gtrace <- function(deout, pars) {
   return(list())

R/adult-RM.R

@@ -307,14 +307,15 @@ make_parameters_MYZ_RM <- function(pars, g, sigma, f, q, nu, eggsPerBatch, eip,
 #' @return a [list]
 #' @export
 parse_deout_MYZ.RM <- function(deout, pars) {
+  time = deout[,1]
   M = deout[,pars$MYZpar$M_ix+1]
   P = deout[,pars$MYZpar$P_ix+1]
   Y = deout[,pars$MYZpar$Y_ix+1]
   Z = deout[,pars$MYZpar$Z_ix+1]
   y = Y/M
   z = Z/M
   parous = P/M
-  return(list(M=M, P=P, Y=Y, Z=Z, y=y, z=z, parous))
+  return(list(time=time, M=M, P=P, Y=Y, Z=Z, y=y, z=z, parous))
 }
 
 #' @title Make inits for RM adult mosquito model

R/adult-basicM.R

@@ -164,13 +164,14 @@ make_indices_MYZ.basicM <- function(pars) {
 #' @title Parse the output of deSolve and return variables for the basicM model
 #' @description Implements [parse_deout_MYZ] for the basicM model.
 #' @inheritParams parse_deout_MYZ
-#' @return none
+#' @return [list]
 #' @export
 parse_deout_MYZ.basicM <- function(deout, pars) {
+  time = deout[,1]
   M = deout[,pars$MYZpar$M_ix+1]
   P = deout[,pars$MYZpar$P_ix+1]
   parous = P/M
-  return(list(M=M, P=P, parous=parous))
+  return(list(time=time, M=M, P=P, parous=parous))
 }
 
 #' @title Make parameters for a basic adult mosquito model

R/adult-interface.R

@@ -95,7 +95,7 @@ dMYZdt <- function(t, y, pars, Lambda, kappa) {
 #' @param nPatches a [numeric] value (an integer), the number of patches
 #' @param MYZopts a [list]
 #' @param calK is a [matrix]
-#' @return none
+#' @return [list]
 #' @export
 setup_MYZ = function(pars, MYZname, nPatches=1, MYZopts=list(), calK=diag(1)){
   class(MYZopts) <- MYZname
@@ -105,7 +105,7 @@ setup_MYZ = function(pars, MYZname, nPatches=1, MYZopts=list(), calK=diag(1)){
 #' @title Add indices for adult mosquitoes to parameter list
 #' @description This method dispatches on the type of `pars$MYZpar`.
 #' @param pars a [list]
-#' @return none
+#' @return [list]
 #' @export
 make_indices_MYZ <- function(pars) {
   UseMethod("make_indices_MYZ", pars$MYZpar)
@@ -116,6 +116,7 @@ make_indices_MYZ <- function(pars) {
 #' It computes the variables by name and returns a named list.
 #' @param deout a [matrix] of outputs from deSolve
 #' @param pars a [list] that defines a model
+#' @return [list]
 #' @export
 parse_deout_MYZ <- function(deout, pars) {
   UseMethod("parse_deout_MYZ", pars$MYZpar)

R/aquatic-basic.R

@@ -113,8 +113,9 @@ make_indices_L.basic <- function(pars) {
 #' @return [list]
 #' @export
 parse_deout_L.basic <- function(deout, pars) {
+  time = deout[,1]
   L = deout[,pars$Lpar$L_ix+1]
-  return(list(L=L))
+  return(list(time=time, L=L))
 }
 
 

R/compute.R

@@ -18,12 +18,13 @@ compute_terms <- function(varslist, deout, pars) {
 #' @return [matrix]
 #' @export
 compute_terms.xde <- function(varslist, deout, pars) {
+  time = deout[,1]
   eir = compute_EIR(deout, pars)
   ni = compute_NI(deout, pars)
   kappa = compute_kappa(deout, pars)
   fqZ = compute_fqZ(deout, pars)
   pr = F_pr(varslist, pars)
-  return(list(eir=eir,pr=pr,ni=ni,kappa=kappa,fqZ=fqZ))
+  return(list(time=time,eir=eir,pr=pr,ni=ni,kappa=kappa,fqZ=fqZ))
 }
 
 #' @title Compute dynamical terms
@@ -35,10 +36,12 @@ compute_terms.xde <- function(varslist, deout, pars) {
 #' @return [matrix]
 #' @export
 compute_terms.cohort <- function(varslist, deout, pars) {
-  eir = pars$F_eir(deout[,1], pars)
+  time = deout[,1]
+  d1 = length(time)
+  eir = matrix(pars$F_eir(time, pars), d1, pars$nStrata)
   ni = compute_NI(deout, pars)
   pr = F_pr(varslist, pars)
-  return(list(eir=eir,pr=pr,ni=ni))
+  return(list(time=time,eir=eir,pr=pr,ni=ni))
 }
 
 
@@ -51,11 +54,12 @@ compute_terms.cohort <- function(varslist, deout, pars) {
 #' @return [matrix]
 #' @export
 compute_terms.human<- function(varslist, deout, pars) {
+  time = deout[,1]
   eir = compute_EIR(deout, pars)
   ni = compute_NI(deout, pars)
   fqZ = compute_fqZ(deout, pars)
   pr = F_pr(varslist, pars)
-  return(list(eir=eir,pr=pr,ni=ni,fqZ=fqZ))
+  return(list(time=time,eir=eir,pr=pr,ni=ni,fqZ=fqZ))
 }
 
 #' @title Compute dynamical terms
@@ -84,7 +88,7 @@ compute_terms_steady<- function(varslist, y_eq, pars) {
   kappa <- compute_kappa_ty(0, y_eq, pars)
   fqZ <- F_fqZ(0, y_eq, pars)
   ni <- F_X(0, y_eq, pars)/varslist$XH$H
-  pr <- F_pr(varslist, pars)/varslist$XH$H
+  pr <- F_pr(varslist, pars)
   return(list(eir=eir,pr=pr,kappa=kappa,fqZ=fqZ,ni=ni))
 }
 
@@ -96,8 +100,9 @@ compute_terms_steady<- function(varslist, y_eq, pars) {
 #' @return [matrix]
 #' @export
 compute_EIR <- function(deout, pars) {
-  ix = 1:length(deout[,1])
-  eir = sapply(ix, compute_EIR_i, deout=deout, pars=pars)
+  d1 = length(deout[,1])
+  eir = sapply(1:d1, compute_EIR_i, deout=deout, pars=pars)
+  eir = shapeIt(eir, d1, pars$nStrata)
   return(eir)
 }
 
@@ -137,8 +142,9 @@ compute_EIR_ty <- function(t, y, pars) {
 #' @return [vector]
 #' @export
 compute_fqZ <- function(deout, pars) {
-  ix = 1:length(deout[,1])
-  fqZ = sapply(ix, compute_fqZ_i, deout=deout, pars=pars)
+  d1 = length(deout[,1])
+  fqZ = sapply(1:d1, compute_fqZ_i, deout=deout, pars=pars)
+  fqZ = shapeIt(fqZ, d1, pars$nPatches)
   return(fqZ)
 }
 
@@ -165,8 +171,9 @@ compute_fqZ_i <- function(i, deout, pars) {
 #' @return [numeric] containing the NI
 #' @export
 compute_NI <- function(deout, pars) {
-  ix = 1:length(deout[,1])
-  NI = sapply(ix, compute_NI_i, deout=deout, pars=pars)
+  d1 = length(deout[,1])
+  NI = sapply(1:d1, compute_NI_i, deout=deout, pars=pars)
+  NI = shapeIt(NI, d1, pars$nStrata)
   return(NI)
 }
 
@@ -195,8 +202,9 @@ compute_NI_i <- function(i, deout, pars) {
 #' @return [numeric] containing the kappa
 #' @export
 compute_kappa <- function(deout, pars) {
-  ix = 1:length(deout[,1])
-  kappa = sapply(ix, compute_kappa_i, deout=deout, pars=pars)
+  d1 = length(deout[,1])
+  kappa = sapply(1:d1, compute_kappa_i, deout=deout, pars=pars)
+  kappa = shapeIt(kappa, d1, pars$nPatches)
   return(kappa)
 }
 

R/demography-dynamic.R

@@ -85,9 +85,10 @@ make_parameters_demography_dynamic <- function(pars, H, residence, searchWts, Ta
   Hpar <- list()
   class(Hpar) <- c('dynamic')
   Hpar$H <- H
-  Hpar$residence <- residence
-  Hpar$wts_f <- searchWts
+  Hpar$residence <- checkIt(residence, pars$nStrata, F)
+  Hpar$wts_f <- checkIt(searchWts, pars$nStrata, F)
   Hpar$TaR <- TaR
+  Hpar$rbr <- searchWts*sum(H)/sum(searchWts*H)
   Hpar$birthFpars <- birthFpars
   Hpar$birthXstrata <- birthsXstrata
   Hpar$Hmatrix <- Hmatrix

R/demography-interface.R

@@ -104,8 +104,9 @@ make_parameters_demography_null <- function(pars, H, residence, searchWts, TaR)
   Hpar$H <- H
 
   class(Hpar$H) <- "static"
-  Hpar$residence <- residence
-  Hpar$wts_f <- searchWts
+  Hpar$residence <- checkIt(residence, pars$nStrata, F)
+  Hpar$wts_f <- checkIt(searchWts, pars$nStrata, F)
+  Hpar$rbr <- searchWts*sum(H)/sum(searchWts*H)
   Hpar$TaR <- TaR
 
   birthF <- "null"

R/demography-static.R

@@ -86,8 +86,9 @@ make_parameters_demography_static <- function(pars, H, residence, searchWts, TaR
   class(Hpar) <- c("static")
   Hpar$H <- H
   class(Hpar$H) <- "static"
-  Hpar$residence <- residence
-  Hpar$wts_f <- searchWts
+  Hpar$residence <- checkIt(residence, pars$nStrata, F)
+  Hpar$wts_f <- checkIt(searchWts, pars$nStrata, F)
+  Hpar$rbr <- searchWts*sum(H)/sum(searchWts*H)
   Hpar$TaR <- TaR
 
   Hpar$birthFpars <- birthFpars

R/human-SIP.R

@@ -146,11 +146,12 @@ make_Xinits_SIP = function(pars, Xopts = list(),
 #' @return none
 #' @export
 parse_deout_X.SIP <- function(deout, pars) {
+  time = deout[,1]
   Hlist <- parse_deout_H(deout, pars)
   with(Hlist,{
     X = deout[,pars$Xpar$X_ix+1]
     P = deout[,pars$Xpar$P_ix+1]
-  return(list(X=X,P=P,H=H))
+  return(list(time=time, X=X,P=P,H=H))
 })}
 
 #' @title Add indices for human population to parameter list

R/human-SIS.R

@@ -119,10 +119,11 @@ make_Xinits_SIS = function(pars, Xopts = list(), X0=1){with(Xopts,{
 #' @return none
 #' @export
 parse_deout_X.SIS <- function(deout, pars) {
+  time = deout[,1]
   Hlist <- parse_deout_H(deout, pars)
   with(Hlist,{
     X = deout[,pars$Xpar$X_ix+1]
-    return(list(X=X, H=H))
+    return(list(time=time, X=X, H=H))
 })}
 
 #' @title Compute the HTC for the SIS model

R/human-hMoI.R

@@ -190,11 +190,12 @@ update_inits_X.hMoI <- function(pars, y0) {
 #' @return none
 #' @export
 parse_deout_X.hMoI <- function(deout, pars){
+  time = deout[,1]
   Hlist <- parse_deout_H(deout, pars)
   with(Hlist,{
     m1 = deout[,pars$Xpar$m1_ix+1]
     m2 = deout[,pars$Xpar$m2_ix+1]
-    return(list(H=H,m1=m1,m2=m2))
+    return(list(time=time, H=H,m1=m1,m2=m2))
 })}
 
 #' @title Return initial values as a vector

R/setup.R

@@ -251,6 +251,7 @@ xde_setup_human = function(modelName,
 #' @param F_eir is a function F_eir(t, pars) that returns the daily FoI
 #' @param Xname is a character string defining a X model
 #' @param HPop is the number of humans in each patch
+#' @param searchB is a vector of search weights for blood feeding
 #' @param Xopts a list to configure the X model
 #' @param Hopts a list to configure the H model
 #' @return a [list]
@@ -262,6 +263,7 @@ xde_setup_cohort = function(modelName, F_eir,
 
                            # Model Structure
                            HPop=1000,
+                           searchB = 1,
 
                            # Human Strata / Options
                            Xopts = list(),
@@ -279,7 +281,7 @@ xde_setup_cohort = function(modelName, F_eir,
   pars$nPatches = as.integer(nStrata)
   pars$nStrata = nStrata
 
-  pars = setup_Hpar(pars, HPop, 1:nStrata, rep(1, nStrata), Hopts)
+  pars = setup_Hpar(pars, HPop, 1:nStrata, searchB, Hopts)
 
   # Dynamics
   pars = setup_X(pars, Xname, Xopts)

R/utils.R

@@ -75,18 +75,14 @@ parse_deout <- function(deout, pars){
   varslist = list()
   if ('Lpar' %in% names(pars)) {
     varslist$L = parse_deout_L(deout, pars)
-    varslist$L$time = deout[,1]
   }
   if ('MYZpar' %in% names(pars)) {
     varslist$MYZ = parse_deout_MYZ(deout, pars)
-    varslist$MYZ$time = deout[,1]
   }
   if ('Xpar' %in% names(pars)) {
     varslist$XH = parse_deout_X(deout, pars)
-    varslist$XH$time = deout[,1]
   }
   varslist$terms = compute_terms(varslist, deout, pars)
-  varslist$terms$time = deout[,1]
   varslist$deout = deout
   return(varslist)
 }
@@ -157,6 +153,21 @@ checkIt = function(x, lng, type = "numeric", fixit=TRUE){
   x
 }
 
+#' @title Check the shape and dimensions of an object
+#' @param obj a [numeric] object
+#' @param d1 an [integer]
+#' @param d2 an [integer]
+#' @return [matrix]
+#' @export
+shapeIt = function(obj, d1, d2){
+  Obj = as.matrix(obj)
+  dd = dim(Obj)
+  stopifnot(d1 %in% dd)
+  stopifnot(d2 %in% dd)
+  if(dd[1]!=d1) obj = t(obj)
+  return(obj)
+}
+
 #' @title Set the initial values to the last values of the last simulation
 #' @param pars a [list]
 #' @return y a [numeric] vector

_pkgdown.yml

@@ -724,6 +724,7 @@ reference:
   - diag_inverse
   - approx_equal
   - checkIt
+  - shapeIt
 - title: Compute terms
   contents:
   - compute_terms