[Pomp-commits] r739 - in pkg/pomp: R man tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jun 29 23:10:09 CEST 2012
Author: kingaa
Date: 2012-06-29 23:10:08 +0200 (Fri, 29 Jun 2012)
New Revision: 739
Added:
pkg/pomp/tests/bbs-trajmatch.R
pkg/pomp/tests/bbs-trajmatch.Rout.save
Modified:
pkg/pomp/R/traj-match.R
pkg/pomp/man/traj-match.Rd
Log:
- extra arguments (...) to 'traj.match.objfun' are now passed on to the ODE integrator in case the skeleton is a vectorfield
Modified: pkg/pomp/R/traj-match.R
===================================================================
--- pkg/pomp/R/traj-match.R 2012-06-29 16:17:17 UTC (rev 738)
+++ pkg/pomp/R/traj-match.R 2012-06-29 21:10:08 UTC (rev 739)
@@ -32,7 +32,7 @@
}
)
-traj.match.objfun <- function (object, params, est, transform = FALSE) {
+traj.match.objfun <- function (object, params, est, transform = FALSE, ...) {
transform <- as.logical(transform)
if (missing(est)) est <- character(0)
@@ -53,7 +53,7 @@
d <- dmeasure(
object,
y=object at data,
- x=trajectory(object,params=tparams),
+ x=trajectory(object,params=tparams,...),
times=time(object),
params=tparams,
log=TRUE
@@ -62,7 +62,7 @@
d <- dmeasure(
object,
y=object at data,
- x=trajectory(object,params=params),
+ x=trajectory(object,params=params,...),
times=time(object),
params=params,
log=TRUE
Modified: pkg/pomp/man/traj-match.Rd
===================================================================
--- pkg/pomp/man/traj-match.Rd 2012-06-29 16:17:17 UTC (rev 738)
+++ pkg/pomp/man/traj-match.Rd 2012-06-29 21:10:08 UTC (rev 739)
@@ -25,7 +25,7 @@
\S4method{traj.match}{traj.matched.pomp}(object, start, est,
method = c("Nelder-Mead","subplex","SANN","BFGS","sannbox"),
gr = NULL, eval.only = FALSE, transform, \dots)
-traj.match.objfun(object, params, est, transform = FALSE)
+traj.match.objfun(object, params, est, transform = FALSE, \dots)
}
\arguments{
\item{object}{
@@ -63,7 +63,10 @@
if \code{TRUE}, optimization is performed on the transformed scale.
}
\item{\dots}{
- Arguments that will be passed to \code{\link{optim}}, \code{\link[subplex]{subplex}} or \code{\link{sannbox}}, via their \code{control} lists.
+ Extra arguments that will be passed either to the optimizer (\code{\link{optim}}, \code{\link[subplex]{subplex}} or \code{\link{sannbox}}, via their \code{control} lists) or to the ODE integrator.
+ In \code{traj.match}, extra arguments will be passed to the optimizer.
+ In \code{traj.match.objfun}, extra arguments are passed to the ODE integrator, but only if an ODE integrator is called, i.e., only when the deterministic skeleton is a vectorfield.
+ If extra arguments are needed by both optimizer and ODE integrator, construct an objective function first using \code{traj.match.objfun}, then give this objective function to the optimizer.
}
}
\details{
@@ -137,6 +140,10 @@
data(ricker)
ofun <- traj.match.objfun(ricker,est=c("r","phi"),transform=TRUE)
optim(fn=ofun,par=c(2,0),method="BFGS")
+
+ data(bbs)
+ ofun <- traj.match.objfun(bbs,est=c("beta","gamma"),transform=TRUE,hmax=0.001)
+ optim(fn=ofun,par=c(0,-1),method="Nelder-Mead")
}
\seealso{
\code{\link{trajectory}},
Added: pkg/pomp/tests/bbs-trajmatch.R
===================================================================
--- pkg/pomp/tests/bbs-trajmatch.R (rev 0)
+++ pkg/pomp/tests/bbs-trajmatch.R 2012-06-29 21:10:08 UTC (rev 739)
@@ -0,0 +1,28 @@
+library(pomp)
+
+data(bbs)
+
+guess <- c(
+ mu=0,gamma=1/3,beta=1,beta.sd=0,iota=0,
+ pop=1400,rho=0.9,sigma=3.6,
+ S.0=1390,I.0=1,R.0=0
+ )
+est <- c("beta","gamma")
+
+tj1 <- trajectory(bbs,params=guess,as.data.frame=TRUE)
+tail(tj1)
+
+tj2 <- trajectory(bbs,params=guess,hmax=0.001,as.data.frame=TRUE)
+tail(tj2)
+
+tm1 <- traj.match(bbs,start=guess,transform=TRUE,est=est,method="subplex",reltol=1e-7)
+
+tmf <- traj.match.objfun(bbs,params=guess,est=est,transform=TRUE,hmax=0.001)
+
+fit <- subplex(fn=tmf,par=log(guess[est]),control=list(reltol=1e-7))
+tm2 <- bbs
+coef(tm2) <- guess
+coef(tm2,names(fit$par),transform=T) <- fit$par
+
+round(coef(tm1,est)/coef(tm2,est),5)
+
Added: pkg/pomp/tests/bbs-trajmatch.Rout.save
===================================================================
--- pkg/pomp/tests/bbs-trajmatch.Rout.save (rev 0)
+++ pkg/pomp/tests/bbs-trajmatch.Rout.save 2012-06-29 21:10:08 UTC (rev 739)
@@ -0,0 +1,71 @@
+
+R version 2.15.1 (2012-06-22) -- "Roasted Marshmallows"
+Copyright (C) 2012 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+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.
+
+> library(pomp)
+Loading required package: mvtnorm
+Loading required package: subplex
+Loading required package: deSolve
+>
+> data(bbs)
+>
+> guess <- c(
++ mu=0,gamma=1/3,beta=1,beta.sd=0,iota=0,
++ pop=1400,rho=0.9,sigma=3.6,
++ S.0=1390,I.0=1,R.0=0
++ )
+> est <- c("beta","gamma")
+>
+> tj1 <- trajectory(bbs,params=guess,as.data.frame=TRUE)
+> tail(tj1)
+ S I R cases W time traj
+9 1004.7078 240.7973 154.4950 65.49148 0 9 1
+10 818.5872 331.3108 250.1020 95.60710 0 10 1
+11 629.5161 397.8216 372.6623 122.56026 0 11 1
+12 468.6154 420.9769 510.4077 137.74540 0 12 1
+13 348.4464 402.8738 648.6798 138.27211 0 13 1
+14 265.1901 358.7123 776.0977 127.41785 0 14 1
+>
+> tj2 <- trajectory(bbs,params=guess,hmax=0.001,as.data.frame=TRUE)
+> tail(tj2)
+ S I R cases W time traj
+9 1004.7078 240.7971 154.4951 65.49145 0 9 1
+10 818.5872 331.3107 250.1021 95.60696 0 10 1
+11 629.5156 397.8220 372.6624 122.56036 0 11 1
+12 468.6150 420.9770 510.4080 137.74558 0 12 1
+13 348.4463 402.8736 648.6801 138.27206 0 13 1
+14 265.1899 358.7122 776.0979 127.41782 0 14 1
+>
+> tm1 <- traj.match(bbs,start=guess,transform=TRUE,est=est,method="subplex",reltol=1e-7)
+>
+> tmf <- traj.match.objfun(bbs,params=guess,est=est,transform=TRUE,hmax=0.001)
+>
+> fit <- subplex(fn=tmf,par=log(guess[est]),control=list(reltol=1e-7))
+> tm2 <- bbs
+> coef(tm2) <- guess
+> coef(tm2,names(fit$par),transform=T) <- fit$par
+Warning message:
+in 'coef<-' names of 'value' are being discarded
+>
+> round(coef(tm1,est)/coef(tm2,est),5)
+ beta gamma
+ 1 1
+>
+>
+> proc.time()
+ user system elapsed
+ 2.180 0.032 2.236
More information about the pomp-commits
mailing list