R/load.R

In kidusasfaw/pomp: Statistical Inference for Partially Observed Markov Processes

##' Loading and unloading shared-object libraries
##'
##' \code{pompLoad} and \code{pompUnload} cause compiled codes associated with \code{object} to be dynamically linked or unlinked, respectively.
##' \code{solibs<-} is a helper function for developers of packages that extend \pkg{pomp}.
##'
##' When C snippets are used in the construction of a \sQuote{pomp} object, the resulting shared-object library is dynamically loaded (linked) before each use, and unloaded afterward.
##'
##' @name load
##' @docType methods
##' @rdname load
##' @include pomp_class.R
##' @keywords internal
NULL

## dynamic loading and unloading
setGeneric(
  "pompLoad",
  function (object, ...)
    standardGeneric("pompLoad")
)

setGeneric(
  "pompUnload",
  function (object, ...)
    standardGeneric("pompUnload")
)

setGeneric(
  "solibs<-",
  function (object, ..., value)
    standardGeneric("solibs<-")
)

##' @name pompLoad
##' @aliases pompLoad,pomp-method pompLoad-pomp
##' @rdname load
##'
##' @param object an object of class \sQuote{pomp}, or extending this class.
##'
##' @return
##' NULL, invisibly.
##'
##' @export
setMethod(
  "pompLoad",
  signature=signature(object="pomp"),
  definition = function (object, ...) {
    pompLoad.internal(object,...)
  })

##' @name pompUnload
##' @aliases pompUnload,pomp-method pompUnload-pomp
##' @rdname load
##' @inheritParams pompLoad
##' @export
setMethod(
  "pompUnload",
  signature=signature(object="pomp"),
  definition = function (object, ...) {
    pompUnload.internal(object,...)
  })

##' @name solibs<-
##' @aliases solibs<-,pomp-method solibs<--pomp
##' @rdname load
##'
##' @details
##' \code{solibs<-} prepends the \sQuote{lib} generated by \code{\link{hitch}}
##'  to the \sQuote{solibs} slot of a \sQuote{pomp} object.
##'
##' @export
setMethod(
  "solibs<-",
  signature=signature(object="pomp"),
  definition=function (object, ..., value) {
    if (!is.null(value)) {
      object@solibs <- c(list(value),object@solibs)
    }
    object
  }
)

pompLoad.internal <- function (object, ...,
  verbose = getOption("verbose", FALSE)) {
  for (lib in object@solibs) {
    if (!is.loaded("__pomp_load_stack_incr",PACKAGE=lib$name)) {
      dir <- srcDir(lib$dir,verbose=verbose)
      solib <- file.path(dir,paste0(lib$name,.Platform$dynlib.ext))
      if (file.exists(solib)) {
        dyn.load(solib)
      } else {
        pompCompile(fname=lib$name,direc=dir,src=lib$src,verbose=verbose)
        dyn.load(solib)
      }
      if (verbose) cat("loading",sQuote(solib),"\n")
    }
    .Call(P_load_stack_incr,lib$name)
  }
  invisible(NULL)
}

pompUnload.internal <- function (object, ...,
  verbose = getOption("verbose", FALSE)) {
  for (lib in object@solibs) {
    if (is.loaded("__pomp_load_stack_decr",PACKAGE=lib$name)) {
      st <- .Call(P_load_stack_decr,lib$name)
      if (st==0) {
        dir <- srcDir(lib$dir,verbose=verbose)
        solib <- file.path(dir,paste0(lib$name,.Platform$dynlib.ext))
        dyn.unload(solib)
        if (verbose) cat("unloading",sQuote(solib),"\n")
      }
    }
  }
  invisible(NULL)
}