From noreply at r-forge.r-project.org  Mon Feb  4 13:43:18 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon,  4 Feb 2013 13:43:18 +0100 (CET)
Subject: [Pomp-commits] r822 - in pkg/pomp: . R inst man tests
Message-ID: <20130204124318.D04341841A4@r-forge.r-project.org>

Author: kingaa
Date: 2013-02-04 13:43:18 +0100 (Mon, 04 Feb 2013)
New Revision: 822

Modified:
   pkg/pomp/DESCRIPTION
   pkg/pomp/R/mif-class.R
   pkg/pomp/R/mif.R
   pkg/pomp/R/pfilter.R
   pkg/pomp/inst/NEWS
   pkg/pomp/man/mif-class.Rd
   pkg/pomp/man/mif.Rd
   pkg/pomp/tests/bbs-trajmatch.Rout.save
   pkg/pomp/tests/bbs.Rout.save
   pkg/pomp/tests/blowflies.Rout.save
   pkg/pomp/tests/dacca.Rout.save
   pkg/pomp/tests/dimchecks.Rout.save
   pkg/pomp/tests/fhn.Rout.save
   pkg/pomp/tests/filtfail.Rout.save
   pkg/pomp/tests/gillespie.Rout.save
   pkg/pomp/tests/gompertz.R
   pkg/pomp/tests/gompertz.Rout.save
   pkg/pomp/tests/logistic.Rout.save
   pkg/pomp/tests/ou2-bsmc.Rout.save
   pkg/pomp/tests/ou2-forecast.R
   pkg/pomp/tests/ou2-forecast.Rout.save
   pkg/pomp/tests/ou2-icfit.R
   pkg/pomp/tests/ou2-icfit.Rout.save
   pkg/pomp/tests/ou2-kalman.Rout.save
   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
   pkg/pomp/tests/ou2-nlf.Rout.save
   pkg/pomp/tests/ou2-pmcmc.Rout.save
   pkg/pomp/tests/ou2-probe.Rout.save
   pkg/pomp/tests/ou2-procmeas.Rout.save
   pkg/pomp/tests/ou2-simulate.Rout.save
   pkg/pomp/tests/ou2-trajmatch.Rout.save
   pkg/pomp/tests/pfilter.Rout.save
   pkg/pomp/tests/pomppomp.Rout.save
   pkg/pomp/tests/ricker-bsmc.Rout.save
   pkg/pomp/tests/ricker-probe.Rout.save
   pkg/pomp/tests/ricker-spect.Rout.save
   pkg/pomp/tests/ricker.Rout.save
   pkg/pomp/tests/rw2.Rout.save
   pkg/pomp/tests/sir.Rout.save
   pkg/pomp/tests/skeleton.Rout.save
   pkg/pomp/tests/steps.Rout.save
   pkg/pomp/tests/synlik.Rout.save
   pkg/pomp/tests/verhulst.Rout.save
Log:
- change handling of MIF cooling


Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/DESCRIPTION	2013-02-04 12:43:18 UTC (rev 822)
@@ -2,7 +2,7 @@
 Type: Package
 Title: Statistical inference for partially observed Markov processes
 Version: 0.44-1
-Date: 2013-01-15
+Date: 2013-02-04
 Author: Aaron A. King, Edward L. Ionides, Carles Breto, Steve Ellner, Bruce Kendall, Helen Wearing, Matthew J. Ferrari, Michael Lavine, Daniel C. Reuman
 Maintainer: Aaron A. King <kingaa at umich.edu>
 URL: http://pomp.r-forge.r-project.org

Modified: pkg/pomp/R/mif-class.R
===================================================================
--- pkg/pomp/R/mif-class.R	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/R/mif-class.R	2013-02-04 12:43:18 UTC (rev 822)
@@ -10,7 +10,7 @@
            particles = 'function',
            var.factor='numeric',
            ic.lag='integer',
-           cooling.factor='numeric',
+           cooling.type='character',
            cooling.fraction='numeric',
            method='character',
            random.walk.sd = 'numeric',

Modified: pkg/pomp/R/mif.R
===================================================================
--- pkg/pomp/R/mif.R	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/R/mif.R	2013-02-04 12:43:18 UTC (rev 822)
@@ -16,6 +16,43 @@
          )
 }
 
+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))
+         )
+}
+
 mif.cooling <- function (factor, n) {   # default geometric cooling schedule
   alpha <- factor^(n-1)
   list(alpha=alpha,gamma=alpha^2)
@@ -23,8 +60,8 @@
 
 mif2.cooling <- function (frac, nt, m, n) {   # cooling schedule for mif2
   ## frac is the fraction of cooling after 50 iterations
-  cooling.scalar <- (50*n*frac-1)/(1-frac)
-  alpha <- (1+cooling.scalar)/(cooling.scalar+nt+n*(m-1))
+  scal <- (50*n*frac-1)/(1-frac)
+  alpha <- (1+scal)/(scal+nt+n*(m-1))
   list(alpha=alpha)
 }
 
@@ -44,8 +81,8 @@
                           start, pars, ivps,
                           particles,
                           rw.sd,
-                          Np, cooling.factor, var.factor, ic.lag,
-                          cooling.fraction, 
+                          Np, var.factor, ic.lag,
+                          cooling.type, cooling.fraction, cooling.factor, 
                           method,
                           tol, max.fail,
                           verbose, transform, .ndone = 0,
@@ -164,28 +201,39 @@
             )
   }
   
-  if (method=="mif2") {
-    if (missing(cooling.fraction) || is.na(cooling.fraction))
-      stop("mif error: ",sQuote("cooling.fraction")," must be specified for method = ",sQuote("mif2"),call.=FALSE)
-    cooling.fraction <- as.numeric(cooling.fraction)
-    if ((length(cooling.fraction)!=1)||(cooling.fraction<0)||(cooling.fraction>1))
-      stop("mif error: ",sQuote("cooling.fraction")," must be a number between 0 and 1",call.=FALSE)
-    if (!missing(cooling.factor) && !(is.na(cooling.factor)))
-      warning(sQuote("cooling.factor")," ignored for method = ",sQuote("mif2"),call.=FALSE)
-    cooling.factor <- as.numeric(NA)
-    if (Np[1]!=Np[ntimes+1])
-      stop("the first and last values of ",sQuote("Np")," must agree when method = ",sQuote("mif2"))
-  } else {
-    if (missing(cooling.factor) || is.na(cooling.factor))
-      stop("mif error: ",sQuote("cooling.factor")," must be specified",call.=FALSE)
+  ## the following deals with the deprecated option 'cooling.factor'
+  if (!missing(cooling.factor)) {
+    warning(sQuote("cooling.factor")," is deprecated.\n",
+            "See ?mif for instructions on specifying the cooling schedule.",
+            call.=FALSE)
     cooling.factor <- as.numeric(cooling.factor)
     if ((length(cooling.factor)!=1)||(cooling.factor<0)||(cooling.factor>1))
       stop("mif error: ",sQuote("cooling.factor")," must be a number between 0 and 1",call.=FALSE)
-    if (!missing(cooling.fraction) && !(is.na(cooling.fraction)))
-      warning(sQuote("cooling.fraction")," ignored for method != ",sQuote("mif2"),call.=FALSE)
-    cooling.fraction <- as.numeric(NA)
+    if (missing(cooling.fraction)) {
+      cooling.fraction <- cooling.factor^50
+    } else {
+      warning("specification of ",sQuote("cooling.factor"),
+              " is overridden by that of ",sQuote("cooling.fraction"),
+              call.=FALSE)
+    }
   }
+
+  if (missing(cooling.fraction))
+    stop("mif error: ",sQuote("cooling.fraction")," must be specified",call.=FALSE)
+  cooling.fraction <- as.numeric(cooling.fraction)
+  if ((length(cooling.fraction)!=1)||(cooling.fraction<0)||(cooling.fraction>1))
+    stop("mif error: ",sQuote("cooling.fraction")," must be a number between 0 and 1",call.=FALSE)
   
+  cooling <- cooling.function(
+                              type=cooling.type,
+                              perobs=(method=="mif2"),
+                              fraction=cooling.fraction,
+                              ntimes=ntimes
+                              )
+
+  if ((method=="mif2")&&(Np[1]!=Np[ntimes+1]))
+    stop("the first and last values of ",sQuote("Np")," must agree when method = ",sQuote("mif2"))
+  
   if (missing(var.factor))
     stop("mif error: ",sQuote("var.factor")," must be specified",call.=FALSE)
   if ((length(var.factor)!=1)||(var.factor < 0))
@@ -243,16 +291,7 @@
   for (n in seq_len(Nmif)) { ## iterate the filtering
 
     ## get the intensity of artificial noise from the cooling schedule
-    cool.sched <- try(
-                      switch(
-                             method,
-                             mif2=mif2.cooling(frac=cooling.fraction,nt=1,m=.ndone+n,n=ntimes),
-                             mif.cooling(factor=cooling.factor,n=.ndone+n)
-                             ),
-                      silent=FALSE
-                      )
-    if (inherits(cool.sched,"try-error")) 
-      stop("mif error: cooling schedule error",call.=FALSE)
+    cool.sched <- cooling(nt=1,m=.ndone+n)
     sigma.n <- sigma*cool.sched$alpha
     
     ## initialize the parameter portions of the particles
@@ -283,7 +322,7 @@
                                 pred.mean=(n==Nmif),
                                 pred.var=((method=="mif")||(n==Nmif)),
                                 filter.mean=TRUE,
-                                cooling.fraction=cooling.fraction,
+                                cooling=cooling,
                                 cooling.m=.ndone+n,
                                 .mif2=(method=="mif2"),
                                 .rw.sd=sigma.n[pars],
@@ -341,7 +380,7 @@
       tol=tol,
       conv.rec=conv.rec,
       method=method,
-      cooling.factor=cooling.factor,
+      cooling.type=cooling.type,
       cooling.fraction=cooling.fraction,
       paramMatrix=if (method=="mif2") paramMatrix else array(data=numeric(0),dim=c(0,0))
       )
@@ -356,8 +395,9 @@
                     start,
                     pars, ivps = character(0),
                     particles, rw.sd,
-                    Np, ic.lag, var.factor, cooling.factor,
-                    cooling.fraction,
+                    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"),
@@ -380,6 +420,8 @@
               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
@@ -404,6 +446,7 @@
                          particles=particles,
                          rw.sd=rw.sd,
                          Np=Np,
+                         cooling.type=cooling.type,
                          cooling.factor=cooling.factor,
                          cooling.fraction=cooling.fraction,
                          var.factor=var.factor,
@@ -445,8 +488,8 @@
                     start,
                     pars, ivps,
                     particles, rw.sd,
-                    Np, ic.lag, var.factor, cooling.factor,
-                    cooling.fraction,
+                    Np, ic.lag, var.factor,
+                    cooling.type, cooling.fraction,
                     method,
                     tol,
                     transform,
@@ -460,7 +503,7 @@
             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.factor)) cooling.factor <- object at cooling.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
@@ -478,7 +521,7 @@
                 particles=particles,
                 rw.sd=rw.sd,
                 Np=Np,
-                cooling.factor=cooling.factor,
+                cooling.type=cooling.type,
                 cooling.fraction=cooling.fraction,
                 var.factor=var.factor,
                 ic.lag=ic.lag,

Modified: pkg/pomp/R/pfilter.R
===================================================================
--- pkg/pomp/R/pfilter.R	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/R/pfilter.R	2013-02-04 12:43:18 UTC (rev 822)
@@ -38,7 +38,7 @@
 pfilter.internal <- function (object, params, Np,
                               tol, max.fail,
                               pred.mean, pred.var, filter.mean,
-                              cooling.fraction, cooling.m, .mif2 = FALSE,
+                              cooling, cooling.m, .mif2 = FALSE,
                               .rw.sd, seed, verbose,
                               save.states, save.params,
                               .transform) {
@@ -184,21 +184,10 @@
   else
     filt.m <- array(data=numeric(0),dim=c(0,0))
 
-  if (mif2) {
-    if (missing(cooling.fraction))
-      stop("pfilter error: ",sQuote("cooling.fraction")," must be specified for method mif2",call.=FALSE)
-    cooling.fraction <- as.numeric(cooling.fraction)
-  }
-  
   for (nt in seq_len(ntimes)) {
     
     if (mif2) {	  
-      cool.sched <- try(
-                        mif2.cooling(frac=cooling.fraction,nt=nt,m=cooling.m,n=ntimes),
-                        silent=FALSE
-                        )
-      if (inherits(cool.sched,"try-error")) 
-        stop("pfilter error: cooling schedule error",call.=FALSE)
+      cool.sched <- cooling(nt=nt,m=cooling.m)
       sigma1 <- sigma*cool.sched$alpha
     } else {
       sigma1 <- sigma

Modified: pkg/pomp/inst/NEWS
===================================================================
--- pkg/pomp/inst/NEWS	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/inst/NEWS	2013-02-04 12:43:18 UTC (rev 822)
@@ -6,6 +6,12 @@
      	Before, the default behavior has been to stop with an error on the first filtering failure ('max.fail=0').
 	Now, the default is 'max.fail=Inf', i.e., an error is never triggered.
 
+     o	The implementation of MIF cooling schedules has been changed to make it more general.
+     	The cooling schedule is now specified by a 'type' and a 'fraction'.
+	Currently, supported 'cooling.type's include 'geometric' (the old behavior) and 'hyperbolic', i.e., a 1/(1+n) schedule.
+	The 'cooling.fraction' argument specifies the cooling at 50 iterations.
+	That is, if s is the intensity of the random-walk perturbation to parameters at the first iteration ('rw.sd'), then the intensity at iteration 50 is s*cooling.fraction.
+
      o	Remove all data()-loadable pomp objects.
 	To load the prebuilt example pomp objects from previous versions, use the new 'pompExample' function.
 	E.g., instead of 'data(euler.sir)', do 'pompExample("euler.sir")'.

Modified: pkg/pomp/man/mif-class.Rd
===================================================================
--- pkg/pomp/man/mif-class.Rd	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/man/mif-class.Rd	2013-02-04 12:43:18 UTC (rev 822)
@@ -39,13 +39,9 @@
     \item{ic.lag}{
       the fixed lag used in the estimation of initial-value parameters (IVPs)
     }
-    \item{cooling.factor}{
-      the exponential cooling factor, where \code{0<cooling.factor<1}.
+    \item{cooling.type, cooling.fraction}{
+      the cooling schedule specifications
     }
-    \item{cooling.fraction}{
-      the fraction that determines the cooling schedule when \code{method='mif2'}.
-      \code{0<cooling.fraction<1}.
-    }
     \item{method}{
       character; the mif update method.
     }

Modified: pkg/pomp/man/mif.Rd
===================================================================
--- pkg/pomp/man/mif.Rd	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/man/mif.Rd	2013-02-04 12:43:18 UTC (rev 822)
@@ -17,13 +17,15 @@
 \usage{
 mif(object, \dots)
 \S4method{mif}{pomp}(object, Nmif = 1, start, pars, ivps = character(0),
-    particles, rw.sd, Np, ic.lag, var.factor, cooling.factor,
-    cooling.fraction, method = c("mif","unweighted","fp","mif2"),
+    particles, rw.sd, Np, ic.lag, var.factor,
+    cooling.type, cooling.fraction, cooling.factor,
+    method = c("mif","unweighted","fp","mif2"),
     tol = 1e-17, max.fail = Inf,
     verbose = getOption("verbose"), transform = FALSE, \dots)
 \S4method{mif}{pfilterd.pomp}(object, Nmif = 1, Np, tol, \dots)
 \S4method{mif}{mif}(object, Nmif, start, pars, ivps,
-    particles, rw.sd, Np, ic.lag, var.factor, cooling.factor, cooling.fraction,
+    particles, rw.sd, Np, ic.lag, var.factor,
+    cooling.type, cooling.fraction,
     method, tol, transform, \dots)
 \S4method{continue}{mif}(object, Nmif = 1, \dots)
 }
@@ -85,13 +87,15 @@
     the scaling coefficient relating the width of the starting particle distribution to \code{rw.sd}.
     In particular, the width of the distribution of particles at the start of the first MIF iteration will be \code{random.walk.sd*var.factor}.
   }
-  \item{cooling.factor}{
-    a positive number not greater than 1;
-    the exponential cooling factor, \code{alpha}.
+  \item{cooling.type, cooling.fraction, cooling.factor}{
+    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}.
+    \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}.
   }
-  \item{cooling.fraction}{
-    [EXPLAIN]
-  }
   \item{method}{
     \code{method} sets the update rule used in the algorithm.
     \code{method="mif"} uses the iterated filtering update rule (Ionides 2006, 2011);

Modified: pkg/pomp/tests/bbs-trajmatch.Rout.save
===================================================================
--- pkg/pomp/tests/bbs-trajmatch.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/bbs-trajmatch.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -70,4 +70,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  2.424   0.060   2.516 
+  2.176   0.032   2.241 

Modified: pkg/pomp/tests/bbs.Rout.save
===================================================================
--- pkg/pomp/tests/bbs.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/bbs.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -60,4 +60,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  2.704   0.100   2.827 
+  2.648   0.048   2.732 

Modified: pkg/pomp/tests/blowflies.Rout.save
===================================================================
--- pkg/pomp/tests/blowflies.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/blowflies.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -72,4 +72,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  1.316   0.064   1.397 
+  1.124   0.056   1.204 

Modified: pkg/pomp/tests/dacca.Rout.save
===================================================================
--- pkg/pomp/tests/dacca.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/dacca.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -52,4 +52,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  3.544   0.096   3.661 
+  3.304   0.044   3.379 

Modified: pkg/pomp/tests/dimchecks.Rout.save
===================================================================
--- pkg/pomp/tests/dimchecks.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/dimchecks.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -164,4 +164,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  0.576   0.032   0.619 
+  0.452   0.040   0.517 

Modified: pkg/pomp/tests/fhn.Rout.save
===================================================================
--- pkg/pomp/tests/fhn.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/fhn.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -93,4 +93,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  1.172   0.064   1.359 
+  0.908   0.060   1.204 

Modified: pkg/pomp/tests/filtfail.Rout.save
===================================================================
--- pkg/pomp/tests/filtfail.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/filtfail.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -121,4 +121,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  0.460   0.056   0.534 
+  0.456   0.052   0.526 

Modified: pkg/pomp/tests/gillespie.Rout.save
===================================================================
--- pkg/pomp/tests/gillespie.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/gillespie.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -133,4 +133,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  4.400   0.056   4.480 
+  2.392   0.040   2.459 

Modified: pkg/pomp/tests/gompertz.R
===================================================================
--- pkg/pomp/tests/gompertz.R	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/gompertz.R	2013-02-04 12:43:18 UTC (rev 822)
@@ -20,7 +20,8 @@
               start=guess,
               Nmif=5,Np=1000,
               transform=TRUE,
-              ic.lag=1,var.factor=1,cooling.factor=0.99,
+              ic.lag=1,var.factor=1,
+              cooling.fraction=0.99^50,
               rw.sd=c(r=0.02,K=0.02)
               )
     )
@@ -30,7 +31,8 @@
           po,
           Nmif=5,Np=1000,
           transform=TRUE,
-          ic.lag=1,var.factor=1,cooling.factor=0.99,
+          ic.lag=1,var.factor=1,
+          cooling.fraction=0.99^50,
           rw.sd=c(r=0.02,K=0.02)
           )
 coef(mf,transform=TRUE)

