From noreply at r-forge.r-project.org Sun Mar 10 21:49:19 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 10 Mar 2013 21:49:19 +0100 (CET) Subject: [Pomp-commits] r831 - pkg/pomp/R Message-ID: <20130310204919.646B5184B6A@r-forge.r-project.org> Author: kingaa Date: 2013-03-10 21:49:19 +0100 (Sun, 10 Mar 2013) New Revision: 831 Modified: pkg/pomp/R/mif.R Log: - throw error in 'mif' when cooling.fraction=1 and method='mif2' Modified: pkg/pomp/R/mif.R =================================================================== --- pkg/pomp/R/mif.R 2013-02-28 05:48:56 UTC (rev 830) +++ pkg/pomp/R/mif.R 2013-03-10 20:49:19 UTC (rev 831) @@ -34,6 +34,13 @@ } }, hyperbolic={ + if (fraction>=1) + stop( + "mif error: ",sQuote("cooling.fraction"), + " must be < 1 when cooling.type = ", + sQuote("hyperbolic") + call.=FALSE + ) if (perobs) { scal <- (50*ntimes*fraction-1)/(1-fraction) function (nt, m) { From noreply at r-forge.r-project.org Sun Mar 10 21:58:03 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 10 Mar 2013 21:58:03 +0100 (CET) Subject: [Pomp-commits] r832 - in pkg/pomp: inst/examples tests Message-ID: <20130310205803.E63E2184B6A@r-forge.r-project.org> Author: kingaa Date: 2013-03-10 21:58:03 +0100 (Sun, 10 Mar 2013) New Revision: 832 Modified: pkg/pomp/inst/examples/bbs.R pkg/pomp/inst/examples/blowflies.R pkg/pomp/inst/examples/euler.sir.R pkg/pomp/inst/examples/gillespie.sir.R pkg/pomp/inst/examples/gompertz.R pkg/pomp/inst/examples/ou2.R pkg/pomp/inst/examples/ricker.R pkg/pomp/inst/examples/rw2.R pkg/pomp/inst/examples/verhulst.R pkg/pomp/tests/filtfail.R pkg/pomp/tests/filtfail.Rout.save Log: - largely cosmetic streamlining Modified: pkg/pomp/inst/examples/bbs.R =================================================================== --- pkg/pomp/inst/examples/bbs.R 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/inst/examples/bbs.R 2013-03-10 20:58:03 UTC (rev 832) @@ -1,6 +1,6 @@ require(pomp) -tc <- textConnection(" +flu <- read.csv2(text=" day;reports 1;3 2;8 @@ -18,9 +18,6 @@ 14;5 ") -flu <- read.csv2(file=tc) -close(tc) - po <- pomp( data=flu, times="day", Modified: pkg/pomp/inst/examples/blowflies.R =================================================================== --- pkg/pomp/inst/examples/blowflies.R 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/inst/examples/blowflies.R 2013-03-10 20:58:03 UTC (rev 832) @@ -868,14 +868,13 @@ 718;8103;4 720;6803;4 ' - raw.data <- subset( - read.csv2(textConnection(blowfly.data),comment.char="#"), - set==4 + read.csv2(text=blowfly.data,comment.char="#"), + set==4, + select=-set ) - pomp( - data=subset(raw.data[c("day","y")],day>14&day<400), + data=subset(raw.data,day>14&day<400), times="day", t0=14, rprocess=discrete.time.sim( Modified: pkg/pomp/inst/examples/euler.sir.R =================================================================== --- pkg/pomp/inst/examples/euler.sir.R 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/inst/examples/euler.sir.R 2013-03-10 20:58:03 UTC (rev 832) @@ -213,7 +213,7 @@ po <- pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c( Modified: pkg/pomp/inst/examples/gillespie.sir.R =================================================================== --- pkg/pomp/inst/examples/gillespie.sir.R 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/inst/examples/gillespie.sir.R 2013-03-10 20:58:03 UTC (rev 832) @@ -525,7 +525,7 @@ ' pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c( Modified: pkg/pomp/inst/examples/gompertz.R =================================================================== --- pkg/pomp/inst/examples/gompertz.R 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/inst/examples/gompertz.R 2013-03-10 20:58:03 UTC (rev 832) @@ -105,7 +105,7 @@ ' po <- pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c(K=1,r=0.1,sigma=0.1,tau=0.1,X.0=1), Modified: pkg/pomp/inst/examples/ou2.R =================================================================== --- pkg/pomp/inst/examples/ou2.R 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/inst/examples/ou2.R 2013-03-10 20:58:03 UTC (rev 832) @@ -104,7 +104,7 @@ ' pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, rprocess=discrete.time.sim("ou2_step",PACKAGE="pomp"), Modified: pkg/pomp/inst/examples/ricker.R =================================================================== --- pkg/pomp/inst/examples/ricker.R 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/inst/examples/ricker.R 2013-03-10 20:58:03 UTC (rev 832) @@ -55,7 +55,7 @@ ' pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c(r=exp(3.8),sigma=0.3,phi=10,N.0=7,e.0=0), # originally used to generate the data Modified: pkg/pomp/inst/examples/rw2.R =================================================================== --- pkg/pomp/inst/examples/rw2.R 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/inst/examples/rw2.R 2013-03-10 20:58:03 UTC (rev 832) @@ -104,7 +104,7 @@ ' pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c(x1.0=0,x2.0=0,s1=1,s2=3,tau=1), # parameters at which data were generated Modified: pkg/pomp/inst/examples/verhulst.R =================================================================== --- pkg/pomp/inst/examples/verhulst.R 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/inst/examples/verhulst.R 2013-03-10 20:58:03 UTC (rev 832) @@ -1004,7 +1004,7 @@ ' pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c(n.0=10000,K=10000,r=0.9,sigma=0.4,tau=0.1), Modified: pkg/pomp/tests/filtfail.R =================================================================== --- pkg/pomp/tests/filtfail.R 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/tests/filtfail.R 2013-03-10 20:58:03 UTC (rev 832) @@ -5,7 +5,8 @@ ### the following example tests to make sure that states are updated properly ### upon filtering failures -"time,admissions,discharges,patients,cases +records <- read.csv(text=" +time,admissions,discharges,patients,cases 0,4,2,8, 1,0,1,10,2 2,2,0,9,1 @@ -27,12 +28,8 @@ 18,4,0,7,1 19,0,0,11,0 20,1,4,11, -" -> csvtext +") -tc <- textConnection(csvtext) -records <- read.csv(tc) -close(tc) - po <- pomp( data=subset(records[c("time","cases")],!is.na(cases)), times="time", Modified: pkg/pomp/tests/filtfail.Rout.save =================================================================== --- pkg/pomp/tests/filtfail.Rout.save 2013-03-10 20:49:19 UTC (rev 831) +++ pkg/pomp/tests/filtfail.Rout.save 2013-03-10 20:58:03 UTC (rev 832) @@ -1,6 +1,6 @@ -R version 2.15.2 (2012-10-26) -- "Trick or Treat" -Copyright (C) 2012 The R Foundation for Statistical Computing +R version 2.15.3 (2013-03-01) -- "Security Blanket" +Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-unknown-linux-gnu (64-bit) @@ -26,7 +26,8 @@ > ### the following example tests to make sure that states are updated properly > ### upon filtering failures > -> "time,admissions,discharges,patients,cases +> records <- read.csv(text=" ++ time,admissions,discharges,patients,cases + 0,4,2,8, + 1,0,1,10,2 + 2,2,0,9,1 @@ -48,12 +49,8 @@ + 18,4,0,7,1 + 19,0,0,11,0 + 20,1,4,11, -+ " -> csvtext ++ ") > -> tc <- textConnection(csvtext) -> records <- read.csv(tc) -> close(tc) -> > po <- pomp( + data=subset(records[c("time","cases")],!is.na(cases)), + times="time", @@ -121,4 +118,4 @@ > > proc.time() user system elapsed - 0.456 0.052 0.526 + 0.464 0.044 0.524 From noreply at r-forge.r-project.org Sun Mar 10 22:00:05 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 10 Mar 2013 22:00:05 +0100 (CET) Subject: [Pomp-commits] r833 - pkg/pomp/R Message-ID: <20130310210006.19F22184B6A@r-forge.r-project.org> Author: kingaa Date: 2013-03-10 22:00:05 +0100 (Sun, 10 Mar 2013) New Revision: 833 Modified: pkg/pomp/R/mif.R Log: - fix error Modified: pkg/pomp/R/mif.R =================================================================== --- pkg/pomp/R/mif.R 2013-03-10 20:58:03 UTC (rev 832) +++ pkg/pomp/R/mif.R 2013-03-10 21:00:05 UTC (rev 833) @@ -38,7 +38,7 @@ stop( "mif error: ",sQuote("cooling.fraction"), " must be < 1 when cooling.type = ", - sQuote("hyperbolic") + sQuote("hyperbolic"), call.=FALSE ) if (perobs) { From noreply at r-forge.r-project.org Sun Mar 10 23:24:43 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 10 Mar 2013 23:24:43 +0100 (CET) Subject: [Pomp-commits] r834 - in pkg/pomp: . R man tests Message-ID: <20130310222443.47C6B18430B@r-forge.r-project.org> Author: kingaa Date: 2013-03-10 23:24:43 +0100 (Sun, 10 Mar 2013) New Revision: 834 Modified: pkg/pomp/DESCRIPTION pkg/pomp/R/mif.R pkg/pomp/man/mif.Rd pkg/pomp/tests/ou2-mif2.R pkg/pomp/tests/ou2-mif2.Rout.save Log: - default for mif method 'mif2' is now ic.lag=length(time(object)) Modified: pkg/pomp/DESCRIPTION =================================================================== --- pkg/pomp/DESCRIPTION 2013-03-10 21:00:05 UTC (rev 833) +++ pkg/pomp/DESCRIPTION 2013-03-10 22:24:43 UTC (rev 834) @@ -1,8 +1,8 @@ Package: pomp Type: Package Title: Statistical inference for partially observed Markov processes -Version: 0.44-1 -Date: 2013-02-26 +Version: 0.44-2 +Date: 2013-03-11 Author: Aaron A. King, Edward L. Ionides, Carles Breto, Steve Ellner, Bruce Kendall, Helen Wearing, Matthew J. Ferrari, Michael Lavine, Daniel C. Reuman Maintainer: Aaron A. King URL: http://pomp.r-forge.r-project.org Modified: pkg/pomp/R/mif.R =================================================================== --- pkg/pomp/R/mif.R 2013-03-10 21:00:05 UTC (rev 833) +++ pkg/pomp/R/mif.R 2013-03-10 22:24:43 UTC (rev 834) @@ -89,11 +89,11 @@ particles, rw.sd, Np, var.factor, ic.lag, - cooling.type, cooling.fraction, cooling.factor, + cooling.type, cooling.fraction, cooling.factor, method, tol, max.fail, verbose, transform, .ndone = 0L, - paramMatrix, + paramMatrix = NULL, .getnativesymbolinfo = TRUE) { gnsi <- as.logical(.getnativesymbolinfo) @@ -123,9 +123,6 @@ if (length(rw.names) == 0) stop("mif error: ",sQuote("rw.sd")," must have one positive entry for each parameter to be estimated",call.=FALSE) - if (missing(pars)) stop("mif error: ",sQuote("pars")," must be specified",call.=FALSE) - if (missing(ivps)) stop("mif error: ",sQuote("ivps")," must be specified",call.=FALSE) - if ( !is.character(pars) || !is.character(ivps) || @@ -163,11 +160,8 @@ rw.sd <- rw.sd[c(pars,ivps)] rw.names <- names(rw.sd) - if (missing(particles)) - stop("mif error: ",sQuote("particles")," must be specified",call.=FALSE) - ntimes <- length(time(object)) - if (missing(Np)) stop("mif error: ",sQuote("Np")," must be specified",call.=FALSE) + if (is.null(Np)) stop("mif error: ",sQuote("Np")," must be specified",call.=FALSE) if (is.function(Np)) { Np <- try( vapply(seq.int(from=0,to=ntimes,by=1),Np,numeric(1)), @@ -186,7 +180,6 @@ stop(sQuote("Np")," must be a number, a vector of numbers, or a function") Np <- as.integer(Np) - if (missing(ic.lag)) stop("mif error: ",sQuote("ic.lag")," must be specified",call.=FALSE) ic.lag <- as.integer(ic.lag) if ((length(ic.lag)!=1)||(ic.lag<1)) stop("mif error: ",sQuote("ic.lag")," must be a positive integer",call.=FALSE) @@ -289,7 +282,7 @@ pfp <- obj } - have.parmat <- !(missing(paramMatrix) || length(paramMatrix)==0) + have.parmat <- !(is.null(paramMatrix) || length(paramMatrix)==0) for (n in seq_len(Nmif)) { ## iterate the filtering @@ -416,14 +409,19 @@ if (missing(start)) start <- coef(object) if (missing(rw.sd)) stop("mif error: ",sQuote("rw.sd")," must be specified",call.=FALSE) + if (missing(ic.lag) && length(ivps)>0) { + if (method=="mif2") + ic.lag <- length(time(object)) # default mif2 behavior + else + stop("mif error: ",sQuote("ic.lag")," must be specified if ",sQuote("ivps"), + " are",call.=FALSE) + } if (missing(pars)) { rw.names <- names(rw.sd)[rw.sd>0] pars <- rw.names[!(rw.names%in%ivps)] } if (missing(Np)) stop("mif error: ",sQuote("Np")," must be specified",call.=FALSE) - if (missing(ic.lag) && length(ivps)>0) - stop("mif error: ",sQuote("ic.lag")," must be specified if ",sQuote("ivps")," are",call.=FALSE) if (missing(var.factor)) stop("mif error: ",sQuote("var.factor")," must be specified",call.=FALSE) Modified: pkg/pomp/man/mif.Rd =================================================================== --- pkg/pomp/man/mif.Rd 2013-03-10 21:00:05 UTC (rev 833) +++ pkg/pomp/man/mif.Rd 2013-03-10 22:24:43 UTC (rev 834) @@ -81,6 +81,7 @@ The \code{mif} update for initial-value parameters consists of replacing them by their filtering mean at time \code{times[ic.lag]}, where \code{times=time(object)}. It makes no sense to set \code{ic.lag>length(times)}; if it is so set, \code{ic.lag} is set to \code{length(times)} with a warning. + For \code{method='mif2'}, the default is \code{ic.lag=length(times)}. } \item{var.factor}{ a positive number; Modified: pkg/pomp/tests/ou2-mif2.R =================================================================== --- pkg/pomp/tests/ou2-mif2.R 2013-03-10 21:00:05 UTC (rev 833) +++ pkg/pomp/tests/ou2-mif2.R 2013-03-10 22:24:43 UTC (rev 834) @@ -76,9 +76,26 @@ ) mif2b <- continue(mif2b,Nmif=50) +mif2c <- mif(ou2,Nmif=50,start=guess1, + pars=c('alpha.2','alpha.3'),ivps=c('x1.0','x2.0'), + rw.sd=c( + x1.0=0.5,x2.0=.5, + alpha.2=0.1,alpha.3=0.1), + transform=F, + Np=1000, + var.factor=1, + cooling.type="hyperbolic", + cooling.fraction=0.05, + max.fail=100, + method="mif2" + ) +mif2c <- continue(mif2c,Nmif=50) + compare.mif(list(mif1b,mif2b)) compare.mif(list(mif1a,mif1b)) compare.mif(list(mif2a,mif2b)) +compare.mif(list(mif1b,mif2c)) + dev.off() Modified: pkg/pomp/tests/ou2-mif2.Rout.save =================================================================== --- pkg/pomp/tests/ou2-mif2.Rout.save 2013-03-10 21:00:05 UTC (rev 833) +++ pkg/pomp/tests/ou2-mif2.Rout.save 2013-03-10 22:24:43 UTC (rev 834) @@ -1,6 +1,6 @@ -R version 2.15.2 (2012-10-26) -- "Trick or Treat" -Copyright (C) 2012 The R Foundation for Statistical Computing +R version 2.15.3 (2013-03-01) -- "Security Blanket" +Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-unknown-linux-gnu (64-bit) @@ -102,15 +102,32 @@ See '?mif' for instructions on specifying the cooling schedule. > mif2b <- continue(mif2b,Nmif=50) > +> mif2c <- mif(ou2,Nmif=50,start=guess1, ++ pars=c('alpha.2','alpha.3'),ivps=c('x1.0','x2.0'), ++ rw.sd=c( ++ x1.0=0.5,x2.0=.5, ++ alpha.2=0.1,alpha.3=0.1), ++ transform=F, ++ Np=1000, ++ var.factor=1, ++ cooling.type="hyperbolic", ++ cooling.fraction=0.05, ++ max.fail=100, ++ method="mif2" ++ ) +> mif2c <- continue(mif2c,Nmif=50) +> > compare.mif(list(mif1b,mif2b)) > > compare.mif(list(mif1a,mif1b)) > compare.mif(list(mif2a,mif2b)) > +> compare.mif(list(mif1b,mif2c)) +> > dev.off() null device 1 > > proc.time() user system elapsed - 42.138 0.064 42.548 + 49.343 0.076 49.753 From noreply at r-forge.r-project.org Mon Mar 11 15:20:26 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 11 Mar 2013 15:20:26 +0100 (CET) Subject: [Pomp-commits] r835 - branches/mif2/R Message-ID: <20130311142026.51DC4180888@r-forge.r-project.org> Author: nxdao2000 Date: 2013-03-11 15:20:26 +0100 (Mon, 11 Mar 2013) New Revision: 835 Modified: branches/mif2/R/mif-class.R Log: change random.walk.sd slot to matrix Modified: branches/mif2/R/mif-class.R =================================================================== --- branches/mif2/R/mif-class.R 2013-03-10 22:24:43 UTC (rev 834) +++ branches/mif2/R/mif-class.R 2013-03-11 14:20:26 UTC (rev 835) @@ -13,7 +13,7 @@ cooling.type='character', cooling.fraction='numeric', method='character', - random.walk.sd = 'numeric', + random.walk.sd = 'matrix', conv.rec = 'matrix' ) ) From noreply at r-forge.r-project.org Mon Mar 11 15:22:36 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 11 Mar 2013 15:22:36 +0100 (CET) Subject: [Pomp-commits] r836 - branches/mif2/R Message-ID: <20130311142236.1B3FE184921@r-forge.r-project.org> Author: nxdao2000 Date: 2013-03-11 15:22:35 +0100 (Mon, 11 Mar 2013) New Revision: 836 Modified: branches/mif2/R/mif.R Log: rw.sd is either a vector, a list or a matrix will be converted to a matrix rwsdMat in mif Modified: branches/mif2/R/mif.R =================================================================== --- branches/mif2/R/mif.R 2013-03-11 14:20:26 UTC (rev 835) +++ branches/mif2/R/mif.R 2013-03-11 14:22:35 UTC (rev 836) @@ -2,55 +2,55 @@ default.pomp.particles.fun <- function (Np, center, sd, ...) { matrix( - data=rnorm( - n=Np*length(center), - mean=center, - sd=sd - ), - nrow=length(center), - ncol=Np, - dimnames=list( - names(center), - NULL - ) - ) + data=rnorm( + n=Np*length(center), + mean=center, + sd=sd + ), + nrow=length(center), + ncol=Np, + dimnames=list( + names(center), + NULL + ) + ) } cooling.function <- function (type, perobs, fraction, ntimes) { switch( - type, - geometric={ - factor <- fraction^(1/50) - if (perobs) { - function (nt, m) { - alpha <- factor^(nt/ntimes+m-1) - list(alpha=alpha,gamma=alpha^2) - } - } else { - function (nt, m) { - alpha <- factor^(m-1) - list(alpha=alpha,gamma=alpha^2) - } - } - }, - hyperbolic={ - if (perobs) { - scal <- (50*ntimes*fraction-1)/(1-fraction) - function (nt, m) { - alpha <- (1+scal)/(scal+nt+ntimes*(m-1)) - list(alpha=alpha,gamma=alpha^2) - } - } else { - scal <- (50*fraction-1)/(1-fraction) - function (nt, m) { - alpha <- (1+scal)/(scal+m-1) - list(alpha=alpha,gamma=alpha^2) - } - - } - }, - stop("unrecognized cooling schedule type ",sQuote(type)) - ) + type, + geometric={ + factor <- fraction^(1/50) + if (perobs) { + function (nt, m) { + alpha <- factor^(nt/ntimes+m-1) + list(alpha=alpha,gamma=alpha^2) + } + } else { + function (nt, m) { + alpha <- factor^(m-1) + list(alpha=alpha,gamma=alpha^2) + } + } + }, + hyperbolic={ + if (perobs) { + scal <- (50*ntimes*fraction-1)/(1-fraction) + function (nt, m) { + alpha <- (1+scal)/(scal+nt+ntimes*(m-1)) + list(alpha=alpha,gamma=alpha^2) + } + } else { + scal <- (50*fraction-1)/(1-fraction) + function (nt, m) { + alpha <- (1+scal)/(scal+m-1) + list(alpha=alpha,gamma=alpha^2) + } + + } + }, + stop("unrecognized cooling schedule type ",sQuote(type)) + ) } mif.cooling <- function (factor, n) { # default geometric cooling schedule @@ -90,15 +90,15 @@ .getnativesymbolinfo = TRUE) { gnsi <- as.logical(.getnativesymbolinfo) - + transform <- as.logical(transform) if (length(start)==0) stop( - "mif error: ",sQuote("start")," must be specified if ", - sQuote("coef(object)")," is NULL", - call.=FALSE - ) + "mif error: ",sQuote("start")," must be specified if ", + sQuote("coef(object)")," is NULL", + call.=FALSE + ) if (transform) start <- partrans(object,start,dir="inverse") @@ -107,7 +107,7 @@ if (is.null(start.names)) stop("mif error: ",sQuote("start")," must be a named vector",call.=FALSE) - rw.names <- names(rw.sd) + rw.names <- colnames(rw.sd) if (is.null(rw.names)) stop("mif error: ",sQuote("rw.sd")," must be a named non-negative numerical vector",call.=FALSE) if (!all(rw.names%in%start.names)) @@ -120,7 +120,7 @@ if (missing(ivps)) stop("mif error: ",sQuote("ivps")," must be specified",call.=FALSE) if ( - !is.character(pars) || + !is.character(pars) || !is.character(ivps) || !all(pars%in%start.names) || !all(ivps%in%start.names) || @@ -128,34 +128,34 @@ any(ivps%in%pars) || !all(pars%in%rw.names) || !all(ivps%in%rw.names) - ) + ) stop( - "mif error: ", - sQuote("pars")," and ",sQuote("ivps"), - " must be mutually disjoint subsets of ", - sQuote("names(start)"), - " and must have a positive random-walk SDs specified in ", - sQuote("rw.sd"), - call.=FALSE - ) + "mif error: ", + sQuote("pars")," and ",sQuote("ivps"), + " must be mutually disjoint subsets of ", + sQuote("names(start)"), + " and must have a positive random-walk SDs specified in ", + sQuote("rw.sd"), + call.=FALSE + ) if (!all(rw.names%in%c(pars,ivps))) { extra.rws <- rw.names[!(rw.names%in%c(pars,ivps))] warning( - ngettext(length(extra.rws),"mif warning: the variable ", - "mif warning: the variables "), - paste(sQuote(extra.rws),collapse=", "), - ngettext(length(extra.rws)," has positive random-walk SD specified, but is included in neither ", - " have positive random-walk SDs specified, but are included in neither "), - sQuote("pars")," nor ",sQuote("ivps"), - ngettext(length(extra.rws),". This random walk SD will be ignored.", - ". These random walk SDs will be ignored."), - call.=FALSE - ) + ngettext(length(extra.rws),"mif warning: the variable ", + "mif warning: the variables "), + paste(sQuote(extra.rws),collapse=", "), + ngettext(length(extra.rws)," has positive random-walk SD specified, but is included in neither ", + " have positive random-walk SDs specified, but are included in neither "), + sQuote("pars")," nor ",sQuote("ivps"), + ngettext(length(extra.rws),". This random walk SD will be ignored.", + ". These random walk SDs will be ignored."), + call.=FALSE + ) } - rw.sd <- rw.sd[c(pars,ivps)] - rw.names <- names(rw.sd) - + #rw.sd <- rw.sd[c(pars,ivps)] + rw.names <- colnames(rw.sd) + rwsdMat <-rw.sd if (missing(particles)) stop("mif error: ",sQuote("particles")," must be specified",call.=FALSE) @@ -163,9 +163,9 @@ if (missing(Np)) stop("mif error: ",sQuote("Np")," must be specified",call.=FALSE) if (is.function(Np)) { Np <- try( - vapply(seq.int(from=0,to=ntimes,by=1),Np,numeric(1)), - silent=FALSE - ) + vapply(seq.int(from=0,to=ntimes,by=1),Np,numeric(1)), + silent=FALSE + ) if (inherits(Np,"try-error")) stop("if ",sQuote("Np")," is a function, it must return a single positive integer") } @@ -185,20 +185,20 @@ stop("mif error: ",sQuote("ic.lag")," must be a positive integer",call.=FALSE) if (ic.lag>ntimes) { warning( - "mif warning: ",sQuote("ic.lag")," = ",ic.lag," > ",ntimes, - " = length(time(",sQuote("object"),"))", - " is nonsensical. Setting ",sQuote("ic.lag")," = ",ntimes,".", - call.=FALSE - ) + "mif warning: ",sQuote("ic.lag")," = ",ic.lag," > ",ntimes, + " = length(time(",sQuote("object"),"))", + " is nonsensical. Setting ",sQuote("ic.lag")," = ",ntimes,".", + call.=FALSE + ) ic.lag <- length(time(object)) } if ((length(pars)==0)&&(ic.lag1) || have.parmat)) { ## use pre-existing particle matrix P[pars,] <- paramMatrix[pars,] } - names(rwsdMat) <- names(start) + colnames(rwsdMat) <- names(start) pfp <- try( - pfilter.internal( - object=obj, - params=P, - Np=Np, - tol=tol, - max.fail=max.fail, - pred.mean=(n==Nmif), - pred.var=((method=="mif")||(n==Nmif)), - filter.mean=TRUE, - cooling=cooling, - cooling.m=.ndone+n, - .mif2=(method=="mif2"), - .rw.sd=rwsdMat, - .transform=transform, - save.states=FALSE, - save.params=FALSE, - verbose=verbose, - .getnativesymbolinfo=gnsi - ), - silent=FALSE - ) + pfilter.internal( + object=obj, + params=P, + Np=Np, + tol=tol, + max.fail=max.fail, + pred.mean=(n==Nmif), + pred.var=((method=="mif")||(n==Nmif)), + filter.mean=TRUE, + cooling=cooling, + cooling.m=.ndone+n, + .mif2=(method=="mif2"), + .rw.sd=rwsdMat*cool.sched$alpha, + .transform=transform, + save.states=FALSE, + save.params=FALSE, + verbose=verbose, + .getnativesymbolinfo=gnsi + ), + silent=FALSE + ) if (inherits(pfp,"try-error")) stop("mif error: error in ",sQuote("pfilter"),call.=FALSE) - + gnsi <- FALSE ## update parameters switch( - method, - mif={ # original Ionides et al. (2006) average - theta <- .Call(mif_update,pfp,theta,cool.sched$gamma,var.factor,sigma,pars) - }, - unweighted={ # unweighted average - theta[pars] <- rowMeans(pfp at filter.mean[pars,,drop=FALSE]) - }, - fp={ # fixed-point iteration - theta[pars] <- pfp at filter.mean[pars,ntimes,drop=FALSE] - }, - mif2={ # "efficient" iterated filtering - paramMatrix <- pfp at paramMatrix - theta[pars] <- rowMeans(paramMatrix[pars,,drop=FALSE]) - }, - stop("unrecognized method ",sQuote(method)) - ) - theta[ivps] <- pfp at filter.mean[ivps,ic.lag] + method, + mif={ # original Ionides et al. (2006) average + theta <- .Call(mif_update,pfp,theta,cool.sched$gamma,var.factor,rwsdMat[1,],pars) + theta[ivps] <- pfp at filter.mean[ivps,ic.lag] + }, + unweighted={ # unweighted average + theta[pars] <- rowMeans(pfp at filter.mean[pars,,drop=FALSE]) + theta[ivps] <- pfp at filter.mean[ivps,ic.lag] + }, + fp={ # fixed-point iteration + theta[pars] <- pfp at filter.mean[pars,ntimes,drop=FALSE] + theta[ivps] <- pfp at filter.mean[ivps,ic.lag] + }, + mif2={ # "efficient" iterated filtering + paramMatrix <- pfp at paramMatrix + theta[pars] <- rowMeans(paramMatrix[pars,,drop=FALSE]) + theta[ivps] <- pfp at filter.mean[ivps,ntimes] + }, + stop("unrecognized method ",sQuote(method)) + ) + conv.rec[n+1,-c(1,2)] <- theta conv.rec[n,c(1,2)] <- c(pfp at loglik,pfp at nfail) if (verbose) cat("MIF iteration ",n," of ",Nmif," completed\n") } ### end of main loop - + ## back transform the parameter estimate if necessary if (transform) theta <- partrans(pfp,theta,dir="forward") new( - "mif", - pfp, - transform=transform, - params=theta, - ivps=ivps, - pars=pars, - Nmif=Nmif, - particles=particles, - var.factor=var.factor, - ic.lag=ic.lag, - random.walk.sd=sigma[rw.names], - tol=tol, - conv.rec=conv.rec, - method=method, - cooling.type=cooling.type, - cooling.fraction=cooling.fraction, - paramMatrix=if (method=="mif2") paramMatrix else array(data=numeric(0),dim=c(0,0)) - ) + "mif", + pfp, + transform=transform, + params=theta, + ivps=ivps, + pars=pars, + Nmif=Nmif, + particles=particles, + var.factor=var.factor, + ic.lag=ic.lag, + random.walk.sd=rwsdMat, + tol=tol, + conv.rec=conv.rec, + method=method, + cooling.type=cooling.type, + cooling.fraction=cooling.fraction, + paramMatrix=if (method=="mif2") paramMatrix else array(data=numeric(0),dim=c(0,0)) + ) } setGeneric('mif',function(object,...)standardGeneric("mif")) setMethod( - "mif", - signature=signature(object="pomp"), - function (object, Nmif = 1, - start, - pars, ivps = character(0), - particles, rw.sd, - Np, ic.lag, var.factor, - cooling.type = c("geometric","hyperbolic"), - cooling.fraction, cooling.factor, - method = c("mif","unweighted","fp","mif2"), - tol = 1e-17, max.fail = Inf, - verbose = getOption("verbose"), - transform = FALSE, - ...) { + "mif", + signature=signature(object="pomp"), + function (object, Nmif = 1, + start, + pars, ivps = character(0), + particles, rw.sd, + Np, ic.lag, var.factor, + cooling.type = c("geometric","hyperbolic"), + cooling.fraction, cooling.factor, + method = c("mif","unweighted","fp","mif2"), + tol = 1e-17, max.fail = Inf, + verbose = getOption("verbose"), + transform = FALSE, + ...) { + + transform <- as.logical(transform) + method <- match.arg(method) + + + ntimes <- length(time(object)) + if (missing(start)) start <- coef(object) + if (missing(rw.sd)) + stop("mif error: ",sQuote("rw.sd")," must be specified",call.=FALSE) + if (missing(pars)) { + stop("mif error: ",sQuote("par")," must be specified",call.=FALSE) + } + rw.names <- c(pars,ivps) + dtheta <- length(start) + rwsdMat <- matrix(rep(0, dtheta*(ntimes+1)), ncol=dtheta, nrow = (ntimes+1)) + colnames(rwsdMat) <- names(start) + + if (is.matrix(rw.sd)) rwsdMat<-rw.sd + else if (is.list(rw.sd)) + { + for (i in 1:length(rw.names)) + { if (rw.names[i] %in% ivps) + { + if (length((rw.sd[[rw.names[i]]])==1)) + { + rwsdMat[1,rw.names[i]] <- rw.sd[[rw.names[i]]][1] + } + else + { + stop(sQuote("rw.sd")," must have length 1 or length ",ntimes+1) + + } + } + else if (rw.names[i] %in% pars) + { + if (length(rw.sd[[rw.names[i]]])==1) + { + rwsdMat[,rw.names[i]] <- rep(rw.sd[[rw.names[i]]],(ntimes+1)) + } + else if (length(rw.sd[[rw.names[i]]])==(ntimes+1)) + { + rwsdMat[,rw.names[i]] <- rw.sd[[rw.names[i]]] + } + else + { + stop(sQuote("rw.sd")," must have length 1 or length ",ntimes+1) - transform <- as.logical(transform) - method <- match.arg(method) - - if (missing(start)) start <- coef(object) - if (missing(rw.sd)) - stop("mif error: ",sQuote("rw.sd")," must be specified",call.=FALSE) - if (missing(pars)) { - rw.names <- names(rw.sd)[rw.sd>0] - pars <- rw.names[!(rw.names%in%ivps)] - } - if (missing(Np)) - stop("mif error: ",sQuote("Np")," must be specified",call.=FALSE) - if (missing(ic.lag) && length(ivps)>0) - stop("mif error: ",sQuote("ic.lag")," must be specified if ",sQuote("ivps")," are",call.=FALSE) - if (missing(var.factor)) - stop("mif error: ",sQuote("var.factor")," must be specified",call.=FALSE) - - cooling.type <- match.arg(cooling.type) - - if (missing(particles)) { # use default: normal distribution - particles <- default.pomp.particles.fun - } else { - particles <- match.fun(particles) - if (!all(c('Np','center','sd','...')%in%names(formals(particles)))) - stop( - "mif error: ", - sQuote("particles"), - " must be a function of prototype ", - sQuote("particles(Np,center,sd,...)"), - call.=FALSE - ) - } - - mif.internal( - object=object, - Nmif=Nmif, - start=start, - pars=pars, - ivps=ivps, - particles=particles, - rw.sd=rw.sd, - Np=Np, - cooling.type=cooling.type, - cooling.factor=cooling.factor, - cooling.fraction=cooling.fraction, - var.factor=var.factor, - ic.lag=ic.lag, - method=method, - tol=tol, - max.fail=max.fail, - verbose=verbose, - transform=transform - ) - } - ) + } + + } + + } + else if (is.vector(rw.sd)) + { + if (missing(pars)) { + rw.names <- names(rw.sd)[rw.sd>0] + pars <- rw.names[!(rw.names%in%ivps)] + } + for (i in 1:length(rw.names)) + { if (rw.names[i] %in% ivps) + { + rwsdMat[1,rw.names[i]] <- rw.sd[rw.names[i]] + + } + else if (rw.names[i] %in% pars) + { + rwsdMat[,rw.names[i]] <- rep(rw.sd[rw.names[i]],(ntimes+1)) + } + + } + + + + } + + + + if (missing(Np)) + stop("mif error: ",sQuote("Np")," must be specified",call.=FALSE) + if (missing(ic.lag) && length(ivps)>0) + stop("mif error: ",sQuote("ic.lag")," must be specified if ",sQuote("ivps")," are",call.=FALSE) + if (missing(var.factor)) + stop("mif error: ",sQuote("var.factor")," must be specified",call.=FALSE) + + cooling.type <- match.arg(cooling.type) + + if (missing(particles)) { # use default: normal distribution + particles <- default.pomp.particles.fun + } else { + particles <- match.fun(particles) + if (!all(c('Np','center','sd','...')%in%names(formals(particles)))) + stop( + "mif error: ", + sQuote("particles"), + " must be a function of prototype ", + sQuote("particles(Np,center,sd,...)"), + call.=FALSE + ) + } + + mif.internal( + object=object, + Nmif=Nmif, + start=start, + pars=pars, + ivps=ivps, + particles=particles, + rw.sd=rwsdMat, + Np=Np, + cooling.type=cooling.type, + cooling.factor=cooling.factor, + cooling.fraction=cooling.fraction, + var.factor=var.factor, + ic.lag=ic.lag, + method=method, + tol=tol, + max.fail=max.fail, + verbose=verbose, + transform=transform + ) + + } +) setMethod( - "mif", - signature=signature(object="pfilterd.pomp"), - function (object, Nmif = 1, Np, tol, - ...) { - - if (missing(Np)) Np <- object at Np - if (missing(tol)) tol <- object at tol - - mif( - object=as(object,"pomp"), - Nmif=Nmif, - Np=Np, - tol=tol, - ... - ) - } - ) + "mif", + signature=signature(object="pfilterd.pomp"), + function (object, Nmif = 1, Np, tol, + ...) { + + if (missing(Np)) Np <- object at Np + if (missing(tol)) tol <- object at tol + + mif( + object=as(object,"pomp"), + Nmif=Nmif, + Np=Np, + tol=tol, + ... + ) + } +) setMethod( - "mif", - signature=signature(object="mif"), - function (object, Nmif, - start, - pars, ivps, - particles, rw.sd, - Np, ic.lag, var.factor, - cooling.type, cooling.fraction, - method, - tol, - transform, - ...) { - - if (missing(Nmif)) Nmif <- object at Nmif - if (missing(start)) start <- coef(object) - if (missing(pars)) pars <- object at pars - if (missing(ivps)) ivps <- object at ivps - if (missing(particles)) particles <- object at particles - if (missing(rw.sd)) rw.sd <- object at random.walk.sd - if (missing(ic.lag)) ic.lag <- object at ic.lag - if (missing(var.factor)) var.factor <- object at var.factor - if (missing(cooling.type)) cooling.type <- object at cooling.type - if (missing(cooling.fraction)) cooling.fraction <- object at cooling.fraction - if (missing(method)) method <- object at method - if (missing(transform)) transform <- object at transform - transform <- as.logical(transform) + "mif", + signature=signature(object="mif"), + function (object, Nmif, + start, + pars, ivps, + particles, rw.sd, + Np, ic.lag, var.factor, + cooling.type, cooling.fraction, + method, + tol, + transform, + ...) { + + if (missing(Nmif)) Nmif <- object at Nmif + if (missing(start)) start <- coef(object) + if (missing(pars)) pars <- object at pars + if (missing(ivps)) ivps <- object at ivps + if (missing(particles)) particles <- object at particles + if (missing(rw.sd)) rw.sd <- object at random.walk.sd + if (missing(ic.lag)) ic.lag <- object at ic.lag + if (missing(var.factor)) var.factor <- object at var.factor + if (missing(cooling.type)) cooling.type <- object at cooling.type + if (missing(cooling.fraction)) cooling.fraction <- object at cooling.fraction + if (missing(method)) method <- object at method + if (missing(transform)) transform <- object at transform + transform <- as.logical(transform) + + if (missing(Np)) Np <- object at Np + if (missing(tol)) tol <- object at tol + + mif( + object=as(object,"pomp"), + Nmif=Nmif, + start=start, + pars=pars, + ivps=ivps, + particles=particles, + rw.sd=rw.sd, + Np=Np, + cooling.type=cooling.type, + cooling.fraction=cooling.fraction, + var.factor=var.factor, + ic.lag=ic.lag, + method=method, + tol=tol, + transform=transform, + ... + ) + } +) - if (missing(Np)) Np <- object at Np - if (missing(tol)) tol <- object at tol - - mif( - object=as(object,"pomp"), - Nmif=Nmif, - start=start, - pars=pars, - ivps=ivps, - particles=particles, - rw.sd=rw.sd, - Np=Np, - cooling.type=cooling.type, - cooling.fraction=cooling.fraction, - var.factor=var.factor, - ic.lag=ic.lag, - method=method, - tol=tol, - transform=transform, - ... - ) - } - ) - setMethod( - 'continue', - signature=signature(object='mif'), - function (object, Nmif = 1, - ...) { - - ndone <- object at Nmif - - obj <- mif( - object=object, - Nmif=Nmif, - .ndone=ndone, - paramMatrix=object at paramMatrix, - ... - ) - - object at conv.rec[ndone+1,c('loglik','nfail')] <- obj at conv.rec[1L,c('loglik','nfail')] - obj at conv.rec <- rbind( - object at conv.rec, - obj at conv.rec[-1L,colnames(object at conv.rec)] - ) - obj at Nmif <- as.integer(ndone+Nmif) - - obj - } - ) + 'continue', + signature=signature(object='mif'), + function (object, Nmif = 1, + ...) { + + ndone <- object at Nmif + + obj <- mif( + object=object, + Nmif=Nmif, + .ndone=ndone, + paramMatrix=object at paramMatrix, + ... + ) + + object at conv.rec[ndone+1,c('loglik','nfail')] <- obj at conv.rec[1L,c('loglik','nfail')] + obj at conv.rec <- rbind( + object at conv.rec, + obj at conv.rec[-1L,colnames(object at conv.rec)] + ) + obj at Nmif <- as.integer(ndone+Nmif) + + obj + } +) mif.profileDesign <- function (object, profile, lower, upper, nprof, ivps, rw.sd, Np, ic.lag, var.factor, cooling.factor,option, cooling.fraction, paramMatrix, ...) @@ -633,24 +647,24 @@ ans <- vector(mode="list",length=nrow(pd)) for (k in seq_len(nrow(pd))) { ans[[k]] <- list( - mf=mif( - object, - Nmif=0, - start=unlist(pd[k,]), - pars=pars, - ivps=ivps, - rw.sd=rw.sd, - Np=Np, - ic.lag=ic.lag, - var.factor=var.factor, - cooling.factor=cooling.factor, - option=option, - cooling.fraction=cooling.fraction, - paramMatrix=paramMatrix, - ... - ) - ) + mf=mif( + object, + Nmif=0, + start=unlist(pd[k,]), + pars=pars, + ivps=ivps, + rw.sd=rw.sd, + Np=Np, + ic.lag=ic.lag, + var.factor=var.factor, + cooling.factor=cooling.factor, + option=option, + cooling.fraction=cooling.fraction, + paramMatrix=paramMatrix, + ... + ) + ) } ans -} +} \ No newline at end of file From noreply at r-forge.r-project.org Mon Mar 11 15:23:10 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 11 Mar 2013 15:23:10 +0100 (CET) Subject: [Pomp-commits] r837 - branches/mif2/R Message-ID: <20130311142310.3757218492B@r-forge.r-project.org> Author: nxdao2000 Date: 2013-03-11 15:23:10 +0100 (Mon, 11 Mar 2013) New Revision: 837 Modified: branches/mif2/R/pfilter.R Log: change pfilter with rwsdMat accordingly. Modified: branches/mif2/R/pfilter.R =================================================================== --- branches/mif2/R/pfilter.R 2013-03-11 14:22:35 UTC (rev 836) +++ branches/mif2/R/pfilter.R 2013-03-11 14:23:10 UTC (rev 837) @@ -1,39 +1,39 @@ ## particle filtering codes setClass( - "pfilterd.pomp", - contains="pomp", - representation=representation( - pred.mean="array", - pred.var="array", - filter.mean="array", - paramMatrix="array", - eff.sample.size="numeric", - cond.loglik="numeric", - saved.states="list", - saved.params="list", - seed="integer", - Np="integer", - tol="numeric", - nfail="integer", - loglik="numeric" - ), - prototype=prototype( - pred.mean=array(data=numeric(0),dim=c(0,0)), - pred.var=array(data=numeric(0),dim=c(0,0)), - filter.mean=array(data=numeric(0),dim=c(0,0)), - paramMatrix=array(data=numeric(0),dim=c(0,0)), - eff.sample.size=numeric(0), - cond.loglik=numeric(0), - saved.states=list(), - saved.params=list(), - seed=as.integer(NA), - Np=as.integer(NA), - tol=as.double(NA), - nfail=as.integer(NA), - loglik=as.double(NA) - ) - ) + "pfilterd.pomp", + contains="pomp", + representation=representation( + pred.mean="array", + pred.var="array", + filter.mean="array", + paramMatrix="array", + eff.sample.size="numeric", + cond.loglik="numeric", + saved.states="list", + saved.params="list", + seed="integer", + Np="integer", + tol="numeric", + nfail="integer", + loglik="numeric" + ), + prototype=prototype( + pred.mean=array(data=numeric(0),dim=c(0,0)), + pred.var=array(data=numeric(0),dim=c(0,0)), + filter.mean=array(data=numeric(0),dim=c(0,0)), + paramMatrix=array(data=numeric(0),dim=c(0,0)), + eff.sample.size=numeric(0), + cond.loglik=numeric(0), + saved.states=list(), + saved.params=list(), + seed=as.integer(NA), + Np=as.integer(NA), + tol=as.double(NA), + nfail=as.integer(NA), + loglik=as.double(NA) + ) +) pfilter.internal <- function (object, params, Np, tol, max.fail, @@ -43,7 +43,7 @@ save.states, save.params, .transform, .getnativesymbolinfo = TRUE) { - + ptsi.inv <- ptsi.for <- gnsi.rproc <- gnsi.dmeas <- as.logical(.getnativesymbolinfo) mif2 <- as.logical(.mif2) transform <- as.logical(.transform) @@ -71,9 +71,9 @@ Np <- NCOL(params) if (is.function(Np)) { Np <- try( - vapply(seq.int(from=0,to=ntimes,by=1),Np,numeric(1)), - silent=FALSE - ) + vapply(seq.int(from=0,to=ntimes,by=1),Np,numeric(1)), + silent=FALSE + ) if (inherits(Np,"try-error")) stop("if ",sQuote("Np")," is a function, it must return a single positive integer",call.=FALSE) } @@ -91,28 +91,28 @@ one.par <- TRUE # there is only one parameter vector coef(object) <- params # set params slot to the parameters params <- matrix( - params, - nrow=length(params), - ncol=Np[1L], - dimnames=list( - names(params), - NULL - ) - ) + params, + nrow=length(params), + ncol=Np[1L], + dimnames=list( + names(params), + NULL + ) + ) } paramnames <- rownames(params) if (is.null(paramnames)) stop(sQuote("pfilter")," error: ",sQuote("params")," must have rownames",call.=FALSE) x <- init.state( - object, - params=if (transform) { - partrans(object,params,dir="forward", - .getnativesymbolinfo=ptsi.for) - } else { - params - } - ) + object, + params=if (transform) { + partrans(object,params,dir="forward", + .getnativesymbolinfo=ptsi.for) + } else { + params + } + ) statenames <- rownames(x) nvars <- nrow(x) ptsi.for <- FALSE @@ -129,15 +129,15 @@ random.walk <- !missing(.rw.sd) if (random.walk) { - rw.names <- names(.rw.sd) + rw.names <- colnames(.rw.sd) if (is.null(rw.names)) stop(sQuote("pfilter")," error: ",sQuote(".rw.sd")," must be a named vector",call.=FALSE) if (any(!(rw.names%in%paramnames))) stop( - sQuote("pfilter")," error: the rownames of ", - sQuote("params")," must include all of the names of ", - sQuote(".rw.sd"),"",call.=FALSE - ) + sQuote("pfilter")," error: the rownames of ", + sQuote("params")," must include all of the names of ", + sQuote(".rw.sd"),"",call.=FALSE + ) sigma <- .rw.sd } else { rw.names <- character(0) @@ -152,51 +152,50 @@ ## set up storage for prediction means, variances, etc. if (pred.mean) pred.m <- matrix( - data=0, - nrow=nvars+npars, - ncol=ntimes, - dimnames=list(c(statenames,rw.names),NULL) - ) + data=0, + nrow=nvars+npars, + ncol=ntimes, + dimnames=list(c(statenames,rw.names),NULL) + ) else pred.m <- array(data=numeric(0),dim=c(0,0)) if (pred.var) pred.v <- matrix( - data=0, - nrow=nvars+npars, - ncol=ntimes, - dimnames=list(c(statenames,rw.names),NULL) - ) + data=0, + nrow=nvars+npars, + ncol=ntimes, + dimnames=list(c(statenames,rw.names),NULL) + ) else pred.v <- array(data=numeric(0),dim=c(0,0)) if (filter.mean) if (random.walk) filt.m <- matrix( - data=0, - nrow=nvars+length(paramnames), - ncol=ntimes, - dimnames=list(c(statenames,paramnames),NULL) - ) - else - filt.m <- matrix( - data=0, - nrow=nvars, - ncol=ntimes, - dimnames=list(statenames,NULL) - ) + data=0, + nrow=nvars+length(paramnames), + ncol=ntimes, + dimnames=list(c(statenames,paramnames),NULL) + ) else + filt.m <- matrix( + data=0, + nrow=nvars, + ncol=ntimes, + dimnames=list(statenames,NULL) + ) + else filt.m <- array(data=numeric(0),dim=c(0,0)) - + for (nt in seq_len(ntimes)) { - if (mif2) { + if (mif2) { cool.sched <- cooling(nt=nt,m=cooling.m) - sigma1 <- as.numeric(sigma[nt,])*cool.sched$alpha - names(sigma1)<-rw.names + sigma1 <- sigma[nt,]*cool.sched$alpha + } else { - sigma1 <- as.numeric(sigma[nt,]) - names(sigma1)<-rw.names + sigma1 <- sigma[nt,] } ## transform the parameters if necessary @@ -206,16 +205,16 @@ ## advance the state variables according to the process model X <- try( - rprocess( - object, - xstart=x, - times=times[c(nt,nt+1)], - params=if (transform) tparams else params, - offset=1, - .getnativesymbolinfo=gnsi.rproc - ), - silent=FALSE - ) + rprocess( + object, + xstart=x, + times=times[c(nt,nt+1)], + params=if (transform) tparams else params, + offset=1, + .getnativesymbolinfo=gnsi.rproc + ), + silent=FALSE + ) if (inherits(X,'try-error')) stop(sQuote("pfilter")," error: process simulation error",call.=FALSE) gnsi.rproc <- FALSE @@ -224,36 +223,36 @@ problem.indices <- unique(which(!is.finite(X),arr.ind=TRUE)[,1L]) if (length(problem.indices)>0) { # state variables stop( - sQuote("pfilter")," error: non-finite state variable(s): ", - paste(rownames(X)[problem.indices],collapse=', '), - call.=FALSE - ) + sQuote("pfilter")," error: non-finite state variable(s): ", + paste(rownames(X)[problem.indices],collapse=', '), + call.=FALSE + ) } if (random.walk) { # parameters (need to be checked only if 'random.walk=TRUE') problem.indices <- unique(which(!is.finite(params[rw.names,,drop=FALSE]),arr.ind=TRUE)[,1L]) if (length(problem.indices)>0) { stop( - sQuote("pfilter")," error: non-finite parameter(s): ", - paste(rw.names[problem.indices],collapse=', '), - call.=FALSE - ) + sQuote("pfilter")," error: non-finite parameter(s): ", + paste(rw.names[problem.indices],collapse=', '), + call.=FALSE + ) } } } ## determine the weights weights <- try( - dmeasure( - object, - y=object at data[,nt,drop=FALSE], - x=X, - times=times[nt+1], - params=if (transform) tparams else params, - log=FALSE, - .getnativesymbolinfo=gnsi.dmeas - ), - silent=FALSE - ) + dmeasure( + object, + y=object at data[,nt,drop=FALSE], + x=X, + times=times[nt+1], + params=if (transform) tparams else params, + log=FALSE, + .getnativesymbolinfo=gnsi.dmeas + ), + silent=FALSE + ) if (inherits(weights,'try-error')) stop(sQuote("pfilter")," error: error in calculation of weights",call.=FALSE) if (any(!is.finite(weights))) { @@ -265,17 +264,17 @@ ## effective sample size, log-likelihood ## also do resampling if filtering has not failed xx <- try( - .Call( - pfilter_computations, - X,params,Np[nt+1], - random.walk, - sigma1, - pred.mean,pred.var, - filter.mean,one.par, - weights,tol - ), - silent=FALSE - ) + .Call( + pfilter_computations, + X,params,Np[nt+1], + random.walk, + sigma1, + pred.mean,pred.var, + filter.mean,one.par, + weights,tol + ), + silent=FALSE + ) if (inherits(xx,'try-error')) { stop(sQuote("pfilter")," error",call.=FALSE) } @@ -318,81 +317,81 @@ assign(".Random.seed",save.seed,pos=.GlobalEnv) seed <- save.seed } - + if (nfail>0) warning(sprintf(ngettext(nfail,msg1="%d filtering failure occurred in ", msg2="%d filtering failures occurred in "),nfail), sQuote("pfilter"),call.=FALSE) - + new( - "pfilterd.pomp", - object, - pred.mean=pred.m, - pred.var=pred.v, - filter.mean=filt.m, - paramMatrix=if (mif2) params else array(data=numeric(0),dim=c(0,0)), - eff.sample.size=eff.sample.size, - cond.loglik=loglik, - saved.states=xparticles, - saved.params=pparticles, - seed=as.integer(seed), - Np=as.integer(Np), - tol=tol, - nfail=as.integer(nfail), - loglik=sum(loglik) - ) + "pfilterd.pomp", + object, + pred.mean=pred.m, + pred.var=pred.v, + filter.mean=filt.m, + paramMatrix=if (mif2) params else array(data=numeric(0),dim=c(0,0)), + eff.sample.size=eff.sample.size, + cond.loglik=loglik, + saved.states=xparticles, + saved.params=pparticles, + seed=as.integer(seed), + Np=as.integer(Np), + tol=tol, + nfail=as.integer(nfail), + loglik=sum(loglik) + ) } ## generic particle filter setGeneric("pfilter",function(object,...)standardGeneric("pfilter")) setMethod( - "pfilter", - signature=signature(object="pomp"), - function (object, params, Np, - tol = 1e-17, - max.fail = Inf, - pred.mean = FALSE, - pred.var = FALSE, - filter.mean = FALSE, - save.states = FALSE, - save.params = FALSE, - seed = NULL, - verbose = getOption("verbose"), - ...) { - if (missing(params)) params <- coef(object) - pfilter.internal( - object=object, - params=params, - Np=Np, - tol=tol, - max.fail=max.fail, - pred.mean=pred.mean, - pred.var=pred.var, - filter.mean=filter.mean, - save.states=save.states, - save.params=save.params, - seed=seed, - verbose=verbose, - .transform=FALSE, - ... - ) - } - ) + "pfilter", + signature=signature(object="pomp"), + function (object, params, Np, + tol = 1e-17, + max.fail = Inf, + pred.mean = FALSE, + pred.var = FALSE, + filter.mean = FALSE, + save.states = FALSE, + save.params = FALSE, + seed = NULL, + verbose = getOption("verbose"), + ...) { + if (missing(params)) params <- coef(object) + pfilter.internal( + object=object, + params=params, + Np=Np, + tol=tol, + max.fail=max.fail, + pred.mean=pred.mean, + pred.var=pred.var, + filter.mean=filter.mean, + save.states=save.states, + save.params=save.params, + seed=seed, + verbose=verbose, + .transform=FALSE, + ... + ) + } +) setMethod( - "pfilter", - signature=signature(object="pfilterd.pomp"), - function (object, params, Np, tol, ...) { - if (missing(params)) params <- coef(object) - if (missing(Np)) Np <- object at Np - if (missing(tol)) tol <- object at tol - pfilter( - object=as(object,"pomp"), - params=params, - Np=Np, - tol=tol, - ... - ) - } - ) + "pfilter", + signature=signature(object="pfilterd.pomp"), + function (object, params, Np, tol, ...) { + if (missing(params)) params <- coef(object) + if (missing(Np)) Np <- object at Np + if (missing(tol)) tol <- object at tol + pfilter( + object=as(object,"pomp"), + params=params, + Np=Np, + tol=tol, + ... + ) + } +) \ No newline at end of file From noreply at r-forge.r-project.org Wed Mar 20 20:41:25 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 20 Mar 2013 20:41:25 +0100 (CET) Subject: [Pomp-commits] r838 - branches/mif2/man Message-ID: <20130320194125.B7C37183B92@r-forge.r-project.org> Author: ionides Date: 2013-03-20 20:41:25 +0100 (Wed, 20 Mar 2013) New Revision: 838 Modified: branches/mif2/man/mif.Rd Log: updated rw.sd documentation for mif Modified: branches/mif2/man/mif.Rd =================================================================== --- branches/mif2/man/mif.Rd 2013-03-11 14:23:10 UTC (rev 837) +++ branches/mif2/man/mif.Rd 2013-03-20 19:41:25 UTC (rev 838) @@ -55,13 +55,16 @@ If \code{particles} is not supplied by the user, the default behavior is to draw the particles from a multivariate normal distribution with mean \code{center} and standard deviation \code{sd}. } \item{rw.sd}{ - numeric vector with names; the intensity of the random walk to be applied to parameters. + numeric vector with names, or named list, or matrix; the intensity of the random walk to be applied to parameters. + Ultimately, this argument is used to construct a matrix of random walk intensities for each parameter at each time. If the argument is a vector, or the list entry is a scalar, then the random walk intensity is constant at this value (unless the parameter is named in \code{ivps}, in which case it has this value at time t0 and is subsequently zero). + If rw.sd is a matrix, it should have \code{Ntimes+1} rows and a named column for each parameter. + If rw.sd is a list, then vector-valued entries on this list should have length \code{Ntimes+1}. The random walk is only applied to parameters named in \code{pars} (i.e., not to those named in \code{ivps}). - The algorithm requires that the random walk be nontrivial, so each element in \code{rw.sd[pars]} must be positive. + The algorithm requires that the random walk be nontrivial, so each element in \code{rw.sd[pars]} must be positive [THIS IS NO LONGER A REQUIREMENT FOR MIF2. IN GENERAL, THESE CONDITIONS NEED RETHINKING]. \code{rw.sd} is also used to scale the initial-value parameters (via the \code{particles} function). Therefore, each element of \code{rw.sd[ivps]} must be positive. The following must be satisfied: - \code{names(rw.sd)} must be a subset of \code{names(start)}, + \code{names(rw.sd)} or \code{colnames(rw.sd)}must be a subset of \code{names(start)}, \code{rw.sd} must be non-negative (zeros are simply ignored), the name of every positive element of \code{rw.sd} must be in either \code{pars} or \code{ivps}. } From noreply at r-forge.r-project.org Thu Mar 21 15:35:11 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 21 Mar 2013 15:35:11 +0100 (CET) Subject: [Pomp-commits] r839 - in pkg/pomp: . R src Message-ID: <20130321143511.1C90E183A2B@r-forge.r-project.org> Author: kingaa Date: 2013-03-21 15:35:10 +0100 (Thu, 21 Mar 2013) New Revision: 839 Modified: pkg/pomp/DESCRIPTION pkg/pomp/R/authors.R pkg/pomp/src/SSA_wrapper.c pkg/pomp/src/blowfly.c pkg/pomp/src/dprocess.c pkg/pomp/src/partrans.c Log: - update author list - fix some warnings generated by clang Modified: pkg/pomp/DESCRIPTION =================================================================== --- pkg/pomp/DESCRIPTION 2013-03-20 19:41:25 UTC (rev 838) +++ pkg/pomp/DESCRIPTION 2013-03-21 14:35:10 UTC (rev 839) @@ -1,10 +1,21 @@ Package: pomp Type: Package Title: Statistical inference for partially observed Markov processes -Version: 0.44-2 -Date: 2013-03-11 -Author: Aaron A. King, Edward L. Ionides, Carles Breto, Steve Ellner, Bruce Kendall, Helen Wearing, Matthew J. Ferrari, Michael Lavine, Daniel C. Reuman +Version: 0.44-3 +Date: 2013-03-21 +Author: Aaron A. King, Edward L. Ionides, Carles Breto +Contributor: Steve Ellner, Bruce Kendall, Helen Wearing, Matthew J. Ferrari, Michael Lavine, Daniel C. Reuman, Simon N. Wood Maintainer: Aaron A. King +Author 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("ctb")), + person(given=c("Carles"),family="Breto",role=c("ctb")), + 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 Modified: pkg/pomp/R/authors.R =================================================================== --- pkg/pomp/R/authors.R 2013-03-20 19:41:25 UTC (rev 838) +++ pkg/pomp/R/authors.R 2013-03-21 14:35:10 UTC (rev 839) @@ -1,9 +1,9 @@ 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("aut"),email="ionides at umich.edu"), - cb=person(given=c("Carles"),family="Breto",role=c("aut")), - spe=person(given=c("Stephen","P."),family="Ellner",role=c("aut")), - bek=person(given=c("Bruce","E."),family="Kendall",role=c("aut")), + 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")), Modified: pkg/pomp/src/SSA_wrapper.c =================================================================== --- pkg/pomp/src/SSA_wrapper.c 2013-03-20 19:41:25 UTC (rev 838) +++ pkg/pomp/src/SSA_wrapper.c 2013-03-21 14:35:10 UTC (rev 839) @@ -3,6 +3,10 @@ #include "pomp_internal.h" #include +typedef double (*_pomp_rxnrate) (const int *j, const double *t, const double *x, const double *p, + int *stateindex, int *parindex, int *covarindex, + int *ncovar, double *covar); + void F77_SUB(rndstart)(void) { GetRNGstate(); } void F77_SUB(rndend)(void) { PutRNGstate(); } double F77_SUB(unifrnd)(void) { return unif_rand(); } @@ -11,7 +15,7 @@ double F77_SUB(gammarnd)(double shape, double scale) { return rgamma(shape,scale); } void F77_SUB(multinomrnd)(int N, double *p, int ncat, int *ix) { rmultinom(N,p,ncat,ix); } -void F77_NAME(driverssa)(void *fprob, int *nvar, int *nevent, int *npar, int *nreps, int *ntimes, +void F77_NAME(driverssa)(_pomp_rxnrate *fprob, int *nvar, int *nevent, int *npar, int *nreps, int *ntimes, int *kflag, double *xstart, double *times, double *params, double *xout, double *e, double *v, double *d, int *nzero, int *izero, int *istate, int *ipar, int *ncov, int *icov, int *lcov, int *mcov, double *tcov, double *cov); Modified: pkg/pomp/src/blowfly.c =================================================================== --- pkg/pomp/src/blowfly.c 2013-03-20 19:41:25 UTC (rev 838) +++ pkg/pomp/src/blowfly.c 2013-03-21 14:35:10 UTC (rev 839) @@ -5,7 +5,7 @@ #include "pomp.h" #define P (p[parindex[0]]) // growth rate -#define NZERO (p[parindex[1]]) // density-dependence parameter +#define N0 (p[parindex[1]]) // density-dependence parameter #define DELTA (p[parindex[2]]) // survival parameter #define SIGMAP (p[parindex[3]]) // recruitment noise SD #define SIGMAD (p[parindex[4]]) // survivorship noise SD @@ -29,7 +29,7 @@ double eps = rgammawn(SIGMAD,dt)/dt; int k; - R = rpois(P*N[tau]*exp(-N[tau]/NZERO)*dt*e); + R = rpois(P*N[tau]*exp(-N[tau]/N0)*dt*e); S = rbinom(N[0],exp(-DELTA*dt*eps)); E = e; EPS = eps; @@ -60,7 +60,7 @@ #undef EPS #undef P -#undef NZERO +#undef N0 #undef DELTA #undef SIGMAP #undef SIGMAD Modified: pkg/pomp/src/dprocess.c =================================================================== --- pkg/pomp/src/dprocess.c 2013-03-20 19:41:25 UTC (rev 838) +++ pkg/pomp/src/dprocess.c 2013-03-21 14:35:10 UTC (rev 839) @@ -12,7 +12,7 @@ int nprotect = 0; int *xdim, npars, nvars, nreps, nrepsx, ntimes; SEXP X, fn, fcall, rho; - SEXP dimP, dimF; + SEXP dimF; PROTECT(gnsi = duplicate(gnsi)); nprotect++; Modified: pkg/pomp/src/partrans.c =================================================================== --- pkg/pomp/src/partrans.c 2013-03-20 19:41:25 UTC (rev 838) +++ pkg/pomp/src/partrans.c 2013-03-21 14:35:10 UTC (rev 839) @@ -12,7 +12,7 @@ int nprotect = 0; SEXP fn, fcall, rho, ans, nm; SEXP pdim, pvec; - SEXP tparams; + SEXP tparams = R_NilValue; int mode = -1; char direc; int qmat; From noreply at r-forge.r-project.org Tue Mar 26 12:50:29 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 26 Mar 2013 12:50:29 +0100 (CET) Subject: [Pomp-commits] r840 - in branches/mif2: . R inst/examples src tests Message-ID: <20130326115029.9F05A184C53@r-forge.r-project.org> Author: kingaa Date: 2013-03-26 12:50:29 +0100 (Tue, 26 Mar 2013) New Revision: 840 Modified: branches/mif2/DESCRIPTION branches/mif2/R/authors.R branches/mif2/inst/examples/bbs.R branches/mif2/inst/examples/blowflies.R branches/mif2/inst/examples/euler.sir.R branches/mif2/inst/examples/gillespie.sir.R branches/mif2/inst/examples/gompertz.R branches/mif2/inst/examples/ou2.R branches/mif2/inst/examples/ricker.R branches/mif2/inst/examples/rw2.R branches/mif2/inst/examples/verhulst.R branches/mif2/src/SSA_wrapper.c branches/mif2/src/blowfly.c branches/mif2/src/dprocess.c branches/mif2/src/partrans.c branches/mif2/tests/filtfail.R branches/mif2/tests/filtfail.Rout.save branches/mif2/tests/ou2-mif2.R branches/mif2/tests/ou2-mif2.Rout.save Log: - some updates from main branch of pomp Modified: branches/mif2/DESCRIPTION =================================================================== --- branches/mif2/DESCRIPTION 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/DESCRIPTION 2013-03-26 11:50:29 UTC (rev 840) @@ -2,9 +2,20 @@ Type: Package Title: Statistical inference for partially observed Markov processes Version: 0.44-1 -Date: 2013-02-26 -Author: Aaron A. King, Edward L. Ionides, Carles Breto, Steve Ellner, Bruce Kendall, Helen Wearing, Matthew J. Ferrari, Michael Lavine, Daniel C. Reuman +Date: 2013-03-26 +Author: Aaron A. King, Edward L. Ionides, Carles Breto, Steve Ellner, Bruce Kendall, Dao Nguyen, Helen Wearing, Matthew J. Ferrari, Michael Lavine, Daniel C. Reuman Maintainer: Aaron A. King +Author 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("Dao"),family="Nguyen",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 Modified: branches/mif2/R/authors.R =================================================================== --- branches/mif2/R/authors.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/R/authors.R 2013-03-26 11:50:29 UTC (rev 840) @@ -1,9 +1,9 @@ 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("aut"),email="ionides at umich.edu"), - cb=person(given=c("Carles"),family="Breto",role=c("aut")), - spe=person(given=c("Stephen","P."),family="Ellner",role=c("aut")), - bek=person(given=c("Bruce","E."),family="Kendall",role=c("aut")), + 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")), Modified: branches/mif2/inst/examples/bbs.R =================================================================== --- branches/mif2/inst/examples/bbs.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/inst/examples/bbs.R 2013-03-26 11:50:29 UTC (rev 840) @@ -1,6 +1,6 @@ require(pomp) -tc <- textConnection(" +flu <- read.csv2(text=" day;reports 1;3 2;8 @@ -18,9 +18,6 @@ 14;5 ") -flu <- read.csv2(file=tc) -close(tc) - po <- pomp( data=flu, times="day", Modified: branches/mif2/inst/examples/blowflies.R =================================================================== --- branches/mif2/inst/examples/blowflies.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/inst/examples/blowflies.R 2013-03-26 11:50:29 UTC (rev 840) @@ -868,14 +868,13 @@ 718;8103;4 720;6803;4 ' - raw.data <- subset( - read.csv2(textConnection(blowfly.data),comment.char="#"), - set==4 + read.csv2(text=blowfly.data,comment.char="#"), + set==4, + select=-set ) - pomp( - data=subset(raw.data[c("day","y")],day>14&day<400), + data=subset(raw.data,day>14&day<400), times="day", t0=14, rprocess=discrete.time.sim( Modified: branches/mif2/inst/examples/euler.sir.R =================================================================== --- branches/mif2/inst/examples/euler.sir.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/inst/examples/euler.sir.R 2013-03-26 11:50:29 UTC (rev 840) @@ -213,7 +213,7 @@ po <- pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c( Modified: branches/mif2/inst/examples/gillespie.sir.R =================================================================== --- branches/mif2/inst/examples/gillespie.sir.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/inst/examples/gillespie.sir.R 2013-03-26 11:50:29 UTC (rev 840) @@ -525,7 +525,7 @@ ' pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c( Modified: branches/mif2/inst/examples/gompertz.R =================================================================== --- branches/mif2/inst/examples/gompertz.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/inst/examples/gompertz.R 2013-03-26 11:50:29 UTC (rev 840) @@ -105,7 +105,7 @@ ' po <- pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c(K=1,r=0.1,sigma=0.1,tau=0.1,X.0=1), Modified: branches/mif2/inst/examples/ou2.R =================================================================== --- branches/mif2/inst/examples/ou2.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/inst/examples/ou2.R 2013-03-26 11:50:29 UTC (rev 840) @@ -104,7 +104,7 @@ ' pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, rprocess=discrete.time.sim("ou2_step",PACKAGE="pomp"), Modified: branches/mif2/inst/examples/ricker.R =================================================================== --- branches/mif2/inst/examples/ricker.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/inst/examples/ricker.R 2013-03-26 11:50:29 UTC (rev 840) @@ -55,7 +55,7 @@ ' pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c(r=exp(3.8),sigma=0.3,phi=10,N.0=7,e.0=0), # originally used to generate the data Modified: branches/mif2/inst/examples/rw2.R =================================================================== --- branches/mif2/inst/examples/rw2.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/inst/examples/rw2.R 2013-03-26 11:50:29 UTC (rev 840) @@ -104,7 +104,7 @@ ' pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c(x1.0=0,x2.0=0,s1=1,s2=3,tau=1), # parameters at which data were generated Modified: branches/mif2/inst/examples/verhulst.R =================================================================== --- branches/mif2/inst/examples/verhulst.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/inst/examples/verhulst.R 2013-03-26 11:50:29 UTC (rev 840) @@ -1004,7 +1004,7 @@ ' pomp( - data=read.csv2(textConnection(dat)), + data=read.csv2(text=dat), times="time", t0=0, params=c(n.0=10000,K=10000,r=0.9,sigma=0.4,tau=0.1), Modified: branches/mif2/src/SSA_wrapper.c =================================================================== --- branches/mif2/src/SSA_wrapper.c 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/src/SSA_wrapper.c 2013-03-26 11:50:29 UTC (rev 840) @@ -3,6 +3,10 @@ #include "pomp_internal.h" #include +typedef double (*_pomp_rxnrate) (const int *j, const double *t, const double *x, const double *p, + int *stateindex, int *parindex, int *covarindex, + int *ncovar, double *covar); + void F77_SUB(rndstart)(void) { GetRNGstate(); } void F77_SUB(rndend)(void) { PutRNGstate(); } double F77_SUB(unifrnd)(void) { return unif_rand(); } @@ -11,7 +15,7 @@ double F77_SUB(gammarnd)(double shape, double scale) { return rgamma(shape,scale); } void F77_SUB(multinomrnd)(int N, double *p, int ncat, int *ix) { rmultinom(N,p,ncat,ix); } -void F77_NAME(driverssa)(void *fprob, int *nvar, int *nevent, int *npar, int *nreps, int *ntimes, +void F77_NAME(driverssa)(_pomp_rxnrate *fprob, int *nvar, int *nevent, int *npar, int *nreps, int *ntimes, int *kflag, double *xstart, double *times, double *params, double *xout, double *e, double *v, double *d, int *nzero, int *izero, int *istate, int *ipar, int *ncov, int *icov, int *lcov, int *mcov, double *tcov, double *cov); Modified: branches/mif2/src/blowfly.c =================================================================== --- branches/mif2/src/blowfly.c 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/src/blowfly.c 2013-03-26 11:50:29 UTC (rev 840) @@ -5,7 +5,7 @@ #include "pomp.h" #define P (p[parindex[0]]) // growth rate -#define NZERO (p[parindex[1]]) // density-dependence parameter +#define N0 (p[parindex[1]]) // density-dependence parameter #define DELTA (p[parindex[2]]) // survival parameter #define SIGMAP (p[parindex[3]]) // recruitment noise SD #define SIGMAD (p[parindex[4]]) // survivorship noise SD @@ -29,7 +29,7 @@ double eps = rgammawn(SIGMAD,dt)/dt; int k; - R = rpois(P*N[tau]*exp(-N[tau]/NZERO)*dt*e); + R = rpois(P*N[tau]*exp(-N[tau]/N0)*dt*e); S = rbinom(N[0],exp(-DELTA*dt*eps)); E = e; EPS = eps; @@ -60,7 +60,7 @@ #undef EPS #undef P -#undef NZERO +#undef N0 #undef DELTA #undef SIGMAP #undef SIGMAD Modified: branches/mif2/src/dprocess.c =================================================================== --- branches/mif2/src/dprocess.c 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/src/dprocess.c 2013-03-26 11:50:29 UTC (rev 840) @@ -12,7 +12,7 @@ int nprotect = 0; int *xdim, npars, nvars, nreps, nrepsx, ntimes; SEXP X, fn, fcall, rho; - SEXP dimP, dimF; + SEXP dimF; PROTECT(gnsi = duplicate(gnsi)); nprotect++; Modified: branches/mif2/src/partrans.c =================================================================== --- branches/mif2/src/partrans.c 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/src/partrans.c 2013-03-26 11:50:29 UTC (rev 840) @@ -12,7 +12,7 @@ int nprotect = 0; SEXP fn, fcall, rho, ans, nm; SEXP pdim, pvec; - SEXP tparams; + SEXP tparams = R_NilValue; int mode = -1; char direc; int qmat; Modified: branches/mif2/tests/filtfail.R =================================================================== --- branches/mif2/tests/filtfail.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/tests/filtfail.R 2013-03-26 11:50:29 UTC (rev 840) @@ -5,7 +5,8 @@ ### the following example tests to make sure that states are updated properly ### upon filtering failures -"time,admissions,discharges,patients,cases +records <- read.csv(text=" +time,admissions,discharges,patients,cases 0,4,2,8, 1,0,1,10,2 2,2,0,9,1 @@ -27,12 +28,8 @@ 18,4,0,7,1 19,0,0,11,0 20,1,4,11, -" -> csvtext +") -tc <- textConnection(csvtext) -records <- read.csv(tc) -close(tc) - po <- pomp( data=subset(records[c("time","cases")],!is.na(cases)), times="time", Modified: branches/mif2/tests/filtfail.Rout.save =================================================================== --- branches/mif2/tests/filtfail.Rout.save 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/tests/filtfail.Rout.save 2013-03-26 11:50:29 UTC (rev 840) @@ -1,6 +1,6 @@ -R version 2.15.2 (2012-10-26) -- "Trick or Treat" -Copyright (C) 2012 The R Foundation for Statistical Computing +R version 2.15.3 (2013-03-01) -- "Security Blanket" +Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-unknown-linux-gnu (64-bit) @@ -26,7 +26,8 @@ > ### the following example tests to make sure that states are updated properly > ### upon filtering failures > -> "time,admissions,discharges,patients,cases +> records <- read.csv(text=" ++ time,admissions,discharges,patients,cases + 0,4,2,8, + 1,0,1,10,2 + 2,2,0,9,1 @@ -48,12 +49,8 @@ + 18,4,0,7,1 + 19,0,0,11,0 + 20,1,4,11, -+ " -> csvtext ++ ") > -> tc <- textConnection(csvtext) -> records <- read.csv(tc) -> close(tc) -> > po <- pomp( + data=subset(records[c("time","cases")],!is.na(cases)), + times="time", @@ -121,4 +118,4 @@ > > proc.time() user system elapsed - 0.456 0.052 0.526 + 0.464 0.044 0.524 Modified: branches/mif2/tests/ou2-mif2.R =================================================================== --- branches/mif2/tests/ou2-mif2.R 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/tests/ou2-mif2.R 2013-03-26 11:50:29 UTC (rev 840) @@ -76,9 +76,26 @@ ) mif2b <- continue(mif2b,Nmif=50) +mif2c <- mif(ou2,Nmif=50,start=guess1, + pars=c('alpha.2','alpha.3'),ivps=c('x1.0','x2.0'), + rw.sd=c( + x1.0=0.5,x2.0=.5, + alpha.2=0.1,alpha.3=0.1), + transform=F, + Np=1000, + var.factor=1, + cooling.type="hyperbolic", + cooling.fraction=0.05, + max.fail=100, + method="mif2" + ) +mif2c <- continue(mif2c,Nmif=50) + compare.mif(list(mif1b,mif2b)) compare.mif(list(mif1a,mif1b)) compare.mif(list(mif2a,mif2b)) +compare.mif(list(mif1b,mif2c)) + dev.off() Modified: branches/mif2/tests/ou2-mif2.Rout.save =================================================================== --- branches/mif2/tests/ou2-mif2.Rout.save 2013-03-21 14:35:10 UTC (rev 839) +++ branches/mif2/tests/ou2-mif2.Rout.save 2013-03-26 11:50:29 UTC (rev 840) @@ -1,6 +1,6 @@ -R version 2.15.2 (2012-10-26) -- "Trick or Treat" -Copyright (C) 2012 The R Foundation for Statistical Computing +R version 2.15.3 (2013-03-01) -- "Security Blanket" +Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-unknown-linux-gnu (64-bit) @@ -102,15 +102,32 @@ See '?mif' for instructions on specifying the cooling schedule. > mif2b <- continue(mif2b,Nmif=50) > +> mif2c <- mif(ou2,Nmif=50,start=guess1, ++ pars=c('alpha.2','alpha.3'),ivps=c('x1.0','x2.0'), ++ rw.sd=c( ++ x1.0=0.5,x2.0=.5, ++ alpha.2=0.1,alpha.3=0.1), ++ transform=F, ++ Np=1000, ++ var.factor=1, ++ cooling.type="hyperbolic", ++ cooling.fraction=0.05, ++ max.fail=100, ++ method="mif2" ++ ) +> mif2c <- continue(mif2c,Nmif=50) +> > compare.mif(list(mif1b,mif2b)) > > compare.mif(list(mif1a,mif1b)) > compare.mif(list(mif2a,mif2b)) > +> compare.mif(list(mif1b,mif2c)) +> > dev.off() null device 1 > > proc.time() user system elapsed - 42.138 0.064 42.548 + 49.343 0.076 49.753 From noreply at r-forge.r-project.org Tue Mar 26 12:51:33 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 26 Mar 2013 12:51:33 +0100 (CET) Subject: [Pomp-commits] r841 - www/vignettes Message-ID: <20130326115133.B3054184BE2@r-forge.r-project.org> Author: kingaa Date: 2013-03-26 12:51:33 +0100 (Tue, 26 Mar 2013) New Revision: 841 Modified: www/vignettes/advanced_topics_in_pomp.pdf www/vignettes/intro_to_pomp.pdf www/vignettes/plugin-C-code.rda www/vignettes/plugin-R-code.rda www/vignettes/vectorized-C-code.rda www/vignettes/vectorized-R-code.rda Log: Modified: www/vignettes/advanced_topics_in_pomp.pdf =================================================================== (Binary files differ) Modified: www/vignettes/intro_to_pomp.pdf =================================================================== (Binary files differ) Modified: www/vignettes/plugin-C-code.rda =================================================================== (Binary files differ) Modified: www/vignettes/plugin-R-code.rda =================================================================== (Binary files differ) Modified: www/vignettes/vectorized-C-code.rda =================================================================== (Binary files differ) Modified: www/vignettes/vectorized-R-code.rda =================================================================== (Binary files differ)