improve testing

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: pomp
 Type: Package
 Title: Statistical Inference for Partially Observed Markov Processes
-Version: 5.2.3.3
-Date: 2023-06-21
+Version: 5.2.3.4
+Date: 2023-06-22
 Authors@R: c(person(given=c("Aaron","A."),family="King",role=c("aut","cre"),email="[email protected]",comment=c(ORCID="0000-0001-6159-3207")),
 	  person(given=c("Edward","L."),family="Ionides",role="aut",comment=c(ORCID="0000-0002-4190-0174"))	,
 	  person(given="Carles",family="Bretó",role="aut",comment=c(ORCID="0000-0003-4695-4902")),

R/filter_traj.R

@@ -53,7 +53,7 @@ setMethod(
     if (missing(vars)) {
       x <- object@filter.traj
     } else {
-      x <- object@filter.traj[vars,,drop=FALSE]
+      x <- object@filter.traj[vars,,,drop=FALSE]
     }
     format <- match.arg(format)
     if (format == "data.frame") {

tests/kalman2.R

@@ -61,8 +61,16 @@ kf |> forecast() |> melt() |> sapply(class)
 kf |> forecast(format="d") |> sapply(class)
 kf |> filter_mean() |> melt() |> sapply(class)
 kf |> filter_mean(format="d") |> sapply(class)
+kf |> filter_mean(vars="x") |> dim()
+kf |> filter_mean(vars="x") |> dimnames()
+kf |> filter_mean(vars="x",format="d") |> dim()
+kf |> filter_mean(vars="x",format="d") |> getElement("name") |> unique()
 kf |> pred_mean() |> melt() |> sapply(class)
 kf |> pred_mean(format="d") |> sapply(class)
+kf |> pred_mean(vars="x") |> dim()
+kf |> pred_mean(vars="x") |> dimnames()
+kf |> pred_mean(vars="x",format="d") |> dim()
+kf |> pred_mean(vars="x",format="d") |> getElement("name") |> unique()
 try(kf |> pred_var() |> melt() |> sapply(class))
 try(kf |> pred_var(format="d") |> sapply(class))
 try(kf |> filter_traj() |> melt() |> sapply(class))

tests/kalman2.Rout.save

@@ -102,12 +102,40 @@ NOTE: The provided object 'R' is available for use by POMP basic components.
 > kf |> filter_mean(format="d") |> sapply(class)
        name        time       value 
 "character"   "numeric"   "numeric" 
+> kf |> filter_mean(vars="x") |> dim()
+[1]  1 30
+> kf |> filter_mean(vars="x") |> dimnames()
+$name
+[1] "x"
+
+$time
+ [1] "1"  "2"  "3"  "4"  "5"  "6"  "7"  "8"  "9"  "10" "11" "12" "13" "14" "15"
+[16] "16" "17" "18" "19" "20" "21" "22" "23" "24" "25" "26" "27" "28" "29" "30"
+
+> kf |> filter_mean(vars="x",format="d") |> dim()
+[1] 30  3
+> kf |> filter_mean(vars="x",format="d") |> getElement("name") |> unique()
+[1] "x"
 > kf |> pred_mean() |> melt() |> sapply(class)
        name        time       value 
 "character" "character"   "numeric" 
 > kf |> pred_mean(format="d") |> sapply(class)
        name        time       value 
 "character"   "numeric"   "numeric" 
+> kf |> pred_mean(vars="x") |> dim()
+[1]  1 30
+> kf |> pred_mean(vars="x") |> dimnames()
+$name
+[1] "x"
+
+$time
+ [1] "1"  "2"  "3"  "4"  "5"  "6"  "7"  "8"  "9"  "10" "11" "12" "13" "14" "15"
+[16] "16" "17" "18" "19" "20" "21" "22" "23" "24" "25" "26" "27" "28" "29" "30"
+
+> kf |> pred_mean(vars="x",format="d") |> dim()
+[1] 30  3
+> kf |> pred_mean(vars="x",format="d") |> getElement("name") |> unique()
+[1] "x"
 > try(kf |> pred_var() |> melt() |> sapply(class))
 Error in h(simpleError(msg, call)) : 
   error in evaluating the argument 'data' in selecting a method for function 'melt': 'pred_var' is undefined for 'object' of class 'kalmand_pomp'.

tests/pfilter.R

@@ -61,7 +61,7 @@ theta["alpha_1"] <- 1e60
 try(pfilter(pf,params=theta,pred.var=TRUE))
 
 try(pfilter(pf,rprocess=onestep(
-  function(x, t, params, delta.t, ...)stop("yikes!"))))
+                 function(x, t, params, delta.t, ...)stop("yikes!"))))
 try(pfilter(pf,dmeasure=Csnippet("error(\"ouch!\");")))
 pfilter(pf,dmeasure=function(log,...) -Inf)
 pfilter(pf,dmeasure=function(log,...) -Inf,filter.mean=TRUE)