Modified: pkg/pomp/tests/gompertz.Rout.save
===================================================================
--- pkg/pomp/tests/gompertz.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/gompertz.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -55,7 +55,8 @@
 +               start=guess,
 +               Nmif=5,Np=1000,
 +               transform=TRUE,
-+               ic.lag=1,var.factor=1,cooling.factor=0.99,
++               ic.lag=1,var.factor=1,
++               cooling.fraction=0.99^50,
 +               rw.sd=c(r=0.02,K=0.02)
 +               )
 +     )
@@ -67,7 +68,8 @@
 +           po,
 +           Nmif=5,Np=1000,
 +           transform=TRUE,
-+           ic.lag=1,var.factor=1,cooling.factor=0.99,
++           ic.lag=1,var.factor=1,
++           cooling.fraction=0.99^50,
 +           rw.sd=c(r=0.02,K=0.02)
 +           )
 > coef(mf,transform=TRUE)
@@ -133,4 +135,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  1.512   0.036   1.573 
+  1.488   0.048   1.562 

Modified: pkg/pomp/tests/logistic.Rout.save
===================================================================
--- pkg/pomp/tests/logistic.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/logistic.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -124,4 +124,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  1.052   0.048   1.219 
+  0.788   0.056   0.968 

Modified: pkg/pomp/tests/ou2-bsmc.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-bsmc.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/ou2-bsmc.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -64,7 +64,7 @@
 > post <- smc$post
 > 
 > print(etime <- toc-tic)
-Time difference of 3.497756 secs
+Time difference of 2.994066 secs
 > 
 > print(
 +       cbind(
@@ -100,4 +100,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  5.452   0.080   5.564 
+  4.876   0.048   4.960 

Modified: pkg/pomp/tests/ou2-forecast.R
===================================================================
--- pkg/pomp/tests/ou2-forecast.R	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/ou2-forecast.R	2013-02-04 12:43:18 UTC (rev 822)
@@ -28,7 +28,7 @@
   mse[,k,] <- bias^2+sd^2                         ## mean squared error
 }
 
-fit <- mif(ou2,Nmif=3,rw.sd=c(alpha.1=0.1,alpha.4=0.1),Np=1000,cooling.factor=0.98,var.factor=1,ic.lag=2)
+fit <- mif(ou2,Nmif=3,rw.sd=c(alpha.1=0.1,alpha.4=0.1),Np=1000,cooling.fraction=0.98^50,var.factor=1,ic.lag=2)
 pf <- pfilter(fit,save.states=TRUE,save.params=TRUE)
 
 pdf(file="ou2-forecast.pdf")

Modified: pkg/pomp/tests/ou2-forecast.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-forecast.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/ou2-forecast.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -51,7 +51,7 @@
 +   mse[,k,] <- bias^2+sd^2                         ## mean squared error
 + }
 > 
-> fit <- mif(ou2,Nmif=3,rw.sd=c(alpha.1=0.1,alpha.4=0.1),Np=1000,cooling.factor=0.98,var.factor=1,ic.lag=2)
+> fit <- mif(ou2,Nmif=3,rw.sd=c(alpha.1=0.1,alpha.4=0.1),Np=1000,cooling.fraction=0.98^50,var.factor=1,ic.lag=2)
 > pf <- pfilter(fit,save.states=TRUE,save.params=TRUE)
 > 
 > pdf(file="ou2-forecast.pdf")
@@ -63,4 +63,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  1.928   0.060   2.108 
+  1.528   0.044   1.689 

Modified: pkg/pomp/tests/ou2-icfit.R
===================================================================
--- pkg/pomp/tests/ou2-icfit.R	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/ou2-icfit.R	2013-02-04 12:43:18 UTC (rev 822)
@@ -20,7 +20,7 @@
              x1.0=1,x2.0=1
              ),
            Np=1000,
-           cooling.factor=1,
+           cooling.fraction=1,
            max.fail=10
            )
 
@@ -35,7 +35,7 @@
              x1.0=1,x2.0=1
              ),
            Np=1000,
-           cooling.factor=1,
+           cooling.fraction=1,
            max.fail=10
            )
 
@@ -50,7 +50,7 @@
              x1.0=1,x2.0=1
              ),
            Np=1000,
-           cooling.factor=1,
+           cooling.fraction=1,
            max.fail=10
            )
 

Modified: pkg/pomp/tests/ou2-icfit.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-icfit.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/ou2-icfit.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -43,7 +43,7 @@
 +              x1.0=1,x2.0=1
 +              ),
 +            Np=1000,
-+            cooling.factor=1,
++            cooling.fraction=1,
 +            max.fail=10
 +            )
 Warning message:
@@ -60,7 +60,7 @@
 +              x1.0=1,x2.0=1
 +              ),
 +            Np=1000,
-+            cooling.factor=1,
++            cooling.fraction=1,
 +            max.fail=10
 +            )
 Warning message:
@@ -77,7 +77,7 @@
 +              x1.0=1,x2.0=1
 +              ),
 +            Np=1000,
-+            cooling.factor=1,
++            cooling.fraction=1,
 +            max.fail=10
 +            )
 > 
@@ -109,4 +109,4 @@
 > 
 > proc.time()
    user  system elapsed 
- 17.629   0.060  17.749 
+ 16.897   0.048  17.022 

Modified: pkg/pomp/tests/ou2-kalman.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-kalman.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/ou2-kalman.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -166,7 +166,7 @@
     117 function evaluations used
 > toc <- Sys.time()
 > print(toc-tic)
-Time difference of 5.160968 secs
+Time difference of 5.084913 secs
 > tic <- Sys.time()
 > print(loglik.mle <- -kalm.fit1$value,digits=4)
 [1] -477.2
@@ -190,4 +190,4 @@
 > 
 > proc.time()
    user  system elapsed 
-  5.680   0.044   5.752 
+  5.596   0.044   5.680 

Modified: pkg/pomp/tests/ou2-mif-fp.R
===================================================================
--- pkg/pomp/tests/ou2-mif-fp.R	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/ou2-mif-fp.R	2013-02-04 12:43:18 UTC (rev 822)
@@ -14,30 +14,32 @@
 mif1 <- mif(ou2,Nmif=100,start=guess1,
 	    pars=c('alpha.2','alpha.3'),ivps=c('x1.0','x2.0'),
 	    rw.sd=c(
-	    x1.0=5,x2.0=5,
-	    alpha.2=0.1,alpha.3=0.1
-	    ),
-	  Np=1000,
-	  var.factor=1,
-	  ic.lag=10,
-	  cooling.factor=0.95,
-	  max.fail=100,
-	  method="fp"
+              x1.0=5,x2.0=5,
+              alpha.2=0.1,alpha.3=0.1
+              ),
+            Np=1000,
+            var.factor=1,
+            ic.lag=10,
+            cooling.type="geometric",
+            cooling.fraction=0.95^50,
+            max.fail=100,
+            method="fp"
 	  )
 	  
 mif2 <- mif(ou2,Nmif=100,start=guess2,
 	    pars=c('alpha.2','alpha.3'),ivps=c('x1.0','x2.0'),
 	    rw.sd=c(
-	    x1.0=5,x2.0=5,
-	    alpha.2=0.1,alpha.3=0.1
-	    ),
-	  Np=1000,
-	  var.factor=1,
-	  ic.lag=10,
-	  cooling.factor=0.95,
-	  max.fail=100,
-	  method="fp"
-	  )
+              x1.0=5,x2.0=5,
+              alpha.2=0.1,alpha.3=0.1
+              ),
+            Np=1000,
+            var.factor=1,
+            ic.lag=10,
+            cooling.type="geometric",
+            cooling.fraction=0.95^50,
+            max.fail=100,
+            method="fp"
+            )
 	  
 compare.mif(list(mif1,mif2))
 

Modified: pkg/pomp/tests/ou2-mif-fp.Rout.save
===================================================================
--- pkg/pomp/tests/ou2-mif-fp.Rout.save	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/ou2-mif-fp.Rout.save	2013-02-04 12:43:18 UTC (rev 822)
@@ -37,30 +37,32 @@
 > mif1 <- mif(ou2,Nmif=100,start=guess1,
 + 	    pars=c('alpha.2','alpha.3'),ivps=c('x1.0','x2.0'),
 + 	    rw.sd=c(
-+ 	    x1.0=5,x2.0=5,
-+ 	    alpha.2=0.1,alpha.3=0.1
-+ 	    ),
-+ 	  Np=1000,
-+ 	  var.factor=1,
-+ 	  ic.lag=10,
-+ 	  cooling.factor=0.95,
-+ 	  max.fail=100,
-+ 	  method="fp"
++               x1.0=5,x2.0=5,
++               alpha.2=0.1,alpha.3=0.1
++               ),
++             Np=1000,
++             var.factor=1,
++             ic.lag=10,
++             cooling.type="geometric",
++             cooling.fraction=0.95^50,
++             max.fail=100,
++             method="fp"
 + 	  )
 > 	  
 > mif2 <- mif(ou2,Nmif=100,start=guess2,
 + 	    pars=c('alpha.2','alpha.3'),ivps=c('x1.0','x2.0'),
 + 	    rw.sd=c(
-+ 	    x1.0=5,x2.0=5,
-+ 	    alpha.2=0.1,alpha.3=0.1
-+ 	    ),
-+ 	  Np=1000,
-+ 	  var.factor=1,
-+ 	  ic.lag=10,
-+ 	  cooling.factor=0.95,
-+ 	  max.fail=100,
-+ 	  method="fp"
-+ 	  )
++               x1.0=5,x2.0=5,
++               alpha.2=0.1,alpha.3=0.1
++               ),
++             Np=1000,
++             var.factor=1,
++             ic.lag=10,
++             cooling.type="geometric",
++             cooling.fraction=0.95^50,
++             max.fail=100,
++             method="fp"
++             )
 > 	  
 > compare.mif(list(mif1,mif2))
 > 
@@ -70,4 +72,4 @@
 > 
 > proc.time()
    user  system elapsed 
- 20.065   0.076  20.346 
+ 19.653   0.024  19.956 

Modified: pkg/pomp/tests/ou2-mif.R
===================================================================
--- pkg/pomp/tests/ou2-mif.R	2013-01-21 23:14:11 UTC (rev 821)
+++ pkg/pomp/tests/ou2-mif.R	2013-02-04 12:43:18 UTC (rev 822)
@@ -27,6 +27,7 @@
             Np=1000,
             var.factor=1,
             ic.lag=10,
+            cooling.type="geometric",
             cooling.factor=0.95,
             max.fail=100
             )
@@ -41,7 +42,8 @@
             Np=1000,
             var.factor=1,
             ic.lag=10,
-            cooling.factor=0.95,
+            cooling.type="geometric",
+            cooling.fraction=0.95^50,
             max.fail=100
             )
 
@@ -61,7 +63,8 @@
         pars=c("alpha.1","alpha.4","x1.0"),
         ivps=c("x1.0","x2.0"),
         rw.sd=c(x1.0=5,x2.0=5,alpha.1=0.1,alpha.4=0.2,alpha.3=0),
-        Np=100,cooling.factor=0.95,ic.lag=10,var.factor=1
+        Np=100,cooling.type="geometric",cooling.fraction=0.95^50,
+        ic.lag=10,var.factor=1
         )
     )
 
@@ -72,7 +75,9 @@
         pars=c("alpha.1","alpha.4"),
         ivps=c("x1.0","x2.0"),
         rw.sd=c(x1.0=5,x2.0=5,alpha.1=0,alpha.4=0.2,alpha.3=0),
-        Np=100,cooling.factor=0.95,ic.lag=10,var.factor=1
+        Np=100,
+        cooling.type="geometric",cooling.fraction=0.95^50,
+        ic.lag=10,var.factor=1
         )
     )
 
@@ -82,7 +87,8 @@
         Nmif=1,
         ivps=c("x1.0","x2.0"),
         rw.sd=c(alpha.1=0.1,alpha.4=0.2,alpha.3=0),
-        Np=100,cooling.factor=0.95,ic.lag=10,var.factor=1
+        Np=100,cooling.type="geometric",cooling.fraction=0.95^50,
+        cooling.factor=0.95,ic.lag=10,var.factor=1
         )
     )
 
@@ -102,7 +108,8 @@
         Nmif=1,
         ivps=c("x1.0","x2.0"),
         rw.sd=c(x1.0=5,x2.0=5,alpha.1=0,alpha.4=0.2,alpha.3=0),
-        Np=-10,cooling.factor=0.95,ic.lag=10,var.factor=1
+        Np=-10,cooling.type="geometric",cooling.fraction=0.95^50,
+        ic.lag=10,var.factor=1
         )
     )
 
