[Pomp-commits] r1102 - in pkg/pomp: R src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Feb 26 10:43:14 CET 2015
Author: kingaa
Date: 2015-02-26 10:43:14 +0100 (Thu, 26 Feb 2015)
New Revision: 1102
Modified:
pkg/pomp/R/pomp-fun.R
pkg/pomp/R/pomp.R
pkg/pomp/src/dmeasure.c
pkg/pomp/src/dprior.c
pkg/pomp/src/euler.c
pkg/pomp/src/partrans.c
pkg/pomp/src/pomp_fun.c
pkg/pomp/src/pomp_internal.h
pkg/pomp/src/rmeasure.c
pkg/pomp/src/rprior.c
pkg/pomp/src/skeleton.c
pkg/pomp/src/trajectory.c
Log:
- use R_GetCCallable() instead of getNativeSymbolInfo() when Csnippet codes are used
- replace int mode with enum mode
Modified: pkg/pomp/R/pomp-fun.R
===================================================================
--- pkg/pomp/R/pomp-fun.R 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/R/pomp-fun.R 2015-02-26 09:43:14 UTC (rev 1102)
@@ -1,6 +1,8 @@
## a class for functions that may be defined in R,
## using pre-written native routines, or C snippets
+pompfunmode <- list(undef=-1L,Rfun=0L,native=1L,regNative=2L)
+
setClass(
'pomp.fun',
slots=c(
@@ -20,7 +22,7 @@
},
native.fun=character(0),
PACKAGE=character(0),
- mode=-1L, ## undefined behavior
+ mode=pompfunmode$undef,
obsnames = character(0),
statenames = character(0),
paramnames = character(0),
@@ -58,7 +60,7 @@
stop(sQuote(fname)," must be a function of prototype ",
deparse(proto),call.=FALSE)
}
- new("pomp.fun",R.fun=f,mode=1L)
+ new("pomp.fun",R.fun=f,mode=pompfunmode$Rfun)
}
)
@@ -72,7 +74,7 @@
"pomp.fun",
native.fun=f,
PACKAGE=as.character(PACKAGE),
- mode=2L,
+ mode=pompfunmode$native,
obsnames=obsnames,
statenames=statenames,
paramnames=paramnames,
@@ -97,7 +99,7 @@
"pomp.fun",
native.fun=render(fnames[[slotname]],name=libname),
PACKAGE=as.character(libname),
- mode=2L,
+ mode=pompfunmode$regNative,
obsnames=obsnames,
statenames=statenames,
paramnames=paramnames,
@@ -114,16 +116,21 @@
setMethod(
'show',
- 'pomp.fun',
- function (object) {
+ signature=signature('pomp.fun'),
+ definition=function (object) {
mode <- object at mode
- if (mode==1L) {
+ if (mode==pompfunmode$Rfun) { # R function
show(object at R.fun)
- } else if (mode==2L) {
+ } else if (mode==pompfunmode$native) { # user supplied native code
cat("native function ",sQuote(object at native.fun),sep="")
if (length(object at PACKAGE)>0)
cat(", dynamically loaded from ",sQuote(object at PACKAGE),sep="")
cat ("\n")
+ } else if (mode==pompfunmode$regNative) { # built from Csnippets
+ cat("native function ",sQuote(object at native.fun),sep="")
+ if (length(object at PACKAGE)>0)
+ cat(", dynamically loaded from ",sQuote(object at PACKAGE),sep="")
+ cat ("\n")
} else {
cat("function not specified\n")
}
Modified: pkg/pomp/R/pomp.R
===================================================================
--- pkg/pomp/R/pomp.R 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/R/pomp.R 2015-02-26 09:43:14 UTC (rev 1102)
@@ -318,25 +318,28 @@
par.trans <- pomp.fun()
par.untrans <- pomp.fun()
}
- if (has.trans && par.trans at mode<0 && par.untrans at mode<0) has.trans <- FALSE
+ if (has.trans &&
+ par.trans at mode==pompfunmode$undef &&
+ par.untrans at mode==pompfunmode$undef
+ ) has.trans <- FALSE
if (nrow(covar)>0) {
if (
- (skeleton at mode==1L)
+ (skeleton at mode==pompfunmode$Rfun)
&&!("covars"%in%names(formals(skeleton at R.fun)))
)
warning("a covariate table has been given, yet the ",
sQuote("skeleton")," function does not have ",
sQuote("covars")," as a formal argument",call.=FALSE)
if (
- (rmeasure at mode==1L)
+ (rmeasure at mode==pompfunmode$Rfun)
&&!("covars"%in%names(formals(rmeasure at R.fun)))
)
warning("a covariate table has been given, yet the ",
sQuote("rmeasure")," function does not have ",
sQuote("covars")," as a formal argument",call.=FALSE)
if (
- (dmeasure at mode==1L)
+ (dmeasure at mode==pompfunmode$Rfun)
&&!("covars"%in%names(formals(dmeasure at R.fun)))
)
warning("a covariate table has been given, yet the ",
Modified: pkg/pomp/src/dmeasure.c
===================================================================
--- pkg/pomp/src/dmeasure.c 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/src/dmeasure.c 2015-02-26 09:43:14 UTC (rev 1102)
@@ -11,7 +11,7 @@
SEXP do_dmeasure (SEXP object, SEXP y, SEXP x, SEXP times, SEXP params, SEXP log, SEXP gnsi)
{
int nprotect = 0;
- int mode = -1;
+ pompfunmode mode = undef;
int give_log;
int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs;
SEXP Snames, Pnames, Cnames, Onames;
@@ -76,7 +76,7 @@
// first do setup
switch (mode) {
- case 0: // R function
+ case Rfun: // R function
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
@@ -106,7 +106,7 @@
break;
- case 1: // native code
+ case native: // native code
// construct state, parameter, covariate, observable indices
oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames"))); nprotect++;
@@ -137,7 +137,7 @@
// now do computations
switch (mode) {
- case 0: // R function
+ case Rfun: // R function
{
int first = 1;
@@ -190,7 +190,7 @@
break;
- case 1: // native code
+ case native: // native code
set_pomp_userdata(fcall);
Modified: pkg/pomp/src/dprior.c
===================================================================
--- pkg/pomp/src/dprior.c 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/src/dprior.c 2015-02-26 09:43:14 UTC (rev 1102)
@@ -15,7 +15,7 @@
SEXP do_dprior (SEXP object, SEXP params, SEXP log, SEXP gnsi)
{
int nprotect = 0;
- int mode = -1;
+ pompfunmode mode = undef;
int npars, nreps;
SEXP Pnames, F, fn, fcall;
SEXP pompfun;
@@ -39,7 +39,7 @@
// first do setup
switch (mode) {
- case 0: // use R function
+ case Rfun: // use R function
{
SEXP pvec, rho, ans;
@@ -74,7 +74,7 @@
break;
- case 1: // use native routine
+ case native: // use native routine
{
int give_log, *pidx = 0;
Modified: pkg/pomp/src/euler.c
===================================================================
--- pkg/pomp/src/euler.c 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/src/euler.c 2015-02-26 09:43:14 UTC (rev 1102)
@@ -9,7 +9,7 @@
SEXP tcovar, SEXP covar, SEXP args, SEXP gnsi)
{
int nprotect = 0;
- int mode = -1;
+ pompfunmode mode = undef;
int nstep, nvars, npars, nreps, ntimes, nzeros, ncovars, covlen;
SEXP X;
SEXP fn, fcall, rho, ans, nm;
@@ -48,7 +48,7 @@
// set up
switch (mode) {
- case 0: // R function
+ case Rfun: // R function
PROTECT(dtvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
@@ -75,7 +75,7 @@
break;
- case 1: // native code
+ case native: // native code
// construct state, parameter, covariate indices
sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
@@ -87,7 +87,7 @@
break;
default:
- error("unrecognized 'mode' in 'euler_simulator'");
+ error("unrecognized 'mode' %d in 'euler_simulator'",mode);
break;
}
@@ -163,7 +163,7 @@
switch (mode) {
- case 0: // R function
+ case Rfun: // R function
{
double *xp = REAL(xvec);
@@ -211,13 +211,13 @@
break;
- case 1: // native code
+ case native: // native code
(*ff)(xm,pm,sidx,pidx,cidx,ncovars,cp,t,dt);
break;
default:
- error("unrecognized 'mode' in 'euler_simulator'");
+ error("unrecognized 'mode' %d in 'euler_simulator'",mode);
break;
}
@@ -283,7 +283,7 @@
switch (mode) {
- case 0: // R function
+ case Rfun: // R function
PROTECT(t1vec = NEW_NUMERIC(1)); nprotect++;
PROTECT(t2vec = NEW_NUMERIC(1)); nprotect++;
@@ -313,7 +313,7 @@
break;
- case 1: // native code
+ case native: // native code
// construct state, parameter, covariate indices
sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
@@ -325,7 +325,7 @@
break;
default:
- error("unrecognized 'mode' in 'euler_model_density'");
+ error("unrecognized 'mode' %d in 'euler_model_density'",mode);
break;
}
@@ -337,7 +337,7 @@
switch (mode) {
- case 0: // R function
+ case Rfun: // R function
{
double *cp = REAL(cvec);
@@ -379,7 +379,7 @@
break;
- case 1: // native code
+ case native: // native code
set_pomp_userdata(args);
@@ -415,7 +415,7 @@
break;
default:
- error("unrecognized 'mode' in 'euler_model_density'");
+ error("unrecognized 'mode' %d in 'euler_model_density'",mode);
break;
}
Modified: pkg/pomp/src/partrans.c
===================================================================
--- pkg/pomp/src/partrans.c 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/src/partrans.c 2015-02-26 09:43:14 UTC (rev 1102)
@@ -14,7 +14,7 @@
SEXP pdim, pvec;
SEXP pompfun;
SEXP tparams = R_NilValue;
- int mode = -1;
+ pompfunmode mode = undef;
char direc;
int qmat;
int ndim[2], *dim, *idx;
@@ -54,7 +54,7 @@
switch (mode) {
- case 0: // use user-supplied R function
+ case Rfun: // use user-supplied R function
// set up the function call
if (qmat) { // matrix case
@@ -110,7 +110,7 @@
break;
- case 1: // use native routine
+ case native: // use native routine
ff = (pomp_transform_fn *) R_ExternalPtrAddr(fn);
Modified: pkg/pomp/src/pomp_fun.c
===================================================================
--- pkg/pomp/src/pomp_fun.c 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/src/pomp_fun.c 2015-02-26 09:43:14 UTC (rev 1102)
@@ -9,31 +9,65 @@
// returns either the R function or the address of the native routine
// on return, use_native tells whether to use the native or the R function
-SEXP pomp_fun_handler (SEXP pfun, SEXP gnsi, int *mode)
+SEXP pomp_fun_handler (SEXP pfun, SEXP gnsi, pompfunmode *mode)
{
int nprotect = 0;
- SEXP nf, pack, nsi, f = R_NilValue;
+ SEXP f = R_NilValue;
- *mode = *(INTEGER(GET_SLOT(pfun,install("mode"))))-1;
+ *mode = *(INTEGER(GET_SLOT(pfun,install("mode"))));
switch (*mode) {
- case 0: // R function
+
+ case Rfun: // R function
+
PROTECT(f = GET_SLOT(pfun,install("R.fun"))); nprotect++;
+
break;
- case 1: // native code
- if (*(INTEGER(gnsi))) { // get native symbol information
+
+ case native: case regNative: // native code
+
+ if (*(INTEGER(gnsi))) { // get native symbol information?
+
+ SEXP nf, pack;
PROTECT(nf = GET_SLOT(pfun,install("native.fun"))); nprotect++;
PROTECT(pack = GET_SLOT(pfun,install("PACKAGE"))); nprotect++;
if (LENGTH(pack) < 1) {
PROTECT(pack = mkString("")); nprotect++;
}
- PROTECT(nsi = eval(lang3(install("getNativeSymbolInfo"),nf,pack),R_BaseEnv)); nprotect++;
- PROTECT(f = getListElement(nsi,"address")); nprotect++;
+
+ switch (*mode) {
+ case native:
+ {
+ SEXP nsi;
+ PROTECT(nsi = eval(lang3(install("getNativeSymbolInfo"),nf,pack),R_BaseEnv)); nprotect++;
+ PROTECT(f = getListElement(nsi,"address")); nprotect++;
+ }
+ break;
+
+ case regNative:
+ {
+ const char *fname, *pkg;
+ DL_FUNC ff;
+ fname = (const char *) CHARACTER_DATA(STRING_ELT(nf,0));
+ pkg = (const char *) CHARACTER_DATA(STRING_ELT(pack,0));
+ ff = R_GetCCallable(pkg,fname);
+ PROTECT(f = R_MakeExternalPtr(ff,pfun,R_NilValue)); nprotect++;
+ }
+ break;
+ }
+
SET_SLOT(pfun,install("address"),f);
- } else {
+
+ } else { // native symbol info is stored
+
PROTECT(f = GET_SLOT(pfun,install("address"))); nprotect++;
+
}
+
+ *mode = native;
+
break;
+
default:
error("operation cannot be completed: some needed function has not been specified");
break;
@@ -44,21 +78,21 @@
}
SEXP load_stack_incr (SEXP pack) {
- char *pkg;
+ const char *pkg;
void (*ff)(void);
- pkg = CHARACTER_DATA(STRING_ELT(pack,0));
- ff = R_GetCCallable(pkg,"__pomp_load_stack_incr");
+ pkg = (const char *) CHARACTER_DATA(STRING_ELT(pack,0));
+ ff = (void (*)(void)) R_GetCCallable(pkg,"__pomp_load_stack_incr");
ff();
return R_NilValue;
}
SEXP load_stack_decr (SEXP pack) {
SEXP s;
- char *pkg;
+ const char *pkg;
void (*ff)(int *);
PROTECT(s = NEW_INTEGER(1));
- pkg = CHARACTER_DATA(STRING_ELT(pack,0));
- ff = R_GetCCallable(pkg,"__pomp_load_stack_decr");
+ pkg = (const char *) CHARACTER_DATA(STRING_ELT(pack,0));
+ ff = (void (*)(int *)) R_GetCCallable(pkg,"__pomp_load_stack_decr");
ff(INTEGER(s));
if (*(INTEGER(s)) < 0) error("impossible!");
UNPROTECT(1);
Modified: pkg/pomp/src/pomp_internal.h
===================================================================
--- pkg/pomp/src/pomp_internal.h 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/src/pomp_internal.h 2015-02-26 09:43:14 UTC (rev 1102)
@@ -40,7 +40,8 @@
SEXP sobol_sequence(SEXP dim);
// pomp_fun.c
-SEXP pomp_fun_handler (SEXP pfun, SEXP gnsi, int *mode);
+typedef enum {undef=-1,Rfun=0,native=1,regNative=2} pompfunmode;
+SEXP pomp_fun_handler (SEXP pfun, SEXP gnsi, pompfunmode *mode);
// lookup_table.c
SEXP lookup_in_table (SEXP ttable, SEXP xtable, SEXP t);
Modified: pkg/pomp/src/rmeasure.c
===================================================================
--- pkg/pomp/src/rmeasure.c 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/src/rmeasure.c 2015-02-26 09:43:14 UTC (rev 1102)
@@ -11,7 +11,7 @@
SEXP do_rmeasure (SEXP object, SEXP x, SEXP times, SEXP params, SEXP gnsi)
{
int nprotect = 0;
- int mode = -1;
+ pompfunmode mode = undef;
int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs;
SEXP Snames, Pnames, Cnames, Onames;
SEXP tvec, xvec, pvec, cvec;
@@ -76,7 +76,7 @@
// first do setup
switch (mode) {
- case 0: // use R function
+ case Rfun: // use R function
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
@@ -100,7 +100,7 @@
break;
- case 1: // use native routine
+ case native: // use native routine
// construct state, parameter, covariate, observable indices
oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames"))); nprotect++;
@@ -123,7 +123,7 @@
// now do computations
switch (mode) {
- case 0: // R function
+ case Rfun: // R function
{
int first = 1;
@@ -192,7 +192,7 @@
break;
- case 1: // native routine
+ case native: // native routine
{
double *yt = REAL(Y);
Modified: pkg/pomp/src/rprior.c
===================================================================
--- pkg/pomp/src/rprior.c 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/src/rprior.c 2015-02-26 09:43:14 UTC (rev 1102)
@@ -15,7 +15,7 @@
SEXP do_rprior (SEXP object, SEXP params, SEXP gnsi)
{
int nprotect = 0;
- int mode = -1;
+ pompfunmode mode = undef;
int npars, nreps;
SEXP Pnames, P, fn, fcall;
SEXP pompfun;
@@ -37,7 +37,7 @@
// first do setup
switch (mode) {
- case 0: // use R function
+ case Rfun: // use R function
{
SEXP pvec, rho, ans, nm;
@@ -106,7 +106,7 @@
break;
- case 1: // use native routine
+ case native: // use native routine
{
double *pp, *ps;
Modified: pkg/pomp/src/skeleton.c
===================================================================
--- pkg/pomp/src/skeleton.c 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/src/skeleton.c 2015-02-26 09:43:14 UTC (rev 1102)
@@ -89,7 +89,7 @@
{
int nprotect = 0;
int nvars, npars, nrepp, nrepx, nreps, ntimes, ncovars;
- int mode = -1;
+ pompfunmode mode = undef;
int *dim;
SEXP Snames, Cnames, Pnames;
SEXP pompfun;
@@ -139,7 +139,7 @@
// first do setup
switch (mode) {
- case 0: // R skeleton
+ case Rfun: // R skeleton
{
int nprotect = 0;
SEXP tvec, xvec, pvec, cvec, fcall, rho;
@@ -173,7 +173,7 @@
UNPROTECT(nprotect);
}
break;
- case 1: // native skeleton
+ case native: // native skeleton
{
int nprotect = 0;
int *sidx, *pidx, *cidx;
Modified: pkg/pomp/src/trajectory.c
===================================================================
--- pkg/pomp/src/trajectory.c 2015-02-26 09:43:11 UTC (rev 1101)
+++ pkg/pomp/src/trajectory.c 2015-02-26 09:43:14 UTC (rev 1102)
@@ -97,7 +97,7 @@
SEXP iterate_map (SEXP object, SEXP times, SEXP t0, SEXP x0, SEXP params, SEXP gnsi)
{
int nprotect = 0;
- int mode = -1;
+ pompfunmode mode = undef;
SEXP fn, args;
SEXP X;
SEXP Snames, Pnames, Cnames;
@@ -156,7 +156,7 @@
// set up the computations
switch (mode) {
- case 0: // R function
+ case Rfun: // R function
{
int nprotect = 0;
SEXP cvec, tvec, xvec, pvec;
@@ -190,7 +190,7 @@
UNPROTECT(nprotect);
}
break;
- case 1: // native skeleton
+ case native: // native skeleton
{
int nprotect = 0;
int *sidx, *pidx, *cidx;
@@ -218,7 +218,7 @@
static struct {
struct {
- int mode;
+ pompfunmode mode;
SEXP object;
SEXP params;
lookup_table covar_table;
@@ -250,7 +250,7 @@
SEXP pomp_desolve_setup (SEXP object, SEXP x0, SEXP params, SEXP gnsi) {
int nprotect = 0;
- int mode = -1;
+ pompfunmode mode = undef;
SEXP fn, args;
SEXP Snames, Pnames, Cnames;
SEXP pompfun;
@@ -290,7 +290,7 @@
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
switch (COMMON(mode)) {
- case 0: // R function
+ case Rfun: // R function
// arguments of the R function
PROTECT(RFUN(tvec) = NEW_NUMERIC(1)); nprotect++;
PROTECT(RFUN(xvec) = NEW_NUMERIC(nvars)); nprotect++;
@@ -330,7 +330,7 @@
R_PreserveObject(RFUN(cvec));
break;
- case 1: // native code
+ case native: // native code
// set aside userdata
NAT(args) = args;
// construct index vectors
@@ -362,14 +362,14 @@
void pomp_vf_eval (int *neq, double *t, double *y, double *ydot, double *yout, int *ip)
{
switch (COMMON(mode)) {
- case 0: // R function
+ case Rfun: // R function
eval_skeleton_R(ydot,t,y,REAL(COMMON(params)),
RFUN(fcall),RFUN(rho),RFUN(Snames),
REAL(RFUN(tvec)),REAL(RFUN(xvec)),REAL(RFUN(pvec)),REAL(RFUN(cvec)),
COMMON(nvars),COMMON(npars),1,COMMON(nreps),COMMON(nreps),COMMON(nreps),
&COMMON(covar_table));
break;
- case 1: // native code
+ case native: // native code
eval_skeleton_native(ydot,t,y,REAL(COMMON(params)),
COMMON(nvars),COMMON(npars),COMMON(ncovars),1,
COMMON(nreps),COMMON(nreps),COMMON(nreps),
@@ -392,7 +392,7 @@
COMMON(ncovars) = 0;
COMMON(nreps) = 0;
switch (COMMON(mode)) {
- case 0: // R function
+ case Rfun: // R function
R_ReleaseObject(RFUN(fcall));
R_ReleaseObject(RFUN(rho));
R_ReleaseObject(RFUN(Snames));
@@ -408,7 +408,7 @@
RFUN(pvec) = R_NilValue;
RFUN(cvec) = R_NilValue;
break;
- case 1: // native code
+ case native: // native code
NAT(fun) = 0;
R_ReleaseObject(NAT(args));
R_ReleaseObject(NAT(sindex));
More information about the pomp-commits
mailing list