From 486bf59a770658e94c49a0eade3c9804932a075b Mon Sep 17 00:00:00 2001 From: Ed Ionides Date: Tue, 30 Apr 2024 22:10:05 -0400 Subject: [PATCH] more unit tests on basic functions --- R/param_formats.R | 13 +++------ src/dunit_measure.c | 5 ---- src/eunit_measure.c | 5 ---- src/munit_measure.c | 45 ++--------------------------- src/runit_measure.c | 5 ---- src/vunit_measure.c | 6 +--- tests/bm.R | 19 +++++++++++++ tests/bm.Rout.save | 53 +++++++++++++++++++++++++++++++++++ tests/iter_filter.R | 13 +++++++-- tests/iter_filter.Rout.save | 31 ++++++++++++++------ tests/param_formats.R | 4 +++ tests/param_formats.Rout.save | 5 ++++ 12 files changed, 121 insertions(+), 83 deletions(-) diff --git a/R/param_formats.R b/R/param_formats.R index 8145c59..d718037 100644 --- a/R/param_formats.R +++ b/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 diff --git a/src/dunit_measure.c b/src/dunit_measure.c index 8f95ada..e7fd4e8 100644 --- a/src/dunit_measure.c +++ b/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; diff --git a/src/eunit_measure.c b/src/eunit_measure.c index 91aec2f..306404b 100644 --- a/src/eunit_measure.c +++ b/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; diff --git a/src/munit_measure.c b/src/munit_measure.c index 037e19f..924798b 100644 --- a/src/munit_measure.c +++ b/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 diff --git a/src/runit_measure.c b/src/runit_measure.c index b157ce6..f4c976a 100644 --- a/src/runit_measure.c +++ b/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); diff --git a/src/vunit_measure.c b/src/vunit_measure.c index 8dac833..c2f41cc 100644 --- a/src/vunit_measure.c +++ b/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; diff --git a/tests/bm.R b/tests/bm.R index 3cdd66c..7fbe4a1 100644 --- a/tests/bm.R +++ b/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", diff --git a/tests/bm.Rout.save b/tests/bm.Rout.save index 54b5f0f..130f89b 100644 --- a/tests/bm.Rout.save +++ b/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", diff --git a/tests/iter_filter.R b/tests/iter_filter.R index 45d0812..278eb2c 100644 --- a/tests/iter_filter.R +++ b/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) + + diff --git a/tests/iter_filter.Rout.save b/tests/iter_filter.Rout.save index aa4f0ea..f662861 100644 --- a/tests/iter_filter.Rout.save +++ b/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": - - > > 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": + + +> +> +> ## 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 +> > > > diff --git a/tests/param_formats.R b/tests/param_formats.R index f2fe739..4e24776 100644 --- a/tests/param_formats.R +++ b/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 diff --git a/tests/param_formats.Rout.save b/tests/param_formats.Rout.save index 12b90a5..85b9095 100644 --- a/tests/param_formats.Rout.save +++ b/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