@@ -112,7 +119,8 @@
         Nmif=-3,
         ivps=c("x1.0","x2.0"),
         rw.sd=c(x1.0=5,x2.0=5,alpha.1=0,alpha.4=0.2,alpha.3=0),
-        Np=11.6,cooling.factor=0.95,ic.lag=10,var.factor=1
+        Np=11.6,cooling.type="geometric",cooling.fraction=0.95^50,
+        ic.lag=10,var.factor=1
         )
     )
 
@@ -123,7 +131,8 @@
         start=c(alpha.1=0.9,alpha.2=0,alpha.3=0,alpha.4=-Inf,sigma.1=1,sigma.2=0,sigma.3=2,tau=1,x1.0=50,x2.0=-50),
         ivps=c("x1.0","x2.0"),
         rw.sd=c(x1.0=5,x2.0=5,alpha.1=0,alpha.4=0.2,alpha.3=0),
-        Np=11,cooling.factor=0.95,ic.lag=10,var.factor=1
+        Np=11,cooling.type="geometric",cooling.fraction=0.95^50,
+        ic.lag=10,var.factor=1
         )
     )
 
@@ -134,7 +143,8 @@
         start=c(alpha.1=0.9,alpha.2=0,alpha.3=0,alpha.4=0.99,sigma.1=1,sigma.2=0,sigma.3=2,tau=1,x1.0=50,x2.0=NaN),
         ivps=c("x1.0","x2.0"),
         rw.sd=c(x1.0=5,x2.0=5,alpha.1=0,alpha.4=0.2,alpha.3=0),
-        Np=11,cooling.factor=0.95,ic.lag=10,var.factor=1
+        Np=11,cooling.type="geometric",cooling.fraction=0.95^50,
+        ic.lag=10,var.factor=1
         )
     )
 
@@ -144,7 +154,8 @@
            pars=c("alpha.2","alpha.3"),
            ivps=c("x1.0","x2.0"),
            rw.sd=c(x1.0=5,x2.0=5,alpha.2=0.1,alpha.3=0.2,alpha.3=0),
-           Np=100,cooling.factor=0.95,ic.lag=10,var.factor=1
+           Np=100,cooling.type="geometric",cooling.fraction=0.95^50,
+           ic.lag=10,var.factor=1
            )
 fit <- mif(
            fit,
@@ -152,7 +163,8 @@
            ivps=c("x1.0","x2.0"),
            rw.sd=c(x1.0=5,x2.0=5,alpha.2=0.1,alpha.3=0.2),
            Np=function(k)if(k<10) 2000 else 500,
-           cooling.factor=0.95,ic.lag=10,var.factor=1
+           cooling.type="geometric",cooling.fraction=0.95^50,
+           ic.lag=10,var.factor=1
            )
 fit <- continue(fit)
 fit <- continue(fit,Nmif=2)
@@ -163,7 +175,7 @@
 s <- coef(fit)
 s[2] <- 0.01
 fit <- mif(fit,Nmif=3,start=s)
-fit <- mif(ou2,Nmif=3,rw.sd=c(alpha.2=0.1,alpha.3=0.1),Np=1000,cooling.factor=0.98,var.factor=1,ic.lag=2)
+fit <- mif(ou2,Nmif=3,rw.sd=c(alpha.2=0.1,alpha.3=0.1),Np=1000,cooling.type="geometric",cooling.fraction=0.98^50,var.factor=1,ic.lag=2)
 fit <- continue(fit,Nmif=2,Np=2000)
[TRUNCATED]

To get the complete diff run:
    svnlook diff /svnroot/pomp -r 822

From noreply at r-forge.r-project.org  Tue Feb  5 16:21:40 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue,  5 Feb 2013 16:21:40 +0100 (CET)
Subject: [Pomp-commits] r823 - www/vignettes
Message-ID: <20130205152140.166F8184BAE@r-forge.r-project.org>

Author: kingaa
Date: 2013-02-05 16:21:39 +0100 (Tue, 05 Feb 2013)
New Revision: 823

Modified:
   www/vignettes/advanced_topics_in_pomp.pdf
   www/vignettes/complex-sir-def.rda
   www/vignettes/gompertz-multi-mif.rda
   www/vignettes/gompertz-pfilter-guess.rda
   www/vignettes/intro_to_pomp.R
   www/vignettes/intro_to_pomp.Rnw
   www/vignettes/intro_to_pomp.pdf
   www/vignettes/plugin-C-code.rda
   www/vignettes/plugin-R-code.rda
   www/vignettes/ricker-mif.rda
   www/vignettes/vectorized-C-code.rda
   www/vignettes/vectorized-R-code.rda
Log:
- update vignettes


Modified: www/vignettes/advanced_topics_in_pomp.pdf
===================================================================
(Binary files differ)

Modified: www/vignettes/complex-sir-def.rda
===================================================================
(Binary files differ)

Modified: www/vignettes/gompertz-multi-mif.rda
===================================================================
(Binary files differ)

Modified: www/vignettes/gompertz-pfilter-guess.rda
===================================================================
(Binary files differ)

Modified: www/vignettes/intro_to_pomp.R
===================================================================
--- www/vignettes/intro_to_pomp.R	2013-02-04 12:43:18 UTC (rev 822)
+++ www/vignettes/intro_to_pomp.R	2013-02-05 15:21:39 UTC (rev 823)
@@ -387,7 +387,8 @@
 ##                 Np=2000,
 ##                 var.factor=4,
 ##                 ic.lag=10,
-##                 cooling.factor=0.999,
+##                 cooling.type="geometric",
+##                 cooling.fraction=0.95,
 ##                 max.fail=10
 ##                 )
 ##           }
@@ -437,7 +438,8 @@
                 Np=2000,
                 var.factor=4,
                 ic.lag=10,
-                cooling.factor=0.999,
+                cooling.type="geometric",
+                cooling.fraction=0.95,
                 max.fail=10
                 )
           }
@@ -471,7 +473,7 @@
 
 
 ###################################################
-### code chunk number 41: intro_to_pomp.Rnw:689-690 (eval = FALSE)
+### code chunk number 41: intro_to_pomp.Rnw:690-691 (eval = FALSE)
 ###################################################
 ## theta.true <- coef(gompertz)
 ## theta.mif <- apply(sapply(mf,coef),1,mean)
@@ -743,7 +745,8 @@
 ##           Nmif=100,
 ##           Np=1000,
 ##           transform=TRUE,
-##           cooling.factor=0.99,
+##           cooling.type="geometric",
+##           cooling.fraction=0.6,
 ##           var.factor=2,
 ##           ic.lag=3,
 ##           max.fail=50,
@@ -765,7 +768,8 @@
           Nmif=100,
           Np=1000,
           transform=TRUE,
-          cooling.factor=0.99,
+          cooling.type="geometric",
+          cooling.fraction=0.6,
           var.factor=2,
           ic.lag=3,
           max.fail=50,
@@ -931,7 +935,7 @@
 
 
 ###################################################
-### code chunk number 69: intro_to_pomp.Rnw:1123-1124
+### code chunk number 69: intro_to_pomp.Rnw:1125-1126
 ###################################################
 fits
 
@@ -1116,7 +1120,7 @@
 
 
 ###################################################
-### code chunk number 77: intro_to_pomp.Rnw:1269-1270
+### code chunk number 77: intro_to_pomp.Rnw:1271-1272
 ###################################################
 apply(fvals,2,function(x)sd(x)/mean(x))
 
@@ -1158,7 +1162,7 @@
 
 
 ###################################################
-### code chunk number 80: intro_to_pomp.Rnw:1308-1309
+### code chunk number 80: intro_to_pomp.Rnw:1310-1311
 ###################################################
 set.seed(32329L)
 
@@ -1228,7 +1232,7 @@
 
 
 ###################################################
-### code chunk number 83: intro_to_pomp.Rnw:1346-1347
+### code chunk number 83: intro_to_pomp.Rnw:1348-1349
 ###################################################
 apply(pars,2,sd)
 

Modified: www/vignettes/intro_to_pomp.Rnw
===================================================================
--- www/vignettes/intro_to_pomp.Rnw	2013-02-04 12:43:18 UTC (rev 822)
+++ www/vignettes/intro_to_pomp.Rnw	2013-02-05 15:21:39 UTC (rev 823)
@@ -631,7 +631,8 @@
                 Np=2000,
                 var.factor=4,
                 ic.lag=10,
-                cooling.factor=0.999,
+                cooling.type="geometric",
+                cooling.fraction=0.95,
                 max.fail=10
                 )
           }
@@ -989,7 +990,8 @@
           Nmif=100,
           Np=1000,
           transform=TRUE,
-          cooling.factor=0.99,
+          cooling.type="geometric",
+          cooling.fraction=0.6,
           var.factor=2,
           ic.lag=3,
           max.fail=50,

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/ricker-mif.rda
===================================================================
(Binary files differ)

Modified: www/vignettes/vectorized-C-code.rda
===================================================================
(Binary files differ)

Modified: www/vignettes/vectorized-R-code.rda
===================================================================
(Binary files differ)


From noreply at r-forge.r-project.org  Tue Feb  5 17:22:39 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue,  5 Feb 2013 17:22:39 +0100 (CET)
Subject: [Pomp-commits] r824 - in branches/mif2: . R tests
Message-ID: <20130205162239.E52BF1812ED@r-forge.r-project.org>

Author: nxdao2000
Date: 2013-02-05 17:22:39 +0100 (Tue, 05 Feb 2013)
New Revision: 824

Modified:
   branches/mif2/
   branches/mif2/.Rbuildignore
   branches/mif2/R/mif.R
   branches/mif2/R/pfilter.R
   branches/mif2/tests/ou2-mif2.R
Log:
change for different cooling scheme and update for branch only


Property changes on: branches/mif2
___________________________________________________________________
Added: svn:ignore
   + .Rproj.user
.Rhistory
.RData


Modified: branches/mif2/.Rbuildignore
===================================================================
--- branches/mif2/.Rbuildignore	2013-02-05 15:21:39 UTC (rev 823)
+++ branches/mif2/.Rbuildignore	2013-02-05 16:22:39 UTC (rev 824)
@@ -2,3 +2,5 @@
 inst/doc/(.+?)\.bst$
 inst/doc/(.+?)\.R$
 inst/doc/(.+?)\.png$
+^.*\.Rproj$
+^\.Rproj\.user$

Modified: branches/mif2/R/mif.R
===================================================================
--- branches/mif2/R/mif.R	2013-02-05 15:21:39 UTC (rev 823)
+++ branches/mif2/R/mif.R	2013-02-05 16:22:39 UTC (rev 824)
@@ -25,7 +25,8 @@
   ## frac is the fraction of cooling after 50 iterations
   cooling.scalar <- (50*n*frac-1)/(1-frac)
   alpha <- (1+cooling.scalar)/(cooling.scalar+nt+n*(m-1))
-  list(alpha=alpha)
+  
+  list(alpha=alpha,gamma=alpha^2)
 }
 
 powerlaw.cooling <- function (init = 1, delta = 0.1, eps = (1-delta)/2, n) {
@@ -172,7 +173,7 @@
       stop("mif error: ",sQuote("cooling.fraction")," must be a number between 0 and 1",call.=FALSE)
     if (!missing(cooling.factor) && !(is.na(cooling.factor)))
       warning(sQuote("cooling.factor")," ignored for method = ",sQuote("mif2"),call.=FALSE)
-    cooling.factor <- as.numeric(NA)
+    cooling.factor <- as.numeric(cooling.factor)
     if (Np[1]!=Np[ntimes+1])
       stop("the first and last values of ",sQuote("Np")," must agree when method = ",sQuote("mif2"))
   } else {
@@ -183,7 +184,7 @@
       stop("mif error: ",sQuote("cooling.factor")," must be a number between 0 and 1",call.=FALSE)
     if (!missing(cooling.fraction) && !(is.na(cooling.fraction)))
       warning(sQuote("cooling.fraction")," ignored for method != ",sQuote("mif2"),call.=FALSE)
-    cooling.fraction <- as.numeric(NA)
+    cooling.fraction <- as.numeric(cooling.fraction)
   }
   
   if (missing(var.factor))
@@ -247,6 +248,8 @@
                       switch(
                              method,
                              mif2=mif2.cooling(frac=cooling.fraction,nt=1,m=.ndone+n,n=ntimes),
+                             mif4=mif2.cooling(frac=cooling.fraction,nt=round((.ndone+n)/2),m=.ndone+n,n=ntimes),
+                             mif3=mif.cooling(factor=cooling.factor,n=.ndone+n),
                              mif.cooling(factor=cooling.factor,n=.ndone+n)
                              ),
                       silent=FALSE
@@ -268,24 +271,24 @@
     if (inherits(P,"try-error")) 
       stop("mif error: error in ",sQuote("particles"),call.=FALSE)
 
