[Pomp-commits] r626 - in pkg: . R inst src tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Mar 9 17:00:59 CET 2012
Author: kingaa
Date: 2012-03-09 17:00:59 +0100 (Fri, 09 Mar 2012)
New Revision: 626
Modified:
pkg/DESCRIPTION
pkg/R/pomp-methods.R
pkg/inst/TODO
pkg/src/partrans.c
pkg/src/simulate.c
pkg/tests/ou2-procmeas.Rout.save
Log:
- minor bugfixes
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2012-03-09 00:41:25 UTC (rev 625)
+++ pkg/DESCRIPTION 2012-03-09 16:00:59 UTC (rev 626)
@@ -2,7 +2,7 @@
Type: Package
Title: Statistical inference for partially observed Markov processes
Version: 0.40-8
-Date: 2012-03-08
+Date: 2012-03-09
Revision: $Rev$
Author: Aaron A. King, Edward L. Ionides, Carles Breto, Steve Ellner, Bruce Kendall, Helen Wearing, Matthew J. Ferrari, Michael Lavine, Daniel C. Reuman
Maintainer: Aaron A. King <kingaa at umich.edu>
Modified: pkg/R/pomp-methods.R
===================================================================
--- pkg/R/pomp-methods.R 2012-03-09 00:41:25 UTC (rev 625)
+++ pkg/R/pomp-methods.R 2012-03-09 16:00:59 UTC (rev 626)
@@ -8,7 +8,7 @@
setGeneric("states",function(object,...)standardGeneric("states"))
setGeneric("timezero",function(object,...)standardGeneric("timezero"))
setGeneric("timezero<-",function(object,...,value)standardGeneric("timezero<-"))
-setGeneric("partrans",function(object,params,dir,...)standardGeneric("partrans"))
+setGeneric("partrans",function(object,params,dir=c("forward","inverse"),...)standardGeneric("partrans"))
## 'coerce' method: allows for coercion of a "pomp" object to a data-frame
setAs(
Modified: pkg/inst/TODO
===================================================================
--- pkg/inst/TODO 2012-03-09 00:41:25 UTC (rev 625)
+++ pkg/inst/TODO 2012-03-09 16:00:59 UTC (rev 626)
@@ -1,3 +1,5 @@
+* as.data.frame option for 'simulate'
+
* unit tests for 'sannbox'
* Create objective functions for 'probe.match', 'traj.match', and
@@ -8,7 +10,7 @@
* Partial rejection control for 'pfilter'?
-* Better documentation/rationalization for 'zeronames'.
+* Adaptive particle numbers in pfilter.
* It might be possible to make the writing of basic model functions
using R expressions rather than functions.
@@ -21,10 +23,11 @@
* Parallel 'pfilter' algorithm.
-* Add LPA model example.
+* Add LPA model examples.
+* SDE examples.
+
* Extended Kalman filter.
* Plugin for compartmental models.
-* Adaptive particle numbers in pfilter.
Modified: pkg/src/partrans.c
===================================================================
--- pkg/src/partrans.c 2012-03-09 00:41:25 UTC (rev 625)
+++ pkg/src/partrans.c 2012-03-09 16:00:59 UTC (rev 626)
@@ -102,17 +102,29 @@
case 1: // use native routine
{
pomp_transform_fn *ff = (pomp_transform_fn *) R_ExternalPtrAddr(fn);
- SEXP paramnames, pindex;
- int *idx, npar, nrep;
+ SEXP paramnames, pindex, Dim;
+ int *idx, npar, nrep, qvec;
double *ps, *pt;
int k;
- idx = INTEGER(GET_DIM(params));
- npar = idx[0]; nrep = idx[1];
+ PROTECT(Dim = GET_DIM(params)); nprotect++;
+ if (isNull(Dim)) { // a single vector
+ npar = LENGTH(Dim); nrep = 1;
+ qvec = 1;
+ } else { // a parameter matrix
+ int *dim;
+ dim = INTEGER(Dim);
+ npar = dim[0]; nrep = dim[1];
+ qvec = 0;
+ }
PROTECT(paramnames = GET_SLOT(object,install("paramnames"))); nprotect++;
if (LENGTH(paramnames) > 0) {
- PROTECT(pindex = matchnames(GET_ROWNAMES(GET_DIMNAMES(params)),paramnames)); nprotect++;
+ if (qvec) {
+ PROTECT(pindex = matchnames(GET_NAMES(params),paramnames)); nprotect++;
+ } else {
+ PROTECT(pindex = matchnames(GET_ROWNAMES(GET_DIMNAMES(params)),paramnames)); nprotect++;
+ }
idx = INTEGER(pindex);
} else {
idx = 0;
Modified: pkg/src/simulate.c
===================================================================
--- pkg/src/simulate.c 2012-03-09 00:41:25 UTC (rev 625)
+++ pkg/src/simulate.c 2012-03-09 16:00:59 UTC (rev 626)
@@ -32,6 +32,7 @@
qobs = *(LOGICAL(AS_LOGICAL(obs))); // 'obs' flag set?
qstates = *(LOGICAL(AS_LOGICAL(states))); // 'states' flag set?
+ PROTECT(params = as_matrix(params)); nprotect++;
PROTECT(paramnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
dim = INTEGER(GET_DIM(params));
npars = dim[0]; nparsets = dim[1];
Modified: pkg/tests/ou2-procmeas.Rout.save
===================================================================
--- pkg/tests/ou2-procmeas.Rout.save 2012-03-09 00:41:25 UTC (rev 625)
+++ pkg/tests/ou2-procmeas.Rout.save 2012-03-09 16:00:59 UTC (rev 626)
@@ -1,30 +1,54 @@
-library(pomp)
-data(ou2)
+R version 2.14.2 (2012-02-29)
+Copyright (C) 2012 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-unknown-linux-gnu (64-bit)
-po <- window(ou2,end=10)
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
-set.seed(3434388L)
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
-pmat <- parmat(coef(po),3)
-sims <- simulate(po,states=T,obs=T,params=pmat)
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
-dp <- dprocess(po,x=sims$states,times=time(po),params=pmat,log=T)
-dm <- dmeasure(po,x=sims$states,y=obs(po),times=time(po),params=pmat,log=T)
-
-apply(dp,1,sum)
-apply(dm,1,sum)
-
-dp1 <- dprocess(po,x=sims$states,times=time(po),params=coef(po),log=T)
-dm1 <- dmeasure(po,x=sims$states,y=obs(po),times=time(po),params=coef(po),log=T)
-stopifnot(identical(dp,dp1))
-stopifnot(identical(dm,dm1))
-
-x <- simulate(po,states=T,params=coef(po))
-dp2 <- dprocess(po,x=x,times=time(po),params=coef(po),log=T)
-dp3 <- dprocess(po,x=x,times=time(po),params=pmat,log=T)
-stopifnot(identical(rbind(dp2,dp2,dp2),dp3))
-
-dm2 <- dmeasure(po,x=x,y=obs(po),times=time(po),params=coef(po),log=T)
-dm3 <- dmeasure(po,x=x,y=obs(po),times=time(po),params=pmat,log=T)
-stopifnot(identical(rbind(dm2,dm2,dm2),dm3))
+> library(pomp)
+Loading required package: mvtnorm
+Loading required package: subplex
+Loading required package: deSolve
+>
+> data(ou2)
+>
+> po <- window(ou2,end=10)
+>
+> set.seed(3434388L)
+>
+> pmat <- parmat(coef(po),3)
+> sims <- simulate(po,states=T,obs=T,params=pmat)
+>
+> dp <- dprocess(po,x=sims$states,times=time(po),params=pmat,log=T)
+> dm <- dmeasure(po,x=sims$states,y=obs(po),times=time(po),params=pmat,log=T)
+>
+> apply(dp,1,sum)
+[1] -47.20607 -37.35755 -46.26917
+> apply(dm,1,sum)
+[1] -850.6711 -616.1925 -993.1957
+>
+> dp1 <- dprocess(po,x=sims$states,times=time(po),params=coef(po),log=T)
+> dm1 <- dmeasure(po,x=sims$states,y=obs(po),times=time(po),params=coef(po),log=T)
+> stopifnot(identical(dp,dp1))
+> stopifnot(identical(dm,dm1))
+>
+> x <- simulate(po,states=T,params=coef(po))
+> dp2 <- dprocess(po,x=x,times=time(po),params=coef(po),log=T)
+> dp3 <- dprocess(po,x=x,times=time(po),params=pmat,log=T)
+> stopifnot(identical(rbind(dp2,dp2,dp2),dp3))
+>
+> dm2 <- dmeasure(po,x=x,y=obs(po),times=time(po),params=coef(po),log=T)
+> dm3 <- dmeasure(po,x=x,y=obs(po),times=time(po),params=pmat,log=T)
+> stopifnot(identical(rbind(dm2,dm2,dm2),dm3))
+>
More information about the pomp-commits
mailing list