@@ -72,6 +72,27 @@ pf3 <- pfilter(pf,t0=1,filter.traj=TRUE)
 pf4 <- pfilter(pf,dmeasure=Csnippet("lik = (give_log) ? R_NegInf : 0;"),
   filter.traj=TRUE)
 
+stopifnot(
+  pf2 |> filter_mean() |> dim()==c(2,100),
+  pf2 |> filter_mean(vars="x1") |> dim()==c(1,100),
+  pf2 |> filter_mean(vars=c("x2","x1")) |> dimnames() |> getElement("name")==c("x2","x1"),
+  pf2 |> filter_mean(format="d") |> dim()==c(200,3),
+  pf2 |> filter_mean(vars="x2",format="d") |> dim()==c(100,3),
+  pf2 |> filter_mean(vars="x2",format="d") |> names()==c("name","time","value"),
+  pf2 |> pred_mean() |> dim()==c(2,100),
+  pf2 |> pred_mean(vars="x1") |> dim()==c(1,100),
+  pf2 |> pred_mean(vars=c("x2","x1")) |> dimnames() |> getElement("name")==c("x2","x1"),
+  pf2 |> pred_mean(format="d") |> dim()==c(200,3),
+  pf2 |> pred_mean(vars="x2",format="d") |> dim()==c(100,3),
+  pf2 |> pred_mean(vars="x2",format="d") |> names()==c("name","time","value"),
+  pf2 |> pred_var() |> dim()==c(2,100),
+  pf2 |> pred_var(vars="x1") |> dim()==c(1,100),
+  pf2 |> pred_var(vars=c("x2","x1")) |> dimnames() |> getElement("name")==c("x2","x1"),
+  pf2 |> pred_var(format="d") |> dim()==c(200,3),
+  pf2 |> pred_var(vars="x2",format="d") |> dim()==c(100,3),
+  pf2 |> pred_var(vars="x2",format="d") |> names()==c("name","time","value")
+)
+
 pf1 |> saved_states(format="data") |> names()
 pf1 |> saved_states(format="data") |> dim()
 pf1 |> saved_states() |> melt() |> sapply(class)
@@ -98,6 +119,10 @@ pf2 |> as.data.frame() |> names()
 try(saved_states())
 try(saved_states(NULL))
 try(saved_states("bob"))
+stopifnot(
+  filter_traj(pf1,vars="x2") |> dim()==c(1,1,101),
+  filter_traj(pf1,vars="x2",format="d") |> dim()==c(101,4)
+)
 
 try(ou2 |> as.data.frame() |> pfilter(Np=1000))
 
@@ -108,10 +133,10 @@ ou2 |>
     times="time",t0=0,Np=500,
     params=list(x1_0=-3,x2_0=4),
     rprocess=onestep(
-    step.fun=function(x1,x2,delta.t,...) {
-      setNames(rnorm(n=2,mean=c(x1,x2),sd=5*delta.t),c("x1","x2"))
-    }
-  ),
+      step.fun=function(x1,x2,delta.t,...) {
+        setNames(rnorm(n=2,mean=c(x1,x2),sd=5*delta.t),c("x1","x2"))
+      }
+    ),
     dmeasure=function(x1,x2,y1,y2,...,log) {
       ll <- sum(dnorm(x=c(y1,y2),mean=c(x1,x2),sd=5,log=TRUE))
       if (log) ll else exp(ll)

tests/pfilter.Rout.save

@@ -146,7 +146,7 @@ sigma_3:            2
 Error : in 'pfilter': non-finite state variable: x1
 > 
 > try(pfilter(pf,rprocess=onestep(
-+   function(x, t, params, delta.t, ...)stop("yikes!"))))
++                  function(x, t, params, delta.t, ...)stop("yikes!"))))
 Error : in 'pfilter': in 'rprocess': yikes!
 > try(pfilter(pf,dmeasure=Csnippet("error(\"ouch!\");")))
 Error : in 'pfilter': in 'dmeasure': ouch!