-    if ((method=="mif2") && ((n>1) || have.parmat)) {
+    if (((method=="mif2")||(method=="mif3")) && ((n>1) || have.parmat)) {
       ## use pre-existing particle matrix
       P[pars,] <- paramMatrix[pars,]
     }
 
     pfp <- try(
-               pfilter.internal(
+                pfilter.internal(
                                 object=obj,
                                 params=P, 
                                 Np=Np,
                                 tol=tol,
                                 max.fail=max.fail,
                                 pred.mean=(n==Nmif),
-                                pred.var=((method=="mif")||(n==Nmif)),
+                                pred.var=((method=="mif")||(method=="mif4")||(n==Nmif)),
                                 filter.mean=TRUE,
                                 cooling.fraction=cooling.fraction,
                                 cooling.m=.ndone+n,
-                                .mif2=(method=="mif2"),
+                                .mif2=((method=="mif2")||(method=="mif3")),
                                 .rw.sd=sigma.n[pars],
                                 .transform=transform,
                                 save.states=FALSE, 
@@ -303,6 +306,9 @@
            mif={              # original Ionides et al. (2006) average
              theta <- .Call(mif_update,pfp,theta,cool.sched$gamma,var.factor,sigma,pars)
            },
+           mif4={              # 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])
            },
@@ -313,6 +319,10 @@
              paramMatrix <- pfp at paramMatrix
              theta[pars] <- rowMeans(paramMatrix[pars,,drop=FALSE])
            },
+           mif3={                     # "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]
@@ -343,7 +353,7 @@
       method=method,
       cooling.factor=cooling.factor,
       cooling.fraction=cooling.fraction,
-      paramMatrix=if (method=="mif2") paramMatrix else array(data=numeric(0),dim=c(0,0))
+      paramMatrix=if ((method=="mif2")||(method=="mif3")) paramMatrix else array(data=numeric(0),dim=c(0,0))
       )
 }
 
@@ -358,7 +368,7 @@
                     particles, rw.sd,
                     Np, ic.lag, var.factor, cooling.factor,
                     cooling.fraction,
-                    method = c("mif","unweighted","fp","mif2"),
+                    method = c("mif","unweighted","fp","mif2","mif3","mif4"),
                     tol = 1e-17, max.fail = Inf,
                     verbose = getOption("verbose"),
                     transform = FALSE,

Modified: branches/mif2/R/pfilter.R
===================================================================
--- branches/mif2/R/pfilter.R	2013-02-05 15:21:39 UTC (rev 823)
+++ branches/mif2/R/pfilter.R	2013-02-05 16:22:39 UTC (rev 824)
@@ -192,7 +192,7 @@
   
   for (nt in seq_len(ntimes)) {
     
-    if (mif2) {	  
+    if ((mif2==T) && (cooling.fraction>0)) {	  
       cool.sched <- try(
                         mif2.cooling(frac=cooling.fraction,nt=nt,m=cooling.m,n=ntimes),
                         silent=FALSE
@@ -200,6 +200,7 @@
       if (inherits(cool.sched,"try-error")) 
         stop("pfilter error: cooling schedule error",call.=FALSE)
       sigma1 <- sigma*cool.sched$alpha
+      sigma1 <- sigma
     } else {
       sigma1 <- sigma
     }

Modified: branches/mif2/tests/ou2-mif2.R
===================================================================
--- branches/mif2/tests/ou2-mif2.R	2013-02-05 15:21:39 UTC (rev 823)
+++ branches/mif2/tests/ou2-mif2.R	2013-02-05 16:22:39 UTC (rev 824)
@@ -19,9 +19,9 @@
              Np=1000,
              var.factor=1,
              ic.lag=10,
-             cooling.factor=0.95,
+             cooling.factor=0,
              cooling.fraction=0.05,
-             method="mif2",
+             method="mif4",
              tol=1e-8
              )
 
@@ -35,13 +35,13 @@
              var.factor=1,
              ic.lag=10,
              cooling.factor=0.95,
-             cooling.fraction=0.5,
+             cooling.fraction=0,
              max.fail=100,
-             method="mif",
+             method="mif3",
              tol=1e-8
              )  
 
-compare.mif(list(mif1a,mif2a))
+#compare.mif(list(mif1a,mif2a))
 
 set.seed(64857673L)
 mif1b <- mif(ou2,Nmif=50,start=guess1,
@@ -53,8 +53,8 @@
              Np=1000,
              var.factor=1,
              ic.lag=10,
-             cooling.factor=0.95,
-             cooling.fraction=0.05,
+             cooling.factor=0,
+             cooling.fraction=0.15,
              method="mif2"
              )
 mif1b <- continue(mif1b,Nmif=50)
@@ -69,14 +69,16 @@
              var.factor=1,
              ic.lag=10,
              cooling.whatsit=200,
+             cooling.fraction=0,
              cooling.factor=0.95,
              max.fail=100,
              method="mif"
              )  
 mif2b <- continue(mif2b,Nmif=50)
 
-compare.mif(list(mif1b,mif2b))
+compare.mif(list(mif1a,mif1b,mif2a,mif2b))
 
+
 compare.mif(list(mif1a,mif1b))
 compare.mif(list(mif2a,mif2b))
 


From noreply at r-forge.r-project.org  Tue Feb  5 23:49:06 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue,  5 Feb 2013 23:49:06 +0100 (CET)
Subject: [Pomp-commits] r825 - pkg/pomp/R
Message-ID: <20130205224906.12B0C1813E7@r-forge.r-project.org>

Author: kingaa
Date: 2013-02-05 23:49:05 +0100 (Tue, 05 Feb 2013)
New Revision: 825

Modified:
   pkg/pomp/R/aaa.R
   pkg/pomp/R/basic-probes.R
   pkg/pomp/R/bsmc.R
   pkg/pomp/R/mif.R
   pkg/pomp/R/pfilter.R
   pkg/pomp/R/pomp.R
   pkg/pomp/R/probe.R
   pkg/pomp/R/simulate-pomp.R
   pkg/pomp/R/sobol.R
   pkg/pomp/R/spect.R
   pkg/pomp/R/traj-match.R
   pkg/pomp/R/trajectory-pomp.R
Log:
- use explicit integers where appropriate in subsetting operations


Modified: pkg/pomp/R/aaa.R
===================================================================
--- pkg/pomp/R/aaa.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/aaa.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -1,7 +1,7 @@
 ## .onAttach <- function (...) {
-##   version <- library(help=pomp)$info[[1]]
-##   version <- strsplit(version[pmatch("Version",version)]," ")[[1]]
-##   version <- version[nchar(version)>0][2]
+##   version <- library(help=pomp)$info[[1L]]
+##   version <- strsplit(version[pmatch("Version",version)]," ")[[1L]]
+##   version <- version[nchar(version)>0][2L]
 ##   packageStartupMessage("This is pomp version ",version,"\n")
 ## }
 

Modified: pkg/pomp/R/basic-probes.R
===================================================================
--- pkg/pomp/R/basic-probes.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/basic-probes.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -53,9 +53,9 @@
   method <- match.arg(method)
   lag <- as.integer(lag)
   transform <- match.fun(transform)
-  var1 <- vars[1]
+  var1 <- vars[1L]
   if (length(vars)>1)
-    var2 <- vars[2]
+    var2 <- vars[2L]
   else
     var2 <- var1
   function (y) {
@@ -85,9 +85,9 @@
   method <- match.arg(method)
   lag <- as.integer(lag)
   transform <- match.fun(transform)
-  var1 <- vars[1]
+  var1 <- vars[1L]
   if (length(vars)>1)
-    var2 <- vars[2]
+    var2 <- vars[2L]
   else
     var2 <- var1
   function (y) {
@@ -134,8 +134,8 @@
   lags <- as.integer(lags)
   function (y) .Call(
                      probe_ccf,
-                     x=transform(y[vars[1],,drop=TRUE]),
-                     y=transform(y[vars[2],,drop=TRUE]),
+                     x=transform(y[vars[1L],,drop=TRUE]),
+                     y=transform(y[vars[2L],,drop=TRUE]),
                      lags=lags,
                      corr=corr
                      )

Modified: pkg/pomp/R/bsmc.R
===================================================================
--- pkg/pomp/R/bsmc.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/bsmc.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -50,7 +50,7 @@
             if (missing(seed)) seed <- NULL
             if (!is.null(seed)) {
               if (!exists(".Random.seed",where=.GlobalEnv))
-                runif(1) ## need to initialize the RNG
+                runif(n=1L) ## need to initialize the RNG
               save.seed <- get(".Random.seed",pos=.GlobalEnv)
               set.seed(seed)
             }
@@ -374,17 +374,17 @@
         panel=function (x, y, ...) { ## prior, posterior pairwise scatterplot
           op <- par(new=TRUE)
           on.exit(par(op))
-          i <- which(x[1]==all[1,])
-          j <- which(y[1]==all[1,])
+          i <- which(x[1L]==all[1L,])
+          j <- which(y[1L]==all[1L,])
           points(prior[p1,i],prior[p1,j],pch=20,col=rgb(0.85,0.85,0.85,0.1),xlim=range(all[,i]),ylim=range(all[,j]))
           points(post[p2,i],post[p2,j],pch=20,col=rgb(0,0,1,0.01))
         },
         diag.panel=function (x, ...) { ## marginal posterior histogram
-          i <- which(x[1]==all[1,])
+          i <- which(x[1L]==all[1L,])
           d1 <- density(prior[,i])
           d2 <- density(post[,i])
           usr <- par('usr')
-          op <- par(usr=c(usr[1:2],0,1.5*max(d1$y,d2$y)))
+          op <- par(usr=c(usr[c(1L,2L)],0,1.5*max(d1$y,d2$y)))
           on.exit(par(op))
           polygon(d1,col=rgb(0.85,0.85,0.85,0.5))
           polygon(d2,col=rgb(0,0,1,0.5))

Modified: pkg/pomp/R/mif.R
===================================================================
--- pkg/pomp/R/mif.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/mif.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -231,7 +231,7 @@
                               ntimes=ntimes
                               )
 
-  if ((method=="mif2")&&(Np[1]!=Np[ntimes+1]))
+  if ((method=="mif2")&&(Np[1L]!=Np[ntimes+1]))
     stop("the first and last values of ",sQuote("Np")," must agree when method = ",sQuote("mif2"))
   
   if (missing(var.factor))
@@ -264,7 +264,7 @@
                        c('loglik','nfail',names(theta))
                        )
                      )
-  conv.rec[1,] <- c(NA,NA,theta)
+  conv.rec[1L,] <- c(NA,NA,theta)
   
   if (!all(is.finite(theta[c(pars,ivps)]))) {
     stop(
@@ -281,7 +281,7 @@
   obj <- as(object,"pomp")
   
   if (Nmif>0) {
-    tmp.mif <- new("mif",object,particles=particles,Np=Np[1])
+    tmp.mif <- new("mif",object,particles=particles,Np=Np[1L])
   } else {
     pfp <- obj
   }
@@ -298,7 +298,7 @@
     P <- try(
              particles(
                        tmp.mif,
-                       Np=Np[1],
+                       Np=Np[1L],
                        center=theta,
                        sd=sigma.n*var.factor
                        ),
@@ -549,10 +549,10 @@
                        ...
                        )
             
-            object at conv.rec[ndone+1,c('loglik','nfail')] <- obj at conv.rec[1,c('loglik','nfail')]
+            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[-1,colnames(object at conv.rec)]
+                                  obj at conv.rec[-1L,colnames(object at conv.rec)]
                                   )
             obj at Nmif <- as.integer(ndone+Nmif)
             

Modified: pkg/pomp/R/pfilter.R
===================================================================
--- pkg/pomp/R/pfilter.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/pfilter.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -91,7 +91,7 @@
     params <- matrix(
                      params,
                      nrow=length(params),
-                     ncol=Np[1],
+                     ncol=Np[1L],
                      dimnames=list(
                        names(params),
                        NULL
@@ -211,7 +211,7 @@
       stop(sQuote("pfilter")," error: process simulation error",call.=FALSE)
     
     if (pred.var) { ## check for nonfinite state variables and parameters
-      problem.indices <- unique(which(!is.finite(X),arr.ind=TRUE)[,1])
+      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): ",
@@ -220,7 +220,7 @@
              )
       }
       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)[,1])
+        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): ",

Modified: pkg/pomp/R/pomp.R
===================================================================
--- pkg/pomp/R/pomp.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/pomp.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -42,7 +42,7 @@
   ## check t0
   if (!is.numeric(t0) || length(t0) > 1)
     stop("pomp error: the zero-time ",sQuote("t0")," must be a single number",call.=TRUE)
-  if (t0 > times[1])
+  if (t0 > times[1L])
     stop("pomp error: the zero-time ",sQuote("t0")," must occur no later than the first observation",call.=TRUE)
   storage.mode(t0) <- 'double'
   
@@ -259,8 +259,8 @@
     if (!inherits(formulae[[k]],"formula"))
       stop("pomp error: ",sQuote("measurement.model")," takes formulae as arguments",call.=FALSE)
   }
-  obsnames <- unlist(lapply(formulae,function(x)x[[2]]))
-  distrib <- lapply(formulae,function(x)as.character(x[[3]][[1]]))
+  obsnames <- unlist(lapply(formulae,function(x)x[[2L]]))
+  distrib <- lapply(formulae,function(x)as.character(x[[3L]][[1L]]))
   ddistrib <- lapply(distrib,function(x)paste0("d",x))
   rdistrib <- lapply(distrib,function(x)paste0("r",x))
   for (k in seq_len(nobs)) {
@@ -277,7 +277,7 @@
     if (inherits(res,'try-error'))
       stop("pomp error: random deviate function ",rdistrib[[k]]," not found")
   }
-  pred.args <- lapply(formulae,function(x)as.list(x[[3]][-1]))
+  pred.args <- lapply(formulae,function(x)as.list(x[[3L]][-1L]))
   dcalls <- vector(mode='list',length=nobs)
   rcalls <- vector(mode='list',length=nobs)
   for (k in seq_len(nobs)) {

Modified: pkg/pomp/R/probe.R
===================================================================
--- pkg/pomp/R/probe.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/probe.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -119,34 +119,34 @@
               ##plot a histogram for the simulations
               usr <- par("usr")
               on.exit(par(usr))
-              par(usr=c(usr[1:2],0,1.5))
-              h <- hist(x[-1],plot=FALSE)
+              par(usr=c(usr[c(1L,2L)],0,1.5))
+              h <- hist(x[-1L],plot=FALSE)
               breaks <- h$breaks
               nB <- length(breaks)
               y <- h$counts
               y <- y/max(y)
-              rect(breaks[-nB],0,breaks[-1],y,...)
+              rect(breaks[-nB],0,breaks[-1L],y,...)
               ##plot the data point
-              lines(c(x[1],x[1]),c(0,max(h$counts)),col="red")
+              lines(c(x[1L],x[1L]),c(0,max(h$counts)),col="red")
             }
 
             ##function for plotting above-diagonal panels
             above.diag.panel <- function (x, y, ...) {
               ##plot the simulations
-              points(x[-1],y[-1],...)
+              points(x[-1L],y[-1L],...)
               ##plot the data
               mMx <- c(min(x),max(x))
               mMy <- c(min(y),max(y))
-              lines(c(x[1],x[1]),mMy,col="red")
-              lines(mMx,c(y[1],y[1]),col="red")
+              lines(c(x[1L],x[1L]),mMy,col="red")
+              lines(mMx,c(y[1L],y[1L]),col="red")
             }
             
             ##function for plotting below-diagonal panels
             below.diag.panel <- function (x, y, ...) {
               mMx <- c(min(x),max(x))
               mMy <- c(min(y),max(y))
-              x <- x[-1]
-              y <- y[-1]
+              x <- x[-1L]
+              y <- y[-1L]
               correls <- round(cor(x,y),3)
               text(mean(mMx),mean(mMy),correls,cex=1)
             }
@@ -155,8 +155,8 @@
             nprobes <- length(x at datvals)
             nsim <- nrow(x at simvals)
             datsimvals <- array(dim=c(nsim+1,nprobes))
-            datsimvals[1,] <- x at datvals
-            datsimvals[-1,] <- x at simvals
+            datsimvals[1L,] <- x at datvals
+            datsimvals[-1L,] <- x at simvals
             
             labels <- paste("pb",seq_len(nprobes))
             if (!is.null(names(x at datvals)))

