more unit tests on basic functions

R/param_formats.R

@@ -39,18 +39,13 @@ expand_params <- function(params, expandedParNames,U){
 #' @rdname param_formats
 #' @export
 contract_params <- function(params, expandedParNames,U,average=FALSE){
-if(0){
-p_expanded <- c(a1=0,b1=0,b2=1,b3=2,c1=4,c2=4,c3=4)
-params <- p_expanded
-expandedParNames="c"
-U=3
-average=F
-}
-  expanded <- unlist(lapply(expandedParNames,function(par) params[paste0(par,1:U)]))
+
+  expanded <- unlist(lapply(expandedParNames,
+    function(par) params[paste0(par,1:U)]))
   unexpanded <- params[setdiff(names(params),names(expanded))]
   contracted <- unlist(lapply(expandedParNames,function(par){
     x <- params[paste0(par,1:U)]
-    if(sd(x)>0 & !average) stop ("cannot contract unequal parameters unless average=TRUE")
+    if(sd(x)>0 & !average) pStop_("in ", sQuote(contract_params), " : cannot contract unequal parameters unless average=TRUE")
     x <- mean(x)
     names(x) <- paste0(par,'1')
     x

src/dunit_measure.c

@@ -80,11 +80,6 @@ SEXP do_dunit_measure (SEXP object, SEXP y, SEXP x, SEXP times, SEXP units, SEXP
 
   switch (mode) {
 
-  case Rfun: {
-  }
-
-    break;
-
   case native: case regNative: {
     int *oidx, *sidx, *pidx, *cidx;
     int give_log;

src/eunit_measure.c

@@ -78,11 +78,6 @@ SEXP do_eunit_measure (SEXP object, SEXP X, SEXP Np, SEXP times, SEXP params, SE
   PROTECT(F = ret_array(nunits, nreps, ntimes)); nprotect++;
   switch (mode) {
 
-  case Rfun: {
-  }
-
-    break;
-
   case native: case regNative: {
     int *oidx, *sidx, *pidx, *cidx;
     spatPomp_unit_measure_var *ffthetatoe = NULL;

src/munit_measure.c

@@ -13,7 +13,7 @@ SEXP do_munit_measure(SEXP object, SEXP X, SEXP vc, SEXP Np, SEXP times, SEXP pa
   SEXP Snames, Pnames, Cnames, Onames;
   SEXP cvec, pompfun;
   SEXP fn, args;
-  SEXP F = NULL, mparams;
+  SEXP mparams;
   SEXP x;
   SEXP unitnames;
   int *dim;
@@ -69,47 +69,6 @@ SEXP do_munit_measure(SEXP object, SEXP X, SEXP vc, SEXP Np, SEXP times, SEXP pa
   // PROTECT(F = ret_array(npars, nunits, nreps, ntimes)); nprotect++;
   switch (mode) {
 
-  case Rfun: {
-    //double *ys = REAL(y), *xs = REAL(x), *ps = REAL(params), *time = REAL(times);
-    //double *ft = REAL(F);
-    //int j, k;
-
-    // build argument list
-    //PROTECT(args = dmeas_args(args,Onames,Snames,Pnames,Cnames,log)); nprotect++;
-
-    //for (k = 0; k < ntimes; k++, time++, ys += nobs) { // loop over times
-
-    //R_CheckUserInterrupt();	// check for user interrupt
-
-    //table_lookup(&covariate_table,*time,cov); // interpolate the covariates
-
-    //for (j = 0; j < nreps; j++, ft++) { // loop over replicates
-
-    // evaluate the call
-    //PROTECT(
-    //ans = eval_call(
-    //fn,args,
-    //time,
-    //ys,nobs,
-    //xs+nvars*((j%nrepsx)+nrepsx*k),nvars,
-    //ps+npars*(j%nrepsp),npars,
-    //cov,ncovars
-    //)
-    //);
-
-    //if (k == 0 && j == 0 && LENGTH(ans) != 1)
-    //errorcall(R_NilValue,"user 'dmeasure' returns a vector of length %d when it should return a scalar.",LENGTH(ans));
-
-    //*ft = *(REAL(AS_NUMERIC(ans)));
-
-    //UNPROTECT(1);
-
-    //}
-    //}
-  }
-
-    break;
-
   case native: case regNative: {
     int *oidx, *sidx, *pidx, *cidx;
     spatPomp_unit_mmeasure *ff = NULL;
@@ -146,7 +105,7 @@ SEXP do_munit_measure(SEXP object, SEXP X, SEXP vc, SEXP Np, SEXP times, SEXP pa
     break;
 
   default: {
-    double *ft = REAL(F);
+    double *ft = REAL(mparams);
     int j, k;
 
     for (k = 0; k < ntimes; k++) { // loop over times

src/runit_measure.c

@@ -80,11 +80,6 @@ SEXP do_runit_measure (SEXP object, SEXP x, SEXP times, SEXP units, SEXP params,
   // first do setup
   switch (mode) {
 
-  case Rfun: {
-  }
-
-    break;
-
   case native: case regNative: {
     double *yt = 0, *xp, *pp;
     int *unit = INTEGER(units);

src/vunit_measure.c

@@ -72,11 +72,7 @@ SEXP do_vunit_measure (SEXP object, SEXP X, SEXP Np, SEXP times, SEXP params, SE
   // create array to store results
   PROTECT(F = ret_array(nunits, nreps, ntimes)); nprotect++;
   switch (mode) {
-  case Rfun: {
-  }
-
-    break;
-
+
   case native: case regNative: {
     int *oidx, *sidx, *pidx, *cidx;
     spatPomp_unit_measure_var *ffthetatov = NULL;

tests/bm.R

@@ -43,6 +43,7 @@ b_model_no_eunit_measure <- spatPomp(b_model,eunit_measure=NULL)
 b_model_no_vunit_measure <- spatPomp(b_model,vunit_measure=NULL)
 b_model_no_runit_measure <- spatPomp(b_model,runit_measure=NULL)
 b_model_no_dunit_measure <- spatPomp(b_model,dunit_measure=NULL)
+b_model_no_munit_measure <- spatPomp(b_model,munit_measure=NULL)
 b_model_t0_equal_t1 <- spatPomp(b_model,t0=1)
 b_model5 <- bm(U=U,N=5) 
 b_model_with_accumvars <- b_model
@@ -622,6 +623,24 @@ try(runit_measure(b_model_no_runit_measure, x=b_s, unit=2, time=numeric(0), para
 try(runit_measure(b_model_no_runit_measure, x=b_s, unit=2, time=1:10, params=b_p))
 try(runit_measure(b_model_no_runit_measure, x=b_s2, unit=2, time=1:10, params=b_p2))
 
+## trigger error messages in vunit_measure.c
+vunit_measure(b_model_no_vunit_measure, x=b_s, unit=2, time=1, params=b_p)
+try(vunit_measure(b_model, x=b_s, unit=2, time=1:10, params=b_p))
+try(vunit_measure(b_model, x=b_s2, unit=2, time=1, params=b_p2))
+
+## trigger error messages in eunit_measure.c
+eunit_measure(b_model_no_eunit_measure, x=b_s, unit=2, time=1, params=b_p)
+try(eunit_measure(b_model, x=b_s, unit=2, time=1:10, params=b_p))
+try(eunit_measure(b_model, x=b_s2, unit=2, time=1, params=b_p2))
+
+## trigger error messages in munit_measure.c
+munit_measure(b_model_no_munit_measure, x=b_s, vc=b_vc, Np=1, unit = 2, time=1, params=b_array.params)
+try(munit_measure(b_model, x=b_s, vc=b_vc, Np=1, unit = 2, time=1:10,params=b_array.params))
+b_array.params2 <- array(c(b_p,b_p),
+  dim = c(length(b_p),length(unit_names(b_model)), 2, 1),
+  dimnames = list(params = rownames(b_p)))
+try(munit_measure(b_model, x=b_s2, vc=b_vc, Np=3, unit = 2, time=1,params=b_array.params2))
+
 ## test spatPomp_Csnippet variable construction
 spatPomp_Csnippet("lik=u;",unit_statenames="A",unit_obsnames=c("B","C"),
   unit_covarnames="D",

tests/bm.Rout.save

@@ -63,6 +63,7 @@ Loading required package: pomp
 > b_model_no_vunit_measure <- spatPomp(b_model,vunit_measure=NULL)
 > b_model_no_runit_measure <- spatPomp(b_model,runit_measure=NULL)
 > b_model_no_dunit_measure <- spatPomp(b_model,dunit_measure=NULL)
+> b_model_no_munit_measure <- spatPomp(b_model,munit_measure=NULL)
 > b_model_t0_equal_t1 <- spatPomp(b_model,t0=1)
 > b_model5 <- bm(U=U,N=5) 
 > b_model_with_accumvars <- b_model
@@ -981,6 +982,58 @@ Error : length of 'times' and 3rd dimension of 'x' do not agree.
 > try(runit_measure(b_model_no_runit_measure, x=b_s2, unit=2, time=1:10, params=b_p2))
 Error : length of 'times' and 3rd dimension of 'x' do not agree.
 > 
+> ## trigger error messages in vunit_measure.c
+> vunit_measure(b_model_no_vunit_measure, x=b_s, unit=2, time=1, params=b_p)
+, , 1
+
+      rep
+unit   [,1]
+  [1,]   NA
+
+Warning message:
+'vunit_measure' unspecified. 
+> try(vunit_measure(b_model, x=b_s, unit=2, time=1:10, params=b_p))
+Error : length of 'times' and 3rd dimension of 'x' do not agree.
+> try(vunit_measure(b_model, x=b_s2, unit=2, time=1, params=b_p2))
+Error : larger number of replicates is not a multiple of smaller.
+> 
+> ## trigger error messages in eunit_measure.c
+> eunit_measure(b_model_no_eunit_measure, x=b_s, unit=2, time=1, params=b_p)
+, , 1
+
+      rep
+unit   [,1]
+  [1,]   NA
+
+Warning message:
+'eunit_measure' unspecified. 
+> try(eunit_measure(b_model, x=b_s, unit=2, time=1:10, params=b_p))
+Error : length of 'times' and 3rd dimension of 'x' do not agree.
+> try(eunit_measure(b_model, x=b_s2, unit=2, time=1, params=b_p2))
+Error : larger number of replicates is not a multiple of smaller.
+> 
+> ## trigger error messages in munit_measure.c
+> munit_measure(b_model_no_munit_measure, x=b_s, vc=b_vc, Np=1, unit = 2, time=1, params=b_array.params)
+, , 1, 1
+
+
+params  [,1]
+  rho    0.4
+  sigma  1.0
+  tau    1.0
+  X1_0   0.0
+  X2_0   0.0
+
+Warning message:
+'munit_measure' unspecified. 
+> try(munit_measure(b_model, x=b_s, vc=b_vc, Np=1, unit = 2, time=1:10,params=b_array.params))
+Error : length of 'times' and 3rd dimension of 'x' do not agree.
+> b_array.params2 <- array(c(b_p,b_p),
++   dim = c(length(b_p),length(unit_names(b_model)), 2, 1),
++   dimnames = list(params = rownames(b_p)))
+> try(munit_measure(b_model, x=b_s2, vc=b_vc, Np=3, unit = 2, time=1,params=b_array.params2))
+Error : larger number of replicates is not a multiple of smaller.
+> 
 > ## test spatPomp_Csnippet variable construction
 > spatPomp_Csnippet("lik=u;",unit_statenames="A",unit_obsnames=c("B","C"),
 +   unit_covarnames="D",

tests/iter_filter.R

@@ -14,8 +14,6 @@ try(spatPomp:::perturbn.kernel.sd(rw.sd=rw_sd(0.02)))
 try(spatPomp:::perturbn.kernel.sd(rw.sd=rw_sd(rho=1:10,X1_0=ivp(0.02)),1:2,
   paramnames=c("rho","X1_0")))
 
-spatPomp:::safecall()
-
 spatPomp:::perturbn.kernel.sd(
   rw.sd=matrix(c(0.01,0.02),nrow=2,ncol=2,
     dimnames=list(c("rho","X1_0"),NULL)), 1:2, paramnames=c("rho","X1_0"))
@@ -24,6 +22,17 @@ spatPomp:::perturbn.kernel.sd(
 frac_test <- spatPomp:::mif2.cooling("hyperbolic",fraction=1.5,ntimes=5)
 frac_test(5,1)
 
+## also use this test file for some other miscelaneous edge cases
+
+spatPomp:::safecall()
+
+
+## some unused error message mechanics, which may be used in future
+spatPomp:::pWarn_("testing")
+try(spatPomp:::reqd_arg(NULL,"JUNK"))
+spatPomp:::invalid_names(NULL)
+
+
 
 
 

tests/iter_filter.Rout.save

@@ -37,15 +37,6 @@ Error : in ‘rw.sd’: parameters must be referenced by name.
 > try(spatPomp:::perturbn.kernel.sd(rw.sd=rw_sd(rho=1:10,X1_0=ivp(0.02)),1:2,
 +   paramnames=c("rho","X1_0")))
 Error : ‘rw.sd’ spec for parameter ‘rho’ does not evaluate to a vector of the correct length (‘length(time(object))’=2).
-> 
-> spatPomp:::safecall()
-An object of class "safecall"
-Slot "call":
-spatPomp:::safecall()
-
-Slot "envir":
-<environment: R_GlobalEnv>
-
 > 
 > spatPomp:::perturbn.kernel.sd(
 +   rw.sd=matrix(c(0.01,0.02),nrow=2,ncol=2,
@@ -63,6 +54,28 @@ $alpha
 $gamma
 [1] 1
 
+> 
+> ## also use this test file for some other miscelaneous edge cases
+> 
+> spatPomp:::safecall()
+An object of class "safecall"
+Slot "call":
+spatPomp:::safecall()
+
+Slot "envir":
+<environment: R_GlobalEnv>
+
+> 
+> 
+> ## some unused error message mechanics, which may be used in future
+> spatPomp:::pWarn_("testing")
+Warning message:
+testing 
+> try(spatPomp:::reqd_arg(NULL,"JUNK"))
+Error : ‘JUNK’ is a required argument.
+> spatPomp:::invalid_names(NULL)
+[1] TRUE
+> 
 > 
 > 
 > 

tests/param_formats.R

@@ -2,8 +2,12 @@
 library(spatPomp)
 
 p_expanded <- c(a1=0,b1=0,b2=1,b3=2,c1=4,c2=4,c3=4)
+p_expanded_unequal <- c(a1=0,b1=0,b2=1,b3=2,c1=4,c2=4,c3=5)
 
 p_contracted <- contract_params(p_expanded,expandedParNames="c",U=3)
+
+try(contract_params(p_expanded_unequal,
+  expandedParNames="c",U=3,average=FALSE))
 
 p_contracted
 

tests/param_formats.Rout.save

@@ -22,8 +22,13 @@ Type 'q()' to quit R.
 Loading required package: pomp
 > 
 > p_expanded <- c(a1=0,b1=0,b2=1,b3=2,c1=4,c2=4,c3=4)
+> p_expanded_unequal <- c(a1=0,b1=0,b2=1,b3=2,c1=4,c2=4,c3=5)
 > 
 > p_contracted <- contract_params(p_expanded,expandedParNames="c",U=3)
+> 
+> try(contract_params(p_expanded_unequal,
++   expandedParNames="c",U=3,average=FALSE))
+Error in sQutote(contract_params) : could not find function "sQutote"
 >   
 > p_contracted
 a1 b1 b2 b3 c1