format argument for 'obs' and 'states'

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: pomp
 Type: Package
 Title: Statistical Inference for Partially Observed Markov Processes
-Version: 4.6.1.1
-Date: 2023-01-13
+Version: 4.6.2.0
+Date: 2023-01-14
 Authors@R: c(person(given=c("Aaron","A."),family="King",
 		role=c("aut","cre"),email="[email protected]"),
 	  person(given=c("Edward","L."),family="Ionides",role=c("aut")),

R/filter_mean.R

@@ -19,7 +19,7 @@
 ##'
 ##' @param object result of a filtering computation
 ##' @param vars optional character; names of variables
-##' @param format format of the returned object.
+##' @param format format of the returned object
 ##' @param ... ignored
 ##'
 NULL

R/obs.R

@@ -37,30 +37,45 @@ setMethod(
 ##' @rdname obs
 ##' @param object an object of class \sQuote{pomp}, or of a class extending \sQuote{pomp}
 ##' @param vars names of variables to retrieve
+##' @param format format of the returned object
 ##' @param \dots ignored
 ##' @export
 setMethod(
   "obs",
   signature=signature(object="pomp"),
-  definition=function (object, vars, ...) {
+  definition=function (object, vars, ...,
+    format = c("array", "data.frame")) {
     varnames <- rownames(object@data)
     if (missing(vars))
       vars <- varnames
     else if (!all(vars%in%varnames))
       pStop("obs","some elements of ",
         sQuote("vars")," correspond to no observed variable.")
     y <- object@data[vars,,drop=FALSE]
-    dimnames(y) <- setNames(list(vars,NULL),c("variable","time"))
+    dimnames(y) <- setNames(list(vars,NULL),c("variable",object@timename))
+    format <- match.arg(format)
+    if (format == "data.frame") {
+      y <- data.frame(time=time(object),t(y))
+      names(y)[1L] <- object@timename
+    }
     y
   }
 )
 
 ##' @rdname obs
+##' @importFrom plyr rbind.fill
 ##' @export
 setMethod(
   "obs",
   signature=signature(object="listie"),
-  definition=function (object, vars, ...) {
-    lapply(object,obs,vars=vars)
+  definition=function (object, vars, ...,
+    format = c("array", "data.frame")) {
+    format <- match.arg(format)
+    y <- lapply(object,obs,vars=vars,format=format,...)
+    if (format == "data.frame") {
+      rbind.fill(y,.id=".id")
+    } else {
+      y
+    }
   }
 )

R/saved_states.R

@@ -63,20 +63,20 @@ setMethod(
     } else if ("weights" %in% names(object@saved.states)) {
       s <- melt(object@saved.states$states)
       w <- melt(object@saved.states$weights)
-      s$time <- time(object)[as.integer(s$.L1)]
-      w$time <- time(object)[as.integer(w$.L1)]
+      s[[object@timename]] <- time(object)[as.integer(s$.L1)]
+      w[[object@timename]] <- time(object)[as.integer(w$.L1)]
       w$variable <- ".log.weight"
       x <- rbind(
-        s[,c("time",".id","variable","value")],
-        w[,c("time",".id","variable","value")]
+        s[,c(object@timename,".id","variable","value")],
+        w[,c(object@timename,".id","variable","value")]
       )
       x <- x[order(x$time,x$.id),]
       row.names(x) <- NULL
       x
     } else {
       s <- melt(object@saved.states)
-      s$time <- time(object)[as.integer(s$.L1)]
-      s <- s[,c("time",".id","variable","value")]
+      s[[object@timename]] <- time(object)[as.integer(s$.L1)]
+      s <- s[,c(object@timename,".id","variable","value")]
       row.names(s) <- NULL
       s
     }

R/states.R

@@ -40,7 +40,8 @@ setMethod(
 setMethod(
   "states",
   signature=signature(object="pomp"),
-  definition=function (object, vars, ...) {
+  definition=function (object, vars, ...,
+    format = c("array", "data.frame")) {
     if (length(object@states)==0) {
       x <- array(NA_real_,dim=c(0,length(object@times)),
         dimnames=setNames(list(NULL,NULL),c("variable",object@timename)))
@@ -53,6 +54,11 @@ setMethod(
       x <- object@states[vars,,drop=FALSE]
       dimnames(x) <- setNames(list(vars,NULL),c("variable",object@timename))
     }
+    format <- match.arg(format)
+    if (format == "data.frame") {
+      x <- data.frame(time=time(object),t(x))
+      names(x)[1L] <- object@timename
+    }
     x
   }
 )
@@ -63,7 +69,14 @@ setMethod(
 setMethod(
   "states",
   signature=signature(object="listie"),
-  definition=function (object, vars, ...) {
-    lapply(object,states,vars=vars)
+  definition=function (object, vars, ...,
+    format = c("array", "data.frame")) {
+    format <- match.arg(format)
+    x <- lapply(object,states,vars=vars,format=format,...)
+    if (format == "data.frame") {
+      rbind.fill(x,.id=".id")
+    } else {
+      x
+    }
   }
 )

inst/NEWS

@@ -1,5 +1,11 @@
 _N_e_w_s _f_o_r _p_a_c_k_a_g_e '_p_o_m_p'
 
+_C_h_a_n_g_e_s _i_n '_p_o_m_p' _v_e_r_s_i_o_n _4._6._2:
+
+        • The ‘states’ and ‘obs’ methods take a new optional argument,
+          ‘format’.  Setting ‘format="data.frame"’ causes the method to
+          return the states or data in a convenient data-frame format.
+
 _C_h_a_n_g_e_s _i_n '_p_o_m_p' _v_e_r_s_i_o_n _4._6._1:
 
         • When ‘melt’ is applied to a list, the identifier variable is

inst/NEWS.Rd

@@ -1,5 +1,11 @@
 \name{NEWS}
 \title{News for package `pomp'}
+\section{Changes in \pkg{pomp} version 4.6.2}{
+  \itemize{
+    \item The \code{states} and \code{obs} methods take a new optional argument, \code{format}.
+    Setting \code{format="data.frame"} causes the method to return the states or data in a convenient data-frame format.
+  }
+}
 \section{Changes in \pkg{pomp} version 4.6.1}{
   \itemize{
     \item When \code{melt} is applied to a list, the identifier variable is now \sQuote{.L\code{x}}, where \code{x} denotes the level.

tests/helpers.R

@@ -1,6 +1,9 @@
 set.seed(901772384)
 
-library(pomp)
+suppressPackageStartupMessages({
+  library(pomp)
+  library(tidyr)
+})
 
 try(eff_sample_size())
 try(eff_sample_size("bob"))
@@ -40,9 +43,21 @@ logLik("bob")
 
 try(states())
 try(states("bob"))
+ou2() |>
+  states(format="d") |>
+  head()
+c(A=ou2(),B=gompertz()) |>
+  states(format="d") |>
+  head()
 
 try(obs())
 try(obs("bob"))
+ou2() |>
+  obs(format="d") |>
+  head()
+c(A=ou2(),B=gompertz()) |>
+  obs(format="d") |>
+  head()
 
 try(melt())
 melt("bob")

tests/helpers.Rout.save

@@ -7,8 +7,6 @@ R is free software and comes with ABSOLUTELY NO WARRANTY.
 You are welcome to redistribute it under certain conditions.
 Type 'license()' or 'licence()' for distribution details.
 
-  Natural language support but running in an English locale
-
 R is a collaborative project with many contributors.
 Type 'contributors()' for more information and
 'citation()' on how to cite R or R packages in publications.
@@ -19,15 +17,10 @@ Type 'q()' to quit R.
 
 > set.seed(901772384)
 > 
-> library(pomp)
-
-Welcome to pomp!
-
-As of version 4.6, no user-visible pomp function has a name that
-includes a dot ('.'). Function names have been changed to replace the
-dot with an underscore ('_'). For more information, see the pomp blog:
-https://kingaa.github.io/pomp/blog.html.
-
+> suppressPackageStartupMessages({
++   library(pomp)
++   library(tidyr)
++ })
 > 
 > try(eff_sample_size())
 Error : in 'eff_sample_size': 'object' is a required argument.
@@ -94,11 +87,51 @@ Error : in 'logLik': 'object' is a required argument.
 Error : in 'states': 'object' is a required argument.
 > try(states("bob"))
 Error : 'states' is undefined for '"object"' of class 'character'.
+> ou2() |>
++   states(format="d") |>
++   head()
+  time         x1        x2
+1    1 -3.7184616  4.249533
+2    2  0.9403927  6.843546
+3    3 -0.3725648  7.592267
+4    4  5.8085324  6.490249
+5    5  5.6054356  1.835443
+6    6  7.3546052 -1.566206
+> c(A=ou2(),B=gompertz()) |>
++   states(format="d") |>
++   head()
+  time         x1        x2  X
+1    1 -3.7184616  4.249533 NA
+2    2  0.9403927  6.843546 NA
+3    3 -0.3725648  7.592267 NA
+4    4  5.8085324  6.490249 NA
+5    5  5.6054356  1.835443 NA
+6    6  7.3546052 -1.566206 NA
 > 
 > try(obs())
 Error : in 'obs': 'object' is a required argument.
 > try(obs("bob"))
 Error : 'obs' is undefined for '"object"' of class 'character'.
+> ou2() |>
++   obs(format="d") |>
++   head()
+  time        y1        y2
+1    1 -4.051293 4.7806442
+2    2  1.834630 6.2733019
+3    3 -1.317003 7.5558688
+4    4  6.640487 5.7299615
+5    5  6.575312 1.5614843
+6    6  7.540323 0.1756402
+> c(A=ou2(),B=gompertz()) |>
++   obs(format="d") |>
++   head()
+  time        y1        y2  Y
+1    1 -4.051293 4.7806442 NA
+2    2  1.834630 6.2733019 NA
+3    3 -1.317003 7.5558688 NA
+4    4  6.640487 5.7299615 NA
+5    5  6.575312 1.5614843 NA
+6    6  7.540323 0.1756402 NA
 > 
 > try(melt())
 Error : in 'melt': 'data' is a required argument.