Modified: pkg/pomp/R/simulate-pomp.R
===================================================================
--- pkg/pomp/R/simulate-pomp.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/simulate-pomp.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -59,14 +59,14 @@
   if (as.data.frame) {
     if (obs && states) {
       dm <- dim(retval$obs)
-      nsim <- dm[2]
-      ntimes <- dm[3]
+      nsim <- dm[2L]
+      ntimes <- dm[3L]
       nm <- rownames(retval$obs)
-      dim(retval$obs) <- c(dm[1],prod(dm[-1]))
+      dim(retval$obs) <- c(dm[1L],prod(dm[-1L]))
       rownames(retval$obs) <- nm
       dm <- dim(retval$states)
       nm <- rownames(retval$states)
-      dim(retval$states) <- c(dm[1],prod(dm[-1]))
+      dim(retval$states) <- c(dm[1L],prod(dm[-1L]))
       rownames(retval$states) <- nm
       retval <- cbind(
                       as.data.frame(t(retval$obs)),
@@ -77,10 +77,10 @@
       retval <- retval[order(retval$sim,retval$time),]
     } else if (obs || states) {
       dm <- dim(retval)
-      nsim <- dm[2]
-      ntimes <- dm[3]
+      nsim <- dm[2L]
+      ntimes <- dm[3L]
       nm <- rownames(retval)
-      dim(retval) <- c(dm[1],prod(dm[-1]))
+      dim(retval) <- c(dm[1L],prod(dm[-1L]))
       rownames(retval) <- nm
       retval <- as.data.frame(t(retval))
       retval$sim <- factor(seq_len(nsim))

Modified: pkg/pomp/R/sobol.R
===================================================================
--- pkg/pomp/R/sobol.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/sobol.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -8,7 +8,7 @@
   y <- vapply(
               seq_len(d),
               function (k) {
-                vars[[k]][1]+(vars[[k]][2]-vars[[k]][1])*x[k,]
+                vars[[k]][1L]+(vars[[k]][2L]-vars[[k]][1L])*x[k,]
               },
               numeric(n)
               )

Modified: pkg/pomp/R/spect.R
===================================================================
--- pkg/pomp/R/spect.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/spect.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -51,8 +51,8 @@
 reuman.kernel <- function (kernel.width) {
   ker <- kernel("modified.daniell",m=kernel.width)
   x <- seq.int(from=0,to=kernel.width,by=1)/kernel.width
-  ker[[1]] <- (15/(16*2*pi))*((x-1)^2)*((x+1)^2)
-  ker[[1]] <- ker[[1]]/(2*sum(ker[[1]][-1])+ker[[1]][1])
+  ker[[1L]] <- (15/(16*2*pi))*((x-1)^2)*((x+1)^2)
+  ker[[1L]] <- ker[[1L]]/(2*sum(ker[[1L]][-1])+ker[[1L]][1L])
   attr(ker,"name") <- NULL
   ker
 }

Modified: pkg/pomp/R/traj-match.R
===================================================================
--- pkg/pomp/R/traj-match.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/traj-match.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -132,7 +132,7 @@
 
   ## fill 'states' slot of returned object with the trajectory
   x <- trajectory(obj)
-  obj at states <- array(data=x,dim=dim(x)[c(1,3)])
+  obj at states <- array(data=x,dim=dim(x)[c(1L,3L)])
   rownames(obj at states) <- rownames(x)
   
   new(

Modified: pkg/pomp/R/trajectory-pomp.R
===================================================================
--- pkg/pomp/R/trajectory-pomp.R	2013-02-05 16:22:39 UTC (rev 824)
+++ pkg/pomp/R/trajectory-pomp.R	2013-02-05 22:49:05 UTC (rev 825)
@@ -20,7 +20,7 @@
   else
     t0 <- as.numeric(t0)
   
-  if (t0>times[1])
+  if (t0>times[1L])
     stop("the zero-time ",sQuote("t0")," must occur no later than the first observation",call.=FALSE)
   ntimes <- length(times)
   
@@ -76,10 +76,10 @@
 
     if (inherits(X,'try-error'))
       stop("trajectory error: error in ODE integrator",call.=FALSE)
-    if (attr(X,'istate')[1]!=2)
+    if (attr(X,'istate')[1L]!=2)
       warning("abnormal exit from ODE integrator, istate = ",attr(X,'istate'),call.=FALSE)
 
-    x <- array(data=t(X[-1,-1]),dim=c(nvar,nrep,ntimes),dimnames=list(statenames,NULL,NULL))
+    x <- array(data=t(X[-1L,-1L]),dim=c(nvar,nrep,ntimes),dimnames=list(statenames,NULL,NULL))
     
     for (z in znames)
       for (r in seq_len(ncol(x)))
@@ -97,7 +97,7 @@
                 function (k) {
                   nm <- rownames(x)
                   y <- x[,k,,drop=FALSE]
-                  dim(y) <- dim(y)[c(1,3)]
+                  dim(y) <- dim(y)[c(1L,3L)]
                   y <- as.data.frame(t(y))
                   names(y) <- nm
                   y$time <- times


From noreply at r-forge.r-project.org  Tue Feb 26 14:20:27 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 26 Feb 2013 14:20:27 +0100 (CET)
Subject: [Pomp-commits] r826 - in pkg/pomp: . R man src tests
Message-ID: <20130226132027.B74FD184ABF@r-forge.r-project.org>

Author: kingaa
Date: 2013-02-26 14:20:27 +0100 (Tue, 26 Feb 2013)
New Revision: 826

Modified:
   pkg/pomp/DESCRIPTION
   pkg/pomp/NAMESPACE
   pkg/pomp/R/bsmc.R
   pkg/pomp/R/dmeasure-pomp.R
   pkg/pomp/R/dprocess-pomp.R
   pkg/pomp/R/init-state-pomp.R
   pkg/pomp/R/mif-methods.R
   pkg/pomp/R/mif.R
   pkg/pomp/R/particles-mif.R
   pkg/pomp/R/pfilter.R
   pkg/pomp/R/plot-pomp.R
   pkg/pomp/R/plugins.R
   pkg/pomp/R/pmcmc.R
   pkg/pomp/R/pomp-fun.R
   pkg/pomp/R/pomp-methods.R
   pkg/pomp/R/probe.R
   pkg/pomp/R/rmeasure-pomp.R
   pkg/pomp/R/rprocess-pomp.R
   pkg/pomp/R/simulate-pomp.R
   pkg/pomp/R/skeleton-pomp.R
   pkg/pomp/R/spect-match.R
   pkg/pomp/R/trajectory-pomp.R
   pkg/pomp/man/pmcmc.Rd
   pkg/pomp/man/probe.Rd
   pkg/pomp/src/SSA_wrapper.c
   pkg/pomp/src/dmeasure.c
   pkg/pomp/src/dprocess.c
   pkg/pomp/src/euler.c
   pkg/pomp/src/partrans.c
   pkg/pomp/src/pomp_fun.c
   pkg/pomp/src/pomp_internal.h
   pkg/pomp/src/rmeasure.c
   pkg/pomp/src/rprocess.c
   pkg/pomp/src/simulate.c
   pkg/pomp/src/skeleton.c
   pkg/pomp/src/trajectory.c
   pkg/pomp/tests/dimchecks.Rout.save
   pkg/pomp/tests/ou2-mif.Rout.save
   pkg/pomp/tests/ou2-mif2.Rout.save
   pkg/pomp/tests/ou2-pmcmc.R
   pkg/pomp/tests/ou2-pmcmc.Rout.save
   pkg/pomp/tests/ricker-probe.Rout.save
   pkg/pomp/tests/sir.Rout.save
Log:
- new mechanism to prevent unnecessary symbol-table lookups when native routines are used
- named functions are now used for most methods, to make error messages more sensible
- some changes to the implementation of pmcmc
- fix bug in pmcmc method on pmcmc objects


Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION	2013-02-05 22:49:05 UTC (rev 825)
+++ pkg/pomp/DESCRIPTION	2013-02-26 13:20:27 UTC (rev 826)
@@ -2,7 +2,7 @@
 Type: Package
 Title: Statistical inference for partially observed Markov processes
 Version: 0.44-1
-Date: 2013-02-04
+Date: 2013-02-14
 Author: Aaron A. King, Edward L. Ionides, Carles Breto, Steve Ellner, Bruce Kendall, Helen Wearing, Matthew J. Ferrari, Michael Lavine, Daniel C. Reuman
 Maintainer: Aaron A. King <kingaa at umich.edu>
 URL: http://pomp.r-forge.r-project.org

Modified: pkg/pomp/NAMESPACE
===================================================================
--- pkg/pomp/NAMESPACE	2013-02-05 22:49:05 UTC (rev 825)
+++ pkg/pomp/NAMESPACE	2013-02-26 13:20:27 UTC (rev 826)
@@ -1,6 +1,5 @@
 useDynLib(			
           pomp,
-          get_pomp_fun,
           bspline_basis,
           periodic_bspline_basis,
           bspline_basis_function,

Modified: pkg/pomp/R/bsmc.R
===================================================================
--- pkg/pomp/R/bsmc.R	2013-02-05 22:49:05 UTC (rev 825)
+++ pkg/pomp/R/bsmc.R	2013-02-26 13:20:27 UTC (rev 826)
@@ -31,327 +31,368 @@
 
 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,
-                    ...) {
+bsmc.internal <- 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,
+                           .getnativesymbolinfo = TRUE,
+                           ...) {
 
-            transform <- as.logical(transform)
+  gnsi.rproc <- gnsi.dmeas <- as.logical(.getnativesymbolinfo)
+  ptsi.inv <- ptsi.for <- TRUE
+  transform <- as.logical(transform)
 
-            if (missing(seed)) seed <- NULL
-            if (!is.null(seed)) {
-              if (!exists(".Random.seed",where=.GlobalEnv))
-                runif(n=1L) ## need to initialize the RNG
-              save.seed <- get(".Random.seed",pos=.GlobalEnv)
-              set.seed(seed)
-            }
+  if (missing(seed)) seed <- NULL
+  if (!is.null(seed)) {
+    if (!exists(".Random.seed",where=.GlobalEnv))
+      runif(n=1L) ## need to initialize the RNG
+    save.seed <- get(".Random.seed",pos=.GlobalEnv)
+    set.seed(seed)
+  }
 
-            error.prefix <- paste(sQuote("bsmc"),"error: ")
+  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(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")
+  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",
+                       .getnativesymbolinfo=ptsi.inv)
+  ptsi.inv <- FALSE
+  
+  ntimes <- length(time(object))
+  if (is.null(dim(params))) {
+    params <- matrix(
+                     params,
+                     nrow=length(params),
+                     ncol=Np,
+                     dimnames=list(
+                       names(params),
+                       NULL
+                       )
+                     )
+  }
 
-            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
 
-            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 (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 (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)
 
-            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)
 
-            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                   
+         )
+  }
 
-            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]<lower)|(params[estind,j]>upper))) {
+      ind <- which((params[estind,j]<lower)|(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
+           )
+    }
+  }
 
-            for (j in seq_len(Np)) {
-              if (any((params[estind,j]<lower)|(params[estind,j]>upper))) {
-                ind <- which((params[estind,j]<lower)|(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",
+                                  .getnativesymbolinfo=ptsi.for)
+                       } else {
+                         params
+                       }
+                       )
+  statenames <- rownames(xstart)
+  nvars <- nrow(xstart)
+  ptsi.for <- FALSE
+  
+  times <- time(object,t0=TRUE)
+  x <- xstart
 
-            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]))
 
-            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))
+                  )
+            )
+    }
 
-              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",
+                                 .getnativesymbolinfo=ptsi.for)
+                      } else {
+                        params
+                      },
+                      offset=1,
+                      .getnativesymbolinfo=gnsi.rproc
                       )
-              }
+    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
+    gnsi.rproc <- FALSE
+    
+    ## 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",
+                             .getnativesymbolinfo=ptsi.for)
+                  } else {
+                    m
+                  },
+                  .getnativesymbolinfo=gnsi.dmeas
+                  )	
+    gnsi.dmeas <- FALSE
+    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]
 
-              ## 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)
 
-              ## 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",
+                          .getnativesymbolinfo=ptsi.for)
+    
+    ## 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,
+                  .getnativesymbolinfo=gnsi.rproc
+                  )
 
-              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
+                      },
+                      .getnativesymbolinfo=gnsi.dmeas
+                      )
+    ## evaluate weights as per L&W AGM (5)
 
-              ## 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]<lower)|(params[estind,j]>upper))) {
+        weights[j] <- 0 
+      }
+      ## might this rejection method be preferable?
+      ## while (any((params[estind,j]<lower)|(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,]
+      ## }
+    }
 
-	      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]<lower)|(params[estind,j]>upper))) {
-                  weights[j] <- 0 
-                }
-                ## might this rejection method be preferable?
-                ## while (any((params[estind,j]<lower)|(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<tol)|(!is.finite(weights))) # test for NA weights
+    all.fail <- all(failures)
+    if (all.fail) {                     # all particles are lost
+      if (verbose) {
+        message("filtering failure at time t = ",times[nt+1])
+      }
+      nfail <- nfail+1
+      if (nfail > max.fail)
+        stop(error.prefix,"too many filtering failures",call.=FALSE)
+      evidence[nt] <- log(tol)          # worst log-likelihood
+      weights <- rep(1/Np,Np)
+      eff.sample.size[nt] <- 0
+    } else {                  # not all particles are lost
+      ## compute log-likelihood
+      evidence[nt] <- storeForEvidence1+storeForEvidence2
+      weights[failures] <- 0
+      weights <- weights/sum(weights)
+      ## compute effective sample-size
+      eff.sample.size[nt] <- 1/crossprod(weights)
+    }
 
-              x[,] <- X                
-              
-              ## test for failure to filter
-              dim(weights) <- NULL
-              failures <- ((weights<tol)|(!is.finite(weights))) # test for NA weights
-              all.fail <- all(failures)
-              if (all.fail) {                     # all particles are lost
-                if (verbose) {
-                  message("filtering failure at time t = ",times[nt+1])
-                }
-                nfail <- nfail+1
-                if (nfail > max.fail)
-                  stop(error.prefix,"too many filtering failures",call.=FALSE)
-                evidence[nt] <- log(tol)          # worst log-likelihood
-                weights <- rep(1/Np,Np)
-                eff.sample.size[nt] <- 0
-              } else {                  # not all particles are lost
-                ## compute log-likelihood
-                evidence[nt] <- storeForEvidence1+storeForEvidence2
-                weights[failures] <- 0
-                weights <- weights/sum(weights)
-                ## compute effective sample-size
-                eff.sample.size[nt] <- 1/crossprod(weights)
-              }
+    if (verbose) {
+      cat("effective sample size =",round(eff.sample.size[nt],1),"\n")
+    }
 
-              if (verbose) {
-                cat("effective sample size =",round(eff.sample.size[nt],1),"\n")
-              }
+    ## Matrix with samples (columns) from filtering distribution theta.t | Y.t
+    if (!all.fail) {
+      ## smp <- .Call(systematic_resampling,weights)
+      smp <- sample.int(n=Np,size=Np,replace=TRUE,prob=weights)
+      x <- x[,smp,drop=FALSE]
+      params[estind,] <- params[estind,smp,drop=FALSE]
+    }
 
-              ## Matrix with samples (columns) from filtering distribution theta.t | Y.t
-              if (!all.fail) {
-                ## smp <- .Call(systematic_resampling,weights)
-                smp <- sample.int(n=Np,size=Np,replace=TRUE,prob=weights)
-                x <- x[,smp,drop=FALSE]
-                params[estind,] <- params[estind,smp,drop=FALSE]
-              }
-              
-            }
-            
-            if (!is.null(seed)) {
-              assign(".Random.seed",save.seed,pos=.GlobalEnv)
-              seed <- save.seed
-            }
-            
-            ## if (transform) {
-            ##   params <- partrans(object,params,dir="forward")
-            ##   prior <- partrans(object,prior,dir="forward")
-            ## }
+    .getnativesymbolinfo <- FALSE
+    
+  }
 
-            ## replace parameters with point estimate (posterior median)
-            coef(object,transform=transform) <- apply(params,1,median)
+  if (!is.null(seed)) {
+    assign(".Random.seed",save.seed,pos=.GlobalEnv)
+    seed <- save.seed
+  }
+  
+  ## replace parameters with point estimate (posterior median)
+  coef(object,transform=transform) <- apply(params,1,median)
 
-            new(
-                "bsmcd.pomp",
-                object,
-                transform=transform,
-                post=params,
-                prior=prior,
-                est=as.character(est),
-                eff.sample.size=eff.sample.size,
-                smooth=smooth,
-                seed=as.integer(seed),
-                nfail=as.integer(nfail),
-                cond.log.evidence=evidence,
-                log.evidence=sum(evidence),
-                weights=weights
-                )
+  new(
+      "bsmcd.pomp",
+      object,
+      transform=transform,
+      post=params,
+      prior=prior,
+      est=as.character(est),
+      eff.sample.size=eff.sample.size,
+      smooth=smooth,
+      seed=as.integer(seed),
+      nfail=as.integer(nfail),
+      cond.log.evidence=evidence,
+      log.evidence=sum(evidence),
+      weights=weights
+      )
+}
+
+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,
+                    ...) {
+            bsmc.internal(
+                          object=object,
+                          params=params,
+                          Np=Np,
+                          est=est,
+                          smooth=smooth,
+                          ntries=ntries,
+                          tol=tol,
+                          lower=lower,
+                          upper=upper,
+                          seed=seed,
+                          verbose=verbose,
+                          max.fail=max.fail,
+                          transform=transform,
+                          ...
+                          )
           }
           )
 

Modified: pkg/pomp/R/dmeasure-pomp.R
===================================================================
--- pkg/pomp/R/dmeasure-pomp.R	2013-02-05 22:49:05 UTC (rev 825)
+++ pkg/pomp/R/dmeasure-pomp.R	2013-02-26 13:20:27 UTC (rev 826)
@@ -1,9 +1,11 @@
 ## evaluate the measurement model density function
 setGeneric("dmeasure",function(object,...)standardGeneric("dmeasure"))
 