@@ -161,6 +161,27 @@ Error : in 'pfilter': in 'dmeasure': ouch!
 > pf4 <- pfilter(pf,dmeasure=Csnippet("lik = (give_log) ? R_NegInf : 0;"),
 +   filter.traj=TRUE)
 > 
+> stopifnot(
++   pf2 |> filter_mean() |> dim()==c(2,100),
++   pf2 |> filter_mean(vars="x1") |> dim()==c(1,100),
++   pf2 |> filter_mean(vars=c("x2","x1")) |> dimnames() |> getElement("name")==c("x2","x1"),
++   pf2 |> filter_mean(format="d") |> dim()==c(200,3),
++   pf2 |> filter_mean(vars="x2",format="d") |> dim()==c(100,3),
++   pf2 |> filter_mean(vars="x2",format="d") |> names()==c("name","time","value"),
++   pf2 |> pred_mean() |> dim()==c(2,100),
++   pf2 |> pred_mean(vars="x1") |> dim()==c(1,100),
++   pf2 |> pred_mean(vars=c("x2","x1")) |> dimnames() |> getElement("name")==c("x2","x1"),
++   pf2 |> pred_mean(format="d") |> dim()==c(200,3),
++   pf2 |> pred_mean(vars="x2",format="d") |> dim()==c(100,3),
++   pf2 |> pred_mean(vars="x2",format="d") |> names()==c("name","time","value"),
++   pf2 |> pred_var() |> dim()==c(2,100),
++   pf2 |> pred_var(vars="x1") |> dim()==c(1,100),
++   pf2 |> pred_var(vars=c("x2","x1")) |> dimnames() |> getElement("name")==c("x2","x1"),
++   pf2 |> pred_var(format="d") |> dim()==c(200,3),
++   pf2 |> pred_var(vars="x2",format="d") |> dim()==c(100,3),
++   pf2 |> pred_var(vars="x2",format="d") |> names()==c("name","time","value")
++ )
+> 
 > pf1 |> saved_states(format="data") |> names()
 [1] "time"  ".id"   "name"  "value"
 > pf1 |> saved_states(format="data") |> dim()
@@ -234,6 +255,10 @@ Error : in 'saved_states': 'object' is a required argument.
 Error : 'saved_states' is undefined for 'object' of class 'NULL'.
 > try(saved_states("bob"))
 Error : 'saved_states' is undefined for 'object' of class 'character'.
+> stopifnot(
++   filter_traj(pf1,vars="x2") |> dim()==c(1,1,101),
++   filter_traj(pf1,vars="x2",format="d") |> dim()==c(101,4)
++ )
 > 
 > try(ou2 |> as.data.frame() |> pfilter(Np=1000))
 Error : in 'pfilter': 'times' should either be a numeric vector of observation times or a single name identifying the column of data that represents the observation times.
@@ -245,10 +270,10 @@ Error : in 'pfilter': 'times' should either be a numeric vector of observation t
 +     times="time",t0=0,Np=500,
 +     params=list(x1_0=-3,x2_0=4),
 +     rprocess=onestep(
-+     step.fun=function(x1,x2,delta.t,...) {
-+       setNames(rnorm(n=2,mean=c(x1,x2),sd=5*delta.t),c("x1","x2"))
-+     }
-+   ),
++       step.fun=function(x1,x2,delta.t,...) {
++         setNames(rnorm(n=2,mean=c(x1,x2),sd=5*delta.t),c("x1","x2"))
++       }
++     ),
 +     dmeasure=function(x1,x2,y1,y2,...,log) {
 +       ll <- sum(dnorm(x=c(y1,y2),mean=c(x1,x2),sd=5,log=TRUE))
 +       if (log) ll else exp(ll)