[Pomp-commits] r930 - in pkg/pomp: . R demo inst inst/doc inst/examples man src tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Apr 21 03:01:45 CEST 2014
Author: kingaa
Date: 2014-04-21 03:01:42 +0200 (Mon, 21 Apr 2014)
New Revision: 930
Added:
pkg/pomp/R/csnippet.R
pkg/pomp/man/csnippet.Rd
Removed:
pkg/pomp/man/mif-class.Rd
pkg/pomp/man/pomp-class.Rd
Modified:
pkg/pomp/DESCRIPTION
pkg/pomp/NAMESPACE
pkg/pomp/R/builder.R
pkg/pomp/R/generics.R
pkg/pomp/R/plugins.R
pkg/pomp/R/pomp-class.R
pkg/pomp/R/pomp-fun.R
pkg/pomp/R/pomp.R
pkg/pomp/demo/gompertz.R
pkg/pomp/demo/sir.R
pkg/pomp/inst/NEWS
pkg/pomp/inst/NEWS.Rd
pkg/pomp/inst/doc/manual.pdf
pkg/pomp/inst/examples/blowflies.R
pkg/pomp/man/builder.Rd
pkg/pomp/man/mif.Rd
pkg/pomp/man/pomp-fun.Rd
pkg/pomp/man/pomp.Rd
pkg/pomp/src/SSA_wrapper.c
pkg/pomp/src/dmeasure.c
pkg/pomp/src/dprior.c
pkg/pomp/src/dprocess.c
pkg/pomp/src/euler.c
pkg/pomp/src/initstate.c
pkg/pomp/src/partrans.c
pkg/pomp/src/rmeasure.c
pkg/pomp/src/rprior.c
pkg/pomp/src/rprocess.c
pkg/pomp/src/skeleton.c
pkg/pomp/src/trajectory.c
pkg/pomp/tests/pomppomp.R
pkg/pomp/tests/pomppomp.Rout.save
pkg/pomp/tests/sir.Rout.save
Log:
- add new 'Csnippet' class
- rework 'pomp.fun' and plugins using S4 methods
- add capacity for handling C snippets to basic functions & plugins
- modify demo/sir.R and demo/gompertz.R to use new facilities
- remove 'obsnames', 'paramnames', 'statenames', 'covarnames' from 'pomp' class: transfer these to 'pomp.fun' class
- 'pomp.fun' is now a method
- remove separate documentation of 'pomp' class and 'mif' class.
- add support for compiled 'globals' to 'pomp'
- add support for prior distributions to 'pompBuilder'
- better commentary inside 'pomp'
- remove redundant error checking inside 'pomp' (make use of S4-class validation mechanisms)
- move linking operation inside 'pompCBuilder'
- random 'name' generation inside 'pompCBuilder' when name isn't supplied
Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION 2014-04-18 15:41:12 UTC (rev 929)
+++ pkg/pomp/DESCRIPTION 2014-04-21 01:01:42 UTC (rev 930)
@@ -2,7 +2,7 @@
Type: Package
Title: Statistical inference for partially observed Markov processes
Version: 0.50-1
-Date: 2014-04-18
+Date: 2014-04-20
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,9 +24,10 @@
BuildVignettes: false
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 version.R eulermultinom.R
- plugins.R parmat.R logmeanexp.R slice-design.R
+ csnippet.R pomp-fun.R plugins.R
+ parmat.R logmeanexp.R slice-design.R
profile-design.R sobol.R bsplines.R sannbox.R
- pomp-fun.R pomp-class.R pomp.R pomp-methods.R
+ pomp-class.R pomp.R pomp-methods.R
rmeasure-pomp.R rprocess-pomp.R init-state-pomp.R
dmeasure-pomp.R dprocess-pomp.R skeleton-pomp.R
dprior-pomp.R rprior-pomp.R
Modified: pkg/pomp/NAMESPACE
===================================================================
--- pkg/pomp/NAMESPACE 2014-04-18 15:41:12 UTC (rev 929)
+++ pkg/pomp/NAMESPACE 2014-04-21 01:01:42 UTC (rev 930)
@@ -47,7 +47,8 @@
traj.matched.pomp,
probed.pomp,probe.matched.pomp,
spect.pomp,spect.matched.pomp,
- abc
+ abc,
+ Csnippet
)
exportMethods(
@@ -71,6 +72,7 @@
export(
as.data.frame.pomp,
as.data.frame.pfilterd.pomp,
+ Csnippet,
reulermultinom,
deulermultinom,
rgammawn,
Modified: pkg/pomp/R/builder.R
===================================================================
--- pkg/pomp/R/builder.R 2014-04-18 15:41:12 UTC (rev 929)
+++ pkg/pomp/R/builder.R 2014-04-21 01:01:42 UTC (rev 930)
@@ -1,31 +1,12 @@
-setClass(
- "pompCode",
- representation=representation(
- type="character",
- slot="character",
- text="character",
- fun="function"
- ),
- prototype=prototype(
- type="ccode",
- slot=character(0),
- text=character(0),
- fun=function(...)stop("function not specified")
- )
- )
-
-
-CCode <- function (text, slot) {
- new("pompCode",type="ccode",slot=as.character(slot))
-}
-
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, ..., link = TRUE, save = FALSE) {
+
if (!is.data.frame(data)) stop(sQuote("data")," must be a data-frame")
obsnames <- names(data)
obsnames <- setdiff(obsnames,times)
@@ -39,6 +20,15 @@
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,
@@ -51,35 +41,34 @@
skeleton=skeleton,
parameter.transform=parameter.transform,
parameter.inv.transform=parameter.inv.transform,
+ rprior=rprior,
+ dprior=dprior,
globals=globals,
+ link=link,
save=save
- )
- if (link) {
- if (save) {
- pompLink(name)
- } else {
- pompLink(file.path(tempdir(),name))
- }
- }
+ ) -> name
+
pomp(
- data=data,times=times,t0=t0,
+ data=data,
+ times=times,
+ t0=t0,
rprocess=euler.sim(
- step.fun=render("{%name%}_stepfn",name=name),
+ step.fun=render(fnames$step.fn,name=name),
delta.t=step.fn.delta.t,
PACKAGE=name
),
- rmeasure=render("{%name%}_rmeasure",name=name),
- dmeasure=render("{%name%}_dmeasure",name=name),
- skeleton=render("{%name%}_skelfn",name=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("{%name%}_par_trans",name=name),
- parameter.inv.transform=render("{%name%}_par_untrans",name=name),
+ 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,
- obsnames=obsnames,
statenames=statenames,
paramnames=paramnames,
- covarnames=covarnames,
tcovar=tcovar,
covar=covar,
...
@@ -112,9 +101,23 @@
step.fn="\nvoid {%name%}_stepfn (double *__x, const double *__p, const int *__stateindex, const int *__parindex, const int *__covindex, int __covdim, const double *__covars, double t, double dt)\n{\n",
skeleton="\nvoid {%name%}_skelfn (double *__f, double *__x, double *__p, int *__stateindex, int *__parindex, int *__covindex, int __ncovars, double *__covars, double t)\n{\n",
parameter.transform="\nvoid {%name%}_par_trans (double *__pt, double *__p, int *__parindex)\n{\n",
- parameter.inv.transform="\nvoid {%name%}_par_untrans (double *__pt, double *__p, int *__parindex)\n{\n"
+ parameter.inv.transform="\nvoid {%name%}_par_untrans (double *__pt, double *__p, int *__parindex)\n{\n",
+ rprior="\nvoid {%name%}_rprior (double *__p, int *__parindex)\n{\n",
+ dprior="\nvoid {%name%}_dprior (double *__lik, double *__p, int give_log, int *__parindex)\n{\n"
)
+
+fnames <- list(
+ rmeasure="{%name%}_rmeasure",
+ dmeasure= "{%name%}_dmeasure",
+ step.fn="{%name%}_stepfn",
+ skeleton="{%name%}_skelfn",
+ parameter.transform="{%name%}_par_trans",
+ parameter.inv.transform="{%name%}_par_untrans",
+ rprior="{%name%}_rprior",
+ dprior="{%name%}_dprior"
+ )
+
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",
get_pomp_userdata_int="\tconst int * (*get_pomp_userdata_int)(const char *);\nget_pomp_userdata_int = (const int *(*)(const char*)) R_GetCCallable(\"pomp\",\"get_pomp_userdata_int\");\n",
@@ -128,7 +131,9 @@
step.fn="\n}\n\n",
skeleton="\n}\n\n",
parameter.transform="\n}\n\n",
- parameter.inv.transform="\n}\n\n"
+ parameter.inv.transform="\n}\n\n",
+ rprior="\n}\n\n",
+ dprior="\n}\n\n"
)
utility.fns <- list()
@@ -145,21 +150,24 @@
pompCBuilder <- function (name, statenames, paramnames, covarnames, obsnames,
rmeasure, dmeasure, step.fn, skeleton,
parameter.transform, parameter.inv.transform,
- globals, save = FALSE)
+ rprior, dprior, globals, save = FALSE, link = TRUE)
{
- if (missing(name)) stop(sQuote("name")," must be supplied");
- if (missing(statenames)) stop(sQuote("statenames")," must be supplied");
- if (missing(paramnames)) stop(sQuote("paramnames")," must be supplied");
- if (missing(obsnames)) stop(sQuote("obsnames")," must be supplied");
- if (missing(covarnames)) stop(sQuote("covarnames")," must be supplied");
+
+ if (missing(name))
+ name <- paste0("pomp",
+ paste(
+ format(
+ as.hexmode(ceiling(runif(n=2,max=2^24))),
+ upper.case=TRUE
+ ),
+ collapse=""
+ )
+ )
+
+ has.trans <- !(missing(parameter.transform))
+
if (missing(globals)) globals <- ""
- 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")
- has.trans <- !mpt
-
name <- cleanForC(name)
statenames <- cleanForC(statenames)
paramnames <- cleanForC(paramnames)
@@ -190,12 +198,12 @@
for (v in seq_along(paramnames)) {
cat(file=out,render(define$var,variable=paramnames[v],ptr='__p',ilist='__parindex',index=v-1))
}
+ for (v in seq_along(statenames)) {
+ cat(file=out,render(define$var,variable=statenames[v],ptr='__x',ilist='__stateindex',index=v-1))
+ }
for (v in seq_along(covarnames)) {
cat(file=out,render(define$var,variable=covarnames[v],ptr='__covars',ilist='__covindex',index=v-1))
}
- for (v in seq_along(statenames)) {
- cat(file=out,render(define$var,variable=statenames[v],ptr='__x',ilist='__stateindex',index=v-1))
- }
for (v in seq_along(obsnames)) {
cat(file=out,render(define$var,variable=obsnames[v],ptr='__y',ilist='__obsindex',index=v-1))
}
@@ -238,16 +246,24 @@
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)
+
+ ## dprior function
+ if (missing(dprior)) dprior <- missing.fun("dprior")
+ cat(file=out,render(header$dprior,name=name),dprior,footer$dprior)
+
## undefine variables
for (v in seq_along(paramnames)) {
cat(file=out,render(undefine$var,variable=paramnames[v]))
}
+ for (v in seq_along(statenames)) {
+ cat(file=out,render(undefine$var,variable=statenames[v]))
+ }
for (v in seq_along(covarnames)) {
cat(file=out,render(undefine$var,variable=covarnames[v]))
}
- for (v in seq_along(statenames)) {
- cat(file=out,render(undefine$var,variable=statenames[v]))
- }
for (v in seq_along(obsnames)) {
cat(file=out,render(undefine$var,variable=obsnames[v]))
}
@@ -274,7 +290,15 @@
cat("model codes written to",sQuote(modelfile),
"\nlink to shared-object library",sQuote(solib),"\n")
- invisible(NULL)
+ if (link) {
+ if (save) {
+ pompLink(name)
+ } else {
+ pompLink(file.path(tempdir(),name))
+ }
+ }
+
+ invisible(name)
}
cleanForC <- function (text) {
Added: pkg/pomp/R/csnippet.R
===================================================================
--- pkg/pomp/R/csnippet.R (rev 0)
+++ pkg/pomp/R/csnippet.R 2014-04-21 01:01:42 UTC (rev 930)
@@ -0,0 +1,18 @@
+## a class to hold snippets of C code
+
+setClass(
+ "Csnippet",
+ slots=c(
+ text="character"
+ ),
+ prototype=prototype(
+ text=character(0)
+ )
+ )
+
+Csnippet <- function (text) {
+ new(
+ "Csnippet",
+ text=as.character(text)
+ )
+}
Modified: pkg/pomp/R/generics.R
===================================================================
--- pkg/pomp/R/generics.R 2014-04-18 15:41:12 UTC (rev 929)
+++ pkg/pomp/R/generics.R 2014-04-21 01:01:42 UTC (rev 930)
@@ -29,6 +29,10 @@
setGeneric("partrans",function(object,params,dir=c("forward","inverse"),...)standardGeneric("partrans"))
setGeneric("logLik",function(object,...)standardGeneric("logLik"))
+## internals
+setGeneric("pomp.fun",function(f,...)standardGeneric("pomp.fun"))
+setGeneric("plugin.handler",function(object,...)standardGeneric("plugin.handler"))
+
## prediction mean
setGeneric("pred.mean",function(object,...)standardGeneric("pred.mean"))
## prediction variance
Modified: pkg/pomp/R/plugins.R
===================================================================
--- pkg/pomp/R/plugins.R 2014-04-18 15:41:12 UTC (rev 929)
+++ pkg/pomp/R/plugins.R 2014-04-21 01:01:42 UTC (rev 930)
@@ -1,172 +1,289 @@
+setClass(
+ "pompPlugin",
+ slots=c(
+ csnippet='logical',
+ slotname='character',
+ PACKAGE='character'
+ ),
+ prototype=prototype(
+ csnippet=FALSE,
+ slotname=character(0),
+ PACKAGE=character(0)
+ )
+ )
+
+setClass(
+ "onestepRprocessPlugin",
+ contains="pompPlugin",
+ slots=c(
+ step.fn="ANY"
+ )
+ )
+
+setClass(
+ "discreteRprocessPlugin",
+ contains="pompPlugin",
+ slots=c(
+ step.fn="ANY",
+ delta.t="numeric"
+ )
+ )
+
+setClass(
+ "eulerRprocessPlugin",
+ contains="pompPlugin",
+ slots=c(
+ step.fn="ANY",
+ delta.t="numeric"
+ )
+ )
+
+setClass(
+ "gillespieRprocessPlugin",
+ contains="pompPlugin",
+ slots=c(
+ rate.fn="ANY",
+ v="matrix",
+ d="matrix"
+ )
+ )
+
+setClass(
+ "onestepDprocessPlugin",
+ contains="pompPlugin",
+ slots=c(
+ dens.fn="ANY"
+ )
+ )
+
onestep.sim <- function (step.fun, PACKAGE) {
- efun <- pomp.fun(
- f=step.fun,
- PACKAGE=PACKAGE,
- proto=quote(step.fun(x,t,params,delta.t,...))
- )
- function (xstart, times, params, ...,
- statenames = character(0),
- paramnames = character(0),
- covarnames = character(0),
- zeronames = character(0),
- tcovar, covar,
- .getnativesymbolinfo = TRUE) {
- .Call(
- euler_model_simulator,
- func=efun,
- xstart=xstart,
- times=times,
- params=params,
- dt=0,
- method=1L,
- statenames=statenames,
- paramnames=paramnames,
- covarnames=covarnames,
- zeronames=zeronames,
- tcovar=tcovar,
- covar=covar,
- args=pairlist(...),
- gnsi=.getnativesymbolinfo
- )
- }
+ if (missing(PACKAGE)) PACKAGE <- character(0)
+ new("onestepRprocessPlugin",
+ step.fn=step.fun,
+ slotname="step.fn",
+ PACKAGE=PACKAGE)
}
discrete.time.sim <- function (step.fun, delta.t = 1, PACKAGE) {
- efun <- pomp.fun(
- f=step.fun,
- PACKAGE=PACKAGE,
- proto=quote(step.fun(x,t,params,...))
- )
- function (xstart, times, params, ...,
- statenames = character(0),
- paramnames = character(0),
- covarnames = character(0),
- zeronames = character(0),
- tcovar, covar,
- .getnativesymbolinfo = TRUE) {
- .Call(
- euler_model_simulator,
- func=efun,
- xstart=xstart,
- times=times,
- params=params,
- dt=delta.t,
- method=2L,
- statenames=statenames,
- paramnames=paramnames,
- covarnames=covarnames,
- zeronames=zeronames,
- tcovar=tcovar,
- covar=covar,
- args=pairlist(...),
- gnsi=.getnativesymbolinfo
- )
- }
+ if (missing(PACKAGE)) PACKAGE <- character(0)
+ new("discreteRprocessPlugin",
+ step.fn=step.fun,delta.t=delta.t,
+ slotname="step.fn",
+ csnippet=is(step.fun,"Csnippet"),
+ PACKAGE=PACKAGE)
}
euler.sim <- function (step.fun, delta.t, PACKAGE) {
- efun <- pomp.fun(
- f=step.fun,
- PACKAGE=PACKAGE,
- proto=quote(step.fun(x,t,params,delta.t,...))
- )
- function (xstart, times, params, ...,
- statenames = character(0),
- paramnames = character(0),
- covarnames = character(0),
- zeronames = character(0),
- tcovar, covar,
- .getnativesymbolinfo = TRUE) {
- .Call(
- euler_model_simulator,
- func=efun,
- xstart=xstart,
- times=times,
- params=params,
- dt=delta.t,
- method=0L,
- statenames=statenames,
- paramnames=paramnames,
- covarnames=covarnames,
- zeronames=zeronames,
- tcovar=tcovar,
- covar=covar,
- args=pairlist(...),
- gnsi=.getnativesymbolinfo
- )
- }
+ if (missing(PACKAGE)) PACKAGE <- character(0)
+ new("eulerRprocessPlugin",
+ step.fn=step.fun,delta.t=delta.t,
+ slotname="step.fn",
+ csnippet=is(step.fun,"Csnippet"),
+ PACKAGE=PACKAGE)
}
+gillespie.sim <- function (rate.fun, v, d, PACKAGE) {
+ if (missing(PACKAGE)) PACKAGE <- character(0)
+ new("gillespieRprocessPlugin",
+ rate.fn=rate.fun,v=v,d=d,
+ slotname="rate.fn",
+ csnippet=is(rate.fun,"Csnippet"),
+ PACKAGE=PACKAGE)
+}
+
onestep.dens <- function (dens.fun, PACKAGE) {
- efun <- pomp.fun(
- f=dens.fun,
- PACKAGE=PACKAGE,
- proto=quote(dens.fun(x1,x2,t1,t2,params,...))
- )
- function (x, times, params, ...,
- statenames = character(0),
- paramnames = character(0),
- covarnames = character(0),
- tcovar, covar, log = FALSE,
- .getnativesymbolinfo = TRUE) {
- .Call(
- euler_model_density,
- func=efun,
- x=x,
- times=times,
- params=params,
- statenames=statenames,
- paramnames=paramnames,
- covarnames=covarnames,
- tcovar=tcovar,
- covar=covar,
- log=log,
- args=pairlist(...),
- gnsi=.getnativesymbolinfo
- )
- }
+ if (missing(PACKAGE)) PACKAGE <- character(0)
+ new("onestepDprocessPlugin",
+ dens.fn=dens.fun,
+ slotname="dens.fn",
+ csnippet=is(dens.fun,"Csnippet"),
+ PACKAGE=PACKAGE)
}
-gillespie.sim <- function (rate.fun, v, d, PACKAGE) {
- if (!(is.matrix(d)&&is.matrix(v))) {
- stop(sQuote("v")," and ",sQuote("d")," must be matrices")
- }
- nvar <- nrow(v)
- nevent <- ncol(v)
- if ((nvar!=nrow(d))||(nevent!=ncol(d)))
- stop(sQuote("v")," and ",sQuote("d")," must agree in dimension")
+setMethod(
+ "plugin.handler",
+ signature=signature(object='function'),
+ definition=function (object, ...) {
+ object
+ }
+ )
- efun <- pomp.fun(
- f=rate.fun,
- PACKAGE=PACKAGE,
- proto=quote(rate.fun(j,x,t,params,...))
- )
- function (xstart, times, params,
- statenames = character(0),
- paramnames = character(0),
- covarnames = character(0),
- zeronames = character(0),
- tcovar, covar,
- .getnativesymbolinfo = TRUE,
- ...) {
- .Call(
- SSA_simulator,
- func=efun,
- mflag=0L, ## Gillespie's algorithm
- xstart=xstart,
- times=times,
- params=params,
- e=rep(0,nvar),
- vmatrix=v,
- dmatrix=d,
- tcovar=tcovar,
- covar=covar,
- statenames=statenames,
- paramnames=paramnames,
- covarnames=covarnames,
- zeronames=zeronames,
- args=pairlist(...),
- gnsi=.getnativesymbolinfo
+setMethod(
+ "plugin.handler",
+ signature=signature(object='ANY'),
+ definition=function (object, ...) {
+ stop("plugin has an invalid form")
+ }
)
- }
-}
+
+setMethod(
+ "plugin.handler",
+ signature=signature(object='onestepRprocessPlugin'),
+ definition=function (object, ...) {
+ efun <- pomp.fun(
+ f=object at step.fn,
+ PACKAGE=object at PACKAGE,
+ proto=quote(step.fun(x,t,params,delta.t,...)),
+ slotname=object at slotname,
+ ...
+ )
+ function (xstart, times, params, ...,
+ zeronames = character(0),
+ tcovar, covar,
+ .getnativesymbolinfo = TRUE) {
+ .Call(
+ euler_model_simulator,
+ func=efun,
+ xstart=xstart,
+ times=times,
+ params=params,
+ dt=0,
+ method=1L,
+ zeronames=zeronames,
+ tcovar=tcovar,
+ covar=covar,
+ args=pairlist(...),
+ gnsi=.getnativesymbolinfo
+ )
+ }
+ }
+ )
+
+setMethod(
+ "plugin.handler",
+ signature=signature(object='discreteRprocessPlugin'),
+ definition=function (object, ...) {
+ efun <- pomp.fun(
+ f=object at step.fn,
+ PACKAGE=object at PACKAGE,
+ proto=quote(step.fun(x,t,params,...)),
+ slotname=object at slotname,
+ ...
+ )
+ function (xstart, times, params, ...,
+ zeronames = character(0),
+ tcovar, covar,
+ .getnativesymbolinfo = TRUE) {
+ .Call(
+ euler_model_simulator,
+ func=efun,
+ xstart=xstart,
+ times=times,
+ params=params,
+ dt=object at delta.t,
+ method=2L,
+ zeronames=zeronames,
+ tcovar=tcovar,
+ covar=covar,
+ args=pairlist(...),
+ gnsi=.getnativesymbolinfo
+ )
+ }
+ }
+ )
+
+setMethod(
+ "plugin.handler",
+ signature=signature(object='eulerRprocessPlugin'),
+ definition=function (object, ...) {
+ efun <- pomp.fun(
+ f=object at step.fn,
+ PACKAGE=object at PACKAGE,
+ proto=quote(step.fun(x,t,params,delta.t,...)),
+ slotname=object at slotname,
+ ...
+ )
+ function (xstart, times, params, ...,
+ zeronames = character(0),
+ tcovar, covar,
+ .getnativesymbolinfo = TRUE) {
+ .Call(
+ euler_model_simulator,
+ func=efun,
+ xstart=xstart,
+ times=times,
+ params=params,
+ dt=object at delta.t,
+ method=0L,
+ zeronames=zeronames,
+ tcovar=tcovar,
+ covar=covar,
+ args=pairlist(...),
+ gnsi=.getnativesymbolinfo
+ )
+ }
+ }
+ )
+
+setMethod(
+ "plugin.handler",
+ signature=signature(object='gillespieRprocessPlugin'),
+ definition=function (object, ...) {
+ if (!(is.matrix(object at d)&&is.matrix(object at v))) {
+ stop(sQuote("v")," and ",sQuote("d")," must be matrices")
+ }
+ nvar <- nrow(object at v)
+ nevent <- ncol(object at v)
+ if ((nvar!=nrow(object at d))||(nevent!=ncol(object at d)))
+ stop(sQuote("v")," and ",sQuote("d")," must agree in dimension")
+ efun <- pomp.fun(
+ f=object at rate.fn,
+ PACKAGE=object at PACKAGE,
+ proto=quote(rate.fun(j,x,t,params,...)),
+ slotname=object at slotname,
+ ...
+ )
+ function (xstart, times, params,
+ zeronames = character(0),
+ tcovar, covar,
+ .getnativesymbolinfo = TRUE,
+ ...) {
+ .Call(
+ SSA_simulator,
+ func=efun,
+ mflag=0L, ## Gillespie's algorithm
+ xstart=xstart,
+ times=times,
+ params=params,
+ e=rep(0,nvar),
+ vmatrix=object at v,
+ dmatrix=object at d,
+ tcovar=tcovar,
+ covar=covar,
+ zeronames=zeronames,
+ args=pairlist(...),
+ gnsi=.getnativesymbolinfo
+ )
+ }
+ }
+ )
+
+setMethod(
+ "plugin.handler",
+ signature=signature(object='onestepDprocessPlugin'),
+ definition=function (object, ...) {
+ efun <- pomp.fun(
+ f=object at dens.fn,
+ PACKAGE=object at PACKAGE,
+ proto=quote(dens.fun(x1,x2,t1,t2,params,...)),
+ slotname=object at slotname,
+ ...
+ )
+ function (x, times, params, ...,
+ tcovar, covar, log = FALSE,
+ .getnativesymbolinfo = TRUE) {
+ .Call(
+ euler_model_density,
+ func=efun,
+ x=x,
+ times=times,
+ params=params,
+ tcovar=tcovar,
+ covar=covar,
+ log=log,
+ args=pairlist(...),
+ gnsi=.getnativesymbolinfo
+ )
+ }
+ }
+ )
Modified: pkg/pomp/R/pomp-class.R
===================================================================
--- pkg/pomp/R/pomp-class.R 2014-04-18 15:41:12 UTC (rev 929)
+++ pkg/pomp/R/pomp-class.R 2014-04-21 01:01:42 UTC (rev 930)
@@ -6,9 +6,7 @@
if (length(ivpnames)<1)
stop("default initializer error: no parameter names ending in ",
sQuote(".0")," found: see ",sQuote("pomp")," documentation")
- x <- params[ivpnames]
- names(x) <- sub("\\.0$","",ivpnames)
- x
+ setNames(params[ivpnames],sub("\\.0$","",ivpnames))
}
## define the pomp class
@@ -32,15 +30,10 @@
params = 'numeric',
covar = 'matrix',
tcovar = 'numeric',
- obsnames = 'character',
- statenames = 'character',
- paramnames = 'character',
- covarnames = 'character',
zeronames = 'character',
has.trans = 'logical',
par.trans = 'pomp.fun',
par.untrans = 'pomp.fun',
- PACKAGE = 'character',
userdata = 'list'
),
prototype=prototype(
@@ -61,15 +54,10 @@
params=numeric(0),
covar=array(data=numeric(0),dim=c(0,0)),
tcovar=numeric(0),
- obsnames=character(0),
- statenames=character(0),
- paramnames=character(0),
- covarnames=character(0),
zeronames=character(0),
has.trans=FALSE,
par.trans=pomp.fun(),
par.untrans=pomp.fun(),
- PACKAGE=character(0),
userdata=list()
),
validity=function (object) {
@@ -78,8 +66,6 @@
retval <- append(retval,paste(sQuote("data"),"is a required argument"))
if (length(object at times)<1)
retval <- append(retval,paste(sQuote("times"),"is a required argument"))
- if (length(object at t0)<1)
- retval <- append(retval,paste(sQuote("t0"),"is a required argument"))
if (!is.numeric(object at params) || (length(object at params)>0 && is.null(names(object at params))))
retval <- append(retval,paste(sQuote("params"),"must be a named numeric vector"))
if (ncol(object at data)!=length(object at times))
@@ -89,7 +75,8 @@
if (length(object at t0)>1)
retval <- append(retval,paste(sQuote("t0"),"must be a single number"))
if (object at t0 > object at times[1])
- retval <- append(retval,paste("the zero-time",sQuote("t0"),"must occur no later than the first observation"))
+ retval <- append(retval,paste("the zero-time",sQuote("t0"),
+ "must occur no later than the first observation"))
if (object at skelmap.delta.t <= 0)
retval <- append(retval,paste(sQuote("skelmap.delta.t"),"must be positive"))
if (!all(c('xstart','times','params','...')%in%names(formals(object at rprocess))))
@@ -124,15 +111,6 @@
"should match the number of rows of",sQuote("covar")
)
)
- } else if (!all(object at covarnames%in%colnames(object at covar))) {
- missing <- object at covarnames[!(object at covarnames%in%colnames(object at covar))]
- retval <- append(
- retval,
- paste(
- "covariate(s)",paste(missing,collapse=","),
- "are not found among the columns of",sQuote("covar")
- )
- )
}
if (!is.numeric(object at tcovar))
retval <- append(
Modified: pkg/pomp/R/pomp-fun.R
===================================================================
--- pkg/pomp/R/pomp-fun.R 2014-04-18 15:41:12 UTC (rev 929)
+++ pkg/pomp/R/pomp-fun.R 2014-04-21 01:01:42 UTC (rev 930)
@@ -1,55 +1,118 @@
-## a class for functions that may be defined in R or using native routines
+## a class for functions that may be defined in R,
+## using pre-written native routines, or C snippets
+
setClass(
'pomp.fun',
- representation(
- R.fun = 'function',
- native.fun = 'character',
- PACKAGE = 'character',
- mode = 'integer',
- address = 'externalptr'
- ),
+ slots=c(
+ R.fun = 'function',
+ native.fun = 'character',
+ PACKAGE = 'character',
+ mode = 'integer',
+ address = 'externalptr',
+ obsnames = 'character',
+ statenames = 'character',
+ paramnames = 'character',
+ covarnames = 'character'
+ ),
prototype=prototype(
- R.fun=function(...)stop("unreachable error: please report this bug!"),
+ R.fun=function (...) {
+ stop("unreachable error: please report this bug!")
+ },
native.fun=character(0),
- PACKAGE="",
- mode=-1L ## undefined
+ PACKAGE=character(0),
+ mode=-1L, ## undefined behavior
+ obsnames = character(0),
+ statenames = character(0),
+ paramnames = character(0),
+ covarnames = character(0)
)
)
-## constructor
-pomp.fun <- function (f = NULL, PACKAGE, proto = NULL) {
- if (missing(PACKAGE)) PACKAGE <- ""
- if (!is.null(proto)) {
- if (!is.call(proto))
- stop(sQuote("proto")," must be an unevaluated call")
- prototype <- as.character(proto)
- fname <- prototype[1]
- args <- prototype[-1]
- if (is.function(f)&&(!all(args%in%names(formals(f)))))
- stop(sQuote(fname)," must be a function of prototype ",deparse(proto),call.=FALSE)
- }
- if (is(f,"pomp.fun")) {
- retval <- f
- } else if (is.function(f)) {
- retval <- new(
- "pomp.fun",
- R.fun=f,
- mode=1L
- )
- } else if (is.character(f)) {
- retval <- new(
- "pomp.fun",
- native.fun=f,
- PACKAGE=PACKAGE,
- mode=2L
- )
- } else {
- retval <- new("pomp.fun")
- }
- retval
-}
+setMethod(
+ "pomp.fun",
+ signature=signature(f="missing"),
+ definition=function (f, ...) {
+ new("pomp.fun")
+ }
+ )
setMethod(
+ "pomp.fun",
+ signature=signature(f="NULL"),
+ definition=function (f, ...) {
+ new("pomp.fun")
+ }
+ )
+
+setMethod(
+ "pomp.fun",
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/pomp -r 930
More information about the pomp-commits
mailing list