-dmeasure.internal <- function (object, y, x, times, params, log = FALSE, ...) {
-  fun <- get.pomp.fun(object at dmeasure)
-  .Call(do_dmeasure,object,y,x,times,params,log,fun)
+dmeasure.internal <- function (object, y, x, times, params, log = FALSE, .getnativesymbolinfo = TRUE, ...) {
+  .Call(do_dmeasure,object,y,x,times,params,log,.getnativesymbolinfo)
 }
 
-setMethod("dmeasure","pomp",dmeasure.internal)
+setMethod("dmeasure","pomp",
+          function (object, y, x, times, params, log = FALSE, ...)
+          dmeasure.internal(object=object,y=y,x=x,times=times,params=params,log=log,...)
+          )

Modified: pkg/pomp/R/dprocess-pomp.R
===================================================================
--- pkg/pomp/R/dprocess-pomp.R	2013-02-05 22:49:05 UTC (rev 825)
+++ pkg/pomp/R/dprocess-pomp.R	2013-02-26 13:20:27 UTC (rev 826)
@@ -1,7 +1,10 @@
 ## evaluate the process model density function
 setGeneric("dprocess",function(object,...)standardGeneric("dprocess"))
 
-dprocess.internal <- function (object, x, times, params, log = FALSE, ...)
-  .Call(do_dprocess,object,x,times,params,log)
+dprocess.internal <- function (object, x, times, params, log = FALSE, .getnativesymbolinfo = TRUE, ...)
+  .Call(do_dprocess,object,x,times,params,log,.getnativesymbolinfo)
 
-setMethod("dprocess","pomp",dprocess.internal)
+setMethod("dprocess","pomp",
+          function (object, x, times, params, log = FALSE, ...)
+          dprocess.internal(object=object,x=x,times=times,params=params,log=log,...)
+          )

Modified: pkg/pomp/R/init-state-pomp.R
===================================================================
--- pkg/pomp/R/init-state-pomp.R	2013-02-05 22:49:05 UTC (rev 825)
+++ pkg/pomp/R/init-state-pomp.R	2013-02-26 13:20:27 UTC (rev 826)
@@ -1,12 +1,16 @@
+## initialize the state variables of the process model
+init.state.internal <- function (object, params, t0, ...) {
+  if (missing(t0)) t0 <- object at t0
+  if (missing(params)) params <- coef(object)
+  .Call(do_init_state,object,params,t0)
+}
+
 setGeneric("init.state",function(object,...)standardGeneric("init.state"))
 
-## initialize the process model
 setMethod(
           'init.state',
           'pomp',
-          function (object, params, t0, ...) { # the package algorithms will only use these arguments
-            if (missing(t0)) t0 <- object at t0
-            if (missing(params)) params <- coef(object)
-            .Call(do_init_state,object,params,t0)
+          function (object, params, t0, ...) {
+            init.state.internal(object=object,params=params,t0=t0,...)
           }
           )

Modified: pkg/pomp/R/mif-methods.R
===================================================================
--- pkg/pomp/R/mif-methods.R	2013-02-05 22:49:05 UTC (rev 825)
+++ pkg/pomp/R/mif-methods.R	2013-02-26 13:20:27 UTC (rev 826)
@@ -1,48 +1,48 @@
 ## this file contains short definitions of methods for the 'mif' class
 
-conv.rec <- function (object, ...)
-  stop("function ",sQuote("conv.rec")," is undefined for objects of class ",sQuote(class(object)))
-setGeneric('conv.rec')  
-
 ## extract the estimated log likelihood
 setMethod('logLik','mif',function(object,...)object at loglik)
 
 ## extract the convergence record
-setMethod(
-          'conv.rec',
-          'mif',
+conv.rec.internal <- function (object, pars, transform = FALSE, ...) {
+  if (transform) {
+    pars.improper <- c("loglik","nfail")
+    pars.proper <- setdiff(colnames(object at conv.rec),pars.improper)
+    retval <- cbind(
+                    t(
+                      partrans(
+                               object,
+                               params=t(object at conv.rec[,pars.proper]),
+                               dir="forward"
+                               )
+                      ),
+                    object at conv.rec[,pars.improper]
+                    )
+  } else {
+    retval <- object at conv.rec
+  }
+  if (missing(pars))
+    retval
+  else {
+    bad.pars <- setdiff(pars,colnames(retval))
+    if (length(bad.pars)>0)
+      stop(
+           "in ",sQuote("conv.rec"),": name(s) ",
+           paste(sQuote(bad.pars),collapse=","),
+           " correspond to no parameter(s) in ",
+           if (transform) sQuote("conv.rec(object,transform=TRUE)")
+           else sQuote("conv.rec(object,transform=FALSE)"),
+           call.=FALSE
+           )
+    retval[,pars]
+  }
+}
+
+setGeneric("conv.rec",function(object,...)standardGeneric("conv.rec"))
+
+setMethod('conv.rec','mif',
           function (object, pars, transform = FALSE, ...) {
-            if (transform) {
-              pars.improper <- c("loglik","nfail")
-              pars.proper <- setdiff(colnames(object at conv.rec),pars.improper)
-              retval <- cbind(
-                              t(
-                                partrans(
-                                         object,
-                                         params=t(object at conv.rec[,pars.proper]),
-                                         dir="forward"
-                                         )
-                                ),
-                              object at conv.rec[,pars.improper]
-                              )
-            } else {
-              retval <- object at conv.rec
-            }
-            if (missing(pars))
-              retval
-            else {
-              bad.pars <- setdiff(pars,colnames(retval))
-              if (length(bad.pars)>0)
-                stop(
-                     "in ",sQuote("conv.rec"),": name(s) ",
-                     paste(sQuote(bad.pars),collapse=","),
-                     " correspond to no parameter(s) in ",
-                     if (transform) sQuote("conv.rec(object,transform=TRUE)")
-                     else sQuote("conv.rec(object,transform=FALSE)"),
-                     call.=FALSE
-                     )
-              retval[,pars]
-            }
+            conv.rec.internal(object=object,pars=pars,transform=transform,...)
           }
           )
 

Modified: pkg/pomp/R/mif.R
===================================================================
--- pkg/pomp/R/mif.R	2013-02-05 22:49:05 UTC (rev 825)
+++ pkg/pomp/R/mif.R	2013-02-26 13:20:27 UTC (rev 826)
[TRUNCATED]

To get the complete diff run:
    svnlook diff /svnroot/pomp -r 826

From noreply at r-forge.r-project.org  Tue Feb 26 14:25:06 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 26 Feb 2013 14:25:06 +0100 (CET)
Subject: [Pomp-commits] r827 - pkg/pomp
Message-ID: <20130226132506.D6EB51801CE@r-forge.r-project.org>

Author: kingaa
Date: 2013-02-26 14:25:06 +0100 (Tue, 26 Feb 2013)
New Revision: 827

Modified:
   pkg/pomp/DESCRIPTION
Log:
- update DESCRIPTION file


Modified: pkg/pomp/DESCRIPTION
===================================================================
--- pkg/pomp/DESCRIPTION	2013-02-26 13:20:27 UTC (rev 826)
+++ pkg/pomp/DESCRIPTION	2013-02-26 13:25:06 UTC (rev 827)
@@ -2,7 +2,7 @@
 Type: Package
 Title: Statistical inference for partially observed Markov processes
 Version: 0.44-1
-Date: 2013-02-14
+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
 Maintainer: Aaron A. King <kingaa at umich.edu>
 URL: http://pomp.r-forge.r-project.org


From noreply at r-forge.r-project.org  Thu Feb 28 06:45:23 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu, 28 Feb 2013 06:45:23 +0100 (CET)
Subject: [Pomp-commits] r828 - branches/mif2/R
Message-ID: <20130228054524.003F6184DEE@r-forge.r-project.org>

Author: nxdao2000
Date: 2013-02-28 06:45:23 +0100 (Thu, 28 Feb 2013)
New Revision: 828

Modified:
   branches/mif2/R/mif.R
Log:
change rw.sd to be a function of time
 

Modified: branches/mif2/R/mif.R
===================================================================
--- branches/mif2/R/mif.R	2013-02-26 13:25:06 UTC (rev 827)
+++ branches/mif2/R/mif.R	2013-02-28 05:45:23 UTC (rev 828)
@@ -16,6 +16,43 @@
          )
 }
 
+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))
+         )
+}
+
 mif.cooling <- function (factor, n) {   # default geometric cooling schedule
   alpha <- factor^(n-1)
   list(alpha=alpha,gamma=alpha^2)
@@ -23,10 +60,9 @@
 
 mif2.cooling <- function (frac, nt, m, n) {   # cooling schedule for mif2
   ## frac is the fraction of cooling after 50 iterations
-  cooling.scalar <- (50*n*frac-1)/(1-frac)
-  alpha <- (1+cooling.scalar)/(cooling.scalar+nt+n*(m-1))
-  
-  list(alpha=alpha,gamma=alpha^2)
+  scal <- (50*n*frac-1)/(1-frac)
+  alpha <- (1+scal)/(scal+nt+n*(m-1))
+  list(alpha=alpha)
 }
 
 powerlaw.cooling <- function (init = 1, delta = 0.1, eps = (1-delta)/2, n) {
@@ -45,13 +81,16 @@
                           start, pars, ivps,
                           particles,
                           rw.sd,
-                          Np, cooling.factor, var.factor, ic.lag,
-                          cooling.fraction, 
+                          Np, var.factor, ic.lag,
+                          cooling.type, cooling.fraction, cooling.factor, 
                           method,
                           tol, max.fail,
-                          verbose, transform, .ndone = 0,
-                          paramMatrix) {
+                          verbose, transform, .ndone = 0L,
+                          paramMatrix,
+                          .getnativesymbolinfo = TRUE) {
   
+  gnsi <- as.logical(.getnativesymbolinfo)
+
   transform <- as.logical(transform)
   
   if (length(start)==0)
@@ -68,15 +107,12 @@
   if (is.null(start.names))
     stop("mif error: ",sQuote("start")," must be a named vector",call.=FALSE)
   
-  if (missing(rw.sd))
-    stop("mif error: ",sQuote("rw.sd")," must be specified",call.=FALSE)
-  
   rw.names <- names(rw.sd)
-  if (is.null(rw.names) || any(rw.sd<0))
+  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))
     stop("mif error: all the names of ",sQuote("rw.sd")," must be names of ",sQuote("start"),call.=FALSE)
-  rw.names <- names(rw.sd[rw.sd>0])
+  #rw.names <- names(rw.sd[rw.sd>0])
   if (length(rw.names) == 0)
     stop("mif error: ",sQuote("rw.sd")," must have one positive entry for each parameter to be estimated",call.=FALSE)
   
@@ -165,49 +201,106 @@
             )
   }
   
-  if (method=="mif2") {
-    if (missing(cooling.fraction) || is.na(cooling.fraction))
-      stop("mif error: ",sQuote("cooling.fraction")," must be specified for method = ",sQuote("mif2"),call.=FALSE)
-    cooling.fraction <- as.numeric(cooling.fraction)
-    if ((length(cooling.fraction)!=1)||(cooling.fraction<0)||(cooling.fraction>1))
-      stop("mif error: ",sQuote("cooling.fraction")," must be a number between 0 and 1",call.=FALSE)
-    if (!missing(cooling.factor) && !(is.na(cooling.factor)))
-      warning(sQuote("cooling.factor")," ignored for method = ",sQuote("mif2"),call.=FALSE)
+  ## the following deals with the deprecated option 'cooling.factor'
+  if (!missing(cooling.factor)) {
+    warning(sQuote("cooling.factor")," is deprecated.\n",
+            "See ",sQuote("?mif")," for instructions on specifying the cooling schedule.",
+            call.=FALSE)
     cooling.factor <- as.numeric(cooling.factor)
-    if (Np[1]!=Np[ntimes+1])
-      stop("the first and last values of ",sQuote("Np")," must agree when method = ",sQuote("mif2"))
-  } else {
-    if (missing(cooling.factor) || is.na(cooling.factor))
-      stop("mif error: ",sQuote("cooling.factor")," must be specified",call.=FALSE)
-    cooling.factor <- as.numeric(cooling.factor)
     if ((length(cooling.factor)!=1)||(cooling.factor<0)||(cooling.factor>1))
       stop("mif error: ",sQuote("cooling.factor")," must be a number between 0 and 1",call.=FALSE)
-    if (!missing(cooling.fraction) && !(is.na(cooling.fraction)))
-      warning(sQuote("cooling.fraction")," ignored for method != ",sQuote("mif2"),call.=FALSE)
-    cooling.fraction <- as.numeric(cooling.fraction)
+    if (missing(cooling.fraction)) {
+      cooling.fraction <- cooling.factor^50
+    } else {
+      warning("specification of ",sQuote("cooling.factor"),
+              " is overridden by that of ",sQuote("cooling.fraction"),
+              call.=FALSE)
+    }
   }
+
+  if (missing(cooling.fraction))
+    stop("mif error: ",sQuote("cooling.fraction")," must be specified",call.=FALSE)
+  cooling.fraction <- as.numeric(cooling.fraction)
+  if ((length(cooling.fraction)!=1)||(cooling.fraction<0)||(cooling.fraction>1))
+    stop("mif error: ",sQuote("cooling.fraction")," must be a number between 0 and 1",call.=FALSE)
   
-  if (missing(var.factor))
-    stop("mif error: ",sQuote("var.factor")," must be specified",call.=FALSE)
+  cooling <- cooling.function(
+                              type=cooling.type,
+                              perobs=(method=="mif2"),
+                              fraction=cooling.fraction,
+                              ntimes=ntimes
+                              )
+
+  if ((method=="mif2")&&(Np[1L]!=Np[ntimes+1]))
+    stop("the first and last values of ",sQuote("Np")," must agree when method = ",sQuote("mif2"))
+  
   if ((length(var.factor)!=1)||(var.factor < 0))
     stop("mif error: ",sQuote("var.factor")," must be a positive number",call.=FALSE)
   
-  if (missing(Nmif))
-    stop("mif error: ",sQuote("Nmif")," must be specified",call.=FALSE)
   Nmif <- as.integer(Nmif)
   if (Nmif<0)
     stop("mif error: ",sQuote("Nmif")," must be a positive integer",call.=FALSE)
 
   theta <- start
+  dtheta <- length(start)
+  rwsdMat <- data.frame(matrix(rep(0, dtheta*(ntimes+1)), ncol=dtheta, nrow = (ntimes+1)))
+  names(rwsdMat) <- names(start)
   
+  
+  
   sigma <- rep(0,length(start))
   names(sigma) <- start.names
   
-  rw.sd <- rw.sd[c(pars,ivps)]
-  rw.names <- names(rw.sd)
+  rw.names <- c(pars,ivps)
   
-  sigma[rw.names] <- rw.sd
+  #sigma[rw.names] <- 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]
+      sigma[rw.names[i]] <- rw.sd[[rw.names[i]]][1]
+    }
+    else if (length(rw.sd[[rw.names[i]]])==(ntimes+1))
+    { 
+      sigma[rw.names[i]] <- rw.sd[[rw.names[i]]][1]
+      
+      for (j in 1:(ntimes+1) )
+        rwsdMat[j,rw.names[i]] <- rw.sd[[rw.names[i]]][j]  
+    }
+    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)
+      {
+        sigma[rw.names[i]] <- rw.sd[[rw.names[i]]]
+        #rwsdMat[1,rw.names[i]] <- rw.sd[rw.names[i]]
+        for (j in 1:(ntimes+1) )
+          rwsdMat[j,rw.names[i]] <- rw.sd[[rw.names[i]]] 
+      }
+      else if (length(rw.sd[[rw.names[i]]])==(ntimes+1))
+      { 
+        sigma[rw.names[i]] <- rw.sd[[rw.names[i]]][1]
+        
+        for (j in 1:(ntimes+1) )
+          rwsdMat[j,rw.names[i]] <- rw.sd[[rw.names[i]]][j]  
+      }
+      else
+      {
+        stop(sQuote("rw.sd")," must have length 1 or length ",ntimes+1)
+        
+      }
+    }
+    
+  }
+  
   conv.rec <- matrix(
                      data=NA,
                      nrow=Nmif+1,
@@ -217,7 +310,7 @@
                        c('loglik','nfail',names(theta))
                        )
                      )
