From noreply at r-forge.r-project.org Mon Jun 9 18:30:31 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 9 Jun 2014 18:30:31 +0200 (CEST)
Subject: [Pomp-commits] r967 - pkg/pomp/R
Message-ID: <20140609163031.5A80A187363@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-09 18:30:30 +0200 (Mon, 09 Jun 2014)
New Revision: 967
Modified:
pkg/pomp/R/bsmc.R
pkg/pomp/R/minim.R
pkg/pomp/R/nlf-guts.R
pkg/pomp/R/nlf.R
pkg/pomp/R/spect-match.R
Log:
- remove unneeded explicit namespace references
Modified: pkg/pomp/R/bsmc.R
===================================================================
--- pkg/pomp/R/bsmc.R 2014-05-24 15:59:19 UTC (rev 966)
+++ pkg/pomp/R/bsmc.R 2014-06-09 16:30:30 UTC (rev 967)
@@ -223,12 +223,12 @@
## sample new parameter vector as per L&W AGM (3) and Liu & West eq(3.2)
pvec <- try(
- mvtnorm::rmvnorm(
- n=Np,
- mean=rep(0,npars.est),
- sigma=hsq*params.var,
- method="svd"
- ),
+ rmvnorm(
+ n=Np,
+ mean=rep(0,npars.est),
+ sigma=hsq*params.var,
+ method="svd"
+ ),
silent=FALSE
)
if (inherits(pvec,"try-error"))
Modified: pkg/pomp/R/minim.R
===================================================================
--- pkg/pomp/R/minim.R 2014-05-24 15:59:19 UTC (rev 966)
+++ pkg/pomp/R/minim.R 2014-06-09 16:30:30 UTC (rev 967)
@@ -32,7 +32,7 @@
opts <- list(...)
if (method == 'subplex') {
- opt <- subplex::subplex(par=guess,fn=objfun,control=opts)
+ opt <- subplex(par=guess,fn=objfun,control=opts)
} else if (method=="sannbox") {
opt <- sannbox(par=guess,fn=objfun,control=opts)
} else if (method=="nloptr") {
Modified: pkg/pomp/R/nlf-guts.R
===================================================================
--- pkg/pomp/R/nlf-guts.R 2014-05-24 15:59:19 UTC (rev 966)
+++ pkg/pomp/R/nlf-guts.R 2014-06-09 16:30:30 UTC (rev 967)
@@ -185,7 +185,7 @@
LQL <- dnorm(prediction.errors[,1],mean=0,sd=sigma.model,log=TRUE)
} else {
sigma.model <- cov(model.residuals)
- LQL <- mvtnorm::dmvnorm(prediction.errors,sigma=sigma.model,log=TRUE) ## NOTE: This could be improved using GLS.
+ LQL <- dmvnorm(prediction.errors,sigma=sigma.model,log=TRUE) ## NOTE: This could be improved using GLS.
}
LQL
Modified: pkg/pomp/R/nlf.R
===================================================================
--- pkg/pomp/R/nlf.R 2014-05-24 15:59:19 UTC (rev 966)
+++ pkg/pomp/R/nlf.R 2014-06-09 16:30:30 UTC (rev 967)
@@ -96,26 +96,26 @@
}
if (method == 'subplex') {
- opt <- subplex::subplex(
- par=guess,
- fn=nlf.objfun,
- object=object,
- params=params,
- par.index=par.index,
- transform.params=transform.params,
- times=times,
- t0=t0,
- lags=lags,
- period=period,
- tensor=tensor,
- seed=seed,
- transform=transform,
- nrbf=nrbf,
- verbose=verbose,
- bootstrap=bootstrap,
- bootsamp=bootsamp,
- control=list(...)
- )
+ opt <- subplex(
+ par=guess,
+ fn=nlf.objfun,
+ object=object,
+ params=params,
+ par.index=par.index,
+ transform.params=transform.params,
+ times=times,
+ t0=t0,
+ lags=lags,
+ period=period,
+ tensor=tensor,
+ seed=seed,
+ transform=transform,
+ nrbf=nrbf,
+ verbose=verbose,
+ bootstrap=bootstrap,
+ bootsamp=bootsamp,
+ control=list(...)
+ )
} else {
opt <- optim(
par=guess,
Modified: pkg/pomp/R/spect-match.R
===================================================================
--- pkg/pomp/R/spect-match.R 2014-05-24 15:59:19 UTC (rev 966)
+++ pkg/pomp/R/spect-match.R 2014-06-09 16:30:30 UTC (rev 967)
@@ -168,23 +168,23 @@
msg <- "no optimization performed"
} else {
if (method == 'subplex') {
- opt <- subplex::subplex(
- par=guess,
- fn=obj.fn,
- est=par.index,
- object=object,
- params=params,
- vars=vars,
- ker=ker,
- nsim=nsim,
- seed=seed,
- transform=transform,
- detrend=detrend,
- weights=weights,
- data.spec=ds,
- fail.value=fail.value,
- control=list(...)
- )
+ opt <- subplex(
+ par=guess,
+ fn=obj.fn,
+ est=par.index,
+ object=object,
+ params=params,
+ vars=vars,
+ ker=ker,
+ nsim=nsim,
+ seed=seed,
+ transform=transform,
+ detrend=detrend,
+ weights=weights,
+ data.spec=ds,
+ fail.value=fail.value,
+ control=list(...)
+ )
} else {
opt <- optim(
par=guess,
From noreply at r-forge.r-project.org Mon Jun 9 18:30:39 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 9 Jun 2014 18:30:39 +0200 (CEST)
Subject: [Pomp-commits] r968 - pkg/pomp/src
Message-ID: <20140609163039.A7475187368@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-09 18:30:39 +0200 (Mon, 09 Jun 2014)
New Revision: 968
Modified:
pkg/pomp/src/SSA_wrapper.c
pkg/pomp/src/euler.c
pkg/pomp/src/mif.c
pkg/pomp/src/pfilter.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:
- more informative error messages when variable names are not found using 'matchnames'
Modified: pkg/pomp/src/SSA_wrapper.c
===================================================================
--- pkg/pomp/src/SSA_wrapper.c 2014-06-09 16:30:30 UTC (rev 967)
+++ pkg/pomp/src/SSA_wrapper.c 2014-06-09 16:30:39 UTC (rev 968)
@@ -157,26 +157,26 @@
PROTECT(X = makearray(3,xdim)); nprotect++;
setrownames(X,Snames,3);
- if (nstates>0) {
- PROTECT(sindex = MATCHROWNAMES(xstart,statenames)); nprotect++;
+ if (nstates>0) {
+ PROTECT(sindex = MATCHROWNAMES(xstart,statenames,"state variables")); nprotect++;
sidx = INTEGER(sindex);
} else {
sidx = 0;
}
if (nparams>0) {
- PROTECT(pindex = MATCHROWNAMES(params,paramnames)); nprotect++;
+ PROTECT(pindex = MATCHROWNAMES(params,paramnames,"parameters")); nprotect++;
pidx = INTEGER(pindex);
} else {
pidx = 0;
}
if (ncovars>0) {
- PROTECT(cindex = MATCHCOLNAMES(covar,covarnames)); nprotect++;
+ PROTECT(cindex = MATCHCOLNAMES(covar,covarnames,"covariates")); nprotect++;
cidx = INTEGER(cindex);
} else {
cidx = 0;
}
if (nzeros>0) {
- PROTECT(zindex = MATCHROWNAMES(xstart,zeronames)); nprotect++;
+ PROTECT(zindex = MATCHROWNAMES(xstart,zeronames,"state variables")); nprotect++;
zidx = INTEGER(zindex);
} else {
zidx = 0;
Modified: pkg/pomp/src/euler.c
===================================================================
--- pkg/pomp/src/euler.c 2014-06-09 16:30:30 UTC (rev 967)
+++ pkg/pomp/src/euler.c 2014-06-09 16:30:39 UTC (rev 968)
@@ -40,7 +40,7 @@
// indices of accumulator variables
nzeros = LENGTH(zeronames);
- zidx = INTEGER(PROTECT(matchnames(Snames,zeronames))); nprotect++;
+ zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++;
// extract user function
PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++;
@@ -78,9 +78,9 @@
case 1: // native code
// construct state, parameter, covariate indices
- sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames"))))); nprotect++;
- pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames"))))); nprotect++;
- cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames"))))); nprotect++;
+ sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
+ pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++;
+ cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++;
ff = (pomp_onestep_sim *) R_ExternalPtrAddr(fn);
@@ -181,14 +181,14 @@
PROTECT(ans = eval(fcall,rho)); nprotect++; // evaluate the call
if (LENGTH(ans) != nvars) {
- error("user 'step.fun' returns a vector of %d states but %d are expected: compare initial conditions?",
+ error("user 'step.fun' returns a vector of %d state variables but %d are expected: compare initial conditions?",
LENGTH(ans),nvars);
}
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) {
- posn = INTEGER(PROTECT(matchnames(Snames,nm))); nprotect++;
+ posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++;
}
ap = REAL(AS_NUMERIC(ans));
@@ -316,9 +316,9 @@
case 1: // native code
// construct state, parameter, covariate indices
- sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames"))))); nprotect++;
- pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames"))))); nprotect++;
- cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames"))))); nprotect++;
+ sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
+ pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++;
+ cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++;
ff = (pomp_onestep_pdf *) R_ExternalPtrAddr(fn);
Modified: pkg/pomp/src/mif.c
===================================================================
--- pkg/pomp/src/mif.c 2014-06-09 16:30:30 UTC (rev 967)
+++ pkg/pomp/src/mif.c 2014-06-09 16:30:39 UTC (rev 968)
@@ -26,10 +26,10 @@
dim = INTEGER(GET_DIM(FM)); nfm = dim[0]; ntimes = dim[1];
dim = INTEGER(GET_DIM(PV)); npv = dim[0];
- sidx = INTEGER(PROTECT(MATCHNAMES(sigma,pars))); nprotect++;
- thidx = INTEGER(PROTECT(MATCHNAMES(theta,pars))); nprotect++;
- midx = INTEGER(PROTECT(MATCHROWNAMES(FM,pars))); nprotect++;
- vidx = INTEGER(PROTECT(MATCHROWNAMES(PV,pars))); nprotect++;
+ sidx = INTEGER(PROTECT(MATCHNAMES(sigma,pars,"random-walk SDs"))); nprotect++;
+ thidx = INTEGER(PROTECT(MATCHNAMES(theta,pars,"parameters"))); nprotect++;
+ midx = INTEGER(PROTECT(MATCHROWNAMES(FM,pars,"filter-mean variables"))); nprotect++;
+ vidx = INTEGER(PROTECT(MATCHROWNAMES(PV,pars,"prediction-variance variables"))); nprotect++;
PROTECT(newtheta = duplicate(theta)); nprotect++;
Modified: pkg/pomp/src/pfilter.c
===================================================================
--- pkg/pomp/src/pfilter.c 2014-06-09 16:30:30 UTC (rev 967)
+++ pkg/pomp/src/pfilter.c 2014-06-09 16:30:39 UTC (rev 968)
@@ -120,7 +120,7 @@
if (do_rw) {
// indices of parameters undergoing random walk
- PROTECT(pindex = matchnames(Pnames,rw_names)); nprotect++;
+ PROTECT(pindex = matchnames(Pnames,rw_names,"parameters")); nprotect++;
xp = REAL(params);
pidx = INTEGER(pindex);
nrw = LENGTH(rw_names);
Modified: pkg/pomp/src/pomp_internal.h
===================================================================
--- pkg/pomp/src/pomp_internal.h 2014-06-09 16:30:30 UTC (rev 967)
+++ pkg/pomp/src/pomp_internal.h 2014-06-09 16:30:39 UTC (rev 968)
@@ -10,9 +10,9 @@
#include "pomp.h"
-# define MATCHNAMES(X,N) (matchnames(GET_NAMES(X),(N)))
-# define MATCHROWNAMES(X,N) (matchnames(GET_ROWNAMES(GET_DIMNAMES(X)),(N)))
-# define MATCHCOLNAMES(X,N) (matchnames(GET_COLNAMES(GET_DIMNAMES(X)),(N)))
+# define MATCHNAMES(X,N,W) (matchnames(GET_NAMES(X),(N),(W)))
+# define MATCHROWNAMES(X,N,W) (matchnames(GET_ROWNAMES(GET_DIMNAMES(X)),(N),(W)))
+# define MATCHCOLNAMES(X,N,W) (matchnames(GET_COLNAMES(GET_DIMNAMES(X)),(N),(W)))
# define MATCH_CHAR_TO_ROWNAMES(X,N,A) (match_char_to_names(GET_ROWNAMES(GET_DIMNAMES(X)),(N),(A)))
// lookup-table structure, as used internally
@@ -91,7 +91,7 @@
return x;
}
-static R_INLINE SEXP matchnames (SEXP x, SEXP names) {
+static R_INLINE SEXP matchnames (SEXP x, SEXP names, const char *where) {
int nprotect = 0;
int n = length(names);
int *idx, k;
@@ -100,7 +100,10 @@
PROTECT(index = match(x,names,0)); nprotect++;
idx = INTEGER(index);
for (k = 0; k < n; k++) {
- if (idx[k]==0) error("variable '%s' not found",CHARACTER_DATA(STRING_ELT(nm,k)));
+ if (idx[k]==0)
+ error("variable '%s' not found among the %s",
+ CHARACTER_DATA(STRING_ELT(nm,k)),
+ where);
idx[k] -= 1;
}
UNPROTECT(nprotect);
@@ -132,7 +135,7 @@
SEXP slotnames, index;
PROTECT(slotnames = GET_SLOT(object,install(slot)));
if (LENGTH(slotnames) > 0) {
- PROTECT(index = matchnames(names,slotnames));
+ PROTECT(index = matchnames(names,slotnames,slot));
} else {
PROTECT(index = NEW_INTEGER(0));
}
Modified: pkg/pomp/src/rmeasure.c
===================================================================
--- pkg/pomp/src/rmeasure.c 2014-06-09 16:30:30 UTC (rev 967)
+++ pkg/pomp/src/rmeasure.c 2014-06-09 16:30:39 UTC (rev 968)
@@ -163,7 +163,7 @@
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) { // match names against names from data slot
- posn = INTEGER(PROTECT(matchnames(Onames,nm))); nprotect++;
+ posn = INTEGER(PROTECT(matchnames(Onames,nm,"observables"))); nprotect++;
} else {
posn = 0;
}
Modified: pkg/pomp/src/rprior.c
===================================================================
--- pkg/pomp/src/rprior.c 2014-06-09 16:30:30 UTC (rev 967)
+++ pkg/pomp/src/rprior.c 2014-06-09 16:30:39 UTC (rev 968)
@@ -80,7 +80,7 @@
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) { // match names against names from params slot
- posn = INTEGER(PROTECT(matchnames(Pnames,nm))); nprotect++;
+ posn = INTEGER(PROTECT(matchnames(Pnames,nm,"parameters"))); nprotect++;
} else {
posn = 0;
}
Modified: pkg/pomp/src/skeleton.c
===================================================================
--- pkg/pomp/src/skeleton.c 2014-06-09 16:30:30 UTC (rev 967)
+++ pkg/pomp/src/skeleton.c 2014-06-09 16:30:39 UTC (rev 968)
@@ -67,7 +67,7 @@
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) {
- posn = INTEGER(PROTECT(matchnames(Snames,nm))); nprotect++;
+ posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++;
} else {
posn = 0;
}
Modified: pkg/pomp/src/trajectory.c
===================================================================
--- pkg/pomp/src/trajectory.c 2014-06-09 16:30:30 UTC (rev 967)
+++ pkg/pomp/src/trajectory.c 2014-06-09 16:30:39 UTC (rev 968)
@@ -75,7 +75,7 @@
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) {
- posn = INTEGER(PROTECT(matchnames(Snames,nm))); nprotect++;
+ posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++;
}
fs = REAL(AS_NUMERIC(ans));
first = 0;
@@ -144,7 +144,7 @@
PROTECT(zeronames = GET_SLOT(object,install("zeronames"))); nprotect++;
nzeros = LENGTH(zeronames);
if (nzeros > 0) {
- zidx = INTEGER(PROTECT(matchnames(Snames,zeronames))); nprotect++;
+ zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++;
}
// create array to store results
From noreply at r-forge.r-project.org Mon Jun 9 18:30:46 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 9 Jun 2014 18:30:46 +0200 (CEST)
Subject: [Pomp-commits] r969 - pkg/pomp/man
Message-ID: <20140609163046.AD5F518736E@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-09 18:30:46 +0200 (Mon, 09 Jun 2014)
New Revision: 969
Modified:
pkg/pomp/man/mif.Rd
Log:
- fix documentation error
Modified: pkg/pomp/man/mif.Rd
===================================================================
--- pkg/pomp/man/mif.Rd 2014-06-09 16:30:39 UTC (rev 968)
+++ pkg/pomp/man/mif.Rd 2014-06-09 16:30:46 UTC (rev 969)
@@ -93,7 +93,7 @@
specifications for the cooling schedule, i.e., the manner in which the intensity of the parameter perturbations is reduced with successive filtering iterations.
\code{cooling.type} specifies the nature of the cooling schedule.
When \code{cooling.type="geometric"}, on the n-th MIF iteration, the relative perturbation intensity is \code{cooling.fraction^(n/50)}.
- When \code{cooling.type="hyperbolic"}, on the n-th MIF iteration, the relative perturbation intensity is \code{(s+1)(s+n)}, where \code{(s+1)/(s+50)=cooling.fraction}.
+ When \code{cooling.type="hyperbolic"}, on the n-th MIF iteration, the relative perturbation intensity is \code{(s+1)/(s+n)}, where \code{(s+1)/(s+50)=cooling.fraction}.
\code{cooling.fraction} is the relative magnitude of the parameter perturbations after 50 MIF iterations.
\code{cooling.factor} is now deprecated:
to achieve the old behavior, use \code{cooling.type="geometric"} and \code{cooling.fraction=(cooling.factor)^50}.
From noreply at r-forge.r-project.org Mon Jun 9 18:32:01 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 9 Jun 2014 18:32:01 +0200 (CEST)
Subject: [Pomp-commits] r970 - pkg pkg/pomp pkg/pomp/R pkg/pomp/inst
pkg/pomp/man pkg/pomp/tests www/content www/vignettes
Message-ID: <20140609163201.1D164187379@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-09 18:32:00 +0200 (Mon, 09 Jun 2014)
New Revision: 970
Modified:
pkg/Makefile
pkg/pomp/DESCRIPTION
pkg/pomp/NAMESPACE
pkg/pomp/R/abc-methods.R
pkg/pomp/R/pmcmc-methods.R
pkg/pomp/inst/NEWS
pkg/pomp/inst/NEWS.Rd
pkg/pomp/man/abc-methods.Rd
pkg/pomp/man/pmcmc-methods.Rd
pkg/pomp/tests/abc.R
pkg/pomp/tests/abc.Rout.save
www/content/NEWS.html
www/vignettes/advanced_topics_in_pomp.R
www/vignettes/advanced_topics_in_pomp.Rnw
www/vignettes/advanced_topics_in_pomp.pdf
www/vignettes/intro_to_pomp.R
www/vignettes/intro_to_pomp.Rnw
www/vignettes/intro_to_pomp.pdf
www/vignettes/pomp.pdf
Log:
- redefine the 'pmcmcList' class so that it contains 'list'
- add 'abcList' class and associated methods
- fix problems in vignettes associated with bug in knitr 1.6
Modified: pkg/Makefile
===================================================================
--- pkg/Makefile 2014-06-09 16:30:46 UTC (rev 969)
+++ pkg/Makefile 2014-06-09 16:32:00 UTC (rev 970)
@@ -27,7 +27,7 @@
pomp/inst/include/pomp.h: pomp/src/pomp.h
$(CP) $^ $@
-../www.vignettes: export POMP_BUILD_VIGNETTES=yes
+pomp.vignettes: export POMP_BUILD_VIGNETTES=yes
%.dist %.manual %.vignettes: export R_QPDF=qpdf
%.dist %.manual %.vignettes: export R_GSCMD=gs
%.dist %.manual %.vignettes: export GS_QUALITY=ebook
@@ -123,7 +123,7 @@
$(TOUCH) $@
%.remove:
- $(RCMD) REMOVE --library=$(INSTALL_DIR) $*
+ -$(RCMD) REMOVE --library=$(INSTALL_DIR) $*
$(RM) $*.install
%.publish: %.dist %.manual
Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION 2014-06-09 16:30:46 UTC (rev 969)
+++ pkg/pomp/DESCRIPTION 2014-06-09 16:32:00 UTC (rev 970)
@@ -1,8 +1,8 @@
Package: pomp
Type: Package
Title: Statistical inference for partially observed Markov processes
-Version: 0.51-1
-Date: 2014-05-23
+Version: 0.51-2
+Date: 2014-06-10
Authors at R: c(person(given=c("Aaron","A."),family="King",
role=c("aut","cre"),email="kingaa at umich.edu"),
person(given=c("Edward","L."),family="Ionides",role=c("aut")),
Modified: pkg/pomp/NAMESPACE
===================================================================
--- pkg/pomp/NAMESPACE 2014-06-09 16:30:46 UTC (rev 969)
+++ pkg/pomp/NAMESPACE 2014-06-09 16:32:00 UTC (rev 970)
@@ -48,7 +48,7 @@
traj.matched.pomp,
probed.pomp,probe.matched.pomp,
spect.pomp,spect.matched.pomp,
- abc,
+ abc,abcList,
Csnippet
)
Modified: pkg/pomp/R/abc-methods.R
===================================================================
--- pkg/pomp/R/abc-methods.R 2014-06-09 16:30:46 UTC (rev 969)
+++ pkg/pomp/R/abc-methods.R 2014-06-09 16:32:00 UTC (rev 970)
@@ -6,7 +6,7 @@
'abc',
function (object, pars, ...) {
if (missing(pars)) pars <- colnames(object at conv.rec)
- coda::mcmc(object at conv.rec[,pars])
+ coda::mcmc(object at conv.rec[,pars,drop=FALSE])
}
)
@@ -15,64 +15,165 @@
"plot",
"abc",
function (x, y, pars, scatter = FALSE, ...) {
- if (missing(pars)) pars <- x at pars
- if (scatter) {
- pairs(as.matrix(conv.rec(x, pars)))
+ ## if (missing(pars)) pars <- x at pars
+ ## if (scatter) {
+ ## pairs(as.matrix(conv.rec(x,pars)))
+ ## } else {
+ ## plot.ts(conv.rec(x,pars),xlab="iteration",...)
+ ## }
+ abc.diagnostics(c(x),pars=pars,scatter=scatter,...)
+ }
+ )
+
+## abcList class
+setClass(
+ 'abcList',
+ contains='list',
+ validity=function (object) {
+ if (!all(sapply(object,is,'abc'))) {
+ retval <- paste0(
+ "error in ",sQuote("c"),
+ ": dissimilar objects cannot be combined"
+ )
+ return(retval)
+ }
+ d <- sapply(object,function(x)dim(x at conv.rec))
+ if (!all(apply(d,1,diff)==0)) {
+ retval <- paste0(
+ "error in ",sQuote("c"),
+ ": to be combined, ",sQuote("abc"),
+ " objects must have chains of equal length"
+ )
+ return(retval)
+ }
+ TRUE
+ }
+ )
+
+setMethod(
+ 'c',
+ signature=signature(x='abc'),
+ definition=function (x, ...) {
+ y <- list(...)
+ if (length(y)==0) {
+ new("abcList",list(x))
} else {
- plot.ts(conv.rec(x,pars),xlab="iteration",...)
+ p <- sapply(y,is,'abc')
+ pl <- sapply(y,is,'abcList')
+ if (any(!(p||pl)))
+ stop("cannot mix ",sQuote("abc"),
+ " and non-",sQuote("abc")," objects")
+ y[p] <- lapply(y[p],list)
+ y[pl] <- lapply(y[pl],as,"list")
+ new("abcList",c(list(x),y,recursive=TRUE))
}
}
)
-compare.abc <- function (z) {
- ## assumes that z is a list of abcs with identical structure
- if (!is.list(z)) z <- list(z)
- if (!all(sapply(z,function(x)is(x,'abc'))))
- stop("compare.abc error: ",
- sQuote("z"),
- " must be a pmcmc object or a list of pmcmc objects",call.=FALSE)
- mar.multi <- c(0,5.1,0,2.1)
- oma.multi <- c(6,0,5,0)
- xx <- z[[1]]
- estnames <- xx at pars
- parnames <- names(coef(xx))
- unestnames <- parnames[-match(estnames,parnames)]
+setMethod(
+ 'c',
+ signature=signature(x='abcList'),
+ definition=function (x, ...) {
+ y <- list(...)
+ if (length(y)==0) {
+ x
+ } else {
+ p <- sapply(y,is,'abc')
+ pl <- sapply(y,is,'abcList')
+ if (any(!(p||pl)))
+ stop("cannot mix ",sQuote("abc"),
+ " and non-",sQuote("abc")," objects")
+ y[p] <- lapply(y[p],list)
+ y[pl] <- lapply(y[pl],as,"list")
+ new("abcList",c(as(x,"list"),y,recursive=TRUE))
+ }
+ }
+ )
- ## plot pmcmc convergence diagnostics
- other.diagnostics <- c()
- plotnames <- c(other.diagnostics,estnames)
- nplots <- length(plotnames)
- n.per.page <- min(nplots,10)
- nc <- if (n.per.page<=4) 1 else 2
- nr <- ceiling(n.per.page/nc)
- oldpar <- par(mar=mar.multi,oma=oma.multi,mfcol=c(nr,nc))
- on.exit(par(oldpar))
- low <- 1
- hi <- 0
- iteration <- seq(0,xx at Nabc)
- while (hi pompExample(ou2)
newly created pomp object(s):
ou2
@@ -117,6 +119,14 @@
+ )
> plot(abc6)
>
+> try(abc7 <- c(abc2,abc3))
+Error in validObject(.Object) :
+ invalid class "abcList" object: error in 'c': to be combined, 'abc' objects must have chains of equal length
+> plot(abc7 <- c(abc2,abc4))
+> plot(abc7,scatter=TRUE)
+> plot(conv.rec(c(abc2,abc4)))
+> plot(conv.rec(c(abc7,abc6)))
+>
> dev.off()
null device
1
@@ -124,4 +134,4 @@
>
> proc.time()
user system elapsed
- 7.884 0.052 8.120
+ 8.616 0.052 8.991
Modified: www/content/NEWS.html
===================================================================
--- www/content/NEWS.html 2014-06-09 16:30:46 UTC (rev 969)
+++ www/content/NEWS.html 2014-06-09 16:32:00 UTC (rev 970)
@@ -8,22 +8,40 @@
News for package ‘pomp’
+Changes in pomp version 0.51-2
+
+
+
+ More informative error messages are generated when a needed variable cannot be found.
+
+
+ Features that facilitate multiple ABC chains have been added.
+There is a c
method to combine abc
objects into an abcList
object and to combine abcList
objects.
+Running conv.rec
on an abc
or abcList
object produces coda mcmc
and mcmc.list
objects, respectively.
+Diagnostic plots are produced by running plot
on such objects.
+
+
+ Basic structure of pmcmcList
and abcList
objects is changed: these objects now inherit directly from list
.
+
+
+
+
+
Changes in pomp version 0.51-1
- Package 'coda' is now a dependency of 'pomp'.
+
Package coda is now a dependency of pomp.
This package provides various generic MCMC diagnostics.
Features that facilitate multiple PMCMC chains have been added.
-There is a 'c' method to combine 'pmcmc' objects into a 'pmcmcList' object.
-Running 'conv.rec' on a 'pmcmc' or 'pmcmcList' object now produces 'coda' 'mcmc' and 'mcmc.list' objects, respectively.
-Diagnostic plots are produced by running 'plot' on such objects.
+There is a c
method to combine pmcmc
objects into a pmcmcList
object and to combine pmcmcList
objects.
+Running conv.rec
on a pmcmc
or pmcmcList
object now produces coda mcmc
and mcmc.list
objects, respectively.
+Diagnostic plots are produced by running plot
on such objects.
- The 'compare.pmcmc' and 'compare.abc' methods have been removed.
-They are superceded by these diagnostic plots.
+
The compare.pmcmc
and compare.abc
methods have been removed as obsolete.
@@ -68,7 +86,7 @@
The data()
-loadable examples have been re-implemented to make use of the above-mentioned facility.
-Note that this new functionality makes it unnecessary to "un-transform" model parameters within the user-specified rprocess
, dprocess
, rmeasure
, dmeasure
, skeleton
, and initializer
codes.
+Note that this new functionality makes it unnecessary to un-transform model parameters within the user-specified rprocess
, dprocess
, rmeasure
, dmeasure
, skeleton
, and initializer
codes.
This change is not backward-compatible, but only codes using these data()
-loadable example are affected.
Modified: www/vignettes/advanced_topics_in_pomp.R
===================================================================
--- www/vignettes/advanced_topics_in_pomp.R 2014-06-09 16:30:46 UTC (rev 969)
+++ www/vignettes/advanced_topics_in_pomp.R 2014-06-09 16:32:00 UTC (rev 970)
@@ -1,6 +1,5 @@
## ----include=FALSE-------------------------------------------------------
-
opts_chunk$set(
echo=TRUE,results='markup',
progress=TRUE,prompt=FALSE,tidy=FALSE,highlight=FALSE,
@@ -21,14 +20,11 @@
## ----include=FALSE-------------------------------------------------------
-
library(pomp)
set.seed(5384959)
-
## ----pomp-builder-measmod,eval=T-----------------------------------------
-
## negative binomial measurement model
## E[cases|incid] = rho*incid
## Var[cases|incid] = rho*incid*(1+rho*incid/theta)
@@ -41,9 +37,7 @@
'
-
## ----pomp-builder-stepfn,eval=T------------------------------------------
-
## SIR process model with extra-demographic stochasticity
## and seasonal transmission
step.fn <- '
@@ -83,9 +77,7 @@
'
-
## ----pomp-builder-skel,eval=T--------------------------------------------
-
skel <- '
int nrate = 6;
double rate[nrate]; // transition rates
@@ -121,9 +113,7 @@
'
-
## ----pomp-builder-partrans,eval=T----------------------------------------
-
## parameter transformations
## note we use barycentric coordinates for the initial conditions
## the success of this depends on S0, I0, R0 being in
@@ -155,9 +145,7 @@
"
-
## ----pomp-builder-covar,eval=T-------------------------------------------
-
covartab <- data.frame(
time=seq(from=-1/52,to=10+1/52,by=1/26)
)
@@ -178,7 +166,6 @@
## ----pomp-builder,eval=F-------------------------------------------------
-##
## pompBuilder(
## name="SIR",
## data=data.frame(
@@ -212,13 +199,11 @@
## x0
## }
## ) -> sir
-##
## ----pomp-builder-eval,echo=F,eval=T,results='hide'----------------------
if (Sys.getenv("POMP_BUILD_VIGNETTES")=="yes") {
require(pomp)
-
pompBuilder(
name="SIR",
data=data.frame(
@@ -252,12 +237,10 @@
x0
}
) -> sir
-
}
## ----sir-sim,eval=T------------------------------------------------------
-
coef(sir) <- c(
gamma=26,mu=0.02,iota=0.01,
beta1=400,beta2=480,beta3=320,
@@ -271,7 +254,6 @@
traj <- trajectory(sir,hmax=1/52)
-
## ----sir-plot,fig=T,echo=F-----------------------------------------------
plot(sir)
@@ -304,7 +286,6 @@
dim(fp)
fp[,36:40]
-
## ------------------------------------------------------------------------
fm <- dmeasure(ou2,y=y[,1,],x=x,times=time(ou2),params=true.p)
dim(fm)
@@ -346,11 +327,9 @@
)
) -> ou2.Rplug
-
## ----plugin-R-code-sim,echo=T,eval=F-------------------------------------
## simdat.Rplug <- simulate(ou2.Rplug,params=coef(ou2),nsim=5000,states=T)
-
## ----plugin-R-code-eval,echo=F,eval=T------------------------------------
binary.file <- "plugin-R-code.rda"
if (file.exists(binary.file)) {
@@ -412,11 +391,9 @@
## sigma.1=3, sigma.2=-0.5, sigma.3=2
## )
-
## ----vectorized-R-code-sim,eval=F,echo=T---------------------------------
## simdat.Rvect <- simulate(ou2.Rvect,params=theta,states=T,nsim=100000)
-
## ----vectorized-R-code-eval,eval=T,echo=F--------------------------------
binary.file <- "vectorized-R-code.rda"
if (file.exists(binary.file)) {
@@ -562,7 +539,6 @@
## simdat.Cvect <- simulate(ou2.Cvect,params=theta[paramnames],
## nsim=100000,states=T)
-
## ----vectorized-C-code-eval,echo=F,eval=T--------------------------------
binary.file <- "vectorized-C-code.rda"
if (file.exists(binary.file)) {
Modified: www/vignettes/advanced_topics_in_pomp.Rnw
===================================================================
--- www/vignettes/advanced_topics_in_pomp.Rnw 2014-06-09 16:30:46 UTC (rev 969)
+++ www/vignettes/advanced_topics_in_pomp.Rnw 2014-06-09 16:32:00 UTC (rev 970)
@@ -50,7 +50,6 @@
<>=
-
opts_chunk$set(
echo=TRUE,results='markup',
progress=TRUE,prompt=FALSE,tidy=FALSE,highlight=FALSE,
@@ -80,10 +79,8 @@
\tableofcontents
<>=
-
library(pomp)
set.seed(5384959)
-
@
\section{Accumulator variables}
@@ -126,7 +123,6 @@
We'll start by writing snippets of C code to implement each of the important parts of our model.
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/pomp -r 970
From noreply at r-forge.r-project.org Tue Jun 10 15:21:48 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 10 Jun 2014 15:21:48 +0200 (CEST)
Subject: [Pomp-commits] r971 - pkg/pomp/R
Message-ID: <20140610132148.52C7E187304@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-10 15:21:48 +0200 (Tue, 10 Jun 2014)
New Revision: 971
Modified:
pkg/pomp/R/abc-methods.R
pkg/pomp/R/pmcmc-methods.R
Log:
- minor tweaks to diagnostic plotting routines
Modified: pkg/pomp/R/abc-methods.R
===================================================================
--- pkg/pomp/R/abc-methods.R 2014-06-09 16:32:00 UTC (rev 970)
+++ pkg/pomp/R/abc-methods.R 2014-06-10 13:21:48 UTC (rev 971)
@@ -135,7 +135,6 @@
oma.multi <- c(6,0,5,0)
xx <- z[[1]]
estnames <- pars
-
## plot abc convergence diagnostics
other.diagnostics <- c()
plotnames <- c(other.diagnostics,estnames)
@@ -152,7 +151,7 @@
hi <- min(low+n.per.page-1,nplots)
for (i in seq(from=low,to=hi,by=1)) {
n <- i-low+1
- dat <- sapply(z,function(po,label) conv.rec(po,label),label=plotnames[i])
+ dat <- sapply(z,conv.rec,pars=plotnames[i])
matplot(
y=dat,
x=iteration,
Modified: pkg/pomp/R/pmcmc-methods.R
===================================================================
--- pkg/pomp/R/pmcmc-methods.R 2014-06-09 16:32:00 UTC (rev 970)
+++ pkg/pomp/R/pmcmc-methods.R 2014-06-10 13:21:48 UTC (rev 971)
@@ -135,7 +135,7 @@
hi <- min(low+n.per.page-1,nplots)
for (i in seq(from=low,to=hi,by=1)) {
n <- i-low+1
- dat <- sapply(z,function(po,label) conv.rec(po,label),label=plotnames[i])
+ dat <- sapply(z,conv.rec,pars=plotnames[i])
matplot(
y=dat,
x=iteration,
From noreply at r-forge.r-project.org Tue Jun 10 15:57:52 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 10 Jun 2014 15:57:52 +0200 (CEST)
Subject: [Pomp-commits] r972 - pkg/pomp/man
Message-ID: <20140610135752.74EE1186C8D@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-10 15:57:52 +0200 (Tue, 10 Jun 2014)
New Revision: 972
Modified:
pkg/pomp/man/gompertz.Rd
pkg/pomp/man/plugins.Rd
pkg/pomp/man/pomp-package.Rd
pkg/pomp/man/pomp.Rd
pkg/pomp/man/sir.Rd
Log:
- repairs to the documentation
Modified: pkg/pomp/man/gompertz.Rd
===================================================================
--- pkg/pomp/man/gompertz.Rd 2014-06-10 13:21:48 UTC (rev 971)
+++ pkg/pomp/man/gompertz.Rd 2014-06-10 13:57:52 UTC (rev 972)
@@ -18,6 +18,6 @@
coef(gompertz,transform=TRUE)
}
\seealso{
- the \dQuote{Introduction to \pkg{pomp}} vignette
+ the \href{http://pomp.r-forge.r-project.org/vignettes/intro_to_pomp.pdf}{\dQuote{Introduction to \pkg{pomp}}} tutorial.
}
\keyword{datasets}
Modified: pkg/pomp/man/plugins.Rd
===================================================================
--- pkg/pomp/man/plugins.Rd 2014-06-10 13:21:48 UTC (rev 971)
+++ pkg/pomp/man/plugins.Rd 2014-06-10 13:57:52 UTC (rev 972)
@@ -27,7 +27,7 @@
\code{params} is a named numeric vector containing parameters,
and \code{delta.t} is the length of the Euler time-step.
- For examples on the use of \code{\link{Csnippet}} to write fast simulators easily, see the \dQuote{Introduction to \pkg{pomp}} document, included with the package.
+ For examples on the use of \code{\link{Csnippet}} to write fast simulators easily, see the \dQuote{Introduction to \pkg{pomp}} tutorial vignette, available on the \href{http://pomp.r-forge.r-project.org}{package website}.
If \code{step.fun} is the name of a native function, it must be of type \dQuote{pomp_onestep_sim} as defined in the header \dQuote{pomp.h}, which is included with the \pkg{pomp} package.
For details on how to write such codes, see Details.
@@ -39,7 +39,7 @@
\code{x} is a named numeric vector containing the value of the state process at time \code{t} and
\code{params} is a named numeric vector containing parameters.
- For examples on the use of \code{\link{Csnippet}} to write fast simulators easily, see the \dQuote{Introduction to \pkg{pomp}} document, included with the package.
+ For examples on the use of \code{\link{Csnippet}} to write fast simulators easily, see the \dQuote{Introduction to \pkg{pomp}} tutorial vignette, available on the \href{http://pomp.r-forge.r-project.org}{package website}.
If \code{rate.fun} is a native function, it must be of type \dQuote{pomp_ssa_rate_fn} as defined in the header \dQuote{pomp.h}, which is included with the package.
For details on how to write such codes, see Details.
Modified: pkg/pomp/man/pomp-package.Rd
===================================================================
--- pkg/pomp/man/pomp-package.Rd 2014-06-10 13:21:48 UTC (rev 971)
+++ pkg/pomp/man/pomp-package.Rd 2014-06-10 13:57:52 UTC (rev 972)
@@ -8,7 +8,7 @@
The first step in using \pkg{pomp} is to encode one's model and data in an object of class \code{pomp}.
One does this via a call to \code{\link{pomp}}, which involves specifying the process and measurement components of the model in one or more of a variety of ways.
Details on this are given in the documentation for the \code{\link{pomp}} function.
- Examples are given in the \sQuote{Introduction to \pkg{pomp}} document, in the demos (\code{demo(package='pomp')}), and via the \code{\link{pompExample}} function.
+ Examples are given in the \href{http://pomp.r-forge.r-project.org/vignettes/intro_to_pomp.pdf}{\dQuote{Introduction to \pkg{pomp}}} document, in the demos (\code{demo(package='pomp')}), and via the \code{\link{pompExample}} function.
\pkg{pomp} version \Sexpr[echo=F,stage=install,results=text]{packageDescription("pomp",fields="Version")} provides algorithms for
\enumerate{
@@ -37,8 +37,8 @@
The basic class, \code{\link{pomp}}, encodes a partially-observed Markov process together with a uni- or multi-variate data set and (possibly) parameters.
}
\section{Documentation}{
- The \href{http://pomp.r-forge.r-project.org/vignettes/index.html}{\sQuote{Introduction to \pkg{pomp}}} document illustrates the facilities of the package using familiar stochastic processes.
- The \href{http://pomp.r-forge.r-project.org/vignettes/index.html}{\sQuote{Advanced topics in \pkg{pomp}}} document discusses the low-level interface and some more advanced modeling techniques.
+ The \href{http://pomp.r-forge.r-project.org/vignettes/intro_to_pomp.pdf}{\sQuote{Introduction to \pkg{pomp}}} document illustrates the facilities of the package using familiar stochastic processes.
+ The \href{http://pomp.r-forge.r-project.org/vignettes/advanced_topics_in_pomp.pdf}{\sQuote{Advanced topics in \pkg{pomp}}} document discusses the low-level interface and some more advanced modeling techniques.
These documents can be viewed at \url{http://pomp.r-forge.r-project.org}.
}
\references{
Modified: pkg/pomp/man/pomp.Rd
===================================================================
--- pkg/pomp/man/pomp.Rd 2014-06-10 13:21:48 UTC (rev 971)
+++ pkg/pomp/man/pomp.Rd 2014-06-10 13:57:52 UTC (rev 972)
@@ -300,8 +300,8 @@
}
}
\examples{
-## For examples, see the \dQuote{Introduction to \pkg{pomp}}
-## and \dQuote{Advanced topics in \pkg{pomp}} documents,
+## For examples, see the "Introduction to pomp"
+## and "Advanced topics in pomp" documents,
## the demos, and the examples provided with the package, e.g.:
\dontrun{
pompExample()
Modified: pkg/pomp/man/sir.Rd
===================================================================
--- pkg/pomp/man/sir.Rd 2014-06-10 13:21:48 UTC (rev 971)
+++ pkg/pomp/man/sir.Rd 2014-06-10 13:57:52 UTC (rev 972)
@@ -11,7 +11,7 @@
\code{bbs} is a nonseasonal SIR model together with data from a 1978 outbreak of influenza in a British boarding school.
}
\details{
- This example is discussed extensively in the \dQuote{Introduction to \pkg{pomp}} and \dQuote{Advanced topics in \pkg{pomp}} vignettes.
+ This example is discussed extensively in the \dQuote{Introduction to \pkg{pomp}} and \dQuote{Advanced topics in \pkg{pomp}} vignettes, available on the \href{http://pomp.r-forge.r-project.org}{package website}.
The codes that construct these \code{pomp} objects can be found in the \dQuote{examples} directory in the installed package.
Do \code{system.file("examples",package="pomp"))} to find this directory.
From noreply at r-forge.r-project.org Tue Jun 10 15:58:53 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 10 Jun 2014 15:58:53 +0200 (CEST)
Subject: [Pomp-commits] r973 - www/vignettes
Message-ID: <20140610135853.9D816186CA0@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-10 15:58:53 +0200 (Tue, 10 Jun 2014)
New Revision: 973
Modified:
www/vignettes/advanced_topics_in_pomp.pdf
www/vignettes/intro_to_pomp.pdf
www/vignettes/pomp.pdf
Log:
- updates to the online documentation
Modified: www/vignettes/advanced_topics_in_pomp.pdf
===================================================================
(Binary files differ)
Modified: www/vignettes/intro_to_pomp.pdf
===================================================================
(Binary files differ)
Modified: www/vignettes/pomp.pdf
===================================================================
(Binary files differ)
From noreply at r-forge.r-project.org Fri Jun 13 13:37:30 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Fri, 13 Jun 2014 13:37:30 +0200 (CEST)
Subject: [Pomp-commits] r974 - pkg/pomp
Message-ID: <20140613113730.2C49A1872A5@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-13 13:37:29 +0200 (Fri, 13 Jun 2014)
New Revision: 974
Modified:
pkg/pomp/DESCRIPTION
Log:
- bump for rebuild
Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION 2014-06-10 13:58:53 UTC (rev 973)
+++ pkg/pomp/DESCRIPTION 2014-06-13 11:37:29 UTC (rev 974)
@@ -2,7 +2,7 @@
Type: Package
Title: Statistical inference for partially observed Markov processes
Version: 0.51-2
-Date: 2014-06-10
+Date: 2014-06-12
Authors at R: c(person(given=c("Aaron","A."),family="King",
role=c("aut","cre"),email="kingaa at umich.edu"),
person(given=c("Edward","L."),family="Ionides",role=c("aut")),
From noreply at r-forge.r-project.org Tue Jun 17 14:46:29 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 17 Jun 2014 14:46:29 +0200 (CEST)
Subject: [Pomp-commits] r975 - in pkg/pomp: R man
Message-ID: <20140617124629.C056E18631C@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-17 14:46:29 +0200 (Tue, 17 Jun 2014)
New Revision: 975
Modified:
pkg/pomp/R/pmcmc.R
pkg/pomp/man/pmcmc.Rd
Log:
- remove 'transform' option from 'pmcmc'
Modified: pkg/pomp/R/pmcmc.R
===================================================================
--- pkg/pomp/R/pmcmc.R 2014-06-13 11:37:29 UTC (rev 974)
+++ pkg/pomp/R/pmcmc.R 2014-06-17 12:46:29 UTC (rev 975)
@@ -4,7 +4,6 @@
contains='pfilterd.pomp',
slots=c(
pars = 'character',
- transform = 'logical',
Nmcmc = 'integer',
random.walk.sd = 'numeric',
conv.rec = 'matrix',
@@ -16,14 +15,13 @@
start, pars,
rw.sd, Np,
tol, max.fail,
- verbose, transform,
+ verbose,
.ndone = 0L,
.prev.pfp = NULL, .prev.log.prior = NULL,
.getnativesymbolinfo = TRUE) {
object <- as(object,"pomp")
gnsi <- as.logical(.getnativesymbolinfo)
- transform <- as.logical(transform)
.ndone <- as.integer(.ndone)
if (missing(start))
@@ -154,8 +152,8 @@
filter.mean=TRUE,
save.states=FALSE,
save.params=FALSE,
- verbose=verbose,
.transform=FALSE,
+ verbose=verbose,
.getnativesymbolinfo=gnsi
),
silent=FALSE
@@ -174,11 +172,7 @@
for (n in seq_len(Nmcmc)) { # main loop
theta.prop <- theta
- if (transform)
- theta <- partrans(object,theta.prop,dir='inverse',.getnativesymbolinfo=gnsi)
theta.prop[pars] <- rnorm(n=length(pars),mean=theta.prop[pars],sd=rw.sd)
- if (transform)
- theta <- partrans(object,theta.prop,dir='forward',.getnativesymbolinfo=gnsi)
## run the particle filter on the proposed new parameter values
pfp.prop <- try(
@@ -193,8 +187,8 @@
filter.mean=TRUE,
save.states=FALSE,
save.params=FALSE,
- verbose=verbose,
.transform=FALSE,
+ verbose=verbose,
.getnativesymbolinfo=gnsi
),
silent=FALSE
@@ -223,7 +217,6 @@
"pmcmc",
pfp,
params=theta,
- transform=transform,
Nmcmc=Nmcmc,
pars=pars,
random.walk.sd=rw.sd,
@@ -241,10 +234,9 @@
start, pars, rw.sd, Np,
tol = 1e-17, max.fail = 0,
verbose = getOption("verbose"),
- transform = FALSE,
...) {
- if (missing(start)) start <- coef(object,transform=transform)
+ if (missing(start)) start <- coef(object)
if (missing(rw.sd))
stop("pmcmc error: ",sQuote("rw.sd")," must be specified",call.=FALSE)
if (missing(pars)) pars <- names(rw.sd)[rw.sd>0]
@@ -261,7 +253,6 @@
tol=tol,
max.fail=max.fail,
verbose=verbose,
- transform=transform,
...
)
}
@@ -292,7 +283,6 @@
start, pars, rw.sd,
Np, tol, max.fail = 0,
verbose = getOption("verbose"),
- transform,
...) {
if (missing(Nmcmc)) Nmcmc <- object at Nmcmc
@@ -301,7 +291,6 @@
if (missing(rw.sd)) rw.sd <- object at random.walk.sd
if (missing(Np)) Np <- object at Np
if (missing(tol)) tol <- object at tol
- if (missing(transform)) transform <- object at transform
pmcmc(
object=as(object,"pomp"),
@@ -313,7 +302,6 @@
tol=tol,
max.fail=max.fail,
verbose=verbose,
- transform=transform,
...
)
}
Modified: pkg/pomp/man/pmcmc.Rd
===================================================================
--- pkg/pomp/man/pmcmc.Rd 2014-06-13 11:37:29 UTC (rev 974)
+++ pkg/pomp/man/pmcmc.Rd 2014-06-17 12:46:29 UTC (rev 975)
@@ -15,13 +15,11 @@
The Particle MCMC algorithm for estimating the parameters of a partially-observed Markov process.
}
\usage{
-\S4method{pmcmc}{pomp}(object, Nmcmc = 1, start, pars,
- rw.sd, Np, tol = 1e-17, max.fail = 0,
- verbose = getOption("verbose"), transform = FALSE, \dots)
+\S4method{pmcmc}{pomp}(object, Nmcmc = 1, start, pars, rw.sd, Np,
+ tol = 1e-17, max.fail = 0, verbose = getOption("verbose"), \dots)
\S4method{pmcmc}{pfilterd.pomp}(object, Nmcmc = 1, Np, tol, \dots)
-\S4method{pmcmc}{pmcmc}(object, Nmcmc, start, pars,
- rw.sd, Np, tol, max.fail = 0,
- verbose = getOption("verbose"), transform, \dots)
+\S4method{pmcmc}{pmcmc}(object, Nmcmc, start, pars, rw.sd, Np,
+ tol, max.fail = 0, verbose = getOption("verbose"), \dots)
\S4method{continue}{pmcmc}(object, Nmcmc = 1, \dots)
}
\arguments{
@@ -62,10 +60,6 @@
\item{verbose}{
logical; if TRUE, print progress reports.
}
- \item{transform}{
- logical;
- if \code{TRUE}, optimization is performed on the transformed scale.
- }
\item{\dots}{
Additional arguments.
These are currently ignored.
From noreply at r-forge.r-project.org Tue Jun 17 14:46:34 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 17 Jun 2014 14:46:34 +0200 (CEST)
Subject: [Pomp-commits] r976 - in pkg/pomp: . R inst man
Message-ID: <20140617124634.A4C631866B0@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-17 14:46:34 +0200 (Tue, 17 Jun 2014)
New Revision: 976
Modified:
pkg/pomp/DESCRIPTION
pkg/pomp/R/abc.R
pkg/pomp/inst/NEWS
pkg/pomp/inst/NEWS.Rd
pkg/pomp/man/abc.Rd
Log:
- remove 'transform' argument from 'abc'
Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION 2014-06-17 12:46:29 UTC (rev 975)
+++ pkg/pomp/DESCRIPTION 2014-06-17 12:46:34 UTC (rev 976)
@@ -1,8 +1,8 @@
Package: pomp
Type: Package
Title: Statistical inference for partially observed Markov processes
-Version: 0.51-2
-Date: 2014-06-12
+Version: 0.51-3
+Date: 2014-06-16
Authors at R: c(person(given=c("Aaron","A."),family="King",
role=c("aut","cre"),email="kingaa at umich.edu"),
person(given=c("Edward","L."),family="Ionides",role=c("aut")),
Modified: pkg/pomp/R/abc.R
===================================================================
--- pkg/pomp/R/abc.R 2014-06-17 12:46:29 UTC (rev 975)
+++ pkg/pomp/R/abc.R 2014-06-17 12:46:34 UTC (rev 976)
@@ -4,7 +4,6 @@
contains='pomp',
slots=c(
pars = 'character',
- transform = 'logical',
Nabc = 'integer',
probes='list',
scale = 'numeric',
@@ -18,14 +17,13 @@
start, pars,
rw.sd, probes,
epsilon, scale,
- verbose, transform,
+ verbose,
.ndone = 0L,
.getnativesymbolinfo = TRUE,
...) {
object <- as(object,'pomp')
gnsi <- as.logical(.getnativesymbolinfo)
- transform <- as.logical(transform)
Nabc <- as.integer(Nabc)
epsilon <- as.numeric(epsilon)
epssq <- epsilon*epsilon
@@ -134,17 +132,8 @@
for (n in seq_len(Nabc)) { # main loop
theta.prop <- theta
-
- if (transform)
- theta.prop <- partrans(object,params=theta.prop,dir='inverse',
- .getnativesymbolinfo=gnsi)
-
theta.prop[pars] <- rnorm(n=length(pars),mean=theta.prop[pars],sd=rw.sd)
- if (transform)
- theta.prop <- partrans(object,params=theta.prop,dir='forward',
- .getnativesymbolinfo=gnsi)
-
gnsi <- FALSE
## compute the probes for the proposed new parameter values
@@ -187,7 +176,6 @@
object,
params=theta,
pars=pars,
- transform=transform,
Nabc=Nabc,
probes=probes,
scale=scale,
@@ -205,7 +193,6 @@
start, pars, rw.sd,
probes, scale, epsilon,
verbose = getOption("verbose"),
- transform = FALSE,
...) {
if (missing(start))
@@ -239,8 +226,7 @@
scale=scale,
epsilon=epsilon,
rw.sd=rw.sd,
- verbose=verbose,
- transform=transform
+ verbose=verbose
)
}
)
@@ -250,7 +236,6 @@
signature=signature(object="probed.pomp"),
function (object, probes,
verbose = getOption("verbose"),
- transform = FALSE,
...) {
if (missing(probes)) probes <- object at probes
@@ -258,7 +243,6 @@
f(
object=object,
probes=probes,
- transform=transform,
...
)
}
@@ -271,7 +255,6 @@
start, pars, rw.sd,
probes, scale, epsilon,
verbose = getOption("verbose"),
- transform,
...) {
if (missing(Nabc)) Nabc <- object at Nabc
@@ -281,7 +264,6 @@
if (missing(probes)) probes <- object at probes
if (missing(scale)) scale <- object at scale
if (missing(epsilon)) epsilon <- object at epsilon
- if (missing(transform)) transform <- object at transform
f <- selectMethod("abc","pomp")
@@ -295,7 +277,6 @@
scale=scale,
epsilon=epsilon,
verbose=verbose,
- transform=transform,
...
)
}
Modified: pkg/pomp/inst/NEWS
===================================================================
--- pkg/pomp/inst/NEWS 2014-06-17 12:46:29 UTC (rev 975)
+++ pkg/pomp/inst/NEWS 2014-06-17 12:46:34 UTC (rev 976)
@@ -1,5 +1,9 @@
_N_e_w_s _f_o_r _p_a_c_k_a_g_e '_p_o_m_p'
+_C_h_a_n_g_e_s _i_n '_p_o_m_p' _v_e_r_s_i_o_n _0._5_1-_3:
+
+ ? ?transform? argument for ?pmcmc? and ?abc? has been removed.
+
_C_h_a_n_g_e_s _i_n '_p_o_m_p' _v_e_r_s_i_o_n _0._5_1-_2:
? More informative error messages are generated when a needed
Modified: pkg/pomp/inst/NEWS.Rd
===================================================================
--- pkg/pomp/inst/NEWS.Rd 2014-06-17 12:46:29 UTC (rev 975)
+++ pkg/pomp/inst/NEWS.Rd 2014-06-17 12:46:34 UTC (rev 976)
@@ -1,5 +1,10 @@
\name{NEWS}
\title{News for package `pomp'}
+\section{Changes in \pkg{pomp} version 0.51-3}{
+ \itemize{
+ \item \code{transform} argument for \code{pmcmc} and \code{abc} has been removed.
+ }
+}
\section{Changes in \pkg{pomp} version 0.51-2}{
\itemize{
\item More informative error messages are generated when a needed variable cannot be found.
Modified: pkg/pomp/man/abc.Rd
===================================================================
--- pkg/pomp/man/abc.Rd 2014-06-17 12:46:29 UTC (rev 975)
+++ pkg/pomp/man/abc.Rd 2014-06-17 12:46:34 UTC (rev 976)
@@ -18,12 +18,12 @@
\usage{
\S4method{abc}{pomp}(object, Nabc = 1, start, pars,
rw.sd, probes, scale, epsilon,
- verbose = getOption("verbose"), transform = FALSE, \dots)
+ verbose = getOption("verbose"), \dots)
\S4method{abc}{probed.pomp}(object, probes,
- verbose = getOption("verbose"), transform = FALSE, \dots)
+ verbose = getOption("verbose"), \dots)
\S4method{abc}{abc}(object, Nabc, start, pars,
rw.sd, probes, scale, epsilon,
- verbose = getOption("verbose"), transform, \dots)
+ verbose = getOption("verbose"), \dots)
\S4method{continue}{abc}(object, Nabc = 1, \dots)
}
\arguments{
@@ -62,10 +62,6 @@
\item{verbose}{
logical; if TRUE, print progress reports.
}
- \item{transform}{
- logical;
- if \code{TRUE}, optimization is performed on the transformed scale.
- }
\item{\dots}{
Additional arguments.
These are currently ignored.
@@ -75,7 +71,7 @@
An object of class \code{abc}.
This class inherits from class \code{\link[=probed.pomp-class]{probed.pomp}} and contains the following additional slots:
\describe{
- \item{pars, Nabc, dprior, hyperparams, transform, scale, epsilon}{
+ \item{pars, Nabc, dprior, hyperparams, scale, epsilon}{
These slots hold the values of the corresponding arguments of the call to \code{abc}.
}
\item{random.walk.sd}{
From noreply at r-forge.r-project.org Tue Jun 17 23:36:50 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 17 Jun 2014 23:36:50 +0200 (CEST)
Subject: [Pomp-commits] r977 - in www: content vignettes
Message-ID: <20140617213650.23BCF1874F2@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-17 23:36:49 +0200 (Tue, 17 Jun 2014)
New Revision: 977
Modified:
www/content/NEWS.html
www/vignettes/advanced_topics_in_pomp.pdf
www/vignettes/intro_to_pomp.R
www/vignettes/intro_to_pomp.pdf
www/vignettes/pomp.pdf
Log:
- update vignettes
Modified: www/content/NEWS.html
===================================================================
--- www/content/NEWS.html 2014-06-17 12:46:34 UTC (rev 976)
+++ www/content/NEWS.html 2014-06-17 21:36:49 UTC (rev 977)
@@ -8,6 +8,16 @@
News for package ‘pomp’
+Changes in pomp version 0.51-3
+
+
+
+
+
+
Changes in pomp version 0.51-2
Modified: www/vignettes/advanced_topics_in_pomp.pdf
===================================================================
(Binary files differ)
Modified: www/vignettes/intro_to_pomp.R
===================================================================
--- www/vignettes/intro_to_pomp.R 2014-06-17 12:46:34 UTC (rev 976)
+++ www/vignettes/intro_to_pomp.R 2014-06-17 21:36:49 UTC (rev 977)
@@ -304,6 +304,30 @@
} else {
set.seed(457645443L)
+tic <- Sys.time()
+sim1 <- simulate(gompertz,nsim=1000,seed=5676868L,obs=TRUE)
+toc <- Sys.time()
+g1sim <- toc-tic
+
+tic <- Sys.time()
+sim2 <- simulate(gomp2,nsim=1000,seed=5676868L,obs=TRUE)
+toc <- Sys.time()
+g2sim <- toc-tic
+
+stopifnot(all.equal(sim1,sim2))
+
+tic <- Sys.time()
+pf1 <- pfilter(gompertz,Np=10000,seed=5676868L)
+toc <- Sys.time()
+g1pf <- toc-tic
+
+tic <- Sys.time()
+pf2 <- pfilter(gomp2,Np=10000,seed=5676868L)
+toc <- Sys.time()
+g2pf <- toc-tic
+
+stopifnot(all.equal(logLik(pf1),logLik(pf2)))
+
save(g1sim,g2sim,g1pf,g2pf,file=binary.file,compress='xz')
}
Modified: www/vignettes/intro_to_pomp.pdf
===================================================================
(Binary files differ)
Modified: www/vignettes/pomp.pdf
===================================================================
(Binary files differ)
From noreply at r-forge.r-project.org Mon Jun 23 16:12:36 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 23 Jun 2014 16:12:36 +0200 (CEST)
Subject: [Pomp-commits] r978 - in pkg/pomp: . R
Message-ID: <20140623141236.5133F184F97@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-23 16:12:35 +0200 (Mon, 23 Jun 2014)
New Revision: 978
Modified:
pkg/pomp/DESCRIPTION
pkg/pomp/R/pmcmc.R
Log:
bump version number
Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION 2014-06-17 21:36:49 UTC (rev 977)
+++ pkg/pomp/DESCRIPTION 2014-06-23 14:12:35 UTC (rev 978)
@@ -1,8 +1,8 @@
Package: pomp
Type: Package
Title: Statistical inference for partially observed Markov processes
-Version: 0.51-3
-Date: 2014-06-16
+Version: 0.51-4
+Date: 2014-06-23
Authors at R: c(person(given=c("Aaron","A."),family="King",
role=c("aut","cre"),email="kingaa at umich.edu"),
person(given=c("Edward","L."),family="Ionides",role=c("aut")),
Modified: pkg/pomp/R/pmcmc.R
===================================================================
--- pkg/pomp/R/pmcmc.R 2014-06-17 21:36:49 UTC (rev 977)
+++ pkg/pomp/R/pmcmc.R 2014-06-23 14:12:35 UTC (rev 978)
@@ -172,7 +172,7 @@
for (n in seq_len(Nmcmc)) { # main loop
theta.prop <- theta
- theta.prop[pars] <- rnorm(n=length(pars),mean=theta.prop[pars],sd=rw.sd)
+ theta.prop[pars] <- rnorm(n=length(pars),mean=theta[pars],sd=rw.sd)
## run the particle filter on the proposed new parameter values
pfp.prop <- try(
From noreply at r-forge.r-project.org Mon Jun 23 16:12:41 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 23 Jun 2014 16:12:41 +0200 (CEST)
Subject: [Pomp-commits] r979 - in pkg/pomp: R tests
Message-ID: <20140623141241.D3A51180451@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-23 16:12:41 +0200 (Mon, 23 Jun 2014)
New Revision: 979
Modified:
pkg/pomp/R/abc.R
pkg/pomp/tests/abc.Rout.save
Log:
- fix bug with inadmissible proposals
- more efficient algorithm
Modified: pkg/pomp/R/abc.R
===================================================================
--- pkg/pomp/R/abc.R 2014-06-23 14:12:35 UTC (rev 978)
+++ pkg/pomp/R/abc.R 2014-06-23 14:12:41 UTC (rev 979)
@@ -95,9 +95,12 @@
}
theta <- start
- log.prior <- dprior(object,params=theta,log=TRUE,
- .getnativesymbolinfo=gnsi)
- ## we suppose that theta is a "match", which does the right thing for continue() and
+ log.prior <- dprior(object,params=theta,log=TRUE,.getnativesymbolinfo=gnsi)
+ if (!is.finite(log.prior))
+ stop("inadmissible value of ",sQuote("dprior"),
+ " at parameters ",sQuote("start"))
+ ## we suppose that theta is a "match",
+ ## which does the right thing for continue() and
## should have negligible effect unless doing many short calls to continue()
conv.rec <- matrix(
@@ -132,38 +135,39 @@
for (n in seq_len(Nabc)) { # main loop
theta.prop <- theta
- theta.prop[pars] <- rnorm(n=length(pars),mean=theta.prop[pars],sd=rw.sd)
+ theta.prop[pars] <- rnorm(n=length(pars),mean=theta[pars],sd=rw.sd)
+ log.prior.prop <- dprior(object,params=theta.prop,log=TRUE)
- gnsi <- FALSE
+ if (is.finite(log.prior.prop) &&
+ runif(1) < exp(log.prior.prop-log.prior)) {
- ## compute the probes for the proposed new parameter values
+ ## compute the probes for the proposed new parameter values
- simval <- try(
- .Call(
- apply_probe_sim,
- object=object,
- nsim=1,
- params=theta.prop,
- seed=NULL,
- probes=probes,
- datval=datval
- ),
- silent=FALSE
- )
+ simval <- try(
+ .Call(
+ apply_probe_sim,
+ object=object,
+ nsim=1,
+ params=theta.prop,
+ seed=NULL,
+ probes=probes,
+ datval=datval
+ ),
+ silent=FALSE
+ )
- if (inherits(simval,'try-error'))
- stop("abc error: error in ",sQuote("apply_probe_sim"),call.=FALSE)
+ if (inherits(simval,'try-error'))
+ stop("abc error: error in ",sQuote("apply_probe_sim"),call.=FALSE)
- ## ABC update rule
- distance <- sum(((datval-simval)/scale)^2)
- if( (is.finite(distance)) && (distance runs <- rle(as.vector(conv.rec(abc1)[, "alpha.1"]))
> hist(runs$lengths)
> mean(runs$length)
-[1] 7.31602
+[1] 6.949965
>
> abc2 <- abc(po,
+ Nabc=2000,
@@ -134,4 +134,4 @@
>
> proc.time()
user system elapsed
- 8.616 0.052 8.991
+ 11.122 0.067 11.192
From noreply at r-forge.r-project.org Mon Jun 23 16:13:43 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 23 Jun 2014 16:13:43 +0200 (CEST)
Subject: [Pomp-commits] r980 - pkg www/vignettes
Message-ID: <20140623141343.DAB7D1851CD@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-23 16:13:43 +0200 (Mon, 23 Jun 2014)
New Revision: 980
Modified:
pkg/Makefile
www/vignettes/advanced_topics_in_pomp.pdf
www/vignettes/intro_to_pomp.pdf
www/vignettes/pomp.pdf
Log:
- update vignettes
- remove .manual dependency from .dist
Modified: pkg/Makefile
===================================================================
--- pkg/Makefile 2014-06-23 14:12:41 UTC (rev 979)
+++ pkg/Makefile 2014-06-23 14:13:43 UTC (rev 980)
@@ -99,7 +99,7 @@
$(CP) $*.pdf $*/inst/doc/manual.pdf
$(TOUCH) $@
-%.dist: %.manual
+%.dist:
-$(RCMD) Rdconv -t txt $*/inst/NEWS.Rd -o $*/inst/NEWS
$(RCMD) build --force --no-manual --resave-data --compact-vignettes=both $*
$(TOUCH) $@
Modified: www/vignettes/advanced_topics_in_pomp.pdf
===================================================================
(Binary files differ)
Modified: www/vignettes/intro_to_pomp.pdf
===================================================================
(Binary files differ)
Modified: www/vignettes/pomp.pdf
===================================================================
(Binary files differ)
From noreply at r-forge.r-project.org Wed Jun 25 19:38:58 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 25 Jun 2014 19:38:58 +0200 (CEST)
Subject: [Pomp-commits] r981 - in pkg/pomp: . R inst man tests
Message-ID: <20140625173858.7BFE11874E5@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-25 19:38:58 +0200 (Wed, 25 Jun 2014)
New Revision: 981
Modified:
pkg/pomp/DESCRIPTION
pkg/pomp/NAMESPACE
pkg/pomp/R/abc-methods.R
pkg/pomp/R/bsmc.R
pkg/pomp/R/generics.R
pkg/pomp/R/mif-methods.R
pkg/pomp/R/pmcmc-methods.R
pkg/pomp/R/probe.R
pkg/pomp/inst/NEWS
pkg/pomp/inst/NEWS.Rd
pkg/pomp/man/abc-methods.Rd
pkg/pomp/man/mif-methods.Rd
pkg/pomp/man/pmcmc-methods.Rd
pkg/pomp/tests/ou2-mif-fp.R
pkg/pomp/tests/ou2-mif-fp.Rout.save
pkg/pomp/tests/ou2-mif.R
pkg/pomp/tests/ou2-mif.Rout.save
pkg/pomp/tests/ou2-mif2.R
pkg/pomp/tests/ou2-mif2.Rout.save
Log:
- new 'mifList' class
- define plot methods for 'mifList'
- warn on ignored 'y' in 'plot(x,y)'
- deprecate 'compare.mif'
Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/DESCRIPTION 2014-06-25 17:38:58 UTC (rev 981)
@@ -1,8 +1,8 @@
Package: pomp
Type: Package
Title: Statistical inference for partially observed Markov processes
-Version: 0.51-4
-Date: 2014-06-23
+Version: 0.52-1
+Date: 2014-06-26
Authors at R: c(person(given=c("Aaron","A."),family="King",
role=c("aut","cre"),email="kingaa at umich.edu"),
person(given=c("Edward","L."),family="Ionides",role=c("aut")),
Modified: pkg/pomp/NAMESPACE
===================================================================
--- pkg/pomp/NAMESPACE 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/NAMESPACE 2014-06-25 17:38:58 UTC (rev 981)
@@ -43,7 +43,7 @@
exportClasses(
pomp,
pfilterd.pomp,
- mif,
+ mif,mifList,
pmcmc,pmcmcList,
traj.matched.pomp,
probed.pomp,probe.matched.pomp,
Modified: pkg/pomp/R/abc-methods.R
===================================================================
--- pkg/pomp/R/abc-methods.R 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/R/abc-methods.R 2014-06-25 17:38:58 UTC (rev 981)
@@ -1,12 +1,12 @@
## this file contains short definitions of methods for the 'abc' class
-## extract the convergence record
+## extract the convergence record as an 'mcmc' object
setMethod(
'conv.rec',
'abc',
function (object, pars, ...) {
if (missing(pars)) pars <- colnames(object at conv.rec)
- coda::mcmc(object at conv.rec[,pars,drop=FALSE])
+ coda::mcmc(object at conv.rec[,pars,drop=FALSE],...)
}
)
@@ -21,6 +21,8 @@
## } else {
## plot.ts(conv.rec(x,pars),xlab="iteration",...)
## }
+ if (!missing(y))
+ warning(sQuote("y")," is ignored")
abc.diagnostics(c(x),pars=pars,scatter=scatter,...)
}
)
@@ -98,6 +100,7 @@
}
)
+## extract the convergence record as an 'mcmc.list' object
setMethod(
'conv.rec',
signature=signature(object='abcList'),
@@ -109,7 +112,9 @@
setMethod(
"plot",
signature=signature(x='abcList'),
- definition=function (x, y = NULL, ...) {
+ definition=function (x, y, ...) {
+ if (!missing(y))
+ warning(sQuote("y")," is ignored")
abc.diagnostics(x,...)
}
)
Modified: pkg/pomp/R/bsmc.R
===================================================================
--- pkg/pomp/R/bsmc.R 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/R/bsmc.R 2014-06-25 17:38:58 UTC (rev 981)
@@ -367,17 +367,17 @@
setMethod(
"bsmc",
- "pomp",
- function (object, params, Np, est,
- smooth = 0.1,
- ntries = 1,
- tol = 1e-17,
- lower = -Inf, upper = Inf,
- seed = NULL,
- verbose = getOption("verbose"),
- max.fail = 0,
- transform = FALSE,
- ...) {
+ signature=signature(object="pomp"),
+ definition = function (object, params, Np, est,
+ smooth = 0.1,
+ ntries = 1,
+ tol = 1e-17,
+ lower = -Inf, upper = Inf,
+ seed = NULL,
+ verbose = getOption("verbose"),
+ max.fail = 0,
+ transform = FALSE,
+ ...) {
bsmc.internal(
object=object,
params=params,
@@ -397,7 +397,10 @@
}
)
-setMethod("$",signature(x="bsmcd.pomp"),function (x,name) slot(x,name))
+setMethod("$",
+ signature(x="bsmcd.pomp"),
+ definition = function (x, name) slot(x,name)
+ )
bsmc.plot <- function (prior, post, pars, thin, ...) {
p1 <- sample.int(n=ncol(prior),size=min(thin,ncol(prior)))
@@ -437,7 +440,9 @@
setMethod(
"plot",
signature(x="bsmcd.pomp"),
- function (x, ..., pars, thin) {
+ function (x, y, ..., pars, thin) {
+ if (!missing(y))
+ warning(sQuote("y")," is ignored")
if (missing(pars)) pars <- names(coef(x,transform=!x at transform))
if (missing(thin)) thin <- Inf
bsmc.plot(
Modified: pkg/pomp/R/generics.R
===================================================================
--- pkg/pomp/R/generics.R 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/R/generics.R 2014-06-25 17:38:58 UTC (rev 981)
@@ -45,7 +45,6 @@
setGeneric("eff.sample.size",function(object,...)standardGeneric("eff.sample.size"))
## convergence record
setGeneric("conv.rec",function(object,...)standardGeneric("conv.rec"))
-
## stochastic simulation
setGeneric("simulate",function(object,nsim=1,seed=NULL,...)standardGeneric("simulate"))
Modified: pkg/pomp/R/mif-methods.R
===================================================================
--- pkg/pomp/R/mif-methods.R 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/R/mif-methods.R 2014-06-25 17:38:58 UTC (rev 981)
@@ -89,11 +89,108 @@
setMethod(
"plot",
"mif",
- function (x, y = NULL, ...) {
- compare.mif(x)
+ function (x, y, ...) {
+ if (!missing(y)) {
+ y <- substitute(y)
+ warning(sQuote(y)," is ignored")
+ }
+ mif.diagnostics(list(x))
}
)
+## mifList class
+setClass(
+ 'mifList',
+ contains='list',
+ validity=function (object) {
+ if (!all(sapply(object,is,'mif'))) {
+ retval <- paste0(
+ "error in ",sQuote("c"),
+ ": dissimilar objects cannot be combined"
+ )
+ return(retval)
+ }
+ d <- sapply(object,function(x)dim(x at conv.rec))
+ if (!all(apply(d,1,diff)==0)) {
+ retval <- paste0(
+ "error in ",sQuote("c"),
+ ": to be combined, ",sQuote("mif"),
+ " objects must equal numbers of iterations"
+ )
+ return(retval)
+ }
+ TRUE
+ }
+ )
+
+setMethod(
+ 'c',
+ signature=signature(x='mif'),
+ definition=function (x, ...) {
+ y <- list(...)
+ if (length(y)==0) {
+ new("mifList",list(x))
+ } else {
+ p <- sapply(y,is,'mif')
+ pl <- sapply(y,is,'mifList')
+ if (any(!(p||pl)))
+ stop("cannot mix ",sQuote("mif"),
+ " and non-",sQuote("mif")," objects")
+ y[p] <- lapply(y[p],list)
+ y[pl] <- lapply(y[pl],as,"list")
+ new("mifList",c(list(x),y,recursive=TRUE))
+ }
+ }
+ )
+
+setMethod(
+ 'c',
+ signature=signature(x='mifList'),
+ definition=function (x, ...) {
+ y <- list(...)
+ if (length(y)==0) {
+ x
+ } else {
+ p <- sapply(y,is,'mif')
+ pl <- sapply(y,is,'mifList')
+ if (any(!(p||pl)))
+ stop("cannot mix ",sQuote("mif"),
+ " and non-",sQuote("mif")," objects")
+ y[p] <- lapply(y[p],list)
+ y[pl] <- lapply(y[pl],as,"list")
+ new("mifList",c(as(x,"list"),y,recursive=TRUE))
+ }
+ }
+ )
+
+setMethod(
+ "[",
+ signature=signature(x="mifList"),
+ definition=function(x, i, ...) {
+ new('mifList',as(x,"list")[i])
+ }
+ )
+
+setMethod(
+ 'conv.rec',
+ signature=signature(object='mifList'),
+ definition=function (object, ...) {
+ lapply(object,conv.rec,...)
+ }
+ )
+
+setMethod(
+ "plot",
+ signature=signature(x='mifList'),
+ definition=function (x, y, ...) {
+ if (!missing(y)) {
+ y <- substitute(y)
+ warning(sQuote(y)," is ignored")
+ }
+ mif.diagnostics(x)
+ }
+ )
+
predvarplot.mif <- function (object, pars, type = 'l', mean = FALSE, ...) {
if (!is(object,'mif'))
stop("predvarplot error: ",sQuote("object")," must be of class ",sQuote("mif"),call.=FALSE)
@@ -112,10 +209,12 @@
}
compare.mif <- function (z) {
- ## assumes that x is a list of mifs with identical structure
- if (!is.list(z)) z <- list(z)
- if (!all(sapply(z,function(x)is(x,'mif'))))
- stop("compare.mif error: ",sQuote("z")," must be a mif object or a list of mif objects",call.=FALSE)
+ stop(sQuote("compare.mif")," has been deprecated in favor of ",
+ sQuote("plot"))
+}
+
+mif.diagnostics <- function (z) {
+ ## assumes that z is a list of mifs with identical structure
mar.multi <- c(0,5.1,0,2.1)
oma.multi <- c(6,0,5,0)
xx <- z[[1]]
Modified: pkg/pomp/R/pmcmc-methods.R
===================================================================
--- pkg/pomp/R/pmcmc-methods.R 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/R/pmcmc-methods.R 2014-06-25 17:38:58 UTC (rev 981)
@@ -9,7 +9,7 @@
signature=signature(object='pmcmc'),
function (object, pars, ...) {
if (missing(pars)) pars <- colnames(object at conv.rec)
- coda::mcmc(object at conv.rec[,pars,drop=FALSE])
+ coda::mcmc(object at conv.rec[,pars,drop=FALSE],...)
}
)
@@ -17,7 +17,9 @@
setMethod(
"plot",
signature=signature(x='pmcmc'),
- function (x, y = NULL, ...) {
+ function (x, y, ...) {
+ if (!missing(y))
+ warning(sQuote("y")," is ignored")
pmcmc.diagnostics(list(x))
}
)
@@ -96,6 +98,7 @@
}
)
+## extract the convergence records as a coda::mcmc.list object
setMethod(
'conv.rec',
signature=signature(object='pmcmcList'),
@@ -107,7 +110,9 @@
setMethod(
"plot",
signature=signature(x='pmcmcList'),
- definition=function (x, y = NULL, ...) {
+ definition=function (x, y, ...) {
+ if (!missing(y))
+ warning(sQuote("y")," is ignored")
pmcmc.diagnostics(x)
}
)
Modified: pkg/pomp/R/probe.R
===================================================================
--- pkg/pomp/R/probe.R 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/R/probe.R 2014-06-25 17:38:58 UTC (rev 981)
@@ -104,7 +104,7 @@
}
)
-probeplot.internal <- function (x, y, ...) {
+probeplot.internal <- function (x, ...) {
##function for plotting diagonal panels
diag.panel.hist <- function(x, ...) {
##plot a histogram for the simulations
@@ -170,9 +170,12 @@
}
}
-setMethod("plot","probed.pomp",
- function (x, y, ...) {
- probeplot.internal(x=x,y=y,...)
+setMethod("plot",
+ signature=signature(x="probed.pomp"),
+ definition=function (x, y, ...) {
+ if (!missing(y))
+ warning(sQuote("y")," is ignored")
+ probeplot.internal(x=x,...)
}
)
Modified: pkg/pomp/inst/NEWS
===================================================================
--- pkg/pomp/inst/NEWS 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/inst/NEWS 2014-06-25 17:38:58 UTC (rev 981)
@@ -1,5 +1,14 @@
_N_e_w_s _f_o_r _p_a_c_k_a_g_e '_p_o_m_p'
+_C_h_a_n_g_e_s _i_n '_p_o_m_p' _v_e_r_s_i_o_n _0._5_2-_1:
+
+ ? The new ?mifList? class facilitates approaches based on
+ multiple ?mif? runs. The ?c? method constructs ?mifList?s
+ from ?mif?s. The ?plot? method produces diagnostic plots.
+
+ ? ?compare.mif? is now deprecated in favor of ?plot? applied to
+ a ?mif? or ?mifList?.
+
_C_h_a_n_g_e_s _i_n '_p_o_m_p' _v_e_r_s_i_o_n _0._5_1-_3:
? ?transform? argument for ?pmcmc? and ?abc? has been removed.
Modified: pkg/pomp/inst/NEWS.Rd
===================================================================
--- pkg/pomp/inst/NEWS.Rd 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/inst/NEWS.Rd 2014-06-25 17:38:58 UTC (rev 981)
@@ -1,5 +1,13 @@
\name{NEWS}
\title{News for package `pomp'}
+\section{Changes in \pkg{pomp} version 0.52-1}{
+ \itemize{
+ \item The new \code{mifList} class facilitates approaches based on multiple \code{mif} runs.
+ The \code{c} method constructs \code{mifList}s from \code{mif}s.
+ The \code{plot} method produces diagnostic plots.
+ \item \code{compare.mif} is now deprecated in favor of \code{plot} applied to a \code{mif} or \code{mifList}.
+ }
+}
\section{Changes in \pkg{pomp} version 0.51-3}{
\itemize{
\item \code{transform} argument for \code{pmcmc} and \code{abc} has been removed.
Modified: pkg/pomp/man/abc-methods.Rd
===================================================================
--- pkg/pomp/man/abc-methods.Rd 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/man/abc-methods.Rd 2014-06-25 17:38:58 UTC (rev 981)
@@ -45,6 +45,9 @@
\code{conv.rec(object, pars)} returns the columns of the convergence-record matrix corresponding to the names in \code{pars}.
By default, all rows are returned.
}
+ \item{c}{
+ Concatenates \code{abc} objects into an \code{abcList}.
+ }
\item{plot}{
Diagnostic plots.
}
Modified: pkg/pomp/man/mif-methods.Rd
===================================================================
--- pkg/pomp/man/mif-methods.Rd 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/man/mif-methods.Rd 2014-06-25 17:38:58 UTC (rev 981)
@@ -6,22 +6,37 @@
\alias{conv.rec}
\alias{conv.rec,mif-method}
\alias{conv.rec-mif}
+\alias{conv.rec,mifList-method}
+\alias{conv.rec-mifList}
\alias{plot-mif}
\alias{plot,mif-method}
+\alias{plot-mifList}
+\alias{plot,mifList-method}
+\alias{mifList-class}
+\alias{c-mif}
+\alias{c,mif-method}
+\alias{c-mifList}
+\alias{c,mifList-method}
+\alias{[-mifList}
+\alias{[,mifList-method}
\alias{compare.mif}
\title{Methods of the "mif" class}
\description{Methods of the \code{mif} class.}
\usage{
\S4method{logLik}{mif}(object, \dots)
\S4method{conv.rec}{mif}(object, pars, transform = FALSE, \dots)
-\S4method{plot}{mif}(x, y = NULL, \dots)
+\S4method{conv.rec}{mifList}(object, \dots)
+\S4method{plot}{mif}(x, y, \dots)
+\S4method{plot}{mifList}(x, y, \dots)
+\S4method{c}{mif}(x, \dots, recursive = FALSE)
+\S4method{c}{mifList}(x, \dots, recursive = FALSE)
compare.mif(z)
}
\arguments{
\item{object}{The \code{mif} object.}
\item{pars}{Names of parameters.}
\item{x}{The \code{mif} object.}
- \item{y}{Ignored.}
+ \item{y, recursive}{Ignored.}
\item{z}{A \code{mif} object or list of \code{mif} objects.}
\item{transform}{
optional logical;
@@ -41,13 +56,15 @@
\item{logLik}{
Returns the value in the \code{loglik} slot.
}
- \item{compare.mif}{
- Given a \code{mif} object or a list of \code{mif} objects, \code{compare.mif} produces a set of diagnostic plots.
+ \item{c}{
+ Concatenates \code{mif} objects into an \code{mifList}.
}
\item{plot}{
Plots a series of diagnostic plots.
- When \code{x} is a \code{mif} object, \code{plot(x)} is equivalent to \code{compare.mif(list(x))}.
}
+ \item{compare.mif}{
+ Deprecated: use \code{plot} instead.
+ }
}
}
\author{Aaron A. King \email{kingaa at umich dot edu}}
Modified: pkg/pomp/man/pmcmc-methods.Rd
===================================================================
--- pkg/pomp/man/pmcmc-methods.Rd 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/man/pmcmc-methods.Rd 2014-06-25 17:38:58 UTC (rev 981)
@@ -24,7 +24,7 @@
\S4method{logLik}{pmcmc}(object, \dots)
\S4method{conv.rec}{pmcmc}(object, pars, \dots)
\S4method{conv.rec}{pmcmcList}(object, \dots)
-\S4method{plot}{pmcmc}(x, y = NULL, \dots)
+\S4method{plot}{pmcmc}(x, y, \dots)
\S4method{plot}{pmcmcList}(x, y, \dots)
\S4method{c}{pmcmc}(x, \dots, recursive = FALSE)
\S4method{c}{pmcmcList}(x, \dots, recursive = FALSE)
Modified: pkg/pomp/tests/ou2-mif-fp.R
===================================================================
--- pkg/pomp/tests/ou2-mif-fp.R 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/tests/ou2-mif-fp.R 2014-06-25 17:38:58 UTC (rev 981)
@@ -41,6 +41,6 @@
method="fp"
)
-compare.mif(list(mif1,mif2))
+plot(c(mif1,mif2))
dev.off()
Modified: pkg/pomp/tests/ou2-mif-fp.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-mif-fp.Rout.save 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/tests/ou2-mif-fp.Rout.save 2014-06-25 17:38:58 UTC (rev 981)
@@ -1,5 +1,5 @@
-R version 3.0.3 (2014-03-06) -- "Warm Puppy"
+R version 3.1.0 (2014-04-10) -- "Spring Dance"
Copyright (C) 2014 The R Foundation for Statistical Computing
Platform: x86_64-unknown-linux-gnu (64-bit)
@@ -20,6 +20,8 @@
Loading required package: subplex
Loading required package: nloptr
Loading required package: deSolve
+Loading required package: coda
+Loading required package: lattice
>
> pompExample(ou2)
newly created pomp object(s):
@@ -64,7 +66,7 @@
+ method="fp"
+ )
>
-> compare.mif(list(mif1,mif2))
+> plot(c(mif1,mif2))
>
> dev.off()
null device
@@ -72,4 +74,4 @@
>
> proc.time()
user system elapsed
- 19.269 0.064 19.562
+ 22.609 0.039 22.668
Modified: pkg/pomp/tests/ou2-mif.R
===================================================================
--- pkg/pomp/tests/ou2-mif.R 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/tests/ou2-mif.R 2014-06-25 17:38:58 UTC (rev 981)
@@ -49,9 +49,9 @@
pdf(file="ou2-mif.pdf")
plot(mif1)
-compare.mif(mif2)
-try(compare.mif(mif1,mif2))
-compare.mif(list(mif1,mif2))
+plot(mif2)
+try(plot(mif1,mif2))
+plot(c(mif1,mif2))
dev.off()
set.seed(33848585L)
Modified: pkg/pomp/tests/ou2-mif.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-mif.Rout.save 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/tests/ou2-mif.Rout.save 2014-06-25 17:38:58 UTC (rev 981)
@@ -1,5 +1,5 @@
-R version 3.0.3 (2014-03-06) -- "Warm Puppy"
+R version 3.1.0 (2014-04-10) -- "Spring Dance"
Copyright (C) 2014 The R Foundation for Statistical Computing
Platform: x86_64-unknown-linux-gnu (64-bit)
@@ -20,6 +20,8 @@
Loading required package: subplex
Loading required package: nloptr
Loading required package: deSolve
+Loading required package: coda
+Loading required package: lattice
>
> pompExample(ou2)
newly created pomp object(s):
@@ -85,10 +87,11 @@
>
> pdf(file="ou2-mif.pdf")
> plot(mif1)
-> compare.mif(mif2)
-> try(compare.mif(mif1,mif2))
-Error in compare.mif(mif1, mif2) : unused argument (mif2)
-> compare.mif(list(mif1,mif2))
+> plot(mif2)
+> try(plot(mif1,mif2))
+Warning message:
+In plot(mif1, mif2) : 'mif2' is ignored
+> plot(c(mif1,mif2))
> dev.off()
null device
1
@@ -282,4 +285,4 @@
>
> proc.time()
user system elapsed
- 11.828 0.036 12.014
+ 14.306 0.041 14.344
Modified: pkg/pomp/tests/ou2-mif2.R
===================================================================
--- pkg/pomp/tests/ou2-mif2.R 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/tests/ou2-mif2.R 2014-06-25 17:38:58 UTC (rev 981)
@@ -41,7 +41,7 @@
tol=1e-8
)
-compare.mif(list(mif1a,mif2a))
+plot(c(mif1a,mif2a))
set.seed(64857673L)
mif1b <- mif(ou2,Nmif=50,start=guess1,
@@ -91,11 +91,16 @@
)
mif2c <- continue(mif2c,Nmif=50)
-compare.mif(list(mif1b,mif2b))
+plot(c(mif1b,mif2b))
-compare.mif(list(mif1a,mif1b))
-compare.mif(list(mif2a,mif2b))
+plot(c(mif1a,mif1b))
+plot(c(mif2a,mif2b))
-compare.mif(list(mif1b,mif2c))
+plot(mfl1 <- c(mif1b,mif2c))
+mfl2 <- c(mfl1,mif2c)
+mfl3 <- c(mif2a,mfl1)
+
+try(c(mif2a,continue(mif2b,Nmif=1)))
+
dev.off()
Modified: pkg/pomp/tests/ou2-mif2.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-mif2.Rout.save 2014-06-23 14:13:43 UTC (rev 980)
+++ pkg/pomp/tests/ou2-mif2.Rout.save 2014-06-25 17:38:58 UTC (rev 981)
@@ -1,5 +1,5 @@
-R version 3.0.3 (2014-03-06) -- "Warm Puppy"
+R version 3.1.0 (2014-04-10) -- "Spring Dance"
Copyright (C) 2014 The R Foundation for Statistical Computing
Platform: x86_64-unknown-linux-gnu (64-bit)
@@ -20,6 +20,8 @@
Loading required package: subplex
Loading required package: nloptr
Loading required package: deSolve
+Loading required package: coda
+Loading required package: lattice
>
> pompExample(ou2)
newly created pomp object(s):
@@ -64,7 +66,7 @@
+ tol=1e-8
+ )
>
-> compare.mif(list(mif1a,mif2a))
+> plot(c(mif1a,mif2a))
>
> set.seed(64857673L)
> mif1b <- mif(ou2,Nmif=50,start=guess1,
@@ -117,17 +119,24 @@
+ )
> mif2c <- continue(mif2c,Nmif=50)
>
-> compare.mif(list(mif1b,mif2b))
+> plot(c(mif1b,mif2b))
>
-> compare.mif(list(mif1a,mif1b))
-> compare.mif(list(mif2a,mif2b))
+> plot(c(mif1a,mif1b))
+> plot(c(mif2a,mif2b))
>
-> compare.mif(list(mif1b,mif2c))
+> plot(mfl1 <- c(mif1b,mif2c))
>
+> mfl2 <- c(mfl1,mif2c)
+> mfl3 <- c(mif2a,mfl1)
+>
+> try(c(mif2a,continue(mif2b,Nmif=1)))
+Error in validObject(.Object) :
+ invalid class "mifList" object: error in 'c': to be combined, 'mif' objects must equal numbers of iterations
+>
> dev.off()
null device
1
>
> proc.time()
user system elapsed
- 50.335 0.068 50.772
+ 59.213 0.057 59.317
From noreply at r-forge.r-project.org Wed Jun 25 19:39:12 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 25 Jun 2014 19:39:12 +0200 (CEST)
Subject: [Pomp-commits] r982 - in pkg/pomp: R tests
Message-ID: <20140625173912.1FFD31811CE@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-25 19:39:11 +0200 (Wed, 25 Jun 2014)
New Revision: 982
Added:
pkg/pomp/tests/ou2-abc.R
pkg/pomp/tests/ou2-abc.Rout.save
Removed:
pkg/pomp/tests/abc.R
pkg/pomp/tests/abc.Rout.save
Modified:
pkg/pomp/R/abc-methods.R
pkg/pomp/R/pmcmc-methods.R
pkg/pomp/tests/ou2-pmcmc.R
pkg/pomp/tests/ou2-pmcmc.Rout.save
Log:
- fix bug in 'conv.rec' for 'abc' and 'pmcmc' lists
- rename 'tests/abc.R' -> 'tests/ou2-abc.R'
- add some tests for thinning and windowing 'conv.rec' output
Modified: pkg/pomp/R/abc-methods.R
===================================================================
--- pkg/pomp/R/abc-methods.R 2014-06-25 17:38:58 UTC (rev 981)
+++ pkg/pomp/R/abc-methods.R 2014-06-25 17:39:11 UTC (rev 982)
@@ -1,32 +1,5 @@
## this file contains short definitions of methods for the 'abc' class
-## extract the convergence record as an 'mcmc' object
-setMethod(
- 'conv.rec',
- 'abc',
- function (object, pars, ...) {
- if (missing(pars)) pars <- colnames(object at conv.rec)
- coda::mcmc(object at conv.rec[,pars,drop=FALSE],...)
- }
- )
-
-## plot abc object
-setMethod(
- "plot",
- "abc",
- function (x, y, pars, scatter = FALSE, ...) {
- ## if (missing(pars)) pars <- x at pars
- ## if (scatter) {
- ## pairs(as.matrix(conv.rec(x,pars)))
- ## } else {
- ## plot.ts(conv.rec(x,pars),xlab="iteration",...)
- ## }
- if (!missing(y))
- warning(sQuote("y")," is ignored")
- abc.diagnostics(c(x),pars=pars,scatter=scatter,...)
- }
- )
-
## abcList class
setClass(
'abcList',
@@ -100,21 +73,47 @@
}
)
+## extract the convergence record as an 'mcmc' object
+setMethod(
+ 'conv.rec',
+ 'abc',
+ function (object, pars, ...) {
+ if (missing(pars)) pars <- colnames(object at conv.rec)
+ coda::mcmc(object at conv.rec[,pars,drop=FALSE],...)
+ }
+ )
+
## extract the convergence record as an 'mcmc.list' object
setMethod(
'conv.rec',
signature=signature(object='abcList'),
definition=function (object, ...) {
- coda::mcmc.list(lapply(object,conv.rec,...))
+ f <- selectMethod("conv.rec","abc")
+ coda::mcmc.list(lapply(object,f,...))
}
)
+## plot abc object
setMethod(
"plot",
+ "abc",
+ function (x, y, pars, scatter = FALSE, ...) {
+ if (!missing(y)) {
+ y <- substitute(y)
+ warning(sQuote(y)," is ignored")
+ }
+ abc.diagnostics(c(x),pars=pars,scatter=scatter,...)
+ }
+ )
+
+setMethod(
+ "plot",
signature=signature(x='abcList'),
definition=function (x, y, ...) {
- if (!missing(y))
- warning(sQuote("y")," is ignored")
+ if (!missing(y)) {
+ y <- substitute(y)
+ warning(sQuote(y)," is ignored")
+ }
abc.diagnostics(x,...)
}
)
Modified: pkg/pomp/R/pmcmc-methods.R
===================================================================
--- pkg/pomp/R/pmcmc-methods.R 2014-06-25 17:38:58 UTC (rev 981)
+++ pkg/pomp/R/pmcmc-methods.R 2014-06-25 17:39:11 UTC (rev 982)
@@ -3,28 +3,6 @@
## extract the estimated log likelihood
setMethod('logLik','pmcmc',function(object,...)object at loglik)
-## extract the convergence record as a coda::mcmc object
-setMethod(
- 'conv.rec',
- signature=signature(object='pmcmc'),
- function (object, pars, ...) {
- if (missing(pars)) pars <- colnames(object at conv.rec)
- coda::mcmc(object at conv.rec[,pars,drop=FALSE],...)
- }
- )
-
-## plot pmcmc object
-setMethod(
- "plot",
- signature=signature(x='pmcmc'),
- function (x, y, ...) {
- if (!missing(y))
- warning(sQuote("y")," is ignored")
- pmcmc.diagnostics(list(x))
- }
- )
-
-
## pmcmcList class
setClass(
'pmcmcList',
@@ -98,21 +76,48 @@
}
)
+## extract the convergence record as a coda::mcmc object
+setMethod(
+ 'conv.rec',
+ signature=signature(object='pmcmc'),
+ function (object, pars, ...) {
+ if (missing(pars)) pars <- colnames(object at conv.rec)
+ coda::mcmc(object at conv.rec[,pars,drop=FALSE],...)
+ }
+ )
+
## extract the convergence records as a coda::mcmc.list object
setMethod(
'conv.rec',
signature=signature(object='pmcmcList'),
definition=function (object, ...) {
- coda::mcmc.list(lapply(object,conv.rec,...))
+ f <- selectMethod("conv.rec","pmcmc")
+ coda::mcmc.list(lapply(object,f,...))
}
)
+## plot pmcmc object
setMethod(
"plot",
+ signature=signature(x='pmcmc'),
+ function (x, y, ...) {
+ if (!missing(y)) {
+ y <- substitute(y)
+ warning(sQuote(y)," is ignored")
+ }
+ pmcmc.diagnostics(list(x))
+ }
+ )
+
+
+setMethod(
+ "plot",
signature=signature(x='pmcmcList'),
definition=function (x, y, ...) {
- if (!missing(y))
- warning(sQuote("y")," is ignored")
+ if (!missing(y)) {
+ y <- substitute(y)
+ warning(sQuote(y)," is ignored")
+ }
pmcmc.diagnostics(x)
}
)
Deleted: pkg/pomp/tests/abc.R
===================================================================
--- pkg/pomp/tests/abc.R 2014-06-25 17:38:58 UTC (rev 981)
+++ pkg/pomp/tests/abc.R 2014-06-25 17:39:11 UTC (rev 982)
@@ -1,103 +0,0 @@
-### OU2 test of abc for pomp
-
-library(pomp)
-pompExample(ou2)
-
-pdf(file='abc.pdf')
-
-set.seed(2079015564L)
-
-probes.good <- list(
- y1.mean=probe.mean(var="y1"),
- y2.mean=probe.mean(var="y2"),
- probe.acf(var="y1",lags=c(0,5)),
- probe.acf(var="y2",lags=c(0,5)),
- probe.ccf(vars=c("y1","y2"),lags=0)
- )
-psim <- probe(ou2,probes=probes.good,nsim=200)
-plot(psim)
-## why do simulations sometimes seem extreme with respect to these probes?
-
-scale.dat <- apply(psim$simvals,2,sd)
-
-po <- ou2
-
-abc1 <- abc(po,
- Nabc=10000,
- start=coef(ou2),
- pars=c("alpha.1","alpha.2"),
- probes=probes.good,
- scale=scale.dat,
- epsilon=1.7,
- rw.sd= c(alpha.1=0.01,alpha.2=0.01)
- )
-
-plot(abc1,scatter=TRUE)
-plot(abc1)
-
-## check how sticky the chain is:
-runs <- rle(as.vector(conv.rec(abc1)[, "alpha.1"]))
-hist(runs$lengths)
-mean(runs$length)
-
-abc2 <- abc(po,
- Nabc=2000,
- pars=c("alpha.1","alpha.2"),
- probes=probes.good,
- scale=scale.dat,
- epsilon=1,
- rw.sd= c(alpha.1=0.01,alpha.2=0.01)
- )
-plot(abc2)
-
-abc3 <- abc(po,
- Nabc=2000,
- probes=probes.good,
- scale=scale.dat,
- epsilon=2,
- rw.sd= c(alpha.1=0.01,alpha.2=0.01)
- )
-abc3 <- continue(abc3,Nabc=3000)
-plot(abc3)
-
-abc4 <- abc(probe(po,probes=probes.good,nsim=200),
- Nabc=2000,
- scale=scale.dat,
- epsilon=2,
- rw.sd= c(alpha.1=0.01,alpha.2=0.01)
- )
-plot(abc4)
-
-abc5 <- abc(abc4,Nabc=1000)
-plot(abc5)
-
-dprior6 <- function (params, log, ...) {
- ll <- sum(
- dnorm(
- x=params[c("alpha.1","alpha.2","alpha.3","alpha.4")],
- mean=c(0.8,-0.5,0.3,0.9),
- sd=5,
- log=TRUE
- )
- )
- if (log) ll else exp(ll)
-}
-
-abc6 <- abc(pomp(po,dprior=dprior6),
- Nabc=2000,
- pars=c("alpha.1","alpha.2"),
- probes=probes.good,
- scale=scale.dat,
- epsilon=1,
- rw.sd= c(alpha.1=0.01,alpha.2=0.01)
- )
-plot(abc6)
-
-try(abc7 <- c(abc2,abc3))
-plot(abc7 <- c(abc2,abc4))
-plot(abc7,scatter=TRUE)
-plot(conv.rec(c(abc2,abc4)))
-plot(conv.rec(c(abc7,abc6)))
-
-dev.off()
-
Deleted: pkg/pomp/tests/abc.Rout.save
===================================================================
--- pkg/pomp/tests/abc.Rout.save 2014-06-25 17:38:58 UTC (rev 981)
+++ pkg/pomp/tests/abc.Rout.save 2014-06-25 17:39:11 UTC (rev 982)
@@ -1,137 +0,0 @@
-
-R version 3.1.0 (2014-04-10) -- "Spring Dance"
-Copyright (C) 2014 The R Foundation for Statistical Computing
-Platform: x86_64-unknown-linux-gnu (64-bit)
-
-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.
-
-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.
-
-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.
-
-> ### OU2 test of abc for pomp
->
-> library(pomp)
-Loading required package: mvtnorm
-Loading required package: subplex
-Loading required package: nloptr
-Loading required package: deSolve
-Loading required package: coda
-Loading required package: lattice
-> pompExample(ou2)
-newly created pomp object(s):
- ou2
->
-> pdf(file='abc.pdf')
->
-> set.seed(2079015564L)
->
-> probes.good <- list(
-+ y1.mean=probe.mean(var="y1"),
-+ y2.mean=probe.mean(var="y2"),
-+ probe.acf(var="y1",lags=c(0,5)),
-+ probe.acf(var="y2",lags=c(0,5)),
-+ probe.ccf(vars=c("y1","y2"),lags=0)
-+ )
-> psim <- probe(ou2,probes=probes.good,nsim=200)
-> plot(psim)
-> ## why do simulations sometimes seem extreme with respect to these probes?
->
-> scale.dat <- apply(psim$simvals,2,sd)
->
-> po <- ou2
->
-> abc1 <- abc(po,
-+ Nabc=10000,
-+ start=coef(ou2),
-+ pars=c("alpha.1","alpha.2"),
-+ probes=probes.good,
-+ scale=scale.dat,
-+ epsilon=1.7,
-+ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
-+ )
->
-> plot(abc1,scatter=TRUE)
-> plot(abc1)
->
-> ## check how sticky the chain is:
-> runs <- rle(as.vector(conv.rec(abc1)[, "alpha.1"]))
-> hist(runs$lengths)
-> mean(runs$length)
-[1] 6.949965
->
-> abc2 <- abc(po,
-+ Nabc=2000,
-+ pars=c("alpha.1","alpha.2"),
-+ probes=probes.good,
-+ scale=scale.dat,
-+ epsilon=1,
-+ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
-+ )
-> plot(abc2)
->
-> abc3 <- abc(po,
-+ Nabc=2000,
-+ probes=probes.good,
-+ scale=scale.dat,
-+ epsilon=2,
-+ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
-+ )
-> abc3 <- continue(abc3,Nabc=3000)
-> plot(abc3)
->
-> abc4 <- abc(probe(po,probes=probes.good,nsim=200),
-+ Nabc=2000,
-+ scale=scale.dat,
-+ epsilon=2,
-+ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
-+ )
-> plot(abc4)
->
-> abc5 <- abc(abc4,Nabc=1000)
-> plot(abc5)
->
-> dprior6 <- function (params, log, ...) {
-+ ll <- sum(
-+ dnorm(
-+ x=params[c("alpha.1","alpha.2","alpha.3","alpha.4")],
-+ mean=c(0.8,-0.5,0.3,0.9),
-+ sd=5,
-+ log=TRUE
-+ )
-+ )
-+ if (log) ll else exp(ll)
-+ }
->
-> abc6 <- abc(pomp(po,dprior=dprior6),
-+ Nabc=2000,
-+ pars=c("alpha.1","alpha.2"),
-+ probes=probes.good,
-+ scale=scale.dat,
-+ epsilon=1,
-+ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
-+ )
-> plot(abc6)
->
-> try(abc7 <- c(abc2,abc3))
-Error in validObject(.Object) :
- invalid class "abcList" object: error in 'c': to be combined, 'abc' objects must have chains of equal length
-> plot(abc7 <- c(abc2,abc4))
-> plot(abc7,scatter=TRUE)
-> plot(conv.rec(c(abc2,abc4)))
-> plot(conv.rec(c(abc7,abc6)))
->
-> dev.off()
-null device
- 1
->
->
-> proc.time()
- user system elapsed
- 11.122 0.067 11.192
Copied: pkg/pomp/tests/ou2-abc.R (from rev 981, pkg/pomp/tests/abc.R)
===================================================================
--- pkg/pomp/tests/ou2-abc.R (rev 0)
+++ pkg/pomp/tests/ou2-abc.R 2014-06-25 17:39:11 UTC (rev 982)
@@ -0,0 +1,103 @@
+### OU2 test of abc for pomp
+
+library(pomp)
+pompExample(ou2)
+
+pdf(file='abc.pdf')
+
+set.seed(2079015564L)
+
+probes.good <- list(
+ y1.mean=probe.mean(var="y1"),
+ y2.mean=probe.mean(var="y2"),
+ probe.acf(var="y1",lags=c(0,5)),
+ probe.acf(var="y2",lags=c(0,5)),
+ probe.ccf(vars=c("y1","y2"),lags=0)
+ )
+psim <- probe(ou2,probes=probes.good,nsim=200)
+plot(psim)
+## why do simulations sometimes seem extreme with respect to these probes?
+
+scale.dat <- apply(psim$simvals,2,sd)
+
+po <- ou2
+
+abc1 <- abc(po,
+ Nabc=10000,
+ start=coef(ou2),
+ pars=c("alpha.1","alpha.2"),
+ probes=probes.good,
+ scale=scale.dat,
+ epsilon=1.7,
+ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
+ )
+
+plot(abc1,scatter=TRUE)
+plot(abc1)
+
+## check how sticky the chain is:
+runs <- rle(as.vector(conv.rec(abc1)[, "alpha.1"]))
+hist(runs$lengths)
+mean(runs$length)
+
+abc2 <- abc(po,
+ Nabc=2000,
+ pars=c("alpha.1","alpha.2"),
+ probes=probes.good,
+ scale=scale.dat,
+ epsilon=1,
+ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
+ )
+plot(abc2)
+
+abc3 <- abc(po,
+ Nabc=2000,
+ probes=probes.good,
+ scale=scale.dat,
+ epsilon=2,
+ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
+ )
+abc3 <- continue(abc3,Nabc=3000)
+plot(abc3)
+
+abc4 <- abc(probe(po,probes=probes.good,nsim=200),
+ Nabc=2000,
+ scale=scale.dat,
+ epsilon=2,
+ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
+ )
+plot(abc4)
+
+abc5 <- abc(abc4,Nabc=1000)
+plot(abc5)
+
+dprior6 <- function (params, log, ...) {
+ ll <- sum(
+ dnorm(
+ x=params[c("alpha.1","alpha.2","alpha.3","alpha.4")],
+ mean=c(0.8,-0.5,0.3,0.9),
+ sd=5,
+ log=TRUE
+ )
+ )
+ if (log) ll else exp(ll)
+}
+
+abc6 <- abc(pomp(po,dprior=dprior6),
+ Nabc=2000,
+ pars=c("alpha.1","alpha.2"),
+ probes=probes.good,
+ scale=scale.dat,
+ epsilon=1,
+ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
+ )
+plot(abc6)
+
+try(abc7 <- c(abc2,abc3))
+plot(abc7 <- c(abc2,abc4))
+plot(abc7,scatter=TRUE)
+plot(conv.rec(c(abc2,abc4)))
+plot(conv.rec(c(abc7,abc6),thin=10,start=5000))
+
+dev.off()
+
Copied: pkg/pomp/tests/ou2-abc.Rout.save (from rev 981, pkg/pomp/tests/abc.Rout.save)
===================================================================
--- pkg/pomp/tests/ou2-abc.Rout.save (rev 0)
+++ pkg/pomp/tests/ou2-abc.Rout.save 2014-06-25 17:39:11 UTC (rev 982)
@@ -0,0 +1,137 @@
+
+R version 3.1.0 (2014-04-10) -- "Spring Dance"
+Copyright (C) 2014 The R Foundation for Statistical Computing
+Platform: x86_64-unknown-linux-gnu (64-bit)
+
+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.
+
+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.
+
+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.
+
+> ### OU2 test of abc for pomp
+>
+> library(pomp)
+Loading required package: mvtnorm
+Loading required package: subplex
+Loading required package: nloptr
+Loading required package: deSolve
+Loading required package: coda
+Loading required package: lattice
+> pompExample(ou2)
+newly created pomp object(s):
+ ou2
+>
+> pdf(file='abc.pdf')
+>
+> set.seed(2079015564L)
+>
+> probes.good <- list(
++ y1.mean=probe.mean(var="y1"),
++ y2.mean=probe.mean(var="y2"),
++ probe.acf(var="y1",lags=c(0,5)),
++ probe.acf(var="y2",lags=c(0,5)),
++ probe.ccf(vars=c("y1","y2"),lags=0)
++ )
+> psim <- probe(ou2,probes=probes.good,nsim=200)
+> plot(psim)
+> ## why do simulations sometimes seem extreme with respect to these probes?
+>
+> scale.dat <- apply(psim$simvals,2,sd)
+>
+> po <- ou2
+>
+> abc1 <- abc(po,
++ Nabc=10000,
++ start=coef(ou2),
++ pars=c("alpha.1","alpha.2"),
++ probes=probes.good,
++ scale=scale.dat,
++ epsilon=1.7,
++ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
++ )
+>
+> plot(abc1,scatter=TRUE)
+> plot(abc1)
+>
+> ## check how sticky the chain is:
+> runs <- rle(as.vector(conv.rec(abc1)[, "alpha.1"]))
+> hist(runs$lengths)
+> mean(runs$length)
+[1] 6.949965
+>
+> abc2 <- abc(po,
++ Nabc=2000,
++ pars=c("alpha.1","alpha.2"),
++ probes=probes.good,
++ scale=scale.dat,
++ epsilon=1,
++ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
++ )
+> plot(abc2)
+>
+> abc3 <- abc(po,
++ Nabc=2000,
++ probes=probes.good,
++ scale=scale.dat,
++ epsilon=2,
++ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
++ )
+> abc3 <- continue(abc3,Nabc=3000)
+> plot(abc3)
+>
+> abc4 <- abc(probe(po,probes=probes.good,nsim=200),
++ Nabc=2000,
++ scale=scale.dat,
++ epsilon=2,
++ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
++ )
+> plot(abc4)
+>
+> abc5 <- abc(abc4,Nabc=1000)
+> plot(abc5)
+>
+> dprior6 <- function (params, log, ...) {
++ ll <- sum(
++ dnorm(
++ x=params[c("alpha.1","alpha.2","alpha.3","alpha.4")],
++ mean=c(0.8,-0.5,0.3,0.9),
++ sd=5,
++ log=TRUE
++ )
++ )
++ if (log) ll else exp(ll)
++ }
+>
+> abc6 <- abc(pomp(po,dprior=dprior6),
++ Nabc=2000,
++ pars=c("alpha.1","alpha.2"),
++ probes=probes.good,
++ scale=scale.dat,
++ epsilon=1,
++ rw.sd= c(alpha.1=0.01,alpha.2=0.01)
++ )
+> plot(abc6)
+>
+> try(abc7 <- c(abc2,abc3))
+Error in validObject(.Object) :
+ invalid class "abcList" object: error in 'c': to be combined, 'abc' objects must have chains of equal length
+> plot(abc7 <- c(abc2,abc4))
+> plot(abc7,scatter=TRUE)
+> plot(conv.rec(c(abc2,abc4)))
+> plot(conv.rec(c(abc7,abc6),thin=10,start=5000))
+>
+> dev.off()
+null device
+ 1
+>
+>
+> proc.time()
+ user system elapsed
+ 9.980 0.064 10.288
Modified: pkg/pomp/tests/ou2-pmcmc.R
===================================================================
--- pkg/pomp/tests/ou2-pmcmc.R 2014-06-25 17:38:58 UTC (rev 981)
+++ pkg/pomp/tests/ou2-pmcmc.R 2014-06-25 17:39:11 UTC (rev 982)
@@ -76,7 +76,7 @@
plot(ff <- c(ff,f5))
plot(conv.rec(c(f2,ff),c("alpha.2","alpha.3")))
plot(conv.rec(ff[2],c("alpha.2")))
-plot(conv.rec(ff[2:3],c("alpha.3")))
+plot(conv.rec(ff[2:3],c("alpha.3"),thin=3,start=2))
plot(conv.rec(ff[[3]],c("alpha.3")))
dev.off()
Modified: pkg/pomp/tests/ou2-pmcmc.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-pmcmc.Rout.save 2014-06-25 17:38:58 UTC (rev 981)
+++ pkg/pomp/tests/ou2-pmcmc.Rout.save 2014-06-25 17:39:11 UTC (rev 982)
@@ -107,7 +107,7 @@
> plot(ff <- c(ff,f5))
> plot(conv.rec(c(f2,ff),c("alpha.2","alpha.3")))
> plot(conv.rec(ff[2],c("alpha.2")))
-> plot(conv.rec(ff[2:3],c("alpha.3")))
+> plot(conv.rec(ff[2:3],c("alpha.3"),thin=3,start=2))
> plot(conv.rec(ff[[3]],c("alpha.3")))
>
> dev.off()
@@ -117,4 +117,4 @@
>
> proc.time()
user system elapsed
- 23.369 0.040 23.847
+ 23.325 0.088 23.646
From noreply at r-forge.r-project.org Wed Jun 25 19:39:18 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 25 Jun 2014 19:39:18 +0200 (CEST)
Subject: [Pomp-commits] r983 - in pkg/pomp: R tests
Message-ID: <20140625173918.A0C721811CE@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-25 19:39:18 +0200 (Wed, 25 Jun 2014)
New Revision: 983
Modified:
pkg/pomp/R/abc-methods.R
pkg/pomp/R/pmcmc-methods.R
pkg/pomp/tests/ou2-abc.R
pkg/pomp/tests/ou2-abc.Rout.save
pkg/pomp/tests/ou2-pmcmc.R
pkg/pomp/tests/ou2-pmcmc.Rout.save
Log:
- fix problems with 'conv.rec' on 'abc' and 'pmcmc' objects
Modified: pkg/pomp/R/abc-methods.R
===================================================================
--- pkg/pomp/R/abc-methods.R 2014-06-25 17:39:11 UTC (rev 982)
+++ pkg/pomp/R/abc-methods.R 2014-06-25 17:39:18 UTC (rev 983)
@@ -79,7 +79,7 @@
'abc',
function (object, pars, ...) {
if (missing(pars)) pars <- colnames(object at conv.rec)
- coda::mcmc(object at conv.rec[,pars,drop=FALSE],...)
+ coda::mcmc(object at conv.rec[,pars,drop=FALSE])
}
)
Modified: pkg/pomp/R/pmcmc-methods.R
===================================================================
--- pkg/pomp/R/pmcmc-methods.R 2014-06-25 17:39:11 UTC (rev 982)
+++ pkg/pomp/R/pmcmc-methods.R 2014-06-25 17:39:18 UTC (rev 983)
@@ -82,7 +82,7 @@
signature=signature(object='pmcmc'),
function (object, pars, ...) {
if (missing(pars)) pars <- colnames(object at conv.rec)
- coda::mcmc(object at conv.rec[,pars,drop=FALSE],...)
+ coda::mcmc(object at conv.rec[,pars,drop=FALSE])
}
)
Modified: pkg/pomp/tests/ou2-abc.R
===================================================================
--- pkg/pomp/tests/ou2-abc.R 2014-06-25 17:39:11 UTC (rev 982)
+++ pkg/pomp/tests/ou2-abc.R 2014-06-25 17:39:18 UTC (rev 983)
@@ -3,7 +3,7 @@
library(pomp)
pompExample(ou2)
-pdf(file='abc.pdf')
+pdf(file='ou2-abc.pdf')
set.seed(2079015564L)
@@ -97,7 +97,8 @@
plot(abc7 <- c(abc2,abc4))
plot(abc7,scatter=TRUE)
plot(conv.rec(c(abc2,abc4)))
-plot(conv.rec(c(abc7,abc6),thin=10,start=5000))
+plot(conv.rec(c(abc7,abc6)))
+plot(window(conv.rec(c(abc7,abc6),c("alpha.1","alpha.2")),thin=20,start=1000))
dev.off()
Modified: pkg/pomp/tests/ou2-abc.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-abc.Rout.save 2014-06-25 17:39:11 UTC (rev 982)
+++ pkg/pomp/tests/ou2-abc.Rout.save 2014-06-25 17:39:18 UTC (rev 983)
@@ -28,7 +28,7 @@
newly created pomp object(s):
ou2
>
-> pdf(file='abc.pdf')
+> pdf(file='ou2-abc.pdf')
>
> set.seed(2079015564L)
>
@@ -125,7 +125,8 @@
> plot(abc7 <- c(abc2,abc4))
> plot(abc7,scatter=TRUE)
> plot(conv.rec(c(abc2,abc4)))
-> plot(conv.rec(c(abc7,abc6),thin=10,start=5000))
+> plot(conv.rec(c(abc7,abc6)))
+> plot(window(conv.rec(c(abc7,abc6),c("alpha.1","alpha.2")),thin=20,start=1000))
>
> dev.off()
null device
@@ -134,4 +135,4 @@
>
> proc.time()
user system elapsed
- 9.980 0.064 10.288
+ 9.604 0.052 9.963
Modified: pkg/pomp/tests/ou2-pmcmc.R
===================================================================
--- pkg/pomp/tests/ou2-pmcmc.R 2014-06-25 17:39:11 UTC (rev 982)
+++ pkg/pomp/tests/ou2-pmcmc.R 2014-06-25 17:39:18 UTC (rev 983)
@@ -76,7 +76,8 @@
plot(ff <- c(ff,f5))
plot(conv.rec(c(f2,ff),c("alpha.2","alpha.3")))
plot(conv.rec(ff[2],c("alpha.2")))
-plot(conv.rec(ff[2:3],c("alpha.3"),thin=3,start=2))
+plot(conv.rec(ff[2:3],c("alpha.3")))
+plot(window(conv.rec(ff[2:3],c("alpha.3")),thin=3,start=2))
plot(conv.rec(ff[[3]],c("alpha.3")))
dev.off()
Modified: pkg/pomp/tests/ou2-pmcmc.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-pmcmc.Rout.save 2014-06-25 17:39:11 UTC (rev 982)
+++ pkg/pomp/tests/ou2-pmcmc.Rout.save 2014-06-25 17:39:18 UTC (rev 983)
@@ -107,7 +107,8 @@
> plot(ff <- c(ff,f5))
> plot(conv.rec(c(f2,ff),c("alpha.2","alpha.3")))
> plot(conv.rec(ff[2],c("alpha.2")))
-> plot(conv.rec(ff[2:3],c("alpha.3"),thin=3,start=2))
+> plot(conv.rec(ff[2:3],c("alpha.3")))
+> plot(window(conv.rec(ff[2:3],c("alpha.3")),thin=3,start=2))
> plot(conv.rec(ff[[3]],c("alpha.3")))
>
> dev.off()
@@ -117,4 +118,4 @@
>
> proc.time()
user system elapsed
- 23.325 0.088 23.646
+ 24.093 0.136 24.494
From noreply at r-forge.r-project.org Wed Jun 25 19:50:18 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 25 Jun 2014 19:50:18 +0200 (CEST)
Subject: [Pomp-commits] r984 - in www: content vignettes
Message-ID: <20140625175019.0BF721873C7@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-25 19:50:18 +0200 (Wed, 25 Jun 2014)
New Revision: 984
Modified:
www/content/NEWS.html
www/vignettes/advanced_topics_in_pomp.pdf
www/vignettes/intro_to_pomp.Rnw
www/vignettes/intro_to_pomp.pdf
www/vignettes/pomp.pdf
Log:
- update the website
Modified: www/content/NEWS.html
===================================================================
--- www/content/NEWS.html 2014-06-25 17:39:18 UTC (rev 983)
+++ www/content/NEWS.html 2014-06-25 17:50:18 UTC (rev 984)
@@ -8,6 +8,21 @@
News for package ‘pomp’
+Changes in pomp version 0.52-1
+
+
+
+ The new mifList
class facilitates approaches based on multiple mif
runs.
+The c
method constructs mifList
s from mif
s.
+The plot
method produces diagnostic plots.
+
+
+-
compare.mif
is now deprecated in favor of plot
applied to a mif
or mifList
.
+
+
+
+
+
Changes in pomp version 0.51-3
Modified: www/vignettes/advanced_topics_in_pomp.pdf
===================================================================
(Binary files differ)
Modified: www/vignettes/intro_to_pomp.Rnw
===================================================================
--- www/vignettes/intro_to_pomp.Rnw 2014-06-25 17:39:18 UTC (rev 983)
+++ www/vignettes/intro_to_pomp.Rnw 2014-06-25 17:50:18 UTC (rev 984)
@@ -823,7 +823,7 @@
@
\caption{
Convergence plots can be used to help diagnose convergence of the iterated filtering algorithm.
- This shows part of the output of \code{compare.mif(mf)}.
+ This shows part of the output of \code{plot(mf)}.
}
\label{fig:convplot}
\end{figure}
Modified: www/vignettes/intro_to_pomp.pdf
===================================================================
(Binary files differ)
Modified: www/vignettes/pomp.pdf
===================================================================
(Binary files differ)
From noreply at r-forge.r-project.org Fri Jun 27 21:48:02 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Fri, 27 Jun 2014 21:48:02 +0200 (CEST)
Subject: [Pomp-commits] r985 - in pkg: . pomp pomp/R pomp/inst pomp/man
pomp/tests
Message-ID: <20140627194802.E8F14184C5F@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-27 21:48:02 +0200 (Fri, 27 Jun 2014)
New Revision: 985
Modified:
pkg/Makefile
pkg/pomp/DESCRIPTION
pkg/pomp/NAMESPACE
pkg/pomp/R/generics.R
pkg/pomp/R/nlf-funcs.R
pkg/pomp/R/nlf-objfun.R
pkg/pomp/R/nlf.R
pkg/pomp/inst/NEWS
pkg/pomp/inst/NEWS.Rd
pkg/pomp/man/mif.Rd
pkg/pomp/man/nlf.Rd
pkg/pomp/tests/ou2-nlf.R
pkg/pomp/tests/ou2-nlf.Rout.save
Log:
- introduce new 'nlfd.pomp' class
- 'nlf' is now an S4 method
- improve the 'cran' build methods in the Makefile
Modified: pkg/Makefile
===================================================================
--- pkg/Makefile 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/Makefile 2014-06-27 19:48:02 UTC (rev 985)
@@ -63,9 +63,9 @@
$(TOUCH) $@
%.cransrc:
- $(RM) -r cran
mkdir -p cran
- svn export $* cran/$*
+ $(RM) -r cran/$*
+ git archive --format=tar master $* | (cd cran; tar -xf -)
$(RM) -r cran/$*/tests
$(TOUCH) $@
Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/pomp/DESCRIPTION 2014-06-27 19:48:02 UTC (rev 985)
@@ -1,8 +1,8 @@
Package: pomp
Type: Package
Title: Statistical inference for partially observed Markov processes
-Version: 0.52-1
-Date: 2014-06-26
+Version: 0.53-1
+Date: 2014-06-27
Authors at R: c(person(given=c("Aaron","A."),family="King",
role=c("aut","cre"),email="kingaa at umich.edu"),
person(given=c("Edward","L."),family="Ionides",role=c("aut")),
Modified: pkg/pomp/NAMESPACE
===================================================================
--- pkg/pomp/NAMESPACE 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/pomp/NAMESPACE 2014-06-27 19:48:02 UTC (rev 985)
@@ -46,6 +46,7 @@
mif,mifList,
pmcmc,pmcmcList,
traj.matched.pomp,
+ nlfd.pomp,
probed.pomp,probe.matched.pomp,
spect.pomp,spect.matched.pomp,
abc,abcList,
@@ -63,7 +64,7 @@
eff.sample.size,cond.logLik,
particles,mif,continue,states,trajectory,
pred.mean,pred.var,filter.mean,conv.rec,
- bsmc,pmcmc,abc,
+ bsmc,pmcmc,abc,nlf,
traj.match.objfun,
probe.match.objfun,
spect,probe,probe.match,
@@ -89,7 +90,6 @@
bspline.basis,
periodic.bspline.basis,
compare.mif,
- nlf,
parmat,
logmeanexp,
probe.mean,
Modified: pkg/pomp/R/generics.R
===================================================================
--- pkg/pomp/R/generics.R 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/pomp/R/generics.R 2014-06-27 19:48:02 UTC (rev 985)
@@ -66,6 +66,9 @@
## particle Markov chain Monte Carlo (PMCMC)
setGeneric('pmcmc',function(object,...)standardGeneric("pmcmc"))
+## nonlinear forecasting
+setGeneric('nlf',function(object,...)standardGeneric("nlf"))
+
## iterated filtering
setGeneric('mif',function(object,...)standardGeneric("mif"))
## generate new particles
Modified: pkg/pomp/R/nlf-funcs.R
===================================================================
--- pkg/pomp/R/nlf-funcs.R 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/pomp/R/nlf-funcs.R 2014-06-27 19:48:02 UTC (rev 985)
@@ -81,7 +81,7 @@
ncol.B <- ncol(B)
Tmat <- matrix(0,nrow(A),ncol.A*ncol.B)
for (i in seq_len(ncol.A)) {
- start=(i-1)*ncol.B
+ start <- (i-1)*ncol.B
for (j in seq_len(ncol.B)) {
Tmat[,start+j] <- A[,i]*B[,j]
}
Modified: pkg/pomp/R/nlf-objfun.R
===================================================================
--- pkg/pomp/R/nlf-objfun.R 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/pomp/R/nlf-objfun.R 2014-06-27 19:48:02 UTC (rev 985)
@@ -1,6 +1,6 @@
-NLF.LQL <- function (params.fitted, object, params, par.index, transform.params = FALSE,
- times, t0, lags, period, tensor, seed = NULL, transform = identity,
- nrbf = 4, verbose = FALSE,
+NLF.LQL <- function (params.fitted, object, params, par.index, transform = FALSE,
+ times, t0, lags, period, tensor, seed = NULL,
+ transform.data = identity, nrbf = 4, verbose = FALSE,
bootstrap = FALSE, bootsamp = NULL) {
###>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
@@ -9,16 +9,14 @@
### so a large NEGATIVE value is used to flag bad parameters
###>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- transform.params <- as.logical(transform.params)
+ transform <- as.logical(transform)
FAILED = -99999999999
params[par.index] <- params.fitted
- if (transform.params)
+ if (transform)
params <- partrans(object,params,dir="forward")
- ## Need to extract number of state variables (nvar) from pomp object
- ## Need to include simulation times in problem specification
## Evaluates the NLF objective function given a POMP object.
## Version 0.1, 3 Dec. 2007, Bruce E. Kendall & Stephen P. Ellner
## Version 0.2, May 2008, Stephen P. Ellner
@@ -31,6 +29,7 @@
)
if (inherits(y,"try-error"))
stop(sQuote("NLF.LQL")," reports: error in simulation")
+
## Test whether the model time series is valid
if (!all(is.finite(y))) return(FAILED)
@@ -38,8 +37,8 @@
dim=c(nrow(data.ts),length(times)),
dimnames=list(rownames(data.ts),NULL)
)
- model.ts[,] <- apply(y[,1,,drop=FALSE],c(2,3),transform)
- data.ts[,] <- apply(data.ts,2,transform)
+ model.ts[,] <- apply(y[,1,,drop=FALSE],c(2,3),transform.data)
+ data.ts[,] <- apply(data.ts,2,transform.data)
LQL <- try(
NLF.guts(
Modified: pkg/pomp/R/nlf.R
===================================================================
--- pkg/pomp/R/nlf.R 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/pomp/R/nlf.R 2014-06-27 19:48:02 UTC (rev 985)
@@ -1,60 +1,78 @@
-nlf <- function (object, start, est, lags,
- period = NA, tensor = FALSE,
- nconverge = 1000, nasymp = 1000,
- seed = 1066, transform = identity,
- nrbf = 4, method = "subplex",
- skip.se = FALSE, verbose = FALSE, gr = NULL,
- bootstrap = FALSE, bootsamp = NULL,
- lql.frac = 0.1, se.par.frac = 0.1,
- eval.only = FALSE, transform.params = FALSE, ...) {
+## Fit a POMP object using NLF
+## v. 0.1, 3 Dec. 2007
+## by Bruce Kendall & Steve Ellner
+##
+## v. 0.2, 30 May 2008, by Steve Ellner
+## Adds automatic Wald asymptotic standard errors and the
+## capability for moving-blocks bootstrap standard errors.
+## Quadratic regression near optimum used to select increments
+## for finite-difference approximations to gradient and Hessian
+##
+## v 1.0, 19 June 2008 by Steve Ellner and Aaron King
+## adds capacity to fit models with periodically time-varying parameters
+## of known period and improves the compatibility with the standard for pomp objects
- ## Fit a POMP object using NLF
- ## v. 0.1, 3 Dec. 2007
- ## by Bruce Kendall & Steve Ellner
- ##
- ## v. 0.2, 30 May 2008, by Steve Ellner
- ## Adds automatic Wald asymptotic standard errors and the
- ## capability for moving-blocks bootstrap standard errors.
- ## Quadratic regression near optimum used to select increments
- ## for finite-difference approximations to gradient and Hessian
- ##
- ## v 1.0, 19 June 2008 by Steve Ellner and Aaron King
- ## adds capacity to fit models with periodically time-varying parameters
- ## of known period and improves the compatibility with the standard for pomp objects
+setClass("nlfd.pomp",
+ contains="pomp",
+ slots=c(
+ transform = "logical",
+ transform.data = "function",
+ est = 'character',
+ lags="integer",
+ nconverge = 'integer',
+ nasymp = 'integer',
+ seed="integer",
+ period="numeric",
+ tensor="logical",
+ nrbf="integer",
+ method="character",
+ lql.frac="numeric",
+ se.par.frac="numeric",
+ Qhat="matrix",
+ se="numeric",
+ logql="numeric"
+ ),
+ prototype=prototype(
+ transform=FALSE,
+ transform.data=identity,
+ est=character(0),
+ lags=integer(0),
+ nconverge=0L,
+ nasymp=0L,
+ seed=0L,
+ period=as.numeric(NA),
+ tensor=FALSE,
+ nrbf=4L,
+ method=character(0),
+ lql.frac=0.1,
+ se.par.frac=0.1,
+ Qhat=matrix(NA,0,0),
+ se=numeric(0),
+ logql=as.numeric(NA)
+ )
+ )
- if (!is(object,'pomp'))
- stop("'object' must be a 'pomp' object")
-
- transform <- match.fun(transform)
-
- if (eval.only) est <- 1L
-
+nlf.internal <- function (object, start, est, lags, period, tensor,
+ nconverge, nasymp, seed, transform,
+ nrbf, method, skip.se, verbose,
+ bootstrap, bootsamp, lql.frac, se.par.frac,
+ eval.only, transform.data, ...)
+{
+
+ if (eval.only) est <- character(0)
if (missing(start)) start <- coef(object)
-
- transform.params <- as.logical(transform.params)
- if (transform.params)
+ if (transform)
params <- partrans(object,start,dir="inverse")
else
params <- start
- if (is.character(est)) {
- if (!all(est%in%names(params)))
- stop("parameters named in ",sQuote("est")," must exist in ",sQuote("start"))
- par.index <- which(names(params)%in%est)
- } else if (is.numeric(est)) {
- est <- as.integer(est)
- if (any((est<1)|(est>length(params))))
- stop("indices in ",sQuote("est")," are not appropriate")
- par.index <- est
- }
-
+ par.index <- which(names(params)%in%est)
+ if (length(est)==0) par.index <- integer(0)
guess <- params[par.index]
- lql.frac <- as.numeric(lql.frac)
if ((lql.frac<=0)||(lql.frac>=1))
stop(sQuote("lql.frac")," must be in (0,1)")
- se.par.frac <- as.numeric(se.par.frac)
if ((se.par.frac<=0)||(se.par.frac>=1))
stop(sQuote("se.par.frac")," must be in (0,1)")
@@ -79,88 +97,93 @@
object=object,
params=params,
par.index=par.index,
- transform.params=transform.params,
+ transform=transform,
times=times,
t0=t0,
lags=lags,
period=period,
tensor=tensor,
seed=seed,
- transform=transform,
+ transform.data=transform.data,
nrbf=nrbf,
verbose=verbose,
bootstrap=bootstrap,
bootsamp=bootsamp
)
- return(-val)
- }
-
- if (method == 'subplex') {
- opt <- subplex(
+ opt <- list(params=params,value=val)
+ } else {
+ if (method == 'subplex') {
+ opt <- subplex(
+ par=guess,
+ fn=nlf.objfun,
+ object=object,
+ params=params,
+ par.index=par.index,
+ transform=transform,
+ times=times,
+ t0=t0,
+ lags=lags,
+ period=period,
+ tensor=tensor,
+ seed=seed,
+ transform.data=transform.data,
+ nrbf=nrbf,
+ verbose=verbose,
+ bootstrap=bootstrap,
+ bootsamp=bootsamp,
+ control=list(...)
+ )
+ } else {
+ opt <- optim(
par=guess,
fn=nlf.objfun,
+ gr=NULL,
+ method=method,
object=object,
params=params,
par.index=par.index,
- transform.params=transform.params,
+ transform=transform,
times=times,
t0=t0,
lags=lags,
period=period,
tensor=tensor,
seed=seed,
- transform=transform,
+ transform.data=transform.data,
nrbf=nrbf,
verbose=verbose,
bootstrap=bootstrap,
bootsamp=bootsamp,
control=list(...)
- )
- } else {
- opt <- optim(
- par=guess,
- fn=nlf.objfun,
- gr=gr,
- method=method,
- object=object,
- params=params,
- par.index=par.index,
- transform.params=transform.params,
- times=times,
- t0=t0,
- lags=lags,
- period=period,
- tensor=tensor,
- seed=seed,
- transform=transform,
- nrbf=nrbf,
- verbose=verbose,
- bootstrap=bootstrap,
- bootsamp=bootsamp,
- control=list(...)
- )
+ )
+ }
+
+ params[par.index] <- opt$par
+ opt$params <- if (transform) partrans(object,params,dir="forward") else params
+
}
- opt$est <- est
- opt$value <- -opt$value
- params[par.index] <- opt$par
- opt$params <- if (transform.params) partrans(object,params,dir="forward") else params
- opt$par <- NULL
+ opt$Qhat <- matrix(NA,0,0)
+ opt$se <- numeric(0)
+
+ ## compute estimated Variance-Covariance matrix of fitted parameters
+ fitted <- params[par.index]
+ nfitted <- length(fitted)
- if (!skip.se) { ## compute estimated Variance-Covariance matrix of fitted parameters
- fitted <- params[par.index]
- nfitted <- length(fitted)
+ if (!skip.se && nfitted>0) {
Jhat <- matrix(0,nfitted,nfitted)
Ihat <- Jhat
- f0 <- NLF.LQL(fitted,
+ f0 <- NLF.LQL(
+ fitted,
object=object,
params=params,
par.index=par.index,
- transform.params=transform.params,
+ transform=transform,
times=times, t0=t0,
lags=lags, period=period, tensor=tensor, seed=seed,
- transform=transform, nrbf=4,
- verbose=FALSE)
+ transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ )
F0 <- mean(f0,na.rm=T)
npts <- length(f0)
@@ -177,33 +200,53 @@
Fvals[3] <- F0
guess <- fitted
guess[i] <- fitted[i]-sqrt(2)*h*abs(fitted[i])
- Fvals[1] <- mean(NLF.LQL(guess,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ Fvals[1] <- mean(
+ NLF.LQL(
+ guess,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform,
- nrbf=4, verbose=FALSE),na.rm=T)
+ seed=seed, transform.data=transform.data,nrbf=4,
+ verbose=FALSE
+ ),
+ na.rm=T
+ )
guess <- fitted
guess[i] <- fitted[i]-h*abs(fitted[i])
- Fvals[2] <- mean(NLF.LQL(guess,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ Fvals[2] <- mean(
+ NLF.LQL(
+ guess,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform, nrbf=4,
- verbose=FALSE),na.rm=T)
+ seed=seed, transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ ),
+ na.rm=T
+ )
guess <- fitted
guess[i] <- fitted[i]+h*abs(fitted[i])
- Fvals[4] <- mean(NLF.LQL(guess,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ Fvals[4] <- mean(
+ NLF.LQL(
+ guess,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform, nrbf=4,
- verbose=FALSE),na.rm=T)
+ seed=seed, transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ ),
+ na.rm=T
+ )
guess <- fitted
guess[i] <- fitted[i]+sqrt(2)*h*abs(fitted[i])
- Fvals[5] <- mean(NLF.LQL(guess,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ Fvals[5] <- mean(
+ NLF.LQL(
+ guess,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform, nrbf=4,
- verbose=FALSE),na.rm=T)
- FAILED = - 999999
+ seed=seed, transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ ),
+ na.rm=T
+ )
+ FAILED <- -999999
Fvals[Fvals < FAILED+10] <- NA
xvals <- c(sqrt(2),1,0,1,sqrt(2))*h*fitted[i]
c2 <- lm(Fvals~I(xvals^2))$coef[2]
@@ -217,29 +260,35 @@
for (i in seq_len(nfitted)) {
guess.up <- fitted
guess.up[i] <- guess.up[i]+eps[i]
- f.up <- NLF.LQL(guess.up,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ f.up <- NLF.LQL(
+ guess.up,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform, nrbf=4,
- verbose=FALSE)
+ seed=seed, transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ )
F.up <- mean(f.up,na.rm=T)
- f.up2 <- NLF.LQL(guess.up,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ f.up2 <- NLF.LQL(
+ guess.up,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform, nrbf=4,
- verbose=FALSE)
+ seed=seed, transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ )
if (verbose)
cat("Fitted param ", i, F.up, mean(f.up2,na.rm=T)," up in ",sQuote("nlf"),"\n")
guess.down <- fitted
guess.down[i] <- guess.down[i]-eps[i]
- f.down <- NLF.LQL(guess.down,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ f.down <- NLF.LQL(
+ guess.down,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform, nrbf=4,
- verbose=FALSE)
+ seed=seed, transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ )
F.down <- mean(f.down,na.rm=T)
if (verbose)
@@ -255,38 +304,58 @@
guess.uu <- fitted
guess.uu[i] <- guess.uu[i]+eps[i]
guess.uu[j] <- guess.uu[j]+eps[j]
- F.uu <- mean(NLF.LQL(guess.uu,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ F.uu <- mean(
+ NLF.LQL(
+ guess.uu,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform, nrbf=4,
- verbose=FALSE),na.rm=T)
+ seed=seed, transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ ),
+ na.rm=T
+ )
guess.ud <- fitted
guess.ud[i] <- guess.ud[i]+eps[i]
guess.ud[j] <- guess.ud[j]-eps[j]
- F.ud <- mean(NLF.LQL(guess.ud,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ F.ud <- mean(
+ NLF.LQL(
+ guess.ud,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform, nrbf=4,
- verbose=FALSE),na.rm=T)
+ seed=seed, transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ ),
+ na.rm=T
+ )
guess.du <- fitted
guess.du[i] <- guess.du[i]-eps[i]
guess.du[j] <- guess.du[j]+eps[j]
- F.du <- mean(NLF.LQL(guess.du,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ F.du <- mean(
+ NLF.LQL(
+ guess.du,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform, nrbf=4,
- verbose=FALSE),na.rm=T)
+ seed=seed, transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ ),
+ na.rm=T
+ )
guess.dd <- fitted
guess.dd[i] <- guess.dd[i]-eps[i]
guess.dd[j] <- guess.dd[j]-eps[j]
- F.dd <- mean(NLF.LQL(guess.dd,object=object, params=params, par.index=par.index,
- transform.params=transform.params,
+ F.dd <- mean(
+ NLF.LQL(
+ guess.dd,object=object, params=params, par.index=par.index,
+ transform=transform,
times=times, t0=t0, lags=lags, period=period, tensor=tensor,
- seed=seed, transform=transform, nrbf=4,
- verbose=FALSE),na.rm=T)
+ seed=seed, transform.data=transform.data, nrbf=4,
+ verbose=FALSE
+ ),
+ na.rm=T
+ )
dij <- (F.uu+F.dd)-(F.ud+F.du)
dij <- dij/(4*eps[i]*eps[j])
@@ -296,17 +365,175 @@
Ihat[j,i] <- Ihat[i,j]
}
}
- opt$transform.params <- transform.params
opt$Jhat <- Jhat
opt$Ihat <- Ihat
negJinv <- -solve(Jhat)
Qhat <- negJinv%*%Ihat%*%negJinv
opt$Qhat <- Qhat
- opt$se <- sqrt(diag(Qhat))/sqrt(npts)
- names(opt$se) <- names(params)[par.index]
+ opt$se <- setNames(sqrt(diag(Qhat))/sqrt(npts),names(params)[par.index])
opt$npts <- npts
}
- opt
+ new(
+ "nlfd.pomp",
+ object,
+ params=opt$params,
+ transform=transform,
+ transform.data=transform.data,
+ est=est,
+ lags=lags,
+ nconverge=nconverge,
+ nasymp=nasymp,
+ seed=seed,
+ period=period,
+ tensor=tensor,
+ nrbf=nrbf,
+ method=method,
+ lql.frac=lql.frac,
+ se.par.frac=se.par.frac,
+ Qhat=opt$Qhat,
+ se=opt$se,
+ logql=-opt$value
+ )
}
+setMethod(
+ "nlf",
+ signature=signature(object="pomp"),
+ definition=function (object,
+ start, est, lags,
+ period = NA, tensor = FALSE,
+ nconverge = 1000L, nasymp = 1000L,
+ seed = 1066L, transform.data,
+ nrbf = 4L,
+ method = c(
+ "subplex", "Nelder-Mead", "BFGS", "CG",
+ "L-BFGS-B", "SANN", "Brent"
+ ),
+ skip.se = FALSE,
+ verbose = getOption("verbose"),
+ bootstrap = FALSE, bootsamp = NULL,
+ lql.frac = 0.1, se.par.frac = 0.1,
+ eval.only = FALSE, transform.params = FALSE,
+ transform, ...)
+ {
+ transform.params <- as.logical(transform.params)
+ if (!missing(transform)) {
+ warning("argument ",sQuote("transform"),
+ " is deprecated and will change meaning in a future release.\n",
+ "Use ",sQuote("transform.data")," instead.")
+ if (missing(transform.data)) transform.data <- transform
+ }
+ if (missing(transform.data)) transform.data <- identity
+ transform.data <- match.fun(transform.data)
+ period <- as.numeric(period)
+ tensor <- as.logical(tensor)
+ skip.se <- as.logical(skip.se)
+ eval.only <- as.logical(eval.only)
+ seed <- as.integer(seed)
+ lql.frac <- as.numeric(lql.frac)
+ se.par.frac <- as.numeric(se.par.frac)
+ bootstrap <- as.logical(bootstrap)
+ bootsamp <- as.integer(bootsamp)
+ lags <- as.integer(lags)
+ nrbf <- as.integer(nrbf)
+ nasymp <- as.integer(nasymp)
+ nconverge <- as.integer(nconverge)
+
+ method <- match.arg(method)
+
+ if (eval.only) est <- character(0)
+ if (missing(start)) start <- coef(object)
+ if (!is.character(est))
+ stop(sQuote("est")," must name the parameters to be estimated")
+ if (!all(est%in%names(start)))
+ stop("parameters named in ",sQuote("est"),
+ " must exist in ",sQuote("start"))
+
+ nlf.internal(
+ object=object,
+ start=start,
+ est=est,
+ lags=lags,
+ period=period,
+ tensor=tensor,
+ nconverge=nconverge,
+ nasymp=nasymp,
+ seed=seed,
+ nrbf=nrbf,
+ method=method,
+ skip.se=skip.se,
+ verbose=verbose,
+ bootstrap=bootstrap,
+ bootsamp=bootsamp,
+ lql.frac=lql.frac,
+ se.par.frac=se.par.frac,
+ eval.only=eval.only,
+ transform=transform.params,
+ transform.data=transform.data,
+ ...
+ )
+ }
+ )
+
+setMethod(
+ "nlf",
+ signature=signature(object="nlfd.pomp"),
+ definition=function (object, start, est, lags,
+ period, tensor, nconverge, nasymp, seed,
+ transform.data, nrbf, method, lql.frac, se.par.frac,
+ transform.params, ...)
+ {
+ if (missing(start)) start <- coef(object)
+ if (missing(est)) est <- object at est
+ if (missing(lags)) lags <- object at lags
+ if (missing(period)) period <- object at period
+ if (missing(tensor)) tensor <- object at tensor
+ if (missing(nconverge)) nconverge <- object at nconverge
+ if (missing(nasymp)) nasymp <- object at nasymp
+ if (missing(seed)) seed <- object at seed
+ if (missing(transform.params)) transform.params <- object at transform
+ if (missing(transform.data)) transform.data <- object at transform.data
+ if (missing(nrbf)) nrbf <- object at nrbf
+ if (missing(method)) method <- object at method
+ if (missing(lql.frac)) lql.frac <- object at lql.frac
+ if (missing(se.par.frac)) se.par.frac <- object at se.par.frac
+
+ f <- selectMethod("nlf","pomp")
+ f(
+ object=as(object,"pomp"),
+ start=start,
+ est=est,
+ lags=lags,
+ period=period,
+ tensor=tensor,
+ nconverge=nconverge,
+ seed=seed,
+ transform.params=transform.params,
+ transform.data=transform.data,
+ nrbf=nrbf,
+ method=method,
+ lql.frac=lql.frac,
+ se.par.frac=se.par.frac,
+ ...
+ )
+ }
+ )
+
+
+
+setMethod(
+ "$",
+ signature=signature(x="nlfd.pomp"),
+ definition = function (x, name) {
+ slot(x,name)
+ }
+ )
+
+setMethod(
+ "logLik",
+ signature=signature(object="nlfd.pomp"),
+ definition = function(object, ...) {
+ object at logql
+ }
+ )
Modified: pkg/pomp/inst/NEWS
===================================================================
--- pkg/pomp/inst/NEWS 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/pomp/inst/NEWS 2014-06-27 19:48:02 UTC (rev 985)
@@ -1,5 +1,17 @@
_N_e_w_s _f_o_r _p_a_c_k_a_g_e '_p_o_m_p'
+_C_h_a_n_g_e_s _i_n '_p_o_m_p' _v_e_r_s_i_o_n _0._5_3-_1:
+
+ ? ?nlf? now returns an S4 object of class ?nlfd.pomp? with a
+ ?logLik? method for extracting the log quasi likelihood and a
+ ?$? method for extracting arbitrary components.
+
+ ? The ?transform? argument (for providing a function to
+ transform the data) has been removed in favor of
+ ?transform.data?. The logical ?transform.params? argument
+ has been removed in favor of ?transform?, as used in the
+ other inference algorithms (?mif?, ?probe.match?, etc.).
+
_C_h_a_n_g_e_s _i_n '_p_o_m_p' _v_e_r_s_i_o_n _0._5_2-_1:
? The new ?mifList? class facilitates approaches based on
Modified: pkg/pomp/inst/NEWS.Rd
===================================================================
--- pkg/pomp/inst/NEWS.Rd 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/pomp/inst/NEWS.Rd 2014-06-27 19:48:02 UTC (rev 985)
@@ -1,5 +1,11 @@
\name{NEWS}
\title{News for package `pomp'}
+\section{Changes in \pkg{pomp} version 0.53-1}{
+ \itemize{
+ \item \code{nlf} now returns an S4 object of class \code{nlfd.pomp} with a \code{logLik} method for extracting the log quasi likelihood and a \code{$} method for extracting arbitrary components.
+ \item The \code{transform} argument (for providing a function to transform the data) has been removed in favor of \code{transform.data}.
+ }
+}
\section{Changes in \pkg{pomp} version 0.52-1}{
\itemize{
\item The new \code{mifList} class facilitates approaches based on multiple \code{mif} runs.
Modified: pkg/pomp/man/mif.Rd
===================================================================
--- pkg/pomp/man/mif.Rd 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/pomp/man/mif.Rd 2014-06-27 19:48:02 UTC (rev 985)
@@ -16,7 +16,6 @@
Iterated filtering algorithms for estimating the parameters of a partially-observed Markov process.
}
\usage{
-mif(object, \dots)
\S4method{mif}{pomp}(object, Nmif = 1, start, pars, ivps = character(0),
particles, rw.sd, Np, ic.lag, var.factor,
cooling.type, cooling.fraction, cooling.factor,
Modified: pkg/pomp/man/nlf.Rd
===================================================================
--- pkg/pomp/man/nlf.Rd 2014-06-25 17:50:18 UTC (rev 984)
+++ pkg/pomp/man/nlf.Rd 2014-06-27 19:48:02 UTC (rev 985)
@@ -1,19 +1,31 @@
\name{nlf}
\alias{nlf}
+\alias{nlf,pomp-method}
+\alias{nlf-pomp}
+\alias{nlf,nlfd.pomp-method}
+\alias{nlf-nlfd.pomp}
+\alias{nlfd.pomp-class}
+\alias{logLik,nlfd.pomp-method}
+\alias{logLik-nlfd.pomp}
+\alias{$,nlfd.pomp-method}
+\alias{$-nlfd.pomp}
\title{Fit Model to Data Using Nonlinear Forecasting (NLF)}
\description{
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/pomp -r 985
From noreply at r-forge.r-project.org Fri Jun 27 21:48:22 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Fri, 27 Jun 2014 21:48:22 +0200 (CEST)
Subject: [Pomp-commits] r986 - pkg/pomp
Message-ID: <20140627194822.7D6AD184C5F@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-27 21:48:22 +0200 (Fri, 27 Jun 2014)
New Revision: 986
Modified:
pkg/pomp/DESCRIPTION
Log:
- remove Suggests: knitr
- remove VignetteBuiilder and BuildVignettes files (no vignettes)
Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION 2014-06-27 19:48:02 UTC (rev 985)
+++ pkg/pomp/DESCRIPTION 2014-06-27 19:48:22 UTC (rev 986)
@@ -19,11 +19,8 @@
URL: http://pomp.r-forge.r-project.org
Description: Inference methods for partially-observed Markov processes
Depends: R(>= 3.0.0), stats, graphics, methods, mvtnorm, subplex, nloptr, deSolve, coda
-Suggests: knitr
License: GPL(>= 2)
LazyData: true
-BuildVignettes: true
-VignetteBuilder: knitr
MailingList: Subscribe to pomp-announce at r-forge.r-project.org for announcements by going to http://lists.r-forge.r-project.org/mailman/listinfo/pomp-announce.
Collate: aaa.R authors.R generics.R eulermultinom.R
csnippet.R pomp-fun.R plugins.R
From noreply at r-forge.r-project.org Fri Jun 27 21:48:33 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Fri, 27 Jun 2014 21:48:33 +0200 (CEST)
Subject: [Pomp-commits] r987 - pkg/pomp/inst
Message-ID: <20140627194833.18EC0184C5F@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-27 21:48:32 +0200 (Fri, 27 Jun 2014)
New Revision: 987
Modified:
pkg/pomp/inst/NEWS
Log:
- update NEWS
Modified: pkg/pomp/inst/NEWS
===================================================================
--- pkg/pomp/inst/NEWS 2014-06-27 19:48:22 UTC (rev 986)
+++ pkg/pomp/inst/NEWS 2014-06-27 19:48:32 UTC (rev 987)
@@ -8,9 +8,7 @@
? The ?transform? argument (for providing a function to
transform the data) has been removed in favor of
- ?transform.data?. The logical ?transform.params? argument
- has been removed in favor of ?transform?, as used in the
- other inference algorithms (?mif?, ?probe.match?, etc.).
+ ?transform.data?.
_C_h_a_n_g_e_s _i_n '_p_o_m_p' _v_e_r_s_i_o_n _0._5_2-_1:
From noreply at r-forge.r-project.org Fri Jun 27 21:50:35 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Fri, 27 Jun 2014 21:50:35 +0200 (CEST)
Subject: [Pomp-commits] r988 - in www: content vignettes
Message-ID: <20140627195035.7F27E184E49@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-27 21:50:35 +0200 (Fri, 27 Jun 2014)
New Revision: 988
Modified:
www/content/NEWS.html
www/vignettes/advanced_topics_in_pomp.pdf
www/vignettes/intro_to_pomp.R
www/vignettes/intro_to_pomp.Rnw
www/vignettes/intro_to_pomp.pdf
www/vignettes/nlf-block-boot.rda
www/vignettes/nlf-boot.rda
www/vignettes/nlf-fit-from-truth.rda
www/vignettes/nlf-fits.rda
www/vignettes/nlf-lag-tests.rda
www/vignettes/nlf-multi-short.rda
www/vignettes/pomp.pdf
Log:
- update the vignettes
Modified: www/content/NEWS.html
===================================================================
--- www/content/NEWS.html 2014-06-27 19:48:32 UTC (rev 987)
+++ www/content/NEWS.html 2014-06-27 19:50:35 UTC (rev 988)
@@ -8,6 +8,19 @@
News for package ‘pomp’
+Changes in pomp version 0.53-1
+
+
+
+-
nlf
now returns an S4 object of class nlfd.pomp
with a logLik
method for extracting the log quasi likelihood and a $
method for extracting arbitrary components.
+
+
+ The transform
argument (for providing a function to transform the data) has been removed in favor of transform.data
.
+
+
+
+
+
Changes in pomp version 0.52-1
Modified: www/vignettes/advanced_topics_in_pomp.pdf
===================================================================
(Binary files differ)
Modified: www/vignettes/intro_to_pomp.R
===================================================================
--- www/vignettes/intro_to_pomp.R 2014-06-27 19:48:32 UTC (rev 987)
+++ www/vignettes/intro_to_pomp.R 2014-06-27 19:50:35 UTC (rev 988)
@@ -854,7 +854,7 @@
## out[[j]] <- nlf(
## gompertz,
## start=starts[[j]],
-## transform=log,
+## transform.data=log,
## transform.params=TRUE,
## est=c("K","r"),
## lags=c(1,2),
@@ -865,42 +865,42 @@
## nasymp=5000
## )
## }
-## fits <- t(sapply(out,function(x)c(x$params[c("r","K")],value=x$value)))
+## fits <- t(sapply(out,function(x)c(coef(x,c("r","K")),value=logLik(x))))
## ----nlf-fits-eval,echo=F,eval=T,results='hide'--------------------------
binary.file <- "nlf-fits.rda"
if (file.exists(binary.file)) {
load(binary.file)
} else {
-# pick 5 random starting parameter values
-starts <- replicate(n=5,
- {
- p <- coef(gompertz)
- p[c("K","r")] <- rlnorm(n=2,meanlog=log(p[c("K","r")]),
- sdlog=0.1)
- p
- },
- simplify=FALSE
- )
-out <- list()
-## Do the fitting.
-## method, trace, and nasymp are explained below
-for (j in 1:5) {
- out[[j]] <- nlf(
- gompertz,
- start=starts[[j]],
- transform=log,
- transform.params=TRUE,
- est=c("K","r"),
- lags=c(1,2),
- seed=7639873L,
- method="Nelder-Mead",
- trace=4,
- skip.se=TRUE,
- nasymp=5000
- )
-}
-fits <- t(sapply(out,function(x)c(x$params[c("r","K")],value=x$value)))
+ # pick 5 random starting parameter values
+ starts <- replicate(n=5,
+ {
+ p <- coef(gompertz)
+ p[c("K","r")] <- rlnorm(n=2,meanlog=log(p[c("K","r")]),
+ sdlog=0.1)
+ p
+ },
+ simplify=FALSE
+ )
+ out <- list()
+ ## Do the fitting.
+ ## method, trace, and nasymp are explained below
+ for (j in 1:5) {
+ out[[j]] <- nlf(
+ gompertz,
+ start=starts[[j]],
+ transform.data=log,
+ transform.params=TRUE,
+ est=c("K","r"),
+ lags=c(1,2),
+ seed=7639873L,
+ method="Nelder-Mead",
+ trace=4,
+ skip.se=TRUE,
+ nasymp=5000
+ )
+ }
+ fits <- t(sapply(out,function(x)c(coef(x,c("r","K")),value=logLik(x))))
save(starts,out,fits,file=binary.file,compress="xz")
}
@@ -922,14 +922,14 @@
## pars <- theta
## pars["r"] <- r.vals[j]
## for(k in 1:4) {
-## fvals[j,k] <- nlf(
-## long.gomp,
-## start=pars,
-## nasymp=5000,
-## est=NULL,
-## lags=lags[[k]],
-## eval.only=TRUE
-## )
+## fit <- nlf(
+## long.gomp,
+## start=pars,
+## nasymp=5000,
+## lags=lags[[k]],
+## eval.only=TRUE
+## )
+## fvals[j,k] <- logLik(fit)
## }
## }
@@ -940,14 +940,14 @@
## pars <- theta
## pars["K"] <- pars["X.0"] <- K.vals[j]
## for(k in 1:4) {
-## fvals2[j,k] <- nlf(
-## long.gomp,
-## start=pars,
-## nasymp=5000,
-## est=NULL,
-## lags=lags[[k]],
-## eval.only=TRUE
-## )
+## fit <- nlf(
+## long.gomp,
+## start=pars,
+## nasymp=5000,
+## lags=lags[[k]],
+## eval.only=TRUE
+## )
+## fvals2[j,k] <- logLik(fit)
## }
## }
@@ -956,41 +956,41 @@
if (file.exists(binary.file)) {
load(binary.file)
} else {
-long.gomp <- simulate(gompertz,times=1:1000)
-theta <- coef(long.gomp)
-lags <- list(1,2,c(1,2),c(2,3))
-r.vals <- theta["r"]*exp(seq(-0.69,0.69,length=25))
-fvals <- matrix(nrow=25,ncol=4)
-for (j in 1:25) {
- pars <- theta
- pars["r"] <- r.vals[j]
- for(k in 1:4) {
- fvals[j,k] <- nlf(
- long.gomp,
- start=pars,
- nasymp=5000,
- est=NULL,
- lags=lags[[k]],
- eval.only=TRUE
- )
+ long.gomp <- simulate(gompertz,times=1:1000)
+ theta <- coef(long.gomp)
+ lags <- list(1,2,c(1,2),c(2,3))
+ r.vals <- theta["r"]*exp(seq(-0.69,0.69,length=25))
+ fvals <- matrix(nrow=25,ncol=4)
+ for (j in 1:25) {
+ pars <- theta
+ pars["r"] <- r.vals[j]
+ for(k in 1:4) {
+ fit <- nlf(
+ long.gomp,
+ start=pars,
+ nasymp=5000,
+ lags=lags[[k]],
+ eval.only=TRUE
+ )
+ fvals[j,k] <- logLik(fit)
+ }
}
-}
-K.vals <- theta["K"]*exp(seq(-0.15,0.15,length=25))
-fvals2 <- matrix(nrow=25,ncol=4)
-for (j in 1:25) {
- pars <- theta
- pars["K"] <- pars["X.0"] <- K.vals[j]
- for(k in 1:4) {
- fvals2[j,k] <- nlf(
- long.gomp,
- start=pars,
- nasymp=5000,
- est=NULL,
- lags=lags[[k]],
- eval.only=TRUE
- )
+ K.vals <- theta["K"]*exp(seq(-0.15,0.15,length=25))
+ fvals2 <- matrix(nrow=25,ncol=4)
+ for (j in 1:25) {
+ pars <- theta
+ pars["K"] <- pars["X.0"] <- K.vals[j]
+ for(k in 1:4) {
+ fit <- nlf(
+ long.gomp,
+ start=pars,
+ nasymp=5000,
+ lags=lags[[k]],
+ eval.only=TRUE
+ )
+ fvals2[j,k] <- logLik(fit)
+ }
}
-}
save(theta,lags,r.vals,K.vals,fvals,fvals2,file=binary.file,compress="xz")
}
@@ -1033,14 +1033,14 @@
## new.pomp <- simulate(gompertz,times=1:ndata,nsim=nreps,seed=NULL) # nreps simulated data sets
## for (j in 1:nreps) {
## for (k in seq_along(lags)) {
-## fvals[j,k] <- nlf(
-## new.pomp[[j]],
-## start=coef(gompertz),
-## nasymp=5000,
-## est=NULL,
-## lags=lags[[k]],
-## eval.only=TRUE
-## )
+## fit <- nlf(
+## new.pomp[[j]],
+## start=coef(gompertz),
+## nasymp=5000,
+## lags=lags[[k]],
+## eval.only=TRUE
+## )
+## fvals[j,k] <- logLik(fit)
## }
## }
## fvals <- exp(fvals/ndata)
@@ -1050,23 +1050,23 @@
if (file.exists(binary.file)) {
load(binary.file)
} else {
-nreps <- 100
-ndata <- 60
-fvals <- matrix(nrow=nreps,ncol=length(lags))
-new.pomp <- simulate(gompertz,times=1:ndata,nsim=nreps,seed=NULL) # nreps simulated data sets
-for (j in 1:nreps) {
- for (k in seq_along(lags)) {
- fvals[j,k] <- nlf(
- new.pomp[[j]],
- start=coef(gompertz),
- nasymp=5000,
- est=NULL,
- lags=lags[[k]],
- eval.only=TRUE
- )
+ nreps <- 100
+ ndata <- 60
+ fvals <- matrix(nrow=nreps,ncol=length(lags))
+ new.pomp <- simulate(gompertz,times=1:ndata,nsim=nreps,seed=NULL) # nreps simulated data sets
+ for (j in 1:nreps) {
+ for (k in seq_along(lags)) {
+ fit <- nlf(
+ new.pomp[[j]],
+ start=coef(gompertz),
+ nasymp=5000,
+ lags=lags[[k]],
+ eval.only=TRUE
+ )
+ fvals[j,k] <- logLik(fit)
+ }
}
-}
-fvals <- exp(fvals/ndata)
+ fvals <- exp(fvals/ndata)
save(lags,nreps,ndata,fvals,file=binary.file,compress="xz")
}
@@ -1092,16 +1092,16 @@
if (file.exists(binary.file)) {
load(binary.file)
} else {
-true.fit <- nlf(
- gompertz,
- transform.params=TRUE,
- est=c("K","r"),
- lags=2,
- seed=7639873,
- method="Nelder-Mead",
- trace=4,
- nasymp=5000
- )
+ true.fit <- nlf(
+ gompertz,
+ transform.params=TRUE,
+ est=c("K","r"),
+ lags=2,
+ seed=7639873,
+ method="Nelder-Mead",
+ trace=4,
+ nasymp=5000
+ )
save(true.fit,file=binary.file,compress="xz")
}
@@ -1131,7 +1131,7 @@
## trace=4,
## nasymp=5000
## )
-## pars[j,] <- fit$params[c("r","K")]
+## pars[j,] <- coef(fit,c("r","K"))
## }
## colnames(pars) <- c("r","K")
@@ -1140,30 +1140,30 @@
if (file.exists(binary.file)) {
load(binary.file)
} else {
-lags <- 2
-ndata <- length(obs(gompertz))
-nboot <- ndata-max(lags)
-nreps <- 100
-pars <- matrix(0,nreps,2)
-bootsamp <- replicate(n=nreps,sample(nboot,replace=TRUE))
-for (j in seq_len(nreps)) {
- fit <- nlf(
- gompertz,
- start=coef(gompertz),
- transform.params=TRUE,
- est=c("K","r"),
- lags=lags,
- seed=7639873,
- bootstrap=TRUE,
- bootsamp=bootsamp[,j],
- skip.se=TRUE,
- method="Nelder-Mead",
- trace=4,
- nasymp=5000
- )
- pars[j,] <- fit$params[c("r","K")]
-}
-colnames(pars) <- c("r","K")
+ lags <- 2
+ ndata <- length(obs(gompertz))
+ nboot <- ndata-max(lags)
+ nreps <- 100
+ pars <- matrix(0,nreps,2)
+ bootsamp <- replicate(n=nreps,sample(nboot,replace=TRUE))
+ for (j in seq_len(nreps)) {
+ fit <- nlf(
+ gompertz,
+ start=coef(gompertz),
+ transform.params=TRUE,
+ est=c("K","r"),
+ lags=lags,
+ seed=7639873,
+ bootstrap=TRUE,
+ bootsamp=bootsamp[,j],
+ skip.se=TRUE,
+ method="Nelder-Mead",
+ trace=4,
+ nasymp=5000
+ )
+ pars[j,] <- coef(fit,c("r","K"))
+ }
+ colnames(pars) <- c("r","K")
save(pars,file=binary.file,compress="xz")
}
@@ -1201,7 +1201,7 @@
## trace=4,
## nasymp=5000
## )
-## pars[j,] <- fit$params[c("r","K")]
+## pars[j,] <- coef(fit,c("r","K"))
## }
## colnames(pars) <- c("r","K")
@@ -1211,33 +1211,33 @@
if (file.exists(binary.file)) {
load(binary.file)
} else {
-lags <- 2
-ndata <- length(obs(gompertz))
-nboot <- ndata-max(lags)
-nreps <- 100
-pars <- matrix(0,nreps,2)
-bootsamp <- replicate(
- n=nreps,
- sample(nboot-2,size=floor(nboot/3),replace=TRUE)
- )
-bootsamp <- rbind(bootsamp,bootsamp+1,bootsamp+2)
-for (j in seq_len(nreps)) {
- fit <- nlf(
- gompertz,
- transform.params=TRUE,
- est=c("K","r"),
- lags=lags,
- seed=7639873L,
- bootstrap=TRUE,
- bootsamp=bootsamp[,j],
- skip.se=TRUE,
- method="Nelder-Mead",
- trace=4,
- nasymp=5000
- )
- pars[j,] <- fit$params[c("r","K")]
-}
-colnames(pars) <- c("r","K")
+ lags <- 2
+ ndata <- length(obs(gompertz))
+ nboot <- ndata-max(lags)
+ nreps <- 100
+ pars <- matrix(0,nreps,2)
+ bootsamp <- replicate(
+ n=nreps,
+ sample(nboot-2,size=floor(nboot/3),replace=TRUE)
+ )
+ bootsamp <- rbind(bootsamp,bootsamp+1,bootsamp+2)
+ for (j in seq_len(nreps)) {
+ fit <- nlf(
+ gompertz,
+ transform.params=TRUE,
+ est=c("K","r"),
+ lags=lags,
+ seed=7639873L,
+ bootstrap=TRUE,
+ bootsamp=bootsamp[,j],
+ skip.se=TRUE,
+ method="Nelder-Mead",
+ trace=4,
+ nasymp=5000
+ )
+ pars[j,] <- coef(fit,c("r","K"))
+ }
+ colnames(pars) <- c("r","K")
save(pars,file=binary.file,compress="xz")
}
Modified: www/vignettes/intro_to_pomp.Rnw
===================================================================
--- www/vignettes/intro_to_pomp.Rnw 2014-06-27 19:48:32 UTC (rev 987)
+++ www/vignettes/intro_to_pomp.Rnw 2014-06-27 19:50:35 UTC (rev 988)
@@ -1215,7 +1215,7 @@
out[[j]] <- nlf(
gompertz,
start=starts[[j]],
- transform=log,
+ transform.data=log,
transform.params=TRUE,
est=c("K","r"),
lags=c(1,2),
@@ -1226,15 +1226,15 @@
nasymp=5000
)
}
-fits <- t(sapply(out,function(x)c(x$params[c("r","K")],value=x$value)))
+fits <- t(sapply(out,function(x)c(coef(x,c("r","K")),value=logLik(x))))
@
<>=
binary.file <- "nlf-fits.rda"
if (file.exists(binary.file)) {
load(binary.file)
} else {
-<>
-<>
+ <>
+ <>
save(starts,out,fits,file=binary.file,compress="xz")
}
@
@@ -1273,14 +1273,14 @@
pars <- theta
pars["r"] <- r.vals[j]
for(k in 1:4) {
- fvals[j,k] <- nlf(
- long.gomp,
- start=pars,
- nasymp=5000,
- est=NULL,
- lags=lags[[k]],
- eval.only=TRUE
- )
+ fit <- nlf(
+ long.gomp,
+ start=pars,
+ nasymp=5000,
+ lags=lags[[k]],
+ eval.only=TRUE
+ )
+ fvals[j,k] <- logLik(fit)
}
}
@
@@ -1291,14 +1291,14 @@
pars <- theta
pars["K"] <- pars["X.0"] <- K.vals[j]
for(k in 1:4) {
- fvals2[j,k] <- nlf(
- long.gomp,
- start=pars,
- nasymp=5000,
- est=NULL,
- lags=lags[[k]],
- eval.only=TRUE
- )
+ fit <- nlf(
+ long.gomp,
+ start=pars,
+ nasymp=5000,
+ lags=lags[[k]],
+ eval.only=TRUE
+ )
+ fvals2[j,k] <- logLik(fit)
}
}
@
@@ -1307,9 +1307,9 @@
if (file.exists(binary.file)) {
load(binary.file)
} else {
-<>
-<>
-<>
+ <>
+ <>
+ <>
save(theta,lags,r.vals,K.vals,fvals,fvals2,file=binary.file,compress="xz")
}
@
@@ -1362,14 +1362,14 @@
new.pomp <- simulate(gompertz,times=1:ndata,nsim=nreps,seed=NULL) # nreps simulated data sets
for (j in 1:nreps) {
for (k in seq_along(lags)) {
- fvals[j,k] <- nlf(
- new.pomp[[j]],
- start=coef(gompertz),
- nasymp=5000,
- est=NULL,
- lags=lags[[k]],
- eval.only=TRUE
- )
+ fit <- nlf(
+ new.pomp[[j]],
+ start=coef(gompertz),
+ nasymp=5000,
+ lags=lags[[k]],
+ eval.only=TRUE
+ )
+ fvals[j,k] <- logLik(fit)
}
}
fvals <- exp(fvals/ndata)
@@ -1379,7 +1379,7 @@
if (file.exists(binary.file)) {
load(binary.file)
} else {
-<>
+ <>
save(lags,nreps,ndata,fvals,file=binary.file,compress="xz")
}
@
@@ -1395,7 +1395,7 @@
transform.params=TRUE,
est=c("K","r"),
lags=2,
- seed=7639873,
+ seed=7639873,
method="Nelder-Mead",
trace=4,
nasymp=5000
@@ -1406,14 +1406,13 @@
if (file.exists(binary.file)) {
load(binary.file)
} else {
-<>
+ <>
save(true.fit,file=binary.file,compress="xz")
}
@
-From \verb+true.fit$params+ and \verb+true.fit$se+ we get the estimates ($\pm$ 1 standard error)
-${r}=$~\Sexpr{signif(true.fit$params["r"],2)}~$\pm$~\Sexpr{signif(true.fit$params["r"]*true.fit$se["r"],2)}
-and ${K}=$~\Sexpr{signif(true.fit$params["K"],2)}~$\pm$~\Sexpr{signif(true.fit$params["K"]*true.fit$se["K"],2)}.
-%%$\log K = 0.081 \pm 0.064$, $\log r = -2.2 \pm 0.51$
+From \verb+coef(true.fit)+ and \verb+true.fit$se+ we get the estimates ($\pm$ 1 standard error)
+${r}=$~\Sexpr{signif(coef(true.fit,"r"),2)}~$\pm$~\Sexpr{signif(coef(true.fit,"r")*true.fit$se["r"],2)}
+and ${K}=$~\Sexpr{signif(coef(true.fit,"K"),2)}~$\pm$~\Sexpr{signif(coef(true.fit,"K")*true.fit$se["K"],2)}.
The standard errors provided by \code{nlf} are based on a Newey-West estimate of the variance-covariance matrix that is generally
somewhat biased downward.
@@ -1449,7 +1448,7 @@
trace=4,
nasymp=5000
)
- pars[j,] <- fit$params[c("r","K")]
+ pars[j,] <- coef(fit,c("r","K"))
}
colnames(pars) <- c("r","K")
@
@@ -1458,7 +1457,7 @@
if (file.exists(binary.file)) {
load(binary.file)
} else {
-<>
+ <>
save(pars,file=binary.file,compress="xz")
}
@
@@ -1502,7 +1501,7 @@
trace=4,
nasymp=5000
)
- pars[j,] <- fit$params[c("r","K")]
+ pars[j,] <- coef(fit,c("r","K"))
}
colnames(pars) <- c("r","K")
@
@@ -1512,7 +1511,7 @@
if (file.exists(binary.file)) {
load(binary.file)
} else {
-<>
+ <>
save(pars,file=binary.file,compress="xz")
}
@
Modified: www/vignettes/intro_to_pomp.pdf
===================================================================
(Binary files differ)
Modified: www/vignettes/nlf-block-boot.rda
===================================================================
(Binary files differ)
Modified: www/vignettes/nlf-boot.rda
===================================================================
(Binary files differ)
Modified: www/vignettes/nlf-fit-from-truth.rda
===================================================================
(Binary files differ)
Modified: www/vignettes/nlf-fits.rda
===================================================================
(Binary files differ)
Modified: www/vignettes/nlf-lag-tests.rda
===================================================================
(Binary files differ)
Modified: www/vignettes/nlf-multi-short.rda
===================================================================
(Binary files differ)
Modified: www/vignettes/pomp.pdf
===================================================================
(Binary files differ)
From noreply at r-forge.r-project.org Sun Jun 29 14:21:39 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Sun, 29 Jun 2014 14:21:39 +0200 (CEST)
Subject: [Pomp-commits] r989 - in branches/premif2: . R data demo inst
inst/data-R inst/doc inst/examples inst/include man src tests
Message-ID: <20140629122139.B7A0A1862ED@r-forge.r-project.org>
Author: kingaa
Date: 2014-06-29 14:21:37 +0200 (Sun, 29 Jun 2014)
New Revision: 989
Removed:
branches/premif2/.Rbuildignore
branches/premif2/.Rinstignore
branches/premif2/DESCRIPTION
branches/premif2/NAMESPACE
branches/premif2/R/aaa.R
branches/premif2/R/authors.R
branches/premif2/R/basic-probes.R
branches/premif2/R/bsmc.R
branches/premif2/R/bsplines.R
branches/premif2/R/builder.R
branches/premif2/R/compare-mif.R
branches/premif2/R/compare-pmcmc.R
branches/premif2/R/dmeasure-pomp.R
branches/premif2/R/dprocess-pomp.R
branches/premif2/R/eulermultinom.R
branches/premif2/R/init-state-pomp.R
branches/premif2/R/mif-class.R
branches/premif2/R/mif-methods.R
branches/premif2/R/mif.R
branches/premif2/R/nlf-funcs.R
branches/premif2/R/nlf-guts.R
branches/premif2/R/nlf-objfun.R
branches/premif2/R/nlf.R
branches/premif2/R/parmat.R
branches/premif2/R/particles-mif.R
branches/premif2/R/pfilter-methods.R
branches/premif2/R/pfilter.R
branches/premif2/R/plot-pomp.R
branches/premif2/R/plugins.R
branches/premif2/R/pmcmc-methods.R
branches/premif2/R/pmcmc.R
branches/premif2/R/pomp-fun.R
branches/premif2/R/pomp-methods.R
branches/premif2/R/pomp.R
branches/premif2/R/probe-match.R
branches/premif2/R/probe.R
branches/premif2/R/profile-design.R
branches/premif2/R/rmeasure-pomp.R
branches/premif2/R/rprocess-pomp.R
branches/premif2/R/sannbox.R
branches/premif2/R/simulate-pomp.R
branches/premif2/R/skeleton-pomp.R
branches/premif2/R/slice-design.R
branches/premif2/R/sobol.R
branches/premif2/R/spect-match.R
branches/premif2/R/spect.R
branches/premif2/R/traj-match.R
branches/premif2/R/trajectory-pomp.R
branches/premif2/R/version.R
branches/premif2/data/LondonYorke.rda
branches/premif2/data/bbs.rda
branches/premif2/data/blowflies.rda
branches/premif2/data/dacca.rda
branches/premif2/data/euler.sir.rda
branches/premif2/data/gillespie.sir.rda
branches/premif2/data/gompertz.rda
branches/premif2/data/ou2.rda
branches/premif2/data/ricker.rda
branches/premif2/data/rw2.rda
branches/premif2/data/verhulst.rda
branches/premif2/demo/00Index
branches/premif2/demo/gompertz.R
branches/premif2/demo/logistic.R
branches/premif2/demo/rw2.R
branches/premif2/demo/sir.R
branches/premif2/inst/CHANGES_0.29-1.txt
branches/premif2/inst/CITATION
branches/premif2/inst/ChangeLog
branches/premif2/inst/GPL
branches/premif2/inst/LICENSE
branches/premif2/inst/NEWS
branches/premif2/inst/O_CHANGES
branches/premif2/inst/TODO
branches/premif2/inst/data-R/Makefile
branches/premif2/inst/data-R/blowflies.R
branches/premif2/inst/data-R/blowflies.csv
branches/premif2/inst/data-R/dacca.R
branches/premif2/inst/data-R/gompertz.R
branches/premif2/inst/data-R/make.R
branches/premif2/inst/data-R/ou2.R
branches/premif2/inst/data-R/ricker.R
branches/premif2/inst/data-R/rw2.R
branches/premif2/inst/data-R/sir.R
branches/premif2/inst/data-R/verhulst.R
branches/premif2/inst/doc/Makefile
branches/premif2/inst/doc/advanced_topics_in_pomp.Rnw
branches/premif2/inst/doc/advanced_topics_in_pomp.pdf
branches/premif2/inst/doc/bsmc-ricker-flat-prior.rda
branches/premif2/inst/doc/bsmc-ricker-normal-prior.rda
branches/premif2/inst/doc/complex-sir-def.rda
branches/premif2/inst/doc/fullnat.bst
branches/premif2/inst/doc/gompertz-multi-mif.rda
branches/premif2/inst/doc/gompertz-pfilter-guess.rda
branches/premif2/inst/doc/gompertz-trajmatch.rda
branches/premif2/inst/doc/index.html
branches/premif2/inst/doc/intro_to_pomp.Rnw
branches/premif2/inst/doc/intro_to_pomp.pdf
branches/premif2/inst/doc/nlf-block-boot.rda
branches/premif2/inst/doc/nlf-boot.rda
branches/premif2/inst/doc/nlf-fit-from-truth.rda
branches/premif2/inst/doc/nlf-fits.rda
branches/premif2/inst/doc/nlf-lag-tests.rda
branches/premif2/inst/doc/nlf-multi-short.rda
branches/premif2/inst/doc/plugin-C-code.rda
branches/premif2/inst/doc/plugin-R-code.rda
branches/premif2/inst/doc/pomp.bib
branches/premif2/inst/doc/ricker-comparison.rda
branches/premif2/inst/doc/ricker-first-probe.rda
branches/premif2/inst/doc/ricker-mif.rda
branches/premif2/inst/doc/ricker-probe-match.rda
branches/premif2/inst/doc/ricker-probe.rda
branches/premif2/inst/doc/sim-sim.rda
branches/premif2/inst/doc/sir-pomp-def.rda
branches/premif2/inst/doc/vectorized-C-code.rda
branches/premif2/inst/doc/vectorized-R-code.rda
branches/premif2/inst/examples/ou2.c
branches/premif2/inst/examples/sir.c
branches/premif2/inst/include/pomp.h
branches/premif2/man/LondonYorke.Rd
branches/premif2/man/basic-probes.Rd
branches/premif2/man/blowflies.Rd
branches/premif2/man/bsmc.Rd
branches/premif2/man/bsplines.Rd
branches/premif2/man/builder.Rd
branches/premif2/man/dacca.Rd
branches/premif2/man/dmeasure-pomp.Rd
branches/premif2/man/dprocess-pomp.Rd
branches/premif2/man/eulermultinom.Rd
branches/premif2/man/gompertz.Rd
branches/premif2/man/init.state-pomp.Rd
branches/premif2/man/mif-class.Rd
branches/premif2/man/mif-methods.Rd
branches/premif2/man/mif.Rd
branches/premif2/man/nlf.Rd
branches/premif2/man/ou2.Rd
branches/premif2/man/parmat.Rd
branches/premif2/man/particles-mif.Rd
branches/premif2/man/pfilter-methods.Rd
branches/premif2/man/pfilter.Rd
branches/premif2/man/plugins.Rd
branches/premif2/man/pmcmc-methods.Rd
branches/premif2/man/pmcmc.Rd
branches/premif2/man/pomp-class.Rd
branches/premif2/man/pomp-fun.Rd
branches/premif2/man/pomp-methods.Rd
branches/premif2/man/pomp-package.Rd
branches/premif2/man/pomp.Rd
branches/premif2/man/probe.Rd
branches/premif2/man/probed-pomp-methods.Rd
branches/premif2/man/profile-design.Rd
branches/premif2/man/ricker.Rd
branches/premif2/man/rmeasure-pomp.Rd
branches/premif2/man/rprocess-pomp.Rd
branches/premif2/man/rw2.Rd
branches/premif2/man/sannbox.Rd
branches/premif2/man/simulate-pomp.Rd
branches/premif2/man/sir.Rd
branches/premif2/man/skeleton-pomp.Rd
branches/premif2/man/slice-design.Rd
branches/premif2/man/sobol.Rd
branches/premif2/man/spect.Rd
branches/premif2/man/traj-match.Rd
branches/premif2/man/trajectory-pomp.Rd
branches/premif2/man/verhulst.Rd
branches/premif2/src/Makevars
branches/premif2/src/R_init_pomp.c
branches/premif2/src/SSA.f90
branches/premif2/src/SSA_wrapper.c
branches/premif2/src/blowfly.c
branches/premif2/src/bspline.c
branches/premif2/src/cholmodel.c
branches/premif2/src/dmeasure.c
branches/premif2/src/dprocess.c
branches/premif2/src/dsobol.c
branches/premif2/src/euler.c
branches/premif2/src/eulermultinom.c
branches/premif2/src/gompertz.c
branches/premif2/src/initstate.c
branches/premif2/src/lookup_table.c
branches/premif2/src/lpa.c
branches/premif2/src/ou2.c
branches/premif2/src/partrans.c
branches/premif2/src/pfilter.c
branches/premif2/src/pomp.h
branches/premif2/src/pomp_fun.c
branches/premif2/src/pomp_internal.h
branches/premif2/src/pomp_mat.h
branches/premif2/src/probe.c
branches/premif2/src/probe_acf.c
branches/premif2/src/probe_marginal.c
branches/premif2/src/probe_nlar.c
branches/premif2/src/ricker.c
branches/premif2/src/rmeasure.c
branches/premif2/src/rprocess.c
branches/premif2/src/simulate.c
branches/premif2/src/sir.c
branches/premif2/src/skeleton.c
branches/premif2/src/sobol.f
branches/premif2/src/synth_lik.c
branches/premif2/src/trajectory.c
branches/premif2/src/tsir.c
branches/premif2/src/userdata.c
branches/premif2/tests/bbs-trajmatch.R
branches/premif2/tests/bbs-trajmatch.Rout.save
branches/premif2/tests/bbs.R
branches/premif2/tests/bbs.Rout.save
branches/premif2/tests/blowflies.R
branches/premif2/tests/blowflies.Rout.save
branches/premif2/tests/dacca.R
branches/premif2/tests/dacca.Rout.save
branches/premif2/tests/dimchecks.R
branches/premif2/tests/dimchecks.Rout.save
branches/premif2/tests/fhn.R
branches/premif2/tests/fhn.Rout.save
branches/premif2/tests/filtfail.R
branches/premif2/tests/filtfail.Rout.save
branches/premif2/tests/gillespie.R
branches/premif2/tests/gillespie.Rout.save
branches/premif2/tests/gompertz.R
branches/premif2/tests/gompertz.Rout.save
branches/premif2/tests/logistic.R
branches/premif2/tests/logistic.Rout.save
branches/premif2/tests/ou2-bsmc.R
branches/premif2/tests/ou2-bsmc.Rout.save
branches/premif2/tests/ou2-forecast.R
branches/premif2/tests/ou2-forecast.Rout.save
branches/premif2/tests/ou2-icfit.R
branches/premif2/tests/ou2-icfit.Rout.save
branches/premif2/tests/ou2-kalman.R
branches/premif2/tests/ou2-kalman.Rout.save
branches/premif2/tests/ou2-mif-fp.R
branches/premif2/tests/ou2-mif-fp.Rout.save
branches/premif2/tests/ou2-mif.R
branches/premif2/tests/ou2-mif.Rout.save
branches/premif2/tests/ou2-nlf.R
branches/premif2/tests/ou2-nlf.Rout.save
branches/premif2/tests/ou2-pmcmc.R
branches/premif2/tests/ou2-pmcmc.Rout.save
branches/premif2/tests/ou2-probe.R
branches/premif2/tests/ou2-probe.Rout.save
branches/premif2/tests/ou2-procmeas.R
branches/premif2/tests/ou2-procmeas.Rout.save
branches/premif2/tests/ou2-simulate.R
branches/premif2/tests/ou2-simulate.Rout.save
branches/premif2/tests/ou2-trajmatch.R
branches/premif2/tests/ou2-trajmatch.Rout.save
branches/premif2/tests/partrans.R
branches/premif2/tests/partrans.Rout.save
branches/premif2/tests/pfilter.R
branches/premif2/tests/pfilter.Rout.save
branches/premif2/tests/pomppomp.R
branches/premif2/tests/pomppomp.Rout.save
branches/premif2/tests/ricker-bsmc.R
branches/premif2/tests/ricker-bsmc.Rout.save
branches/premif2/tests/ricker-probe.R
branches/premif2/tests/ricker-probe.Rout.save
branches/premif2/tests/ricker-spect.R
branches/premif2/tests/ricker-spect.Rout.save
branches/premif2/tests/ricker.R
branches/premif2/tests/ricker.Rout.save
branches/premif2/tests/rw2.R
branches/premif2/tests/rw2.Rout.save
branches/premif2/tests/sir.R
branches/premif2/tests/sir.Rout.save
branches/premif2/tests/skeleton.R
branches/premif2/tests/skeleton.Rout.save
branches/premif2/tests/steps.R
branches/premif2/tests/steps.Rout.save
branches/premif2/tests/synlik.R
branches/premif2/tests/synlik.Rout.save
branches/premif2/tests/verhulst.R
branches/premif2/tests/verhulst.Rout.save
Log:
- remove unneeded 'branches' directory
Deleted: branches/premif2/.Rbuildignore
===================================================================
--- branches/premif2/.Rbuildignore 2014-06-27 19:50:35 UTC (rev 988)
+++ branches/premif2/.Rbuildignore 2014-06-29 12:21:37 UTC (rev 989)
@@ -1,6 +0,0 @@
-inst/doc/Makefile
-inst/data-R/Makefile
-inst/data-R/make.R
-inst/doc/(.+?)\.bst$
-inst/doc/(.+?)\.R$
-inst/doc/(.+?)\.png$
Deleted: branches/premif2/.Rinstignore
===================================================================
--- branches/premif2/.Rinstignore 2014-06-27 19:50:35 UTC (rev 988)
+++ branches/premif2/.Rinstignore 2014-06-29 12:21:37 UTC (rev 989)
@@ -1,3 +0,0 @@
-inst/doc/Makefile
-inst/doc/fullnat.bst
-inst/doc/(.+?)\.rda$
Deleted: branches/premif2/DESCRIPTION
===================================================================
--- branches/premif2/DESCRIPTION 2014-06-27 19:50:35 UTC (rev 988)
+++ branches/premif2/DESCRIPTION 2014-06-29 12:21:37 UTC (rev 989)
@@ -1,33 +0,0 @@
-Package: pomp
-Type: Package
-Title: Statistical inference for partially observed Markov processes
-Version: 0.43-9
-Date: 2013-06-03
-Maintainer: Aaron A. King
-Authors at R: c(person(given=c("Aaron","A."),family="King",role=c("aut","cre"),email="kingaa at umich.edu"),
- person(given=c("Edward","L."),family="Ionides",role=c("aut")),
- person(given=c("Carles"),family="Breto",role=c("aut")),
- person(given=c("Stephen","P."),family="Ellner",role=c("ctb")),
- person(given=c("Matthew","J."),family="Ferrari",role=c("ctb")),
- person(given=c("Bruce","E."),family="Kendall",role=c("ctb")),
- person(given=c("Michael"),family="Lavine",role=c("ctb")),
- person(given=c("Daniel","C."),family="Reuman",role=c("ctb")),
- person(given=c("Helen"),family="Wearing",role=c("ctb")),
- person(given=c("Simon","N."),family="Wood",role=c("ctb")))
-URL: http://pomp.r-forge.r-project.org
-Description: Inference methods for partially-observed Markov processes
-Depends: R(>= 2.14.1), stats, methods, graphics, mvtnorm, subplex, deSolve
-License: GPL(>= 2)
-LazyLoad: true
-LazyData: false
-BuildVignettes: no
-Collate: aaa.R authors.R version.R eulermultinom.R plugins.R
- parmat.R slice-design.R profile-design.R sobol.R bsplines.R sannbox.R
- pomp-fun.R pomp.R pomp-methods.R rmeasure-pomp.R rprocess-pomp.R init-state-pomp.R
- dmeasure-pomp.R dprocess-pomp.R skeleton-pomp.R simulate-pomp.R trajectory-pomp.R plot-pomp.R
- pfilter.R pfilter-methods.R traj-match.R bsmc.R
- mif-class.R particles-mif.R mif.R mif-methods.R compare-mif.R
- pmcmc.R pmcmc-methods.R compare-pmcmc.R
- nlf-funcs.R nlf-guts.R nlf-objfun.R nlf.R
- probe.R probe-match.R basic-probes.R spect.R spect-match.R
- builder.R
Deleted: branches/premif2/NAMESPACE
===================================================================
--- branches/premif2/NAMESPACE 2014-06-27 19:50:35 UTC (rev 988)
+++ branches/premif2/NAMESPACE 2014-06-29 12:21:37 UTC (rev 989)
@@ -1,97 +0,0 @@
-useDynLib(
- pomp,
- get_pomp_fun,
- bspline_basis,
- periodic_bspline_basis,
- bspline_basis_function,
- systematic_resampling,
- euler_model_simulator,
- euler_model_density,
- lookup_in_table,
- SSA_simulator,
- R_Euler_Multinom,D_Euler_Multinom,R_GammaWN,
- pfilter_computations,
- simulation_computations,
- iterate_map,traj_transp_and_copy,
- apply_probe_data,apply_probe_sim,
- probe_marginal_setup,probe_marginal_solve,
- probe_acf,probe_ccf,
- probe_nlar,
- synth_loglik,
- pomp_desolve_setup,pomp_desolve_takedown,
- pomp_vf_eval,
- do_partrans,
- do_rprocess,
- do_dprocess,
- do_rmeasure,
- do_dmeasure,
- do_skeleton,
- do_init_state
- )
-
-importFrom(graphics,plot)
-importFrom(stats,simulate,time,coef,logLik,window)
-importFrom(mvtnorm,dmvnorm,rmvnorm)
-importFrom(subplex,subplex)
-importFrom(deSolve,ode)
-
-exportClasses(
- pomp,
- pfilterd.pomp,
- mif,
- pmcmc,
- traj.matched.pomp,
- probed.pomp,probe.matched.pomp,
- spect.pomp,spect.matched.pomp
- )
-
-exportMethods(
- pomp,
- plot,show,print,coerce,summary,logLik,window,"$",
- dprocess,rprocess,rmeasure,dmeasure,init.state,skeleton,
- data.array,obs,partrans,coef,"coef<-",time,"time<-",timezero,"timezero<-",
- simulate,pfilter,
- eff.sample.size,cond.logLik,
- particles,mif,continue,states,trajectory,
- pred.mean,pred.var,filter.mean,conv.rec,
- bsmc,
- pmcmc,dprior,
- spect,probe,
- probe.match,traj.match
- )
-
-export(
- as.data.frame.pomp,
- as.data.frame.pfilterd.pomp,
- reulermultinom,
- deulermultinom,
- rgammawn,
- euler.sim,
- discrete.time.sim,
- onestep.sim,
- onestep.dens,
- gillespie.sim,
- sobol,
- sobolDesign,
- sliceDesign,
- profileDesign,
- bspline.basis,
- periodic.bspline.basis,
- compare.mif,
- nlf,
- parmat,
- probe.mean,
- probe.median,
- probe.var,
- probe.sd,
- probe.period,
- probe.quantile,
- probe.acf,
- probe.ccf,
- probe.nlar,
- probe.marginal,
- sannbox,
- spect.match,
- traj.match.objfun,
- pompBuilder
- )
Deleted: branches/premif2/R/aaa.R
===================================================================
--- branches/premif2/R/aaa.R 2014-06-27 19:50:35 UTC (rev 988)
+++ branches/premif2/R/aaa.R 2014-06-29 12:21:37 UTC (rev 989)
@@ -1,25 +0,0 @@
-## .onAttach <- function (...) {
-## version <- library(help=pomp)$info[[1]]
-## version <- strsplit(version[pmatch("Version",version)]," ")[[1]]
-## version <- version[nchar(version)>0][2]
-## packageStartupMessage("This is pomp version ",version,"\n")
-## }
-
-setGeneric("print",function(x,...)standardGeneric("print"))
-setGeneric("plot",function(x,y,...)standardGeneric("plot"))
-setGeneric("summary",function(object,...)standardGeneric("summary"))
-setGeneric("simulate",function(object,nsim=1,seed=NULL,...)standardGeneric("simulate"))
-setGeneric("time",function(x,...)standardGeneric("time"))
-setGeneric("coef",function(object,...)standardGeneric("coef"))
-setGeneric("logLik",function(object,...)standardGeneric("logLik"))
-setGeneric("window",function(x,...)standardGeneric("window"))
-setGeneric("continue",function(object,...)standardGeneric("continue"))
-setGeneric("pred.mean",function(object,...)standardGeneric("pred.mean"))
-setGeneric("pred.var",function(object,...)standardGeneric("pred.var"))
-setGeneric("filter.mean",function(object,...)standardGeneric("filter.mean"))
-setGeneric("cond.logLik",function(object,...)standardGeneric("cond.logLik"))
-setGeneric("eff.sample.size",function(object,...)standardGeneric("eff.sample.size"))
-
-if (!exists("paste0",where="package:base")) {
- paste0 <- function(...) paste(...,sep="")
-}
Deleted: branches/premif2/R/authors.R
===================================================================
--- branches/premif2/R/authors.R 2014-06-27 19:50:35 UTC (rev 988)
+++ branches/premif2/R/authors.R 2014-06-29 12:21:37 UTC (rev 989)
@@ -1,12 +0,0 @@
-list(
- aak=person(given=c("Aaron","A."),family="King",role=c("aut","cre"),email="kingaa at umich.edu"),
- eli=person(given=c("Edward","L."),family="Ionides",role=c("ctb")),
- cb=person(given=c("Carles"),family="Breto",role=c("ctb")),
- spe=person(given=c("Stephen","P."),family="Ellner",role=c("ctb")),
- bek=person(given=c("Bruce","E."),family="Kendall",role=c("ctb")),
- mf=person(given=c("Matthew","J."),family="Ferrari",role=c("ctb")),
- ml=person(given=c("Michael"),family="Lavine",role=c("ctb")),
- dcr=person(given=c("Daniel","C."),family="Reuman",role=c("ctb")),
- hw=person(given=c("Helen"),family="Wearing",role=c("ctb")),
- snw=person(given=c("Simon","N."),family="Wood",role=c("ctb"))
- ) -> author.list
Deleted: branches/premif2/R/basic-probes.R
===================================================================
--- branches/premif2/R/basic-probes.R 2014-06-27 19:50:35 UTC (rev 988)
+++ branches/premif2/R/basic-probes.R 2014-06-29 12:21:37 UTC (rev 989)
@@ -1,176 +0,0 @@
-probe.mean <- function (var, trim = 0, transform = identity, na.rm = TRUE) {
- if (length(var)>1) stop(sQuote("probe.mean")," is a univariate probe")
- transform <- match.fun(transform)
- function(y) mean(x=transform(y[var,]),trim=trim,na.rm=na.rm)
-}
-
-probe.median <- function (var, na.rm = TRUE) {
- if (length(var)>1) stop(sQuote("probe.median")," is a univariate probe")
- function(y) median(x=as.numeric(y[var,]),na.rm=na.rm)
-}
-
-probe.var <- function (var, transform = identity, na.rm = TRUE) {
- if (length(var)>1) stop(sQuote("probe.var")," is a univariate probe")
- transform <- match.fun(transform)
- function(y) var(x=transform(y[var,]),na.rm=na.rm)
-}
-
-probe.sd <- function (var, transform = identity, na.rm = TRUE) {
- if (length(var)>1) stop(sQuote("probe.sd")," is a univariate probe")
- transform <- match.fun(transform)
- function(y) sd(x=transform(y[var,]),na.rm=na.rm)
-}
-
-probe.period <- function (var, kernel.width, transform = identity) {
- if (length(var)>1) stop(sQuote("probe.period")," is a univariate probe")
- transform <- match.fun(transform)
- function (y) {
- zz <- spec.pgram(
- x=transform(y[var,]),
- kernel=kernel("modified.daniell",m=kernel.width),
- taper=0,
- fast=FALSE,
- pad=0,
- detrend=FALSE,
- plot=FALSE
- )
- 1/zz$freq[which.max(zz$spec)]
- }
-}
-
-probe.quantile <- function (var, prob, transform = identity) {
- if (length(var)>1) stop(sQuote("probe.quantile")," is a univariate probe")
- transform <- match.fun(transform)
- function (y) quantile(transform(y[var,]),probs=prob)
-}
-
-probe.cov <- function (
- vars,
- lag,
- method = c("pearson", "kendall", "spearman"),
- transform = identity
- ) {
- method <- match.arg(method)
- lag <- as.integer(lag)
- transform <- match.fun(transform)
- var1 <- vars[1]
- if (length(vars)>1)
- var2 <- vars[2]
- else
- var2 <- var1
- function (y) {
- if (lag>=0) {
- val <- cov(
- x=transform(y[var1,seq(from=1+lag,to=ncol(y),by=1)]),
- y=transform(y[var2,seq(from=1,to=ncol(y)-lag,by=1)]),
- method=method
- )
- } else {
- val <- cov(
- x=transform(y[var1,seq(from=1,to=ncol(y)+lag,by=1)]),
- y=transform(y[var2,seq(from=-lag,to=ncol(y),by=1)]),
- method=method
- )
- }
- val
- }
-}
-
-probe.cor <- function (
- vars,
- lag,
- method = c("pearson", "kendall", "spearman"),
- transform = identity
- ) {
- method <- match.arg(method)
- lag <- as.integer(lag)
- transform <- match.fun(transform)
- var1 <- vars[1]
- if (length(vars)>1)
- var2 <- vars[2]
- else
- var2 <- var1
- function (y) {
- if (lag>=0) {
- val <- cor(
- x=transform(y[var1,seq(from=1+lag,to=ncol(y),by=1)]),
- y=transform(y[var2,seq(from=1,to=ncol(y)-lag,by=1)]),
- method=method
- )
- } else {
- val <- cor(
- x=transform(y[var1,seq(from=1,to=ncol(y)+lag,by=1)]),
- y=transform(y[var2,seq(from=-lag,to=ncol(y),by=1)]),
- method=method
- )
- }
- val
- }
-}
-
-probe.acf <- function (var, lags, type = c("covariance", "correlation"), transform = identity) {
- type <- match.arg(type)
- corr <- type=="correlation"
- transform <- match.fun(transform)
- if (corr && any(lags==0)) {
- warning("useless zero lag discarded in ",sQuote("probe.acf"))
- lags <- lags[lags!=0]
- }
- lags <- as.integer(lags)
- function (y) .Call(
- probe_acf,
- x=transform(y[var,,drop=FALSE]),
- lags=lags,
- corr=corr
- )
-}
-
-probe.ccf <- function (vars, lags, type = c("covariance", "correlation"), transform = identity) {
- type <- match.arg(type)
- corr <- type=="correlation"
- transform <- match.fun(transform)
- if (length(vars)!=2)
- stop(sQuote("vars")," must name two variables")
- lags <- as.integer(lags)
- function (y) .Call(
- probe_ccf,
- x=transform(y[vars[1],,drop=TRUE]),
- y=transform(y[vars[2],,drop=TRUE]),
- lags=lags,
- corr=corr
- )
-}
-
-probe.marginal <- function (var, ref, order = 3, diff = 1, transform = identity) {
- if (length(var)>1) stop(sQuote("probe.marginal")," is a univariate probe")
- transform <- match.fun(transform)
- setup <- .Call(probe_marginal_setup,transform(ref),order,diff)
- function (y) .Call(
- probe_marginal_solve,
- x=transform(y[var,,drop=TRUE]),
- setup=setup,
- diff=diff
- )
-}
-
-probe.nlar <- function (var, lags, powers, transform = identity) {
- if (length(var)>1) stop(sQuote("probe.nlar")," is a univariate probe")
- transform <- match.fun(transform)
- if (any(lags<1)||any(powers<1))
- stop(sQuote("lags")," and ",sQuote("powers")," must be positive integers")
- if (length(lags)1) stop(sQuote("lags")," must match ",sQuote("powers")," in length, or have length 1")
- lags <- rep(lags,length(powers))
- } else if (length(lags)>length(powers)) {
- if (length(powers)>1) stop(sQuote("powers")," must match ",sQuote("lags")," in length, or have length 1")
- powers <- rep(powers,length(lags))
- }
- lags <- as.integer(lags)
- powers <- as.integer(powers)
- function (y) .Call(
- probe_nlar,
- x=transform(y[var,,drop=TRUE]),
- lags=lags,
- powers=powers
- )
-}
Deleted: branches/premif2/R/bsmc.R
===================================================================
--- branches/premif2/R/bsmc.R 2014-06-27 19:50:35 UTC (rev 988)
+++ branches/premif2/R/bsmc.R 2014-06-29 12:21:37 UTC (rev 989)
@@ -1,409 +0,0 @@
-## Bayesian particle filtering codes
-##
-## in annotation L&W AGM == Liu & West "A General Algorithm"
-##
-## params = the initial particles for the parameter values;
-## these should be drawn from the prior distribution for the parameters
-## est = names of parameters to estimate; other parameters are not updated.
-## smooth = parameter 'h' from AGM
-## ntries = number of samplesto draw from x_{t+1} | x(k)_{t} to estimate
-## mean of mu(k)_t+1 as in sect 2.2 Liu & West
-## lower = lower bounds on prior
-## upper = upper bounds on prior
-
-setClass(
- "bsmcd.pomp",
- contains="pomp",
- representation=representation(
- transform="logical",
- post="array",
- prior="array",
- est="character",
- eff.sample.size="numeric",
- smooth="numeric",
- seed="integer",
- nfail="integer",
- cond.log.evidence="numeric",
- log.evidence="numeric",
- weights="numeric"
- )
- )
-
-setGeneric("bsmc",function(object,...)standardGeneric("bsmc"))
-
-setMethod(
- "bsmc",
- "pomp",
- function (object, params, Np, est,
- smooth = 0.1,
- ntries = 1,
- tol = 1e-17,
- lower = -Inf, upper = Inf,
- seed = NULL,
- verbose = getOption("verbose"),
- max.fail = 0,
- transform = FALSE,
- ...) {
-
- transform <- as.logical(transform)
-
- if (missing(seed)) seed <- NULL
- if (!is.null(seed)) {
- if (!exists(".Random.seed",where=.GlobalEnv))
- runif(1) ## need to initialize the RNG
- save.seed <- get(".Random.seed",pos=.GlobalEnv)
- set.seed(seed)
- }
-
- error.prefix <- paste(sQuote("bsmc"),"error: ")
-
- if (missing(params)) {
- if (length(coef(object))>0) {
- params <- coef(object)
- } else {
- stop(error.prefix,sQuote("params")," must be supplied",call.=FALSE)
- }
- }
-
- if (missing(Np)) Np <- NCOL(params)
- else if (is.matrix(params)&&(Np!=ncol(params)))
- warning(sQuote("Np")," is ignored when ",sQuote("params")," is a matrix")
-
- if (transform)
- params <- partrans(object,params,dir="inverse")
-
- ntimes <- length(time(object))
- if (is.null(dim(params))) {
- params <- matrix(
- params,
- nrow=length(params),
- ncol=Np,
- dimnames=list(
- names(params),
- NULL
- )
- )
- }
-
- npars <- nrow(params)
- paramnames <- rownames(params)
- prior <- params
-
- if (missing(est))
- est <- paramnames[apply(params,1,function(x)diff(range(x))>0)]
- estind <- match(est,paramnames)
- npars.est <- length(estind)
-
- if (npars.est<1)
- stop(error.prefix,"no parameters to estimate",call.=FALSE)
-
- if (is.null(paramnames))
- stop(error.prefix,sQuote("params")," must have rownames",call.=FALSE)
-
- if ((length(smooth)!=1)||(smooth>1)||(smooth<=0))
- stop(error.prefix,sQuote("smooth")," must be a scalar in [0,1)",call.=FALSE)
-
- hsq <- smooth^2 # see Liu & West eq(3.6) p10
- shrink <- sqrt(1-hsq)
-
- if (
- ((length(lower)>1)&&(length(lower)!=npars.est))||
- ((length(upper)>1)&&(length(upper)!=npars.est))
- ) {
- stop(
- error.prefix,
- sQuote("lower")," and ",sQuote("upper"),
- " must each have length 1 or length equal to that of ",sQuote("est"),
- call.=FALSE
- )
- }
-
- for (j in seq_len(Np)) {
- if (any((params[estind,j]upper))) {
- ind <- which((params[estind,j]upper))
- stop(
- error.prefix,
- "parameter(s) ",paste(paramnames[estind[ind]],collapse=","),
- " in column ",j," in ",sQuote("params"),
- " is/are outside the box defined by ",
- sQuote("lower")," and ",sQuote("upper"),
- call.=FALSE
- )
- }
- }
-
- xstart <- init.state(
- object,
- params=if (transform) {
- partrans(object,params,dir="forward")
- } else {
- params
- }
- )
- statenames <- rownames(xstart)
- nvars <- nrow(xstart)
-
- times <- time(object,t0=TRUE)
- x <- xstart
-
- evidence <- rep(NA,ntimes)
- eff.sample.size <- rep(NA,ntimes)
- nfail <- 0
-
- mu <- array(data=NA,dim=c(nvars,Np,1))
- rownames(mu) <- rownames(xstart)
- m <- array(data=NA,dim=c(npars,Np))
- rownames(m) <- rownames(params)
-
- for (nt in seq_len(ntimes)) {
-
- ## calculate particle means ; as per L&W AGM (1)
- params.mean <- apply(params,1,mean)
- ## calculate particle covariances : as per L&W AGM (1)
- params.var <- cov(t(params[estind,,drop=FALSE]))
-
- if (verbose) {
- cat("at step",nt,"(time =",times[nt+1],")\n")
- print(
- rbind(
- prior.mean=params.mean[estind],
- prior.sd=sqrt(diag(params.var))
- )
- )
- }
-
- ## update mean of states at time nt as per L&W AGM (1)
- tries <- rprocess(
- object,
- xstart=parmat(x,nrep=ntries),
- times=times[c(nt,nt+1)],
- params=if (transform) {
- partrans(object,params,dir="forward")
- } else {
- params
- },
- offset=1
- )
- dim(tries) <- c(nvars,Np,ntries,1)
- mu <- apply(tries,c(1,2,4),mean)
- rownames(mu) <- statenames
- ## shrink parameters towards mean as per Liu & West eq (3.3) and L&W AGM (1)
- m <- shrink*params+(1-shrink)*params.mean
-
- ## evaluate probability of obervation given mean value of parameters and states (used in L&W AGM (5) below)
- g <- dmeasure(
- object,
- y=object at data[,nt,drop=FALSE],
- x=mu,
- times=times[nt+1],
- params=if (transform) {
- partrans(object,m,dir="forward")
- } else {
- m
- }
- )
- storeForEvidence1 <- log(sum(g))
- ## sample indices -- From L&W AGM (2)
-## k <- .Call(systematic_resampling,g)
- k <- sample.int(n=Np,size=Np,replace=TRUE,prob=g)
- params <- params[,k]
- m <- m[,k]
- g <- g[k]
-
- ## sample new parameter vector as per L&W AGM (3) and Liu & West eq(3.2)
- pvec <- try(
- mvtnorm::rmvnorm(
- n=Np,
- mean=rep(0,npars.est),
- sigma=hsq*params.var,
- method="svd"
- ),
- silent=FALSE
- )
- if (inherits(pvec,"try-error"))
- stop(error.prefix,"error in ",sQuote("rmvnorm"),call.=FALSE)
- if (any(!is.finite(pvec)))
- stop(error.prefix,"extreme particle depletion",call.=FALSE)
- params[estind,] <- m[estind,]+t(pvec)
-
- if (transform)
- tparams <- partrans(object,params,dir="forward")
-
- ## sample current state vector x^(g)_(t+1) as per L&W AGM (4)
- X <- rprocess(
- object,
- xstart=x[,k,drop=FALSE],
- times=times[c(nt,nt+1)],
- params=if (transform) {
- tparams
- } else {
- params
- },
- offset=1
- )
-
- ## evaluate likelihood of observation given X (from L&W AGM (4))
- numer <- dmeasure(
- object,
- y=object at data[,nt,drop=FALSE],
- x=X,
- times=times[nt+1],
- params=if (transform) {
- tparams
- } else {
- params
- }
- )
- ## evaluate weights as per L&W AGM (5)
-
- weights <- numer/g
- storeForEvidence2 <- log(mean(weights))
-
- ## apply box constraints as per the priors
- for (j in seq_len(Np)) {
- ## the following seems problematic: will it tend to make the boundaries repellors
- if (any((params[estind,j]upper))) {
- weights[j] <- 0
- }
- ## might this rejection method be preferable?
- ## while (any((params[estind,j]upper))) {
- ## ## rejection method
- ## pvec <- try(
- ## mvtnorm::rmvnorm(
- ## n=1,
- ## mean=rep(0,npars.est),
- ## sigma=hsq*params.var,
- ## method="eigen"
- ## ),
- ## silent=FALSE
- ## )
- ## if (inherits(pvec,"try-error"))
- ## stop(error.prefix,"error in ",sQuote("rmvnorm"),call.=FALSE)
- ## if (any(!is.finite(pvec)))
- ## stop(error.prefix,"extreme particle depletion",call.=FALSE)
- ## params[estind,j] <- m[estind,j]+pvec[1,]
- ## }
- }
-
- x[,] <- X
-
- ## test for failure to filter
- dim(weights) <- NULL
- failures <- ((weights
Author: kingaa
Date: 2014-06-29 15:22:21 +0200 (Sun, 29 Jun 2014)
New Revision: 990
Modified:
pkg/Makefile
Log:
- update Makefile
Modified: pkg/Makefile
===================================================================
--- pkg/Makefile 2014-06-29 12:21:37 UTC (rev 989)
+++ pkg/Makefile 2014-06-29 13:22:21 UTC (rev 990)
@@ -144,10 +144,10 @@
$(RSCRIPT) pkgindex.R
%.tex: %.Rnw
- $(RCMD) Sweave $*
+ $(RSCRIPT) -e "library(knitr); knit(\"$*.Rnw\")"
%.R: %.Rnw
- $(RCMD) Stangle $*
+ $(RSCRIPT) -e "library(knitr); purl(\"$*.Rnw\")"
%.pdf: %.tex
$(PDFLATEX) $*
@@ -166,6 +166,7 @@
$(MAKEIDX) $*
clean:
- $(RM) *.o *.so *.tex *.log *.aux *.out *.nav *.snm *.toc *-???.pdf Rplots.ps Rplots.pdf
+ $(RM) *.o *.so *.tex *.log *.aux *.out *.nav *.snm *.toc *.bak
+ $(RM) Rplots.ps Rplots.pdf
.SECONDARY: