Merge pull request #55 from jeswheel/master

panelPomp v1.3.0

.Rbuildignore

@@ -45,3 +45,4 @@ hub_cov\.R
 covr.html
 covr.rds
 website
+^vignettes/articles$

.github/workflows/render-website.yml

@@ -7,6 +7,8 @@ on:
     paths:
       - '.github/workflows/render-website.yml'
       - 'DESCRIPTION'
+      - 'inst/NEWS'
+      - 'inst/NEWS.Rd'
       - 'R/**'
       - 'vignettes/**'
       - 'website/**'  # Make sure to include the path to your website files
@@ -87,7 +89,10 @@ jobs:
 
       - name: Copy Vignettes and Other Files
         run: |
-          cp -r vignettes website/
+          mkdir -p website/vignettes
+          cp vignettes/getting-started.Rmd website/vignettes/.
+          cp vignettes/articles/package_tutorial/tutorial.pdf website/vignettes/.
+          # cp -r vignettes website/
           Rscript --vanilla website/rmd2qmd.R website/vignettes/getting-started
           rm website/vignettes/getting-started.Rmd
           tree website

.gitignore

@@ -35,3 +35,10 @@ website/html
 website/help
 inst/doc
 website/vignettes/*
+vignettes/articles/package_tutorial/tutorial.aux
+vignettes/articles/package_tutorial/tutorial.bbl
+vignettes/articles/package_tutorial/tutorial-concordance.tex
+vignettes/articles/package_tutorial/tutorial.log
+vignettes/articles/package_tutorial/tutorial.tex
+vignettes/articles/package_tutorial/tutorial.synctex.gz
+!vignettes/articles/package_tutorial/tutorial.pdf

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: panelPomp
 Type: Package
 Title: Inference for Panel Partially Observed Markov Processes
-Version: 1.2.0
+Version: 1.3.0
 Date: 2023-05-22
 Authors@R: c(person(given="Carles",family="Breto",role=c("aut","cre"),email="carles.breto@uv.es",comment=c(ORCID="0000-0003-4695-4902")),
 	person(given=c("Edward","L."),family="Ionides",role="aut",comment=c(ORCID="0000-0002-4190-0174")),
@@ -15,7 +15,7 @@ Depends:
 Imports:
     lifecycle,
     methods
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Encoding: UTF-8
 Collate: 
     'panelPomp-package.R'
@@ -42,5 +42,5 @@ Roxygen: list(markdown = TRUE)
 Suggests: 
     knitr,
     rmarkdown,
-    bookdown 
+    bookdown
 VignetteBuilder: knitr

NAMESPACE

@@ -3,21 +3,19 @@
 export("shared<-")
 export("specific<-")
 export(contacts)
-export(fromVectorPparams)
 export(get_col)
 export(get_row)
-export(pParams)
 export(panelGompertz)
 export(panelGompertzLikelihood)
 export(panelPomp)
 export(panelRandomWalk)
 export(panel_logmeanexp)
-export(pparams)
 export(runif_panel_design)
 export(shared)
 export(specific)
 export(toMatrixPparams)
-export(toVectorPparams)
+export(toParamList)
+export(toParamVec)
 export(unitLogLik)
 export(unit_objects)
 export(unitlogLik)
@@ -37,7 +35,6 @@ exportMethods(mif2)
 exportMethods(names)
 exportMethods(pfilter)
 exportMethods(plot)
-exportMethods(pparams)
 exportMethods(print)
 exportMethods(shared)
 exportMethods(show)

R/generics.R

@@ -1,28 +1,5 @@
 ## generic functions
 
-#' @title Extract parameters (coefficients) of a panel model
-#' @description \code{pparams()} is a generic function that extracts parameter
-#' (coefficient) values from objects returned by panel modeling functions. While
-#' the named \code{numeric} vector format is useful and possible via S4 methods
-#' for \code{coef()}, alternative formats capturing the panel structure can be
-#' implemented via \code{pparams()}.
-#' @param object an object for which extraction of panel model parameter
-#' (coefficient) values is meaningful.
-#' @param ... additional arguments.
-#' @details This is a generic function: methods can be defined for it.
-#' @return Parameter (coefficient) values extracted from the panel model
-#' \code{object}.
-#'
-#' \pparamsReturn
-#' @example examples/prw.R
-#' @example examples/pparams.R
-#' @keywords internal
-#' @seealso \link{panelPomp_methods}
-#' @author Carles \Breto
-#' @export
-setGeneric(name = "pparams",
-           def = function(object, ...) standardGeneric("pparams"))
-
 #' @title Extract units of a panel model
 #' @description \code{unit_objects()} is a generic function that extracts a list
 #' of objects corresponding to units of panel objects returned by panel modeling

R/mif2.R

@@ -206,7 +206,7 @@ mif2.internal <- function (object, Nmif, start, Np, rw.sd, cooling.type,
   # Extract loglikelihoods
   unit.logliks <- sapply(X = output, FUN = logLik)
   ploglik <- sum(unit.logliks)
-  # create pParams slot from last mif iteration values in pconv.rec
+  # create parameter list from last mif iteration values in pconv.rec
   pParams <- list()
   pParams$shared <- pconv.rec[nrow(pconv.rec), -1L]
   # Here, we want to drop the iteration dimension but, if there was only one
@@ -262,7 +262,7 @@ setMethod(
   "mif2",
   signature=signature(data="panelPomp"),
   definition = function (data, Nmif = 1, shared.start, specific.start, start,
-                         Np, rw.sd, cooling.type = c("hyperbolic", "geometric"),
+                         Np, rw.sd, cooling.type = c("geometric", "hyperbolic"),
                          cooling.fraction.50, block = FALSE,
                          verbose = getOption("verbose"), ...) {
     object <- data
@@ -275,7 +275,7 @@ setMethod(
     if (missing(start)) {
       start <- list(shared=object@shared,specific=object@specific)
     } else {
-     if (is.numeric(start)) start <- pParams(start)
+     if (is.numeric(start)) start <- toParamList(start)
     }
     if (missing(shared.start)) shared.start <- start$shared
     if (missing(specific.start)) specific.start <- start$specific
@@ -332,7 +332,7 @@ setMethod(
    if (missing(start)) {
       start <- list(shared=object@shared,specific=object@specific)
     } else {
-      if (is.numeric(start)) start <- pParams(start)
+      if (is.numeric(start)) start <- toParamList(start)
     }
     if (missing(shared.start)) shared.start <- start$shared
     if (missing(specific.start)) specific.start <- start$specific

R/panelPomp.R

@@ -179,7 +179,7 @@ panelPomp <- function (object, shared, specific, params) {
         call.=FALSE)
     } else {
       if (is.numeric(params) && !is.null(names(params))) {
-        params <- pParams(params)
+        params <- toParamList(params)
       } else {
         stop(wQuotes(ep,"''params'' must be a named numeric vector"),call.=FALSE)
       }

R/panelPomp_methods.R

@@ -20,8 +20,7 @@ NULL
 #'   \item{coef<-}{Assign coefficients to \code{panelPomp} objects.}
 #'   \item{length}{Count the number of units in \code{panelPomp} objects.}
 #'   \item{names}{Get the unit names of \code{panelPomp} objects.}
-#'   \item{pparams}{Extracts coefficients from \code{panelPomp} objects in list form.}
-#'   \item{pParams}{Converts panel coefficients from vector form to list form.}
+#'   \item{toParamList}{Converts panel coefficients from vector form to list form.}
 #'   \item{window}{Subset \code{panelPomp} objects by changing start time and
 #'   end time.}
 #'   \item{\code{[]}}{Take a subset of units.}
@@ -42,15 +41,21 @@ NULL
 setMethod(
   "coef",
   signature=signature(object="panelPomp"),
-  definition = function (object) {
+  definition = function (object, format = c("vector", 'list')) {
+    out_type <- match.arg(format)
     pmat <- object@specific
-    c(
-      object@shared,
-      setNames(
-        as.numeric(pmat),
-        outer(rownames(pmat),colnames(pmat),sprintf,fmt="%s[%s]")
+
+    if (out_type == 'vector') {
+      c(
+        object@shared,
+        setNames(
+          as.numeric(pmat),
+          outer(rownames(pmat),colnames(pmat),sprintf,fmt="%s[%s]")
+        )
       )
-    )
+    } else if (out_type == 'list') {
+      list(shared=object@shared,specific=object@specific)
+    }
   }
 )
 
@@ -114,28 +119,17 @@ setMethod(
   definition = function (x) names(x@unit_objects)
 )
 
-#' @rdname panelPomp_methods
-#' @return \pparamsReturn
-# \pparamsReturn is resused in documentation of generic function introduced by the panelPomp package
-#' @example examples/pparams.R
-#' @export
-setMethod(
-  "pparams",
-  signature=signature(object="panelPomp"),
-  definition = function (object)
-    list(shared=object@shared,specific=object@specific)
-)
-
 #' @rdname panelPomp_methods
 #' @return
-#' \code{pParams()} returns a \code{list} with the model parameters in list form.
+#' \code{toParamList()} returns a \code{list} with the model parameters in list form.
 #' @examples
 #' # convert vector-form parameters to list-form parameters
-#' pParams(coef(prw))
+#' toParamList(coef(prw))
 #' @export
-pParams <- function (value) {
+toParamList <- function (value) {
 
-  ep <- wQuotes("in ''pParams'': ")
+  ep <- wQuotes("in ''toParamList'': ")
+  if (is.list(value)) stop(ep, 'input is already a list.', call. = FALSE)
   if (!is.vector(value)) stop(ep, "input must be a vector.", call. = FALSE)
 
   nn <- grep("^.+\\[.+?\\]$", names(value), perl = TRUE, value = TRUE)
@@ -183,7 +177,7 @@ setMethod(
     cat("panel of",length(object),ifelse(length(object)>1,"units","unit"),"\n")
     if (length(coef(object))>0) {
       cat("parameter(s):\n")
-      print(pParams(coef(object)))
+      print(coef(object, format = 'list'))
     } else {
       cat("parameter(s) unspecified\n");
     }

R/params.R

@@ -3,89 +3,37 @@
 #' @include panelPomp_methods.R
 NULL
 
-#' @title Convert to and from a \code{panelPomp} object \code{pParams} slot format and a one-row \code{data.frame}
+#' @title Manipulating \code{panelPomp} object parameter formats
 #' @description These facilitate keeping a record of evaluated log likelihoods.
-#' @param vec_pars A one-row \code{data.frame} with format matching that of the
-#' output of \link{toVectorPparams}.
-#' @param pParams A list with the format of the \code{pParams} slot of \code{panelPomp} objects.
+#' @param pParams A list with both shared (vector) and unit-specific (matrix) parameters.
 #' @name params
 NULL
 
 #' @rdname params
 #' @author Carles \Breto
 #' @return
-#' \code{toVectorPparams()} returns an object of class \code{data.frame}.
+#' \code{toParamVec()} returns model parameters in vector form. This function
+#' is the inverse of \link{toParamList}
 #' @examples
 #' prw <- panelRandomWalk()
-#' toVectorPparams(pparams(prw))
+#' toParamVec(coef(prw, format = 'list'))
 #' @export
-toVectorPparams <- function(pParams) {
-  # rbind replicated shared parameters with matrix of specific parameters
-  mat_pars <- rbind(
-    matrix(
-      rep(pParams$shared,
-          times=ncol(pParams$specific)),
-      ncol = ncol(pParams$specific),
-      dimnames = list(names(pParams$shared), NULL)
-    ),
-    pParams$specific
-  )
-  # vectorize the matrix
-  vec_pars <- setNames(
-    as.vector(mat_pars),
-    nm=paste0(rep(colnames(mat_pars), each = nrow(mat_pars)),
-              rownames(mat_pars)))
-  # Append info about ...
-  #... nature of parameters (shared and specific), and ...
-  par_typ <- setNames(
-    c(rep("shared",times=length(pParams$shared)),
-      rep("specific",times=nrow(pParams$specific))),
-    nm=c(names(pParams$shared),rownames(pParams$specific)))
-  # ... unit names
-  u_nms <- setNames(
-    rep("unit_name",ncol(mat_pars)),
-    nm=colnames(pParams$specific)
-  )
-  # return
-  merge(data.frame(t(par_typ),stringsAsFactors=FALSE),
-        y=merge(data.frame(t(u_nms),stringsAsFactors=FALSE),
-                y=data.frame(t(vec_pars))))
-}
+toParamVec <- function(pParams) {
 
-#' @rdname params
-# @author Carles \Breto
-#' @return
-#' \code{fromVectorPparams()} returns an object of class \code{list} with the
-#' model parameters in list form.
-#' @examples
-#' fromVectorPparams(toVectorPparams(pparams(prw)))
-#' @export
-fromVectorPparams <- function(vec_pars) {
-  # Extract unit, shared, and specific names
-  sh_nms <- names(vec_pars[,!is.na(vec_pars=="shared")&vec_pars=="shared",drop=FALSE])
-  sp_nms <- names(vec_pars[,!is.na(vec_pars=="specific")&vec_pars=="specific",drop=FALSE])
-  u_nms <- names(vec_pars)[vec_pars=="unit_name"]
-  # shared
-  sh_pars <- if(length(sh_nms)>0) {
-    sh_pars <- setNames(as.numeric(vec_pars[,paste0(u_nms[1],sh_nms)]),nm=sh_nms)
-  } else {
-    numeric(0)
-  }
-  # specific
-  if(length(sp_nms)>0) {
-    mat_sps <- NULL
-    for (i.u in seq_len(length(u_nms))) {
-      mat_sps <- cbind(
-        mat_sps,
-        as.numeric(vec_pars[, paste0(u_nms[i.u],sp_nms)])
-      )
-    }
-    dimnames(mat_sps) <- list(sp_nms,u_nms)
-  } else {
-    mat_sps <- array(numeric(),dim=c(0,length(u_nms)),dimnames=list(NULL,u_nms))
-  }
-  # return
-  list(shared=sh_pars,specific=mat_sps)
+  ep <- wQuotes("in ''toParamVec'': ")
+  if (!is.list(pParams)) stop(ep, 'input must be a list.', call. = FALSE)
+  if (is.null(pParams$shared) && is.null(pParams$specific)) stop(ep, 'input must have shared or specific components.', call. = FALSE)
+
+  # Create a new list, removing unused components.
+  value <- list(shared=pParams$shared, specific = pParams$specific)
+
+  c(
+    value$shared,
+    setNames(
+      as.numeric(value$specific),
+      outer(rownames(value$specific),colnames(value$specific),sprintf,fmt="%s[%s]")
+    )
+  )
 }
 
 ## Go to list-form pparams from matrix specification
@@ -125,7 +73,7 @@ toListPparams <- function(
 #' \code{toMatrixPparams()} returns an object of class \code{matrix} with the
 #' model parameters in matrix form.
 #' @examples
-#' toMatrixPparams(pparams(prw))
+#' toMatrixPparams(coef(prw, format = 'list'))
 #' @export
 toMatrixPparams <- function(listPparams) {
   common.params <- listPparams[[which(sapply(listPparams, is.vector))]]

R/pfilter.R

@@ -92,7 +92,7 @@ setMethod(
     object <- data # the argument name 'data' is fixed by pomp's generic
     ep <- wQuotes("in ''pfilter'': ")
     ## check for params format
-    if (!missing(params) && is.numeric(params)) params <- pParams(params)
+    if (!missing(params) && is.numeric(params)) params <- toParamList(params)
 
     if (!missing(shared) && !missing(specific) && !missing(params))
       stop(ep,wQuotes("specify either ''params'' only, ''params'' and ''shared'' ,",