-  conv.rec[1,] <- c(NA,NA,theta)
+  conv.rec[1L,] <- c(NA,NA,theta)
   
   if (!all(is.finite(theta[c(pars,ivps)]))) {
     stop(
@@ -234,7 +327,7 @@
   obj <- as(object,"pomp")
   
   if (Nmif>0) {
-    tmp.mif <- new("mif",object,particles=particles,Np=Np[1])
+    tmp.mif <- new("mif",object,particles=particles,Np=Np[1L])
   } else {
     pfp <- obj
   }
@@ -244,25 +337,15 @@
   for (n in seq_len(Nmif)) { ## iterate the filtering
 
     ## get the intensity of artificial noise from the cooling schedule
-    cool.sched <- try(
-                      switch(
-                             method,
-                             mif2=mif2.cooling(frac=cooling.fraction,nt=1,m=.ndone+n,n=ntimes),
-                             mif4=mif2.cooling(frac=cooling.fraction,nt=round((.ndone+n)/2),m=.ndone+n,n=ntimes),
-                             mif3=mif.cooling(factor=cooling.factor,n=.ndone+n),
-                             mif.cooling(factor=cooling.factor,n=.ndone+n)
-                             ),
-                      silent=FALSE
-                      )
-    if (inherits(cool.sched,"try-error")) 
-      stop("mif error: cooling schedule error",call.=FALSE)
-    sigma.n <- sigma*cool.sched$alpha
+    cool.sched <- cooling(nt=1,m=.ndone+n)
+    sigma.n <- as.numeric(rwsdMat[1,])*cool.sched$alpha
+    names(sigma.n)<-names(start)
     
     ## initialize the parameter portions of the particles
     P <- try(
              particles(
                        tmp.mif,
-                       Np=Np[1],
+                       Np=Np[1L],
                        center=theta,
                        sd=sigma.n*var.factor
                        ),
@@ -271,44 +354,44 @@
     if (inherits(P,"try-error")) 
       stop("mif error: error in ",sQuote("particles"),call.=FALSE)
 
-    if (((method=="mif2")||(method=="mif3")) && ((n>1) || have.parmat)) {
+    if ((method=="mif2") && ((n>1) || have.parmat)) {
       ## use pre-existing particle matrix
       P[pars,] <- paramMatrix[pars,]
     }
-
+    names(rwsdMat) <- names(start)
     pfp <- try(
-                pfilter.internal(
+               pfilter.internal(
                                 object=obj,
                                 params=P, 
                                 Np=Np,
                                 tol=tol,
                                 max.fail=max.fail,
                                 pred.mean=(n==Nmif),
-                                pred.var=((method=="mif")||(method=="mif4")||(n==Nmif)),
+                                pred.var=((method=="mif")||(n==Nmif)),
                                 filter.mean=TRUE,
-                                cooling.fraction=cooling.fraction,
+                                cooling=cooling,
                                 cooling.m=.ndone+n,
-                                .mif2=((method=="mif2")||(method=="mif3")),
-                                .rw.sd=sigma.n[pars],
+                                .mif2=(method=="mif2"),
+                                .rw.sd=rwsdMat,
                                 .transform=transform,
                                 save.states=FALSE, 
                                 save.params=FALSE,
-                                verbose=verbose
+                                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)
            },
-           mif4={              # 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])
            },
@@ -319,10 +402,6 @@
              paramMatrix <- pfp at paramMatrix
              theta[pars] <- rowMeans(paramMatrix[pars,,drop=FALSE])
            },
-           mif3={                     # "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]
@@ -351,9 +430,9 @@
       tol=tol,
       conv.rec=conv.rec,
       method=method,
-      cooling.factor=cooling.factor,
+      cooling.type=cooling.type,
       cooling.fraction=cooling.fraction,
-      paramMatrix=if ((method=="mif2")||(method=="mif3")) paramMatrix else array(data=numeric(0),dim=c(0,0))
+      paramMatrix=if (method=="mif2") paramMatrix else array(data=numeric(0),dim=c(0,0))
       )
 }
 
@@ -366,9 +445,10 @@
                     start,
                     pars, ivps = character(0),
                     particles, rw.sd,
-                    Np, ic.lag, var.factor, cooling.factor,
-                    cooling.fraction,
-                    method = c("mif","unweighted","fp","mif2","mif3","mif4"),
+                    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,
@@ -390,6 +470,8 @@
               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
@@ -414,6 +496,7 @@
                          particles=particles,
                          rw.sd=rw.sd,
                          Np=Np,
+                         cooling.type=cooling.type,
                          cooling.factor=cooling.factor,
                          cooling.fraction=cooling.fraction,
                          var.factor=var.factor,
@@ -455,8 +538,8 @@
                     start,
                     pars, ivps,
                     particles, rw.sd,
-                    Np, ic.lag, var.factor, cooling.factor,
-                    cooling.fraction,
+                    Np, ic.lag, var.factor,
+                    cooling.type, cooling.fraction,
                     method,
                     tol,
                     transform,
@@ -470,7 +553,7 @@
             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.factor)) cooling.factor <- object at cooling.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
@@ -488,7 +571,7 @@
                 particles=particles,
                 rw.sd=rw.sd,
                 Np=Np,
-                cooling.factor=cooling.factor,
+                cooling.type=cooling.type,
                 cooling.fraction=cooling.fraction,
                 var.factor=var.factor,
                 ic.lag=ic.lag,
@@ -516,10 +599,10 @@
                        ...
                        )
             
-            object at conv.rec[ndone+1,c('loglik','nfail')] <- obj at conv.rec[1,c('loglik','nfail')]
+            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[-1,colnames(object at conv.rec)]
+                                  obj at conv.rec[-1L,colnames(object at conv.rec)]
                                   )
             obj at Nmif <- as.integer(ndone+Nmif)
             


From noreply at r-forge.r-project.org  Thu Feb 28 06:47:07 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu, 28 Feb 2013 06:47:07 +0100 (CET)
Subject: [Pomp-commits] r829 - branches/mif2/R
Message-ID: <20130228054707.89B9C184DEE@r-forge.r-project.org>

Author: nxdao2000
Date: 2013-02-28 06:47:07 +0100 (Thu, 28 Feb 2013)
New Revision: 829

Modified:
   branches/mif2/R/pfilter.R
Log:
change for rw to be a function of time


Modified: branches/mif2/R/pfilter.R
===================================================================
--- branches/mif2/R/pfilter.R	2013-02-28 05:45:23 UTC (rev 828)
+++ branches/mif2/R/pfilter.R	2013-02-28 05:47:07 UTC (rev 829)
@@ -38,11 +38,13 @@
 pfilter.internal <- function (object, params, Np,
                               tol, max.fail,
                               pred.mean, pred.var, filter.mean,
-                              cooling.fraction, cooling.m, .mif2 = FALSE,
+                              cooling, cooling.m, .mif2 = FALSE,
                               .rw.sd, seed, verbose,
                               save.states, save.params,
-                              .transform) {
+                              .transform,
+                              .getnativesymbolinfo = TRUE) {
 
+  ptsi.inv <- ptsi.for <- gnsi.rproc <- gnsi.dmeas <- as.logical(.getnativesymbolinfo)
   mif2 <- as.logical(.mif2)
   transform <- as.logical(.transform)
   
@@ -91,7 +93,7 @@
     params <- matrix(
                      params,
                      nrow=length(params),
-                     ncol=Np[1],
+                     ncol=Np[1L],
                      dimnames=list(
                        names(params),
                        NULL
@@ -105,13 +107,15 @@
   x <- init.state(
                   object,
                   params=if (transform) {
-                    partrans(object,params,dir="forward")
+                    partrans(object,params,dir="forward",
+                             .getnativesymbolinfo=ptsi.for)
                   } else {
                     params
                   }
                   )
   statenames <- rownames(x)
   nvars <- nrow(x)
+  ptsi.for <- FALSE
   
   ## set up storage for saving samples from filtering distributions
   if (save.states)
@@ -126,7 +130,7 @@
   random.walk <- !missing(.rw.sd)
   if (random.walk) {
     rw.names <- names(.rw.sd)
-    if (is.null(rw.names)||!is.numeric(.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(
@@ -184,29 +188,21 @@
   else
     filt.m <- array(data=numeric(0),dim=c(0,0))
 
-  if (mif2) {
-    if (missing(cooling.fraction))
-      stop("pfilter error: ",sQuote("cooling.fraction")," must be specified for method mif2",call.=FALSE)
-    cooling.fraction <- as.numeric(cooling.fraction)
-  }
-  
   for (nt in seq_len(ntimes)) {
     
-    if ((mif2==T) && (cooling.fraction>0)) {	  
-      cool.sched <- try(
-                        mif2.cooling(frac=cooling.fraction,nt=nt,m=cooling.m,n=ntimes),
-                        silent=FALSE
-                        )
-      if (inherits(cool.sched,"try-error")) 
-        stop("pfilter error: cooling schedule error",call.=FALSE)
-      sigma1 <- sigma*cool.sched$alpha
-      sigma1 <- sigma
+    if (mif2) {	  
+      cool.sched <- cooling(nt=nt,m=cooling.m)
+      sigma1 <- as.numeric(sigma[nt,])*cool.sched$alpha
+      names(sigma1)<-rw.names
     } else {
-      sigma1 <- sigma
+      sigma1 <- as.numeric(sigma[nt,])
+      names(sigma1)<-rw.names
     }
     
     ## transform the parameters if necessary
-    if (transform) tparams <- partrans(object,params,dir="forward")
+    if (transform) tparams <- partrans(object,params,dir="forward",
+                                       .getnativesymbolinfo=ptsi.for)
+    ptsi.for <- FALSE
     
     ## advance the state variables according to the process model
     X <- try(
@@ -215,15 +211,17 @@
                       xstart=x,
                       times=times[c(nt,nt+1)],
                       params=if (transform) tparams else params,
-                      offset=1
+                      offset=1,
+                      .getnativesymbolinfo=gnsi.rproc
                       ),
              silent=FALSE
              )
     if (inherits(X,'try-error'))
       stop(sQuote("pfilter")," error: process simulation error",call.=FALSE)
+    gnsi.rproc <- FALSE
     
     if (pred.var) { ## check for nonfinite state variables and parameters
-      problem.indices <- unique(which(!is.finite(X),arr.ind=TRUE)[,1])
+      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): ",
@@ -232,7 +230,7 @@
              )
       }
       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)[,1])
+        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): ",
@@ -251,7 +249,8 @@
                             x=X,
                             times=times[nt+1],
                             params=if (transform) tparams else params,
-                            log=FALSE
+                            log=FALSE,
+                            .getnativesymbolinfo=gnsi.dmeas
                             ),
                    silent=FALSE
                    )
@@ -260,6 +259,7 @@
     if (any(!is.finite(weights))) {
       stop(sQuote("pfilter")," error: ",sQuote("dmeasure")," returns non-finite value",call.=FALSE)
     }
+    gnsi.dmeas <- FALSE
     
     ## compute prediction mean, prediction variance, filtering mean,
     ## effective sample size, log-likelihood
@@ -374,7 +374,8 @@
                              save.params=save.params,
                              seed=seed,
                              verbose=verbose,
-                             .transform=FALSE
+                             .transform=FALSE,
+                             ...
                              )
           }
           )


From noreply at r-forge.r-project.org  Thu Feb 28 06:48:57 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu, 28 Feb 2013 06:48:57 +0100 (CET)
Subject: [Pomp-commits] r830 - in branches/mif2: . R inst man src tests
Message-ID: <20130228054857.1FEEB184DEE@r-forge.r-project.org>

Author: nxdao2000
Date: 2013-02-28 06:48:56 +0100 (Thu, 28 Feb 2013)
New Revision: 830

Modified:
   branches/mif2/DESCRIPTION
   branches/mif2/NAMESPACE
   branches/mif2/R/aaa.R
   branches/mif2/R/basic-probes.R
   branches/mif2/R/bsmc.R
   branches/mif2/R/dmeasure-pomp.R
   branches/mif2/R/dprocess-pomp.R
   branches/mif2/R/init-state-pomp.R
   branches/mif2/R/mif-class.R
   branches/mif2/R/mif-methods.R
   branches/mif2/R/particles-mif.R
   branches/mif2/R/plot-pomp.R
   branches/mif2/R/plugins.R
   branches/mif2/R/pmcmc.R
   branches/mif2/R/pomp-fun.R
   branches/mif2/R/pomp-methods.R
   branches/mif2/R/pomp.R
   branches/mif2/R/probe.R
   branches/mif2/R/rmeasure-pomp.R
   branches/mif2/R/rprocess-pomp.R
   branches/mif2/R/simulate-pomp.R
   branches/mif2/R/skeleton-pomp.R
   branches/mif2/R/sobol.R
   branches/mif2/R/spect-match.R
   branches/mif2/R/spect.R
   branches/mif2/R/traj-match.R
   branches/mif2/R/trajectory-pomp.R
   branches/mif2/inst/NEWS
   branches/mif2/man/mif-class.Rd
   branches/mif2/man/mif.Rd
   branches/mif2/man/pmcmc.Rd
   branches/mif2/man/probe.Rd
   branches/mif2/src/SSA_wrapper.c
   branches/mif2/src/dmeasure.c
   branches/mif2/src/dprocess.c
   branches/mif2/src/euler.c
   branches/mif2/src/partrans.c
   branches/mif2/src/pomp_fun.c
   branches/mif2/src/pomp_internal.h
   branches/mif2/src/rmeasure.c
   branches/mif2/src/rprocess.c
   branches/mif2/src/simulate.c
   branches/mif2/src/skeleton.c
   branches/mif2/src/trajectory.c
   branches/mif2/tests/bbs-trajmatch.Rout.save
   branches/mif2/tests/bbs.Rout.save
   branches/mif2/tests/blowflies.Rout.save
   branches/mif2/tests/dacca.Rout.save
   branches/mif2/tests/dimchecks.Rout.save
   branches/mif2/tests/fhn.Rout.save
   branches/mif2/tests/filtfail.Rout.save
   branches/mif2/tests/gillespie.Rout.save
   branches/mif2/tests/gompertz.R
   branches/mif2/tests/gompertz.Rout.save
   branches/mif2/tests/logistic.Rout.save
   branches/mif2/tests/ou2-bsmc.Rout.save
   branches/mif2/tests/ou2-forecast.R
   branches/mif2/tests/ou2-forecast.Rout.save
   branches/mif2/tests/ou2-icfit.R
   branches/mif2/tests/ou2-icfit.Rout.save
   branches/mif2/tests/ou2-kalman.Rout.save
   branches/mif2/tests/ou2-mif-fp.R
   branches/mif2/tests/ou2-mif-fp.Rout.save
   branches/mif2/tests/ou2-mif.R
   branches/mif2/tests/ou2-mif.Rout.save
   branches/mif2/tests/ou2-mif2.R
   branches/mif2/tests/ou2-mif2.Rout.save
   branches/mif2/tests/ou2-nlf.Rout.save
   branches/mif2/tests/ou2-pmcmc.R
   branches/mif2/tests/ou2-pmcmc.Rout.save
   branches/mif2/tests/ou2-probe.Rout.save
   branches/mif2/tests/ou2-procmeas.Rout.save
   branches/mif2/tests/ou2-simulate.Rout.save
   branches/mif2/tests/ou2-trajmatch.Rout.save
   branches/mif2/tests/pfilter.Rout.save
   branches/mif2/tests/pomppomp.Rout.save
   branches/mif2/tests/ricker-bsmc.Rout.save
   branches/mif2/tests/ricker-probe.Rout.save
   branches/mif2/tests/ricker-spect.Rout.save
   branches/mif2/tests/ricker.Rout.save
   branches/mif2/tests/rw2.Rout.save
   branches/mif2/tests/sir.Rout.save
   branches/mif2/tests/skeleton.Rout.save
   branches/mif2/tests/steps.Rout.save
   branches/mif2/tests/synlik.Rout.save
   branches/mif2/tests/verhulst.Rout.save
Log:
commit the whole directory for compatibility

Modified: branches/mif2/DESCRIPTION
===================================================================
--- branches/mif2/DESCRIPTION	2013-02-28 05:47:07 UTC (rev 829)
+++ branches/mif2/DESCRIPTION	2013-02-28 05:48:56 UTC (rev 830)
@@ -2,7 +2,7 @@
 Type: Package
 Title: Statistical inference for partially observed Markov processes
 Version: 0.44-1
-Date: 2013-01-15
+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
 Maintainer: Aaron A. King <kingaa at umich.edu>
 URL: http://pomp.r-forge.r-project.org

