Nothing
## basic constructor of the pomp class
pomp.constructor <- function (data, times, t0, rprocess, dprocess,
rmeasure, dmeasure, measurement.model,
skeleton,
skeleton.type = c("map","vectorfield"),
skelmap.delta.t,
initializer, rprior, dprior,
params, covar, tcovar,
obsnames, statenames, paramnames, covarnames,
zeronames, PACKAGE,
fromEstimationScale, toEstimationScale,
parameter.transform = NULL, parameter.inv.transform = NULL,
globals, userdata, ...,
.solibfile = list(),
.filename = NULL,
.filedir = getOption("pomp.cache",NULL),
verbose = getOption("verbose",FALSE)) {
## preliminary error checking
if (missing(data)) stop(sQuote("data")," is a required argument")
if (missing(times)) stop(sQuote("times")," is a required argument")
if (missing(t0)) stop(sQuote("t0")," is a required argument")
if (missing(params)) params <- numeric(0)
if (missing(userdata)) userdata <- list()
added.userdata <- list(...)
if (length(added.userdata)>0) {
message("In ",sQuote("pomp"),
": the following unrecognized argument(s) ",
"will be stored for use by user-defined functions: ",
paste(sQuote(names(added.userdata)),collapse=","))
userdata[names(added.userdata)] <- added.userdata
}
## name of shared object library
if (missing(PACKAGE)) PACKAGE <- NULL
PACKAGE <- as.character(PACKAGE)
if (missing(globals)) globals <- NULL
globals <- as.character(globals)
## deal with missing components
if (missing(skeleton)) skeleton <- NULL
if (missing(rmeasure)) rmeasure <- NULL
if (missing(dmeasure)) dmeasure <- NULL
if (missing(rprior)) rprior <- NULL
if (missing(dprior)) dprior <- NULL
if (missing(fromEstimationScale)) fromEstimationScale <- NULL
if (missing(toEstimationScale)) toEstimationScale <- NULL
## deal with deprecated arguments
if (!is.null(parameter.transform)) {
warning("the ",sQuote("parameter.transform")," argument of ",
sQuote("pomp")," is deprecated, ",
"and will be removed in a future release.\n",
"Use ",sQuote("fromEstimationScale")," instead.",call.=FALSE)
if (!is.null(fromEstimationScale) && !is(fromEstimationScale,"pomp.fun")) {
warning("both ",sQuote("fromEstimationScale")," and ",
sQuote("parameter.transform")," have been specified in a call to ",
sQuote("pomp"),".\n",
"The latter will be ignored.",call.=FALSE)
} else {
fromEstimationScale <- parameter.transform
}
}
if (!is.null(parameter.inv.transform)) {
warning("the ",sQuote("parameter.inv.transform")," argument of ",
sQuote("pomp")," is deprecated, ",
"and will be removed in a future release.\n",
"Use ",sQuote("toEstimationScale")," instead.",call.=FALSE)
if (!is.null(toEstimationScale) && !is(toEstimationScale,"pomp.fun")) {
warning("both ",sQuote("toEstimationScale")," and ",
sQuote("parameter.inv.transform")," have been specified in a call to ",
sQuote("pomp"),".\n",
"The latter will be ignored.",call.=FALSE)
} else {
toEstimationScale <- parameter.inv.transform
}
}
## defaults for names of states, parameters, and accumulator variables
if (missing(statenames)) statenames <- character(0)
if (missing(paramnames)) paramnames <- character(0)
if (missing(zeronames)) zeronames <- character(0)
## check the parameters and force them to be double-precision
if (length(params)>0) {
if (is.null(names(params)) || !is.numeric(params))
stop("pomp error: ",sQuote("params")," must be a named numeric vector")
}
storage.mode(params) <- 'double'
## check the data and store it as double-precision matrix
if (!is.numeric(data))
stop("pomp error: ",sQuote("data")," must be numeric")
storage.mode(data) <- 'double'
if (missing(obsnames) || length(obsnames)==0) obsnames <- rownames(data)
obsnames <- as.character(obsnames)
## check times
if (!is.numeric(times) || !all(diff(times)>0))
stop("pomp error: ",sQuote("times")," must be an increasing numeric vector")
storage.mode(times) <- 'double'
## check t0
if (!is.numeric(t0) || length(t0) > 1)
stop("pomp error: the zero-time ",sQuote("t0")," must be a single number")
storage.mode(t0) <- 'double'
## check and arrange covariates
if (missing(covar)) {
covar <- matrix(data=0,nrow=0,ncol=0)
tcovar <- numeric(0)
} else if (missing(tcovar)) {
stop("pomp error: if ",sQuote("covar")," is supplied, ",
sQuote("tcovar")," must also be supplied")
} else if (is.data.frame(covar)) {
if ((is.numeric(tcovar) && (tcovar<1 || tcovar>length(covar))) ||
(is.character(tcovar) && (!(tcovar%in%names(covar)))) ||
(!is.numeric(tcovar) && !is.character(tcovar))) {
stop("pomp error: if ",sQuote("covar")," is a data frame, ",
sQuote("tcovar")," should indicate the time variable")
} else if (is.numeric(tcovar)) {
tpos <- tcovar
tcovar <- covar[[tpos]]
covar <- as.matrix(covar[-tpos])
} else if (is.character(tcovar)) {
tpos <- match(tcovar,names(covar))
tcovar <- covar[[tpos]]
covar <- as.matrix(covar[-tpos])
}
} else {
covar <- as.matrix(covar)
}
if (missing(covarnames) || length(covarnames)==0) covarnames <- as.character(colnames(covar))
if (!all(covarnames%in%colnames(covar))) {
missing <- covarnames[!(covarnames%in%colnames(covar))]
stop("pomp error: covariate(s) ",paste(missing,collapse=","),
" are not among the columns of ",sQuote("covar"))
}
storage.mode(tcovar) <- "double"
storage.mode(covar) <- "double"
## handle initializer
default.init <- missing(initializer) || (is(initializer,"pomp.fun") && initializer@mode == pompfunmode$undef)
if (default.init) initializer <- pomp.fun()
## default rprocess & dprocess
if (missing(rprocess))
rprocess <- function (xstart,times,params,...) stop(sQuote("rprocess")," not specified")
if (missing(dprocess))
dprocess <- function (x,times,params,log=FALSE,...) stop(sQuote("dprocess")," not specified")
## handle C snippets
snips <- list()
if (is(rprocess,"pompPlugin") && rprocess@csnippet)
snips <- c(snips,setNames(list(slot(rprocess,rprocess@slotname)@text),rprocess@slotname))
if (is(dprocess,"pompPlugin") && dprocess@csnippet)
snips <- c(snips,setNames(list(slot(dprocess,dprocess@slotname)@text),dprocess@slotname))
if (is(skeleton,"Csnippet"))
snips <- c(snips,skeleton=skeleton@text)
if (is(rmeasure,"Csnippet"))
snips <- c(snips,rmeasure=rmeasure@text)
if (is(dmeasure,"Csnippet"))
snips <- c(snips,dmeasure=dmeasure@text)
if (is(rprior,"Csnippet"))
snips <- c(snips,rprior=rprior@text)
if (is(dprior,"Csnippet"))
snips <- c(snips,dprior=dprior@text)
if (is(fromEstimationScale,"Csnippet"))
snips <- c(snips,fromEstimationScale=fromEstimationScale@text)
if (is(toEstimationScale,"Csnippet"))
snips <- c(snips,toEstimationScale=toEstimationScale@text)
if (is(initializer,"Csnippet"))
snips <- c(snips,initializer=initializer@text)
if (length(snips)>0) {
libname <- try(
do.call(
pompCBuilder,
c(
list(
obsnames=obsnames,
statenames=statenames,
paramnames=paramnames,
covarnames=covarnames,
globals=globals,
name=.filename,
dir=.filedir,
verbose=verbose
),
snips
)
),
silent=FALSE
)
if (inherits(libname,"try-error")) {
stop("in ",sQuote("pomp"),": error in building shared-object library from Csnippets:\n",
libname,call.=FALSE)
} else {
.solibfile <- c(.solibfile,list(libname))
libname <- libname[1]
}
} else {
libname <- ''
}
## handle initializer
if (!default.init) {
initializer <- pomp.fun(
f=initializer,
PACKAGE=PACKAGE,
proto=quote(initializer(params,t0,...)),
slotname="initializer",
libname=libname,
statenames=statenames,
paramnames=paramnames,
obsnames=obsnames,
covarnames=covarnames
)
}
## handle rprocess
if (is(rprocess,"pompPlugin")) {
rprocess <- plugin.handler(
rprocess,
libname=libname,
statenames=statenames,
paramnames=paramnames,
obsnames=obsnames,
covarnames=covarnames
)
}
if (!is.function(rprocess))
stop("pomp error: ",sQuote("rprocess")," must be a function")
## handle dprocess
if (is(dprocess,"pompPlugin")) {
dprocess <- plugin.handler(
dprocess,
libname=libname,
statenames=statenames,
paramnames=paramnames,
obsnames=obsnames,
covarnames=covarnames
)
}
if (!is.function(dprocess))
stop("pomp error: ",sQuote("dprocess")," must be a function")
## handle skeleton
skeleton <- pomp.fun(
f=skeleton,
PACKAGE=PACKAGE,
proto=quote(skeleton(x,t,params,...)),
slotname="skeleton",
libname=libname,
statenames=statenames,
paramnames=paramnames,
obsnames=obsnames,
covarnames=covarnames
)
## type of skeleton (map or vectorfield)
## skelmap.delta.t has no meaning in the latter case
skeleton.type <- match.arg(skeleton.type)
skelmap.delta.t <- as.numeric(skelmap.delta.t)
if (skelmap.delta.t <= 0)
stop(sQuote("skelmap.delta.t")," must be positive")
## if 'measurement model' is specified as a formula, this overrides
## specification of 'rmeasure' or 'dmeasure'
if (!missing(measurement.model)) {
if (!(is.null(dmeasure)&&is.null(rmeasure))) {
warning(
"specifying ",sQuote("measurement.model"),
" overrides specification of ",
sQuote("rmeasure")," and ",sQuote("dmeasure")
)
}
mm <- measform2pomp(measurement.model)
rmeasure <- mm$rmeasure
dmeasure <- mm$dmeasure
}
## handle rmeasure
rmeasure <- pomp.fun(
f=rmeasure,
PACKAGE=PACKAGE,
proto=quote(rmeasure(x,t,params,...)),
slotname="rmeasure",
libname=libname,
statenames=statenames,
paramnames=paramnames,
obsnames=obsnames,
covarnames=covarnames
)
## handle dmeasure
dmeasure <- pomp.fun(
f=dmeasure,
PACKAGE=PACKAGE,
proto=quote(dmeasure(y,x,t,params,log,...)),
slotname="dmeasure",
libname=libname,
statenames=statenames,
paramnames=paramnames,
obsnames=obsnames,
covarnames=covarnames
)
## handle rprior
rprior <- pomp.fun(
f=rprior,
PACKAGE=PACKAGE,
proto=quote(rprior(params,...)),
slotname="rprior",
libname=libname,
statenames=statenames,
paramnames=paramnames,
obsnames=obsnames,
covarnames=covarnames
)
## handle dprior
if (is.null(dprior)) {
## by default, use flat improper prior
dprior <- pomp.fun(f="_pomp_default_dprior",PACKAGE="pomp")
} else {
dprior <- pomp.fun(
f=dprior,
PACKAGE=PACKAGE,
proto=quote(dprior(params,log,...)),
slotname="dprior",
libname=libname,
statenames=statenames,
paramnames=paramnames,
obsnames=obsnames,
covarnames=covarnames
)
}
## handle parameter transformations
mpt <- is.null(fromEstimationScale)
mpit <- is.null(toEstimationScale)
if (xor(mpt,mpit)) {
stop("if one of ",sQuote("fromEstimationScale"),", ",
sQuote("toEstimationScale"),
" is supplied, then so must the other")
}
has.trans <- !mpt
if (has.trans) {
from.trans <- pomp.fun(
f=fromEstimationScale,
PACKAGE=PACKAGE,
proto=quote(from.trans(params,...)),
slotname="fromEstimationScale",
libname=libname,
statenames=statenames,
paramnames=paramnames,
obsnames=obsnames,
covarnames=covarnames
)
to.trans <- pomp.fun(
f=toEstimationScale,
PACKAGE=PACKAGE,
proto=quote(to.trans(params,...)),
slotname="toEstimationScale",
libname=libname,
statenames=statenames,
paramnames=paramnames,
obsnames=obsnames,
covarnames=covarnames
)
} else {
from.trans <- pomp.fun()
to.trans <- pomp.fun()
}
if (has.trans &&
from.trans@mode==pompfunmode$undef &&
to.trans@mode==pompfunmode$undef
) has.trans <- FALSE
if (nrow(covar)>0) {
if (
(skeleton@mode==pompfunmode$Rfun)
&&!("covars"%in%names(formals(skeleton@R.fun)))
)
warning("a covariate table has been given, yet the ",
sQuote("skeleton")," function does not have ",
sQuote("covars")," as a formal argument: see ",
sQuote("?pomp"),call.=FALSE)
if (
(rmeasure@mode==pompfunmode$Rfun)
&&!("covars"%in%names(formals(rmeasure@R.fun)))
)
warning("a covariate table has been given, yet the ",
sQuote("rmeasure")," function does not have ",
sQuote("covars")," as a formal argument: see ",
sQuote("?pomp"),call.=FALSE)
if (
(dmeasure@mode==pompfunmode$Rfun)
&&!("covars"%in%names(formals(dmeasure@R.fun)))
)
warning("a covariate table has been given, yet the ",
sQuote("dmeasure")," function does not have ",
sQuote("covars")," as a formal argument: see ",
sQuote("?pomp"),call.=FALSE)
}
if ((length(tcovar)>0)&&((min(tcovar)>t0)||(max(tcovar)<max(times))))
warning(
"the supplied covariate covariate times ",sQuote("tcovar"),
" do not embrace the data times: covariates may be extrapolated"
)
new(
'pomp',
rprocess = rprocess,
dprocess = dprocess,
dmeasure = dmeasure,
rmeasure = rmeasure,
dprior = dprior,
rprior = rprior,
skeleton = skeleton,
skeleton.type = skeleton.type,
skelmap.delta.t = skelmap.delta.t,
data = data,
times = times,
t0 = t0,
default.init = default.init,
initializer = initializer,
params = params,
covar = covar,
tcovar = tcovar,
zeronames = zeronames,
has.trans = has.trans,
from.trans = from.trans,
to.trans = to.trans,
solibfile = .solibfile,
userdata = userdata
)
}
measform2pomp <- function (formulae) {
if (!is.list(formulae))
formulae <- list(formulae)
nobs <- length(formulae)
if (nobs < 1)
stop("pomp error: to use ",sQuote("measurement.model")," you must provide at least one formula",call.=FALSE)
for (k in seq_len(nobs)) {
if (!inherits(formulae[[k]],"formula"))
stop("pomp error: ",sQuote("measurement.model")," takes formulae as arguments",call.=FALSE)
}
obsnames <- unlist(lapply(formulae,function(x)x[[2L]]))
distrib <- lapply(formulae,function(x)as.character(x[[3L]][[1L]]))
ddistrib <- lapply(distrib,function(x)paste0("d",x))
rdistrib <- lapply(distrib,function(x)paste0("r",x))
for (k in seq_len(nobs)) {
res <- try(
match.fun(ddistrib[[k]]),
silent=TRUE
)
if (inherits(res,'try-error'))
stop("pomp error: distribution function ",ddistrib[[k]]," not found")
res <- try(
match.fun(rdistrib[[k]]),
silent=TRUE
)
if (inherits(res,'try-error'))
stop("pomp error: random deviate function ",rdistrib[[k]]," not found")
}
pred.args <- lapply(formulae,function(x)as.list(x[[3L]][-1L]))
dcalls <- vector(mode='list',length=nobs)
rcalls <- vector(mode='list',length=nobs)
for (k in seq_len(nobs)) {
dcalls[[k]] <- as.call(
c(
list(
as.name(ddistrib[[k]]),
x=obsnames[[k]]
),
pred.args[[k]],
list(
log=TRUE
)
)
)
rcalls[[k]] <- as.call(
c(
list(
as.name(rdistrib[[k]]),
n=1
),
pred.args[[k]]
)
)
}
list(
dmeasure = function (y, x, t, params, log, covars, ...) {
f <- 0
for (k in seq_len(nobs)) {
f <- f+eval(
dcalls[[k]],
envir=as.list(c(y,x,params,covars,t=t))
)
}
if (log) f else exp(f)
},
rmeasure = function (x, t, params, covars, ...) {
y <- numeric(length=nobs)
names(y) <- obsnames
for (k in seq_len(nobs)) {
y[k] <- eval(
rcalls[[k]],
envir=as.list(c(x,params,covars,t=t))
)
}
y
}
)
}
setMethod(
"pomp",
signature=signature(data="data.frame"),
definition=function (data, times, t0, ..., rprocess, dprocess,
rmeasure, dmeasure, measurement.model,
skeleton, skeleton.type = c("map","vectorfield"),
skelmap.delta.t = 1,
initializer, rprior, dprior,
params, covar, tcovar,
obsnames, statenames, paramnames, covarnames, zeronames,
PACKAGE, fromEstimationScale, toEstimationScale,
globals) {
data <- t(sapply(data,as.numeric))
if ((is.numeric(times) && (times<1 || times>nrow(data))) ||
(is.character(times) && (!(times%in%rownames(data)))) ||
(!is.numeric(times) && !is.character(times)) ||
length(times)!=1)
stop("pomp error: ",sQuote("times"),
" must identify a single column of ",sQuote("data"))
if (is.numeric(times)) {
tpos <- times
} else if (is.character(times)) {
tpos <- match(times,rownames(data))
}
times <- data[tpos,,drop=TRUE]
data <- data[-tpos,,drop=FALSE]
pomp.constructor(
data=data,
times=times,
t0=t0,
rprocess=rprocess,
dprocess=dprocess,
rmeasure=rmeasure,
dmeasure=dmeasure,
measurement.model=measurement.model,
dprior=dprior,
rprior=rprior,
skeleton=skeleton,
skeleton.type=skeleton.type,
skelmap.delta.t=skelmap.delta.t,
initializer=initializer,
params=params,
covar=covar,
tcovar=tcovar,
obsnames=obsnames,
statenames=statenames,
paramnames=paramnames,
covarnames=covarnames,
zeronames=zeronames,
PACKAGE=PACKAGE,
fromEstimationScale=fromEstimationScale,
toEstimationScale=toEstimationScale,
globals=globals,
...
)
}
)
setMethod(
"pomp",
signature=signature(data="matrix"),
definition=function (data, times, t0, ..., rprocess, dprocess,
rmeasure, dmeasure, measurement.model,
skeleton, skeleton.type = c("map","vectorfield"),
skelmap.delta.t = 1,
initializer, rprior, dprior, params, covar, tcovar,
obsnames, statenames, paramnames, covarnames, zeronames,
PACKAGE, fromEstimationScale, toEstimationScale,
globals) {
pomp.constructor(
data=data,
times=times,
t0=t0,
rprocess=rprocess,
dprocess=dprocess,
rmeasure=rmeasure,
dmeasure=dmeasure,
measurement.model=measurement.model,
dprior=dprior,
rprior=rprior,
skeleton=skeleton,
skeleton.type=skeleton.type,
skelmap.delta.t=skelmap.delta.t,
initializer=initializer,
params=params,
covar=covar,
tcovar=tcovar,
obsnames=obsnames,
statenames=statenames,
paramnames=paramnames,
covarnames=covarnames,
zeronames=zeronames,
PACKAGE=PACKAGE,
fromEstimationScale=fromEstimationScale,
toEstimationScale=toEstimationScale,
globals=globals,
...
)
}
)
setMethod(
"pomp",
signature(data="numeric"),
function (data, times, t0, ..., rprocess, dprocess,
rmeasure, dmeasure, measurement.model,
skeleton, skeleton.type = c("map","vectorfield"),
skelmap.delta.t = 1,
initializer, rprior, dprior, params, covar, tcovar,
obsnames, statenames, paramnames, covarnames, zeronames,
PACKAGE, fromEstimationScale, toEstimationScale,
globals) {
pomp.constructor(
data=matrix(data,nrow=1,ncol=length(data)),
times=times,
t0=t0,
rprocess=rprocess,
dprocess=dprocess,
rmeasure=rmeasure,
dmeasure=dmeasure,
measurement.model=measurement.model,
dprior=dprior,
rprior=rprior,
skeleton=skeleton,
skeleton.type=skeleton.type,
skelmap.delta.t=skelmap.delta.t,
initializer=initializer,
params=params,
covar=covar,
tcovar=tcovar,
obsnames=obsnames,
statenames=statenames,
paramnames=paramnames,
covarnames=covarnames,
zeronames=zeronames,
PACKAGE=PACKAGE,
fromEstimationScale=fromEstimationScale,
toEstimationScale=toEstimationScale,
globals=globals,
...
)
}
)
setMethod(
"pomp",
signature=signature(data="pomp"),
definition=function (data, times, t0, ..., rprocess, dprocess,
rmeasure, dmeasure, measurement.model,
skeleton, skeleton.type, skelmap.delta.t,
initializer, rprior, dprior, params, covar, tcovar,
obsnames, statenames, paramnames, covarnames, zeronames,
PACKAGE, fromEstimationScale, toEstimationScale,
globals) {
if (missing(times)) times <- data@times
if (missing(t0)) t0 <- data@t0
mmg <- !missing(measurement.model)
dmg <- !missing(dmeasure)
rmg <- !missing(rmeasure)
if (mmg) {
if (dmg||rmg)
warning(
"specifying ",sQuote("measurement.model"),
" overrides specification of ",
sQuote("rmeasure")," and ",sQuote("dmeasure")
)
mm <- measform2pomp(measurement.model)
rmeasure <- mm$rmeasure
dmeasure <- mm$dmeasure
} else {
if (!rmg) rmeasure <- data@rmeasure
if (!dmg) dmeasure <- data@dmeasure
}
if (missing(rprocess)) rprocess <- data@rprocess
if (missing(dprocess)) dprocess <- data@dprocess
if (missing(rprior)) rprior <- data@rprior
if (missing(dprior)) dprior <- data@dprior
if (missing(initializer)) initializer <- data@initializer
if (missing(params)) params <- data@params
if (missing(covar)) covar <- data@covar
if (missing(tcovar)) tcovar <- data@tcovar
if (missing(zeronames)) zeronames <- data@zeronames
if (missing(skeleton.type)) skeleton.type <- data@skeleton.type
if (missing(skeleton)) skeleton <- data@skeleton
if (missing(skelmap.delta.t)) skelmap.delta.t <- data@skelmap.delta.t
if (missing(fromEstimationScale)) {
if (missing(toEstimationScale)) {
from.trans <- data@from.trans
to.trans <- data@to.trans
} else {
stop("pomp error: if ",sQuote("toEstimationScale"),
" is supplied, then " ,
sQuote("fromEstimationScale")," must also be supplied")
}
} else {
if (missing(toEstimationScale)) {
stop("pomp error: if ",sQuote("fromEstimationScale"),
" is supplied, then " ,
sQuote("toEstimationScale")," must also be supplied")
} else {
from.trans <- fromEstimationScale
to.trans <- toEstimationScale
}
}
if (missing(obsnames)) obsnames <- character(0)
if (missing(statenames)) statenames <- character(0)
if (missing(paramnames)) paramnames <- character(0)
if (missing(covarnames)) covarnames <- character(0)
if (missing(PACKAGE)) PACKAGE <- character(0)
pomp.constructor(
data=data@data,
times=times,
t0=t0,
rprocess=rprocess,
dprocess=dprocess,
rmeasure=rmeasure,
dmeasure=dmeasure,
dprior=dprior,
rprior=rprior,
skeleton=skeleton,
skeleton.type=skeleton.type,
skelmap.delta.t=skelmap.delta.t,
initializer=initializer,
covar=covar,
tcovar=tcovar,
obsnames=obsnames,
statenames=statenames,
paramnames=paramnames,
covarnames=covarnames,
zeronames=zeronames,
PACKAGE=PACKAGE,
fromEstimationScale=from.trans,
toEstimationScale=to.trans,
params=params,
globals=globals,
.solibfile=data@solibfile,
userdata=data@userdata,
...
)
}
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.