From 73214a8a2f083152641da163166acffa08a2e1cc Mon Sep 17 00:00:00 2001 From: "Aaron A. King" Date: Thu, 22 Jun 2023 10:05:00 -0400 Subject: [PATCH] improve testing --- DESCRIPTION | 4 ++-- R/filter_traj.R | 2 +- tests/kalman2.R | 8 ++++++++ tests/kalman2.Rout.save | 28 ++++++++++++++++++++++++++++ tests/pfilter.R | 35 ++++++++++++++++++++++++++++++----- tests/pfilter.Rout.save | 35 ++++++++++++++++++++++++++++++----- 6 files changed, 99 insertions(+), 13 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 16d988446..7870b208a 100644 --- a/DESCRIPTION +++ b/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="kingaa@umich.edu",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")), diff --git a/R/filter_traj.R b/R/filter_traj.R index ca2be8e88..3f7c8de68 100644 --- a/R/filter_traj.R +++ b/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") { diff --git a/tests/kalman2.R b/tests/kalman2.R index f19e298e8..178b86d0c 100644 --- a/tests/kalman2.R +++ b/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)) diff --git a/tests/kalman2.Rout.save b/tests/kalman2.Rout.save index f330e5ae0..59c7d9cdc 100644 --- a/tests/kalman2.Rout.save +++ b/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'. diff --git a/tests/pfilter.R b/tests/pfilter.R index d5397ff63..f0a318095 100644 --- a/tests/pfilter.R +++ b/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) diff --git a/tests/pfilter.Rout.save b/tests/pfilter.Rout.save index d1ed05ee6..1143797b0 100644 --- a/tests/pfilter.Rout.save +++ b/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)