Modified: branches/mif2/NAMESPACE
===================================================================
--- branches/mif2/NAMESPACE	2013-02-28 05:47:07 UTC (rev 829)
+++ branches/mif2/NAMESPACE	2013-02-28 05:48:56 UTC (rev 830)
@@ -1,6 +1,5 @@
 useDynLib(			
           pomp,
-          get_pomp_fun,
           bspline_basis,
           periodic_bspline_basis,
           bspline_basis_function,

Modified: branches/mif2/R/aaa.R
===================================================================
--- branches/mif2/R/aaa.R	2013-02-28 05:47:07 UTC (rev 829)
+++ branches/mif2/R/aaa.R	2013-02-28 05:48:56 UTC (rev 830)
@@ -1,7 +1,7 @@
 ## .onAttach <- function (...) {
-##   version <- library(help=pomp)$info[[1]]
-##   version <- strsplit(version[pmatch("Version",version)]," ")[[1]]
-##   version <- version[nchar(version)>0][2]
+##   version <- library(help=pomp)$info[[1L]]
+##   version <- strsplit(version[pmatch("Version",version)]," ")[[1L]]
+##   version <- version[nchar(version)>0][2L]
 ##   packageStartupMessage("This is pomp version ",version,"\n")
 ## }
 

Modified: branches/mif2/R/basic-probes.R
===================================================================
--- branches/mif2/R/basic-probes.R	2013-02-28 05:47:07 UTC (rev 829)
+++ branches/mif2/R/basic-probes.R	2013-02-28 05:48:56 UTC (rev 830)
@@ -53,9 +53,9 @@
   method <- match.arg(method)
   lag <- as.integer(lag)
   transform <- match.fun(transform)
-  var1 <- vars[1]
+  var1 <- vars[1L]
   if (length(vars)>1)
-    var2 <- vars[2]
+    var2 <- vars[2L]
   else
     var2 <- var1
   function (y) {
@@ -85,9 +85,9 @@
   method <- match.arg(method)
   lag <- as.integer(lag)
   transform <- match.fun(transform)
-  var1 <- vars[1]
+  var1 <- vars[1L]
   if (length(vars)>1)
-    var2 <- vars[2]
+    var2 <- vars[2L]
   else
     var2 <- var1
   function (y) {
@@ -134,8 +134,8 @@
   lags <- as.integer(lags)
   function (y) .Call(
                      probe_ccf,
-                     x=transform(y[vars[1],,drop=TRUE]),
-                     y=transform(y[vars[2],,drop=TRUE]),
+                     x=transform(y[vars[1L],,drop=TRUE]),
+                     y=transform(y[vars[2L],,drop=TRUE]),
                      lags=lags,
                      corr=corr
                      )

Modified: branches/mif2/R/bsmc.R
===================================================================
--- branches/mif2/R/bsmc.R	2013-02-28 05:47:07 UTC (rev 829)
+++ branches/mif2/R/bsmc.R	2013-02-28 05:48:56 UTC (rev 830)
@@ -31,327 +31,368 @@
 
 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,
-                    ...) {
+bsmc.internal <- 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,
+                           .getnativesymbolinfo = TRUE,
+                           ...) {
 
-            transform <- as.logical(transform)
+  gnsi.rproc <- gnsi.dmeas <- as.logical(.getnativesymbolinfo)
+  ptsi.inv <- ptsi.for <- TRUE
+  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)
-            }
+  if (missing(seed)) seed <- NULL
+  if (!is.null(seed)) {
+    if (!exists(".Random.seed",where=.GlobalEnv))
+      runif(n=1L) ## need to initialize the RNG
+    save.seed <- get(".Random.seed",pos=.GlobalEnv)
+    set.seed(seed)
+  }
 
-            error.prefix <- paste(sQuote("bsmc"),"error: ")
+  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(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")
+  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",
+                       .getnativesymbolinfo=ptsi.inv)
+  ptsi.inv <- FALSE
+  
+  ntimes <- length(time(object))
+  if (is.null(dim(params))) {
+    params <- matrix(
+                     params,
+                     nrow=length(params),
+                     ncol=Np,
+                     dimnames=list(
+                       names(params),
+                       NULL
+                       )
+                     )
+  }
 
-            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
 
-            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 (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 (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)
 
-            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)
 
-            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                   
+         )
+  }
 
-            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]<lower)|(params[estind,j]>upper))) {
+      ind <- which((params[estind,j]<lower)|(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
+           )
+    }
+  }
 
-            for (j in seq_len(Np)) {
-              if (any((params[estind,j]<lower)|(params[estind,j]>upper))) {
-                ind <- which((params[estind,j]<lower)|(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",
+                                  .getnativesymbolinfo=ptsi.for)
+                       } else {
+                         params
+                       }
+                       )
+  statenames <- rownames(xstart)
+  nvars <- nrow(xstart)
+  ptsi.for <- FALSE
+  
+  times <- time(object,t0=TRUE)
+  x <- xstart
 
-            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]))
 
-            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))
+                  )
+            )
+    }
 
-              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",
+                                 .getnativesymbolinfo=ptsi.for)
+                      } else {
+                        params
+                      },
+                      offset=1,
+                      .getnativesymbolinfo=gnsi.rproc
                       )
-              }
+    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
+    gnsi.rproc <- FALSE
+    
+    ## 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",
+                             .getnativesymbolinfo=ptsi.for)
+                  } else {
+                    m
+                  },
+                  .getnativesymbolinfo=gnsi.dmeas
+                  )	
+    gnsi.dmeas <- FALSE
+    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]
 
-              ## 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)
 
-              ## 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",
+                          .getnativesymbolinfo=ptsi.for)
+    
+    ## 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,
+                  .getnativesymbolinfo=gnsi.rproc
+                  )
 
-              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
+                      },
+                      .getnativesymbolinfo=gnsi.dmeas
+                      )
+    ## evaluate weights as per L&W AGM (5)
 
-              ## 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]<lower)|(params[estind,j]>upper))) {
+        weights[j] <- 0 
+      }
+      ## might this rejection method be preferable?
+      ## while (any((params[estind,j]<lower)|(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,]
+      ## }
+    }
 
-	      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]<lower)|(params[estind,j]>upper))) {
-                  weights[j] <- 0 
-                }
-                ## might this rejection method be preferable?
-                ## while (any((params[estind,j]<lower)|(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<tol)|(!is.finite(weights))) # test for NA weights
+    all.fail <- all(failures)
+    if (all.fail) {                     # all particles are lost
+      if (verbose) {
+        message("filtering failure at time t = ",times[nt+1])
+      }
+      nfail <- nfail+1
+      if (nfail > max.fail)
+        stop(error.prefix,"too many filtering failures",call.=FALSE)
+      evidence[nt] <- log(tol)          # worst log-likelihood
+      weights <- rep(1/Np,Np)
+      eff.sample.size[nt] <- 0
+    } else {                  # not all particles are lost
+      ## compute log-likelihood
+      evidence[nt] <- storeForEvidence1+storeForEvidence2
+      weights[failures] <- 0
+      weights <- weights/sum(weights)
+      ## compute effective sample-size
+      eff.sample.size[nt] <- 1/crossprod(weights)
+    }
 
-              x[,] <- X                
-              
-              ## test for failure to filter
-              dim(weights) <- NULL
-              failures <- ((weights<tol)|(!is.finite(weights))) # test for NA weights
-              all.fail <- all(failures)
-              if (all.fail) {                     # all particles are lost
-                if (verbose) {
-                  message("filtering failure at time t = ",times[nt+1])
-                }
-                nfail <- nfail+1
-                if (nfail > max.fail)
-                  stop(error.prefix,"too many filtering failures",call.=FALSE)
-                evidence[nt] <- log(tol)          # worst log-likelihood
-                weights <- rep(1/Np,Np)
-                eff.sample.size[nt] <- 0
-              } else {                  # not all particles are lost
-                ## compute log-likelihood
-                evidence[nt] <- storeForEvidence1+storeForEvidence2
-                weights[failures] <- 0
-                weights <- weights/sum(weights)
-                ## compute effective sample-size
-                eff.sample.size[nt] <- 1/crossprod(weights)
-              }
+    if (verbose) {
+      cat("effective sample size =",round(eff.sample.size[nt],1),"\n")
+    }
 
-              if (verbose) {
-                cat("effective sample size =",round(eff.sample.size[nt],1),"\n")
-              }
+    ## Matrix with samples (columns) from filtering distribution theta.t | Y.t
+    if (!all.fail) {
+      ## smp <- .Call(systematic_resampling,weights)
+      smp <- sample.int(n=Np,size=Np,replace=TRUE,prob=weights)
+      x <- x[,smp,drop=FALSE]
+      params[estind,] <- params[estind,smp,drop=FALSE]
+    }
 
-              ## Matrix with samples (columns) from filtering distribution theta.t | Y.t
-              if (!all.fail) {
-                ## smp <- .Call(systematic_resampling,weights)
-                smp <- sample.int(n=Np,size=Np,replace=TRUE,prob=weights)
-                x <- x[,smp,drop=FALSE]
-                params[estind,] <- params[estind,smp,drop=FALSE]
-              }
-              
-            }
-            
-            if (!is.null(seed)) {
-              assign(".Random.seed",save.seed,pos=.GlobalEnv)
-              seed <- save.seed
-            }
-            
-            ## if (transform) {
-            ##   params <- partrans(object,params,dir="forward")
-            ##   prior <- partrans(object,prior,dir="forward")
-            ## }
+    .getnativesymbolinfo <- FALSE
+    
+  }
 
-            ## replace parameters with point estimate (posterior median)
-            coef(object,transform=transform) <- apply(params,1,median)
+  if (!is.null(seed)) {
+    assign(".Random.seed",save.seed,pos=.GlobalEnv)
+    seed <- save.seed
+  }
+  
+  ## replace parameters with point estimate (posterior median)
+  coef(object,transform=transform) <- apply(params,1,median)
 
-            new(
-                "bsmcd.pomp",
-                object,
-                transform=transform,
-                post=params,
-                prior=prior,
-                est=as.character(est),
-                eff.sample.size=eff.sample.size,
-                smooth=smooth,
-                seed=as.integer(seed),
-                nfail=as.integer(nfail),
-                cond.log.evidence=evidence,
-                log.evidence=sum(evidence),
-                weights=weights
-                )
+  new(
+      "bsmcd.pomp",
+      object,
+      transform=transform,
+      post=params,
+      prior=prior,
+      est=as.character(est),
+      eff.sample.size=eff.sample.size,
+      smooth=smooth,
+      seed=as.integer(seed),
+      nfail=as.integer(nfail),
+      cond.log.evidence=evidence,
+      log.evidence=sum(evidence),
+      weights=weights
+      )
+}
+
+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,
+                    ...) {
+            bsmc.internal(
+                          object=object,
+                          params=params,
+                          Np=Np,
+                          est=est,
+                          smooth=smooth,
+                          ntries=ntries,
+                          tol=tol,
+                          lower=lower,
+                          upper=upper,
+                          seed=seed,
+                          verbose=verbose,
+                          max.fail=max.fail,
+                          transform=transform,
+                          ...
+                          )
           }
           )
 
@@ -374,17 +415,17 @@
         panel=function (x, y, ...) { ## prior, posterior pairwise scatterplot
           op <- par(new=TRUE)
           on.exit(par(op))
-          i <- which(x[1]==all[1,])
-          j <- which(y[1]==all[1,])
+          i <- which(x[1L]==all[1L,])
+          j <- which(y[1L]==all[1L,])
           points(prior[p1,i],prior[p1,j],pch=20,col=rgb(0.85,0.85,0.85,0.1),xlim=range(all[,i]),ylim=range(all[,j]))
           points(post[p2,i],post[p2,j],pch=20,col=rgb(0,0,1,0.01))
         },
         diag.panel=function (x, ...) { ## marginal posterior histogram
-          i <- which(x[1]==all[1,])
+          i <- which(x[1L]==all[1L,])
           d1 <- density(prior[,i])
           d2 <- density(post[,i])
           usr <- par('usr')
-          op <- par(usr=c(usr[1:2],0,1.5*max(d1$y,d2$y)))
+          op <- par(usr=c(usr[c(1L,2L)],0,1.5*max(d1$y,d2$y)))
           on.exit(par(op))
           polygon(d1,col=rgb(0.85,0.85,0.85,0.5))
           polygon(d2,col=rgb(0,0,1,0.5))

Modified: branches/mif2/R/dmeasure-pomp.R
===================================================================
--- branches/mif2/R/dmeasure-pomp.R	2013-02-28 05:47:07 UTC (rev 829)
+++ branches/mif2/R/dmeasure-pomp.R	2013-02-28 05:48:56 UTC (rev 830)
@@ -1,9 +1,11 @@
 ## evaluate the measurement model density function
 setGeneric("dmeasure",function(object,...)standardGeneric("dmeasure"))
 
-dmeasure.internal <- function (object, y, x, times, params, log = FALSE, ...) {
-  fun <- get.pomp.fun(object at dmeasure)
-  .Call(do_dmeasure,object,y,x,times,params,log,fun)
+dmeasure.internal <- function (object, y, x, times, params, log = FALSE, .getnativesymbolinfo = TRUE, ...) {
+  .Call(do_dmeasure,object,y,x,times,params,log,.getnativesymbolinfo)
 }
 
-setMethod("dmeasure","pomp",dmeasure.internal)
+setMethod("dmeasure","pomp",
+          function (object, y, x, times, params, log = FALSE, ...)
+          dmeasure.internal(object=object,y=y,x=x,times=times,params=params,log=log,...)
+          )

Modified: branches/mif2/R/dprocess-pomp.R
===================================================================
--- branches/mif2/R/dprocess-pomp.R	2013-02-28 05:47:07 UTC (rev 829)
+++ branches/mif2/R/dprocess-pomp.R	2013-02-28 05:48:56 UTC (rev 830)
@@ -1,7 +1,10 @@
 ## evaluate the process model density function
 setGeneric("dprocess",function(object,...)standardGeneric("dprocess"))
 
-dprocess.internal <- function (object, x, times, params, log = FALSE, ...)
-  .Call(do_dprocess,object,x,times,params,log)
+dprocess.internal <- function (object, x, times, params, log = FALSE, .getnativesymbolinfo = TRUE, ...)
+  .Call(do_dprocess,object,x,times,params,log,.getnativesymbolinfo)
 
-setMethod("dprocess","pomp",dprocess.internal)
+setMethod("dprocess","pomp",
+          function (object, x, times, params, log = FALSE, ...)
+          dprocess.internal(object=object,x=x,times=times,params=params,log=log,...)
+          )

Modified: branches/mif2/R/init-state-pomp.R
===================================================================
--- branches/mif2/R/init-state-pomp.R	2013-02-28 05:47:07 UTC (rev 829)
+++ branches/mif2/R/init-state-pomp.R	2013-02-28 05:48:56 UTC (rev 830)
@@ -1,12 +1,16 @@
+## initialize the state variables of the process model
+init.state.internal <- function (object, params, t0, ...) {
+  if (missing(t0)) t0 <- object at t0
+  if (missing(params)) params <- coef(object)
+  .Call(do_init_state,object,params,t0)
+}
+
 setGeneric("init.state",function(object,...)standardGeneric("init.state"))
 
-## initialize the process model
 setMethod(
           'init.state',
           'pomp',
-          function (object, params, t0, ...) { # the package algorithms will only use these arguments
-            if (missing(t0)) t0 <- object at t0
-            if (missing(params)) params <- coef(object)
-            .Call(do_init_state,object,params,t0)
+          function (object, params, t0, ...) {
+            init.state.internal(object=object,params=params,t0=t0,...)
           }
           )

Modified: branches/mif2/R/mif-class.R
===================================================================
--- branches/mif2/R/mif-class.R	2013-02-28 05:47:07 UTC (rev 829)
+++ branches/mif2/R/mif-class.R	2013-02-28 05:48:56 UTC (rev 830)
@@ -10,7 +10,7 @@
            particles = 'function',
            var.factor='numeric',
            ic.lag='integer',
-           cooling.factor='numeric',
+           cooling.type='character',
            cooling.fraction='numeric',
            method='character',
            random.walk.sd = 'numeric',

Modified: branches/mif2/R/mif-methods.R
[TRUNCATED]

To get the complete diff run:
    svnlook diff /svnroot/pomp -r 830