issue #56 is resolved

kingaa · Oct 23, 2017 · fca432e · fca432e
1 parent 2189e7e
commit fca432e
Show file tree

Hide file tree

Showing 8 changed files with 286 additions and 214 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: pomp
 Type: Package
 Title: Statistical Inference for Partially Observed Markov Processes
-Version: 1.15.3.1
-Date: 2017-10-20
+Version: 1.15.3.2
+Date: 2017-10-23
 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")),

diff --git a/R/pomp_methods.R b/R/pomp_methods.R
@@ -13,10 +13,10 @@ setAs(
             names(x) <- c(nm,rownames(from@states))
         }
         if (length(from@covar)>0) {
-            nm <- names(x)
+            nm <- c(names(x),colnames(from@covar))
             y <- .Call(lookup_in_table,from@tcovar,from@covar,from@times)
             x <- cbind(x,t(y))
-            names(x) <- c(nm,rownames(y))
+            names(x) <- nm
         }
         x
     }
@@ -185,7 +185,7 @@ setMethod(
     signature=signature(object="pomp"),
     definition=function (object, pars, transform = FALSE, ...) {
         if (length(object@params)>0) {
-            if (transform) 
+            if (transform)
                 params <- partrans(object,params=object@params,dir="toEstimationScale")
             else
                 params <- object@params
@@ -215,7 +215,7 @@ setMethod(
         ep <- paste0("in ",sQuote("coef<-"),": ")
         if (missing(pars)) {          ## replace the whole params slot with 'value'
             if (length(value)>0) {
-                if (transform) 
+                if (transform)
                     value <- partrans(object,params=value,dir="fromEstimationScale")
                 pars <- names(value)
                 if (is.null(pars)) {

diff --git a/R/simulate_pomp.R b/R/simulate_pomp.R
@@ -7,156 +7,156 @@ simulate.internal <- function (object, nsim = 1L, seed = NULL, params,
                                .getnativesymbolinfo = TRUE,
                                verbose = getOption("verbose", FALSE), ...) {
 
-    ep <- paste0("in ",sQuote("simulate"),": ")
-
-    pompLoad(object,verbose=verbose)
-
-    if (missing(times))
-        times <- time(object,t0=FALSE)
-    else
-        times <- as.numeric(times)
-
-    if (missing(t0))
-        t0 <- timezero(object)
-    else
-        t0 <- as.numeric(t0)
-
-    obs <- as.logical(obs)
-    states <- as.logical(states)
-    as.data.frame <- as.logical(as.data.frame)
-    include.data <- as.logical(include.data)
-
-    if (missing(params))
-        params <- coef(object)
-
-    if (length(params)==0)
-        stop(ep,"no ",sQuote("params")," specified",call.=FALSE)
-
-    params <- as.matrix(params)
-
-    ## set the random seed (be very careful about this)
-    seed <- as.integer(seed)
-    if (length(seed)>0) {
-        if (!exists('.Random.seed',envir=.GlobalEnv)) set.seed(NULL)
-        save.seed <- get('.Random.seed',envir=.GlobalEnv)
-        set.seed(seed)
+  ep <- paste0("in ",sQuote("simulate"),": ")
+
+  pompLoad(object,verbose=verbose)
+
+  if (missing(times))
+    times <- time(object,t0=FALSE)
+  else
+    times <- as.numeric(times)
+
+  if (missing(t0))
+    t0 <- timezero(object)
+  else
+    t0 <- as.numeric(t0)
+
+  obs <- as.logical(obs)
+  states <- as.logical(states)
+  as.data.frame <- as.logical(as.data.frame)
+  include.data <- as.logical(include.data)
+
+  if (missing(params))
+    params <- coef(object)
+
+  if (length(params)==0)
+    stop(ep,"no ",sQuote("params")," specified",call.=FALSE)
+
+  params <- as.matrix(params)
+
+  ## set the random seed (be very careful about this)
+  seed <- as.integer(seed)
+  if (length(seed)>0) {
+    if (!exists('.Random.seed',envir=.GlobalEnv)) set.seed(NULL)
+    save.seed <- get('.Random.seed',envir=.GlobalEnv)
+    set.seed(seed)
+  }
+
+  if (!obs && !states)
+    object <- as(object,"pomp")
+
+  retval <- tryCatch(
+    .Call(
+      simulation_computations,
+      object,
+      params,
+      times,
+      t0,
+      nsim,
+      obs,
+      states,
+      .getnativesymbolinfo
+    ),
+    error = function (e) {
+      stop(ep,conditionMessage(e),call.=FALSE)
+    }
+  )
+  .getnativesymbolinfo <- FALSE
+
+  ## restore the RNG state
+  if (length(seed)>0) {
+    assign('.Random.seed',save.seed,envir=.GlobalEnv)
+  }
+
+  if (as.data.frame) {
+    if (obs && states) {
+      dm <- dim(retval$obs)
+      nsim <- dm[2L]
+      nm <- rownames(retval$obs)
+      dim(retval$obs) <- c(dm[1L],prod(dm[-1L]))
+      rownames(retval$obs) <- nm
+      dm <- dim(retval$states)
+      nm <- rownames(retval$states)
+      dim(retval$states) <- c(dm[1L],prod(dm[-1L]))
+      rownames(retval$states) <- nm
+      retval <- cbind(
+        as.data.frame(t(retval$obs)),
+        as.data.frame(t(retval$states))
+      )
+      retval$sim <- seq_len(nsim)
+      retval$time <- rep(times,each=nsim)
+    } else if (obs || states) {
+      dm <- dim(retval)
+      nsim <- dm[2L]
+      nm <- rownames(retval)
+      dim(retval) <- c(dm[1L],prod(dm[-1L]))
+      rownames(retval) <- nm
+      retval <- as.data.frame(t(retval))
+      retval$sim <- seq_len(nsim)
+      retval$time <- rep(times,each=nsim)
+    } else {
+      nsim <- length(retval)
+      if (nsim > 1) {
+        retval <- lapply(
+          seq_len(nsim),
+          function (k) {
+            x <- as.data.frame(retval[[k]])
+            x$sim <- as.integer(k)
+            x
+          }
+        )
+        retval <- do.call(rbind,retval)
+      } else {
+        retval <- as.data.frame(retval)
+        retval$sim <- 1L
+      }
     }
 
-    if (!obs && !states)
-        object <- as(object,"pomp")
-
-    retval <- tryCatch(
-        .Call(
-            simulation_computations,
-            object,
-            params,
-            times,
-            t0,
-            nsim,
-            obs,
-            states,
-            .getnativesymbolinfo
-        ),
+    if (include.data) {
+      od <- as.data.frame(object)
+      od$sim <- 0L
+      tryCatch(
+        {
+          retval <- merge(od,retval,all=TRUE)
+        },
         error = function (e) {
-            stop(ep,conditionMessage(e),call.=FALSE)
+          stop(ep,"error in merging actual and simulated data.\n",
+               "Check names of data, covariates, and states for conflicts.\n",
+               sQuote("merge")," error message: ",conditionMessage(e),call.=FALSE)
         }
-    )
-    .getnativesymbolinfo <- FALSE
-
-    ## restore the RNG state
-    if (length(seed)>0) {
-        assign('.Random.seed',save.seed,envir=.GlobalEnv)
+      )
     }
 
-    if (as.data.frame) {
-        if (obs && states) {
-            dm <- dim(retval$obs)
-            nsim <- dm[2L]
-            nm <- rownames(retval$obs)
-            dim(retval$obs) <- c(dm[1L],prod(dm[-1L]))
-            rownames(retval$obs) <- nm
-            dm <- dim(retval$states)
-            nm <- rownames(retval$states)
-            dim(retval$states) <- c(dm[1L],prod(dm[-1L]))
-            rownames(retval$states) <- nm
-            retval <- cbind(
-                as.data.frame(t(retval$obs)),
-                as.data.frame(t(retval$states))
-            )
-            retval$sim <- seq_len(nsim)
-            retval$time <- rep(times,each=nsim)
-        } else if (obs || states) {
-            dm <- dim(retval)
-            nsim <- dm[2L]
-            nm <- rownames(retval)
-            dim(retval) <- c(dm[1L],prod(dm[-1L]))
-            rownames(retval) <- nm
-            retval <- as.data.frame(t(retval))
-            retval$sim <- seq_len(nsim)
-            retval$time <- rep(times,each=nsim)
-        } else {
-            nsim <- length(retval)
-            if (nsim > 1) {
-                retval <- lapply(
-                    seq_len(nsim),
-                    function (k) {
-                        x <- as.data.frame(retval[[k]])
-                        x$sim <- as.integer(k)
-                        x
-                    }
-                )
-                retval <- do.call(rbind,retval)
-            } else {
-                retval <- as.data.frame(retval)
-                retval$sim <- 1L
-            }
-        }
+    retval$sim <- ordered(retval$sim)
+    if (include.data) levels(retval$sim)[1L] <- "data"
+    retval <- retval[order(retval$sim,retval$time),]
 
-        if (include.data) {
-            od <- as.data.frame(object)
-            od$sim <- 0L
-            tryCatch(
-            {
-                retval <- merge(od,retval,all=TRUE)
-            },
-            error = function (e) {
-                stop(ep,"error in merging actual and simulated data.\n",
-                     "Check names of data, covariates, and states for conflicts.\n",
-                     sQuote("merge")," error message: ",conditionMessage(e),call.=FALSE)
-            }
-            )
-        }
+  }
 
-        retval$sim <- ordered(retval$sim)
-        if (include.data) levels(retval$sim)[1L] <- "data"
-        retval <- retval[order(retval$sim,retval$time),]
+  pompUnload(object,verbose=verbose)
 
-    }
-
-    pompUnload(object,verbose=verbose)
-
-    retval
+  retval
 }
 
 setMethod(
-    "simulate",
-    signature=signature(object="pomp"),
-    definition=function (object, nsim = 1, seed = NULL, params,
-                         states = FALSE, obs = FALSE,
-                         times, t0, as.data.frame = FALSE,
-                         include.data = FALSE,
-                         ...)
-        simulate.internal(
-            object=object,
-            nsim=nsim,
-            seed=seed,
-            params=params,
-            states=states,
-            obs=obs,
-            times=times,
-            t0=t0,
-            as.data.frame=as.data.frame,
-            include.data=include.data,
-            ...
-        )
+  "simulate",
+  signature=signature(object="pomp"),
+  definition=function (object, nsim = 1, seed = NULL, params,
+                       states = FALSE, obs = FALSE,
+                       times, t0, as.data.frame = FALSE,
+                       include.data = FALSE,
+                       ...)
+    simulate.internal(
+      object=object,
+      nsim=nsim,
+      seed=seed,
+      params=params,
+      states=states,
+      obs=obs,
+      times=times,
+      t0=t0,
+      as.data.frame=as.data.frame,
+      include.data=include.data,
+      ...
+    )
 )
diff --git a/inst/NEWS b/inst/NEWS
@@ -2,6 +2,10 @@ _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 _1._1_5._3:
 
+        • Issue #56, in which covariate names are discarded when
+          coercing a pomp object to a data frame, has been fixed.
+          Thanks to Eamon O'Dea for reporting this bug.
+
         • More informative error messages are given when ‘bake’ or
           ‘freeze’ return ‘NULL’.  In such a case, these functions now
           generate a warning and return a character-string message,

diff --git a/inst/NEWS.Rd b/inst/NEWS.Rd
@@ -2,6 +2,8 @@
 \title{News for package `pomp'}
 \section{Changes in \pkg{pomp} version 1.15.3}{
   \itemize{
+    \item Issue #56, in which covariate names are discarded when coercing a pomp object to a data frame, has been fixed.
+    Thanks to Eamon O'Dea for reporting this bug.
     \item More informative error messages are given when \code{bake} or \code{freeze} return \code{NULL}.
     In such a case, these functions now generate a warning and return a character-string message, with attributes.
   }