[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