[Pomp-commits] r696 - in pkg/pomp: demo src tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed May 2 13:33:51 CEST 2012
Author: kingaa
Date: 2012-05-02 13:33:51 +0200 (Wed, 02 May 2012)
New Revision: 696
Added:
pkg/pomp/tests/demos.R
Removed:
pkg/pomp/tests/examples.R
Modified:
pkg/pomp/demo/gompertz.R
pkg/pomp/demo/sir.R
pkg/pomp/src/dmeasure.c
pkg/pomp/src/euler.c
pkg/pomp/src/pomp_internal.h
pkg/pomp/src/rmeasure.c
pkg/pomp/src/skeleton.c
pkg/pomp/src/trajectory.c
Log:
- changes to eliminate pedantic warnings
- put covariate table interpolation into vectorfield trajectory computation
Modified: pkg/pomp/demo/gompertz.R
===================================================================
--- pkg/pomp/demo/gompertz.R 2012-05-02 02:23:43 UTC (rev 695)
+++ pkg/pomp/demo/gompertz.R 2012-05-02 11:33:51 UTC (rev 696)
@@ -86,7 +86,13 @@
step.fn.delta.t=1,
skeleton=skel,
skeleton.type="map",
- skelmap.delta.t=1
+ skelmap.delta.t=1,
+ parameter.inv.transform=function(params,...){
+ log(params)
+ },
+ parameter.transform=function(params,...){
+ exp(params)
+ }
) -> Gompertz
## simulate some data
Modified: pkg/pomp/demo/sir.R
===================================================================
--- pkg/pomp/demo/sir.R 2012-05-02 02:23:43 UTC (rev 695)
+++ pkg/pomp/demo/sir.R 2012-05-02 11:33:51 UTC (rev 696)
@@ -50,24 +50,24 @@
),
## reset cases to zero after each new observation:
zeronames=c("cases"),
- to.log.transform=c(
+ logvar=c(
"gamma","mu","iota",
"beta1","beta2","beta3","beta.sd",
"S.0","I.0","R.0"
),
- to.logit.transform="rho",
+ logitvar="rho",
comp.names=c("S","I","R"),
ic.names=c("S.0","I.0","R.0"),
- parameter.transform=function (params, to.log.transform, to.logit.transform, ic.names, ...) {
- params[log.transformed] <- exp(params[log.transformed])
- params[logit.transformed] <- plogis(params[logit.transformed])
+ parameter.transform=function (params, logvar, logitvar, ic.names, ...) {
+ params[logvar] <- exp(params[logvar])
+ params[logitvar] <- plogis(params[logitvar])
params[ic.names] <- params[ic.names]/sum(params[ic.names])
params
},
- parameter.inv.transform=function (params, log.transformed, logit.transformed, ic.names, ...) {
+ parameter.inv.transform=function (params, logvar, logitvar, ic.names, ...) {
params[ic.names] <- params[ic.names]/sum(params[ic.names])
- params[log.transformed] <- log(params[log.transformed])
- params[logit.transformed] <- qlogis(params[logit.transformed])
+ params[logvar] <- log(params[logvar])
+ params[logitvar] <- qlogis(params[logitvar])
params
},
initializer=function(params, t0, comp.names, ic.names, ...) {
Modified: pkg/pomp/src/dmeasure.c
===================================================================
--- pkg/pomp/src/dmeasure.c 2012-05-02 02:23:43 UTC (rev 695)
+++ pkg/pomp/src/dmeasure.c 2012-05-02 11:33:51 UTC (rev 696)
@@ -15,11 +15,10 @@
int give_log;
int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs;
SEXP Snames, Pnames, Cnames, Onames;
- SEXP statenames, paramnames, covarnames, obsnames;
SEXP tvec, xvec, yvec, pvec, cvec;
SEXP fn, fcall, rho, ans;
SEXP F;
- int *sidx, *pidx, *cidx, *oidx;
+ int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0;
int *dim;
struct lookup_table covariate_table;
pomp_measure_model_density *ff = NULL;
Modified: pkg/pomp/src/euler.c
===================================================================
--- pkg/pomp/src/euler.c 2012-05-02 02:23:43 UTC (rev 695)
+++ pkg/pomp/src/euler.c 2012-05-02 11:33:51 UTC (rev 696)
@@ -256,7 +256,7 @@
pomp_onestep_pdf *ff = NULL;
SEXP t1vec, t2vec, x1vec, x2vec, pvec, cvec;
SEXP Snames, Pnames, Cnames;
- SEXP ans, rho, fcall, fn;
+ SEXP rho, fcall, fn;
SEXP F;
int *pidx = 0, *sidx = 0, *cidx = 0;
Modified: pkg/pomp/src/pomp_internal.h
===================================================================
--- pkg/pomp/src/pomp_internal.h 2012-05-02 02:23:43 UTC (rev 695)
+++ pkg/pomp/src/pomp_internal.h 2012-05-02 11:33:51 UTC (rev 696)
@@ -251,9 +251,9 @@
static R_INLINE SEXP getPairListElement (SEXP list, const char *name)
{
- char *tag;
+ const char *tag;
while (list != R_NilValue) {
- tag = STRING_PTR(PRINTNAME(TAG(list)));
+ tag = CHAR(PRINTNAME(TAG(list)));
if (strcmp(tag,name)==0) break;
list = CDR(list);
}
Modified: pkg/pomp/src/rmeasure.c
===================================================================
--- pkg/pomp/src/rmeasure.c 2012-05-02 02:23:43 UTC (rev 695)
+++ pkg/pomp/src/rmeasure.c 2012-05-02 11:33:51 UTC (rev 696)
@@ -18,8 +18,8 @@
SEXP tvec, xvec, pvec, cvec;
SEXP fn, fcall, rho, ans, nm;
SEXP Y;
- int *dim, ndim[3], *op;
- int *sidx, *pidx, *cidx, *oidx;
+ int *dim;
+ int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0;
struct lookup_table covariate_table;
pomp_measure_model_simulator *ff = NULL;
@@ -59,9 +59,11 @@
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
- ndim[0] = nobs; ndim[1] = nreps; ndim[2] = ntimes;
- PROTECT(Y = makearray(3,ndim)); nprotect++;
- setrownames(Y,Onames,3);
+ {
+ int dim[3] = {nobs, nreps, ntimes};
+ PROTECT(Y = makearray(3,dim)); nprotect++;
+ setrownames(Y,Onames,3);
+ }
// extract the user-defined function
PROTECT(fn = unpack_pomp_fun(fun,&mode)); nprotect++;
Modified: pkg/pomp/src/skeleton.c
===================================================================
--- pkg/pomp/src/skeleton.c 2012-05-02 02:23:43 UTC (rev 695)
+++ pkg/pomp/src/skeleton.c 2012-05-02 11:33:51 UTC (rev 696)
@@ -17,9 +17,8 @@
SEXP fn, fcall, rho, ans, nm;
SEXP tvec, xvec, pvec, cvec;
SEXP Snames, Cnames, Pnames;
- SEXP statenames, paramnames, covarnames;
SEXP F;
- int *sidx, *pidx, *cidx;
+ int *sidx = 0, *pidx = 0, *cidx = 0;
pomp_skeleton *ff = NULL;
struct lookup_table covariate_table;
Modified: pkg/pomp/src/trajectory.c
===================================================================
--- pkg/pomp/src/trajectory.c 2012-05-02 02:23:43 UTC (rev 695)
+++ pkg/pomp/src/trajectory.c 2012-05-02 11:33:51 UTC (rev 696)
@@ -276,6 +276,7 @@
int *sidx;
int *pidx;
int *cidx;
+ struct lookup_table covariate_table;
pomp_skeleton *ff;
} native_code;
} shared;
@@ -291,7 +292,7 @@
SEXP fn, sindex, pindex, cindex;
SEXP Snames, Pnames, Cnames;
int *dim;
- int nvars, npars, ncovars, nreps;
+ int nvars, npars, nreps;
COMMON(object) = object;
@@ -305,9 +306,6 @@
npars = dim[0];
nreps = dim[1];
- dim = INTEGER(GET_DIM(GET_SLOT(object,install("covar"))));
- ncovars = dim[1];
-
switch (COMMON(mode)) {
case 0: // R function
RFUN(skelfun) = fun;
@@ -331,8 +329,8 @@
memcpy(NAT(cidx),INTEGER(cindex),LENGTH(cindex)*sizeof(int));
NAT(nvars) = nvars;
NAT(npars) = npars;
- NAT(ncovars) = ncovars;
NAT(nreps) = nreps;
+ NAT(covariate_table) = make_covariate_table(object,&NAT(ncovars));
NAT(ff) = (pomp_skeleton *) R_ExternalPtrAddr(fn);
break;
default:
@@ -365,6 +363,7 @@
double covars[NAT(ncovars)];
double *pp = REAL(COMMON(params));
pomp_skeleton *ff = NAT(ff);
+ table_lookup(&NAT(covariate_table),*t,covars,0);
for (j = 0; j < NAT(nreps); j++, pp += NAT(npars), y += NAT(nvars), ydot += NAT(nvars)) {
(*ff)(ydot,y,pp,NAT(sidx),NAT(pidx),NAT(cidx),NAT(ncovars),covars,*t);
}
Copied: pkg/pomp/tests/demos.R (from rev 694, pkg/pomp/tests/examples.R)
===================================================================
--- pkg/pomp/tests/demos.R (rev 0)
+++ pkg/pomp/tests/demos.R 2012-05-02 11:33:51 UTC (rev 696)
@@ -0,0 +1,14 @@
+library(pomp)
+
+pdf.options(useDingbats=FALSE)
+pdf(file="demos.pdf")
+
+set.seed(47575684)
+
+demos <- list.files(path=system.file("demo",package="pomp"),pattern=".\\.R$",full.names=TRUE)
+
+for (d in demos) {
+ source(d,local=TRUE,echo=TRUE)
+}
+
+dev.off()
Deleted: pkg/pomp/tests/examples.R
===================================================================
--- pkg/pomp/tests/examples.R 2012-05-02 02:23:43 UTC (rev 695)
+++ pkg/pomp/tests/examples.R 2012-05-02 11:33:51 UTC (rev 696)
@@ -1,9 +0,0 @@
-library(pomp)
-
-set.seed(47575684)
-
-examples <- list.files(path=system.file("examples",package="pomp"),pattern=".\\.R$",full.names=TRUE)
-
-for (e in examples) {
- source(e,local=TRUE,echo=TRUE)
-}
More information about the pomp-commits
mailing list