[Pomp-commits] r1104 - in pkg/pomp: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Feb 26 12:13:49 CET 2015
Author: kingaa
Date: 2015-02-26 12:13:49 +0100 (Thu, 26 Feb 2015)
New Revision: 1104
Added:
pkg/pomp/R/load.R
Modified:
pkg/pomp/DESCRIPTION
pkg/pomp/R/builder.R
Log:
- rearrange some codes
- streamline some of the CBuilder templates
Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION 2015-02-26 09:43:16 UTC (rev 1103)
+++ pkg/pomp/DESCRIPTION 2015-02-26 11:13:49 UTC (rev 1104)
@@ -1,8 +1,8 @@
Package: pomp
Type: Package
Title: Statistical Inference for Partially Observed Markov Processes
-Version: 0.61-1
-Date: 2015-02-24
+Version: 0.61-2
+Date: 2015-02-26
Authors at R: c(person(given=c("Aaron","A."),family="King",
role=c("aut","cre"),email="kingaa at umich.edu"),
person(given=c("Edward","L."),family="Ionides",role=c("aut")),
@@ -24,7 +24,7 @@
LazyData: true
MailingList: Subscribe to pomp-announce at r-forge.r-project.org for announcements by going to http://lists.r-forge.r-project.org/mailman/listinfo/pomp-announce.
Collate: aaa.R authors.R generics.R eulermultinom.R
- csnippet.R pomp-fun.R plugins.R
+ csnippet.R pomp-fun.R plugins.R builder.R load.R
parmat.R logmeanexp.R slice-design.R
profile-design.R sobol.R bsplines.R sannbox.R
pomp-class.R pomp.R pomp-methods.R
@@ -39,4 +39,4 @@
nlf-funcs.R nlf-guts.R nlf-objfun.R nlf.R
probe.R probe-match.R basic-probes.R spect.R spect-match.R
abc.R abc-methods.R
- builder.R example.R
+ example.R
Modified: pkg/pomp/R/builder.R
===================================================================
--- pkg/pomp/R/builder.R 2015-02-26 09:43:16 UTC (rev 1103)
+++ pkg/pomp/R/builder.R 2015-02-26 11:13:49 UTC (rev 1104)
@@ -1,139 +1,3 @@
-pompBuilder <- function (data, times, t0, name,
- statenames, paramnames, tcovar, covar,
- rmeasure, dmeasure, step.fn, step.fn.delta.t,
- skeleton, skeleton.type = c("map","vectorfield"),
- skelmap.delta.t = 1,
- parameter.transform, parameter.inv.transform,
- rprior, dprior,
- globals, ..., save = FALSE) {
-
- if (!is.data.frame(data)) stop(sQuote("data")," must be a data-frame")
- obsnames <- names(data)
- obsnames <- setdiff(obsnames,times)
- if (!missing(covar)) {
- if (!is.data.frame(covar)) stop(sQuote("covar")," must be a data-frame")
- covarnames <- colnames(covar)
- covarnames <- setdiff(covarnames,tcovar)
- } else {
- covar <- matrix(data=0,nrow=0,ncol=0)
- tcovar <- numeric(0)
- covarnames <- character(0)
- }
- skeleton.type <- match.arg(skeleton.type)
-
- if (missing(statenames)) stop(sQuote("statenames")," must be supplied");
- if (missing(paramnames)) stop(sQuote("paramnames")," must be supplied");
-
- mpt <- missing(parameter.transform)
- mpit <- missing(parameter.inv.transform)
- if (xor(mpt,mpit))
- stop("if you supply one transformation function, you must supply its inverse")
-
- pompCBuilder(
- name=name,
- statenames=statenames,
- paramnames=paramnames,
- covarnames=covarnames,
- obsnames=obsnames,
- rmeasure=rmeasure,
- dmeasure=dmeasure,
- step.fn=step.fn,
- skeleton=skeleton,
- parameter.transform=parameter.transform,
- parameter.inv.transform=parameter.inv.transform,
- rprior=rprior,
- dprior=dprior,
- globals=globals,
- dir=if (save) getwd() else NULL
- ) -> solib
-
- name <- solib[1]
-
- pomp(
- data=data,
- times=times,
- t0=t0,
- rprocess=euler.sim(
- step.fun=render(fnames$step.fn,name=name),
- delta.t=step.fn.delta.t,
- PACKAGE=name
- ),
- rmeasure=render(fnames$rmeasure,name=name),
- dmeasure=render(fnames$dmeasure,name=name),
- skeleton=render(fnames$skeleton,name=name),
- skeleton.type=skeleton.type,
- skelmap.delta.t=skelmap.delta.t,
- parameter.transform=render(fnames$parameter.transform,name=name),
- parameter.inv.transform=render(fnames$parameter.inv.transform,name=name),
- rprior=render(fnames$rprior,name=name),
- dprior=render(fnames$dprior,name=name),
- PACKAGE=name,
- statenames=statenames,
- paramnames=paramnames,
- tcovar=tcovar,
- covar=covar,
- ...,
- .solibfile=list(solib)
- )
-}
-
-pompLoad.internal <- function (object, ..., verbose = getOption("verbose",FALSE)) {
- for (lib in object at solibfile) {
- if (!is.loaded("__pomp_load_stack_incr",PACKAGE=lib[1])) {
- dyn.load(lib[2])
- if (verbose) cat("loading",sQuote(lib[2]),"\n")
- }
- .Call(load_stack_incr,lib[1])
- }
- invisible(NULL)
-}
-
-pompUnload.internal <- function (object, ..., verbose = getOption("verbose",FALSE)) {
- for (lib in object at solibfile) {
- if (is.loaded("__pomp_load_stack_decr",PACKAGE=lib[1])) {
- st <- .Call(load_stack_decr,lib[1])
- if (st==0) {
- dyn.unload(lib[2])
- if (verbose) cat("unloading",sQuote(lib[2]),"\n")
- }
- }
- }
- invisible(NULL)
-}
-
-setMethod("pompLoad",
- signature=signature(object='pomp'),
- definition = function (object, ...) {
- pompLoad.internal(object,...)
- })
-
-setMethod("pompUnload",
- signature=signature(object='pomp'),
- definition = function (object, ...) {
- pompUnload.internal(object,...)
- })
-
-callable.decl <- function (code) {
- fns <- vapply(names(decl),grepl,logical(1),code,perl=TRUE)
- do.call(paste0,decl[fns])
-}
-
-missing.fun <- function (name) {
- paste0(" error(\"'",name,"' not defined\");")
-}
-
-randomName <- function (stem = "pomp", size = 2) {
- paste0(stem,
- paste(
- format(
- as.hexmode(ceiling(runif(n=size,max=2^24))),
- upper.case=TRUE
- ),
- collapse=""
- )
- )
-}
-
pompCBuilder <- function (name = NULL,
statenames, paramnames, covarnames, obsnames,
rmeasure, dmeasure, step.fn, skeleton,
@@ -145,7 +9,7 @@
if (is.null(name)) name <- randomName()
if (is.null(dir)) dir <- tempdir()
- if (missing(globals)) globals <- ""
+ if (missing(globals)) globals <- character(0)
name <- cleanForC(name)
statenames <- cleanForC(statenames)
@@ -157,7 +21,6 @@
if (.Platform$OS.type=="windows") {
stem <- gsub("\\","/",stem,fixed=TRUE)
}
-
modelfile <- paste0(stem,".c")
solib <- paste0(stem,.Platform$dynlib.ext)
@@ -198,47 +61,64 @@
}
cat(file=out,render(define$var.alt,variable="lik",ptr='__lik',index=0))
+ ## list of functions to register
+ registry <- c("load_stack_incr","load_stack_decr")
+
## parameter transformation function
- if (missing(parameter.transform))
- parameter.transform <- missing.fun("parameter.transform")
- cat(file=out,render(header$parameter.transform,name=name))
- cat(file=out,callable.decl(parameter.transform))
- cat(file=out,parameter.transform,footer$parameter.transform)
+ if (!missing(parameter.transform)) {
+ registry <- c(registry,"par_trans")
+ cat(file=out,render(header$parameter.transform,name=name))
+ cat(file=out,callable.decl(parameter.transform))
+ cat(file=out,parameter.transform,footer$parameter.transform)
+ }
## inverse parameter transformation function
- if (missing(parameter.inv.transform))
- parameter.inv.transform <- missing.fun("parameter.inv.transform")
- cat(file=out,render(header$parameter.inv.transform,name=name))
- cat(file=out,callable.decl(parameter.inv.transform))
- cat(file=out,parameter.inv.transform,footer$parameter.inv.transform)
+ if (!missing(parameter.inv.transform)) {
+ registry <- c(registry,"par_untrans")
+ cat(file=out,render(header$parameter.inv.transform,name=name))
+ cat(file=out,callable.decl(parameter.inv.transform))
+ cat(file=out,parameter.inv.transform,footer$parameter.inv.transform)
+ }
## rmeasure function
- if (missing(rmeasure)) rmeasure <- missing.fun("rmeasure")
- cat(file=out,render(header$rmeasure,name=name),rmeasure,footer$rmeasure)
+ if (!missing(rmeasure)) {
+ registry <- c(registry,"rmeasure")
+ cat(file=out,render(header$rmeasure,name=name),rmeasure,footer$rmeasure)
+ }
## dmeasure function
- if (missing(dmeasure)) dmeasure <- missing.fun("dmeasure")
- cat(file=out,render(header$dmeasure,name=name),dmeasure,footer$dmeasure)
+ if (!missing(dmeasure)) {
+ registry <- c(registry,"dmeasure")
+ cat(file=out,render(header$dmeasure,name=name),dmeasure,footer$dmeasure)
+ }
## Euler step function
- if (missing(step.fn)) step.fn <- missing.fun("step.fn")
- cat(file=out,render(header$step.fn,name=name))
- cat(file=out,callable.decl(step.fn))
- cat(file=out,step.fn,footer$step.fn)
+ if (!missing(step.fn)) {
+ registry <- c(registry,"stepfn")
+ cat(file=out,render(header$step.fn,name=name))
+ cat(file=out,callable.decl(step.fn))
+ cat(file=out,step.fn,footer$step.fn)
+ }
## skeleton function
- if (missing(skeleton)) skeleton <- missing.fun("skeleton")
- cat(file=out,render(header$skeleton,name=name))
- cat(file=out,callable.decl(skeleton))
- cat(file=out,skeleton,footer$skeleton)
+ if (!missing(skeleton)) {
+ registry <- c(registry,"skelfn")
+ cat(file=out,render(header$skeleton,name=name))
+ cat(file=out,callable.decl(skeleton))
+ cat(file=out,skeleton,footer$skeleton)
+ }
## rprior function
- if (missing(rprior)) rprior <- missing.fun("rprior")
- cat(file=out,render(header$rprior,name=name),rprior,footer$rprior)
+ if (!missing(rprior)) {
+ registry <- c(registry,"rprior")
+ cat(file=out,render(header$rprior,name=name),rprior,footer$rprior)
+ }
## dprior function
- if (missing(dprior)) dprior <- missing.fun("dprior")
- cat(file=out,render(header$dprior,name=name),dprior,footer$dprior)
+ if (!missing(dprior)) {
+ registry <- c(registry,"dprior")
+ cat(file=out,render(header$dprior,name=name),dprior,footer$dprior)
+ }
## undefine variables
for (v in seq_along(paramnames)) {
@@ -264,8 +144,8 @@
## registration
cat(file=out,render(header$registration,name=name))
- for (v in names(regist))
- cat(file=out,render(regist[[v]],name=name))
+ for (v in registry)
+ cat(file=out,render(registration,name=name,fun=v))
cat(file=out,footer$registration)
close(out)
@@ -289,6 +169,27 @@
invisible(c(name,solib))
}
+callable.decl <- function (code) {
+ fns <- vapply(names(decl),grepl,logical(1),code,perl=TRUE)
+ do.call(paste0,decl[fns])
+}
+
+missing.fun <- function (name) {
+ paste0(" error(\"'",name,"' not defined\");")
+}
+
+randomName <- function (stem = "pomp", size = 2) {
+ paste0(stem,
+ paste(
+ format(
+ as.hexmode(ceiling(runif(n=size,max=2^24))),
+ upper.case=TRUE
+ ),
+ collapse=""
+ )
+ )
+}
+
cleanForC <- function (text) {
text <- as.character(text)
text <- gsub("\\.","_",text)
@@ -317,6 +218,85 @@
do.call(paste0,retval)
}
+pompBuilder <- function (data, times, t0, name,
+ statenames, paramnames, tcovar, covar,
+ rmeasure, dmeasure, step.fn, step.fn.delta.t,
+ skeleton, skeleton.type = c("map","vectorfield"),
+ skelmap.delta.t = 1,
+ parameter.transform, parameter.inv.transform,
+ rprior, dprior,
+ globals, ..., save = FALSE) {
+
+ if (!is.data.frame(data)) stop(sQuote("data")," must be a data-frame")
+ obsnames <- names(data)
+ obsnames <- setdiff(obsnames,times)
+ if (!missing(covar)) {
+ if (!is.data.frame(covar)) stop(sQuote("covar")," must be a data-frame")
+ covarnames <- colnames(covar)
+ covarnames <- setdiff(covarnames,tcovar)
+ } else {
+ covar <- matrix(data=0,nrow=0,ncol=0)
+ tcovar <- numeric(0)
+ covarnames <- character(0)
+ }
+ skeleton.type <- match.arg(skeleton.type)
+
+ if (missing(statenames)) stop(sQuote("statenames")," must be supplied");
+ if (missing(paramnames)) stop(sQuote("paramnames")," must be supplied");
+
+ mpt <- missing(parameter.transform)
+ mpit <- missing(parameter.inv.transform)
+ if (xor(mpt,mpit))
+ stop("if you supply one transformation function, you must supply its inverse")
+
+ pompCBuilder(
+ name=name,
+ statenames=statenames,
+ paramnames=paramnames,
+ covarnames=covarnames,
+ obsnames=obsnames,
+ rmeasure=rmeasure,
+ dmeasure=dmeasure,
+ step.fn=step.fn,
+ skeleton=skeleton,
+ parameter.transform=parameter.transform,
+ parameter.inv.transform=parameter.inv.transform,
+ rprior=rprior,
+ dprior=dprior,
+ globals=globals,
+ dir=if (save) getwd() else NULL
+ ) -> solib
+
+ name <- solib[1]
+
+ pomp(
+ data=data,
+ times=times,
+ t0=t0,
+ rprocess=euler.sim(
+ step.fun=render(fnames$step.fn,name=name),
+ delta.t=step.fn.delta.t,
+ PACKAGE=name
+ ),
+ rmeasure=render(fnames$rmeasure,name=name),
+ dmeasure=render(fnames$dmeasure,name=name),
+ skeleton=render(fnames$skeleton,name=name),
+ skeleton.type=skeleton.type,
+ skelmap.delta.t=skelmap.delta.t,
+ parameter.transform=render(fnames$parameter.transform,name=name),
+ parameter.inv.transform=render(fnames$parameter.inv.transform,name=name),
+ rprior=render(fnames$rprior,name=name),
+ dprior=render(fnames$dprior,name=name),
+ PACKAGE=name,
+ statenames=statenames,
+ paramnames=paramnames,
+ tcovar=tcovar,
+ covar=covar,
+ ...,
+ .solibfile=list(solib)
+ )
+}
+
## TEMPLATES
define <- list(
@@ -352,18 +332,7 @@
dprior="__pomp_dprior"
)
-regist <- list(
- rmeasure="R_RegisterCCallable(\"{%name%}\", \"__pomp_rmeasure\", (DL_FUNC) __pomp_rmeasure);\n",
- dmeasure="R_RegisterCCallable(\"{%name%}\", \"__pomp_dmeasure\", (DL_FUNC) __pomp_dmeasure);\n",
- step.fn="R_RegisterCCallable(\"{%name%}\", \"__pomp_stepfn\", (DL_FUNC) __pomp_stepfn);\n",
- skeleton="R_RegisterCCallable(\"{%name%}\", \"__pomp_skelfn\", (DL_FUNC) __pomp_skelfn);\n",
- parameter.transform="R_RegisterCCallable(\"{%name%}\", \"__pomp_par_trans\", (DL_FUNC) __pomp_par_trans);\n",
- parameter.inv.transform="R_RegisterCCallable(\"{%name%}\", \"__pomp_par_untrans\", (DL_FUNC) __pomp_par_untrans);\n",
- rprior="R_RegisterCCallable(\"{%name%}\", \"__pomp_rprior\", (DL_FUNC) __pomp_rprior);\n",
- dprior="R_RegisterCCallable(\"{%name%}\", \"__pomp_dprior\", (DL_FUNC) __pomp_dprior);\n",
- loadstack.incr="R_RegisterCCallable(\"{%name%}\", \"__pomp_load_stack_incr\", (DL_FUNC) __pomp_load_stack_incr);\n",
- loadstack.decr="R_RegisterCCallable(\"{%name%}\", \"__pomp_load_stack_decr\", (DL_FUNC) __pomp_load_stack_decr);\n"
- )
+registration <- "R_RegisterCCallable(\"{%name%}\", \"__pomp_{%fun%}\", (DL_FUNC) __pomp_{%fun%});\n"
decl <- list(
periodic_bspline_basis_eval="\tvoid (*periodic_bspline_basis_eval)(double,double,int,int,double*);\nperiodic_bspline_basis_eval = (void (*)(double,double,int,int,double*)) R_GetCCallable(\"pomp\",\"periodic_bspline_basis_eval\");\n",
Added: pkg/pomp/R/load.R
===================================================================
--- pkg/pomp/R/load.R (rev 0)
+++ pkg/pomp/R/load.R 2015-02-26 11:13:49 UTC (rev 1104)
@@ -0,0 +1,35 @@
+pompLoad.internal <- function (object, ..., verbose = getOption("verbose",FALSE)) {
+ for (lib in object at solibfile) {
+ if (!is.loaded("__pomp_load_stack_incr",PACKAGE=lib[1])) {
+ dyn.load(lib[2])
+ if (verbose) cat("loading",sQuote(lib[2]),"\n")
+ }
+ .Call(load_stack_incr,lib[1])
+ }
+ invisible(NULL)
+}
+
+pompUnload.internal <- function (object, ..., verbose = getOption("verbose",FALSE)) {
+ for (lib in object at solibfile) {
+ if (is.loaded("__pomp_load_stack_decr",PACKAGE=lib[1])) {
+ st <- .Call(load_stack_decr,lib[1])
+ if (st==0) {
+ dyn.unload(lib[2])
+ if (verbose) cat("unloading",sQuote(lib[2]),"\n")
+ }
+ }
+ }
+ invisible(NULL)
+}
+
+setMethod("pompLoad",
+ signature=signature(object='pomp'),
+ definition = function (object, ...) {
+ pompLoad.internal(object,...)
+ })
+
+setMethod("pompUnload",
+ signature=signature(object='pomp'),
+ definition = function (object, ...) {
+ pompUnload.internal(object,...)
+ })
More information about the pomp-commits
mailing list