[Lme4-commits] r1597 - pkg/lme4Eigen/R

[noreply at r-forge.r-project.org]

Author: bbolker
Date: 2012-02-11 00:12:36 +0100 (Sat, 11 Feb 2012)
New Revision: 1597

Modified:
   pkg/lme4Eigen/R/lmer.R
   pkg/lme4Eigen/R/optimizer.R
Log:

   small bootMer hacks
   fixed error message on bad return from NM
   documented return codes from NM



Modified: pkg/lme4Eigen/R/lmer.R
===================================================================
--- pkg/lme4Eigen/R/lmer.R	2012-02-10 22:13:05 UTC (rev 1596)
+++ pkg/lme4Eigen/R/lmer.R	2012-02-10 23:12:36 UTC (rev 1597)
@@ -112,7 +112,7 @@
     environment(fr.form) <- environment(formula)
     mf$formula <- fr.form
     fr <- eval(mf, parent.frame())
-					# random effects and terms modules
+    					# random effects and terms modules
     reTrms <- mkReTrms(findbars(formula[[3]]), fr)
     if (any(unlist(lapply(reTrms$flist, nlevels)) >= nrow(fr)))
 	stop("number of levels of each grouping factor must be less than number of obs")
@@ -139,7 +139,7 @@
                        lower=lower, control=control)
     if (opt$ierr < 0L) {
         if (opt$ierr > -4L)
-            stop("convergence failure, code ", nMres, " in NelderMead")
+            stop("convergence failure, code ", opt$ierr, " in NelderMead")
         else
             warning("failure to converge in", opt$control$maxfun, "evaluations")
     }
@@ -416,7 +416,7 @@
                        lower=lower, control=control)
     if (opt$ierr < 0L) {
         if (opt$ierr > -4L)
-            stop("convergence failure, code ", nMres, " in NelderMead")
+            stop("convergence failure, code ", opt$ierr, " in NelderMead")
         else
             warning("failure to converge in ", cc$maxfun, " evaluations")
     }
@@ -484,8 +484,8 @@
     stopifnot(is.environment(rho), is(rho$resp, "lmResp"))
     ff <- NULL
     if (is(rho$resp, "lmerResp")) {
-        rho$lmer_Deviance <- lmer_Deviance
-	ff <- function(theta) .Call(lmer_Deviance, pp$ptr(), resp$ptr(), theta)
+      rho$lmer_Deviance <- lmer_Deviance
+      ff <- function(theta) .Call(lmer_Deviance, pp$ptr(), resp$ptr(), theta)
     } else if (is(rho$resp, "glmResp")) {
         if (nAGQ < 2L) {
             rho$glmerLaplace <- glmerLaplace
@@ -714,7 +714,7 @@
     mle <- list(beta = beta, theta = theta0, sigma = sigm.x)
 
     t.star <- matrix(t0, nr = length(t0), nc = nsim)
-    resp <- x at resp
+    ## resp <- x at resp
     for(i in 1:nsim) {
 	y <- {
 	    X.beta + sigm.x *
@@ -723,6 +723,10 @@
 	}
 	x @ resp <- new(Class=class(resp), REML=resp$REML, y=y, offset=resp$offset, weights=resp$weights)
 
+        rho <- new.env(parent=parent.env(environment()))
+        rho$pp <- x at pp
+        rho$resp <- x @ resp ## FIXME: ???
+
 	## if (oneD) { # use optimize
 	##     d0 <- devfun(0)
 	##     opt <- optimize(devfun, c(0, 10))
@@ -731,8 +735,10 @@
 	##     if (d0 <= opt$objective) ## prefer theta == 0 when close
 	##	   devfun(0) # -> theta	 := 0  and update the rest
 	## } else {
-	opt <- bobyqa(theta0, mkdevfun(resp, x at pp), x at lower, control = control)
-        ##	  xx <- updateMod(x, opt$par, opt$fval)
+        devfun <- mkdevfun(rho, 0L)
+	opt <- bobyqa(theta0, devfun, x at lower, control = control)
+        xx <- mkMerMod(environment(devfun), opt, vals$reTrms, x at frame, mc)
+        ## xx <- updateMod(x, opt$par, opt$fval)
         ## FIXME: also here, prefer \hat\sigma^2 == 0 (exactly)
         ##	  }
 	foo <- tryCatch(FUN(xx), error = function(e)e)

Modified: pkg/lme4Eigen/R/optimizer.R
===================================================================
--- pkg/lme4Eigen/R/optimizer.R	2012-02-10 22:13:05 UTC (rev 1596)
+++ pkg/lme4Eigen/R/optimizer.R	2012-02-10 23:12:36 UTC (rev 1597)
@@ -21,8 +21,16 @@
 ##' @return a list with 4 components
 ##' \item{fval}{numeric scalar - the minimum function value achieved}
 ##' \item{par}{numeric vector - the value of \code{x} providing the minimum}
-##' \item{ierr}{integer scalar - error code}
+##' \item{ierr}{integer scalar - error code (see below)}
 ##' \item{control}{list - the list of control settings after substituting for defaults}
+##' @note
+##' Return codes:
+##' \describe{
+##' \item{-4}{\code{nm_evals}: maximum evaluations reached}
+##' \item{-3}{\code{nm_forced}: ?}
+##' \item{-2}{\code{nm_nofeasible}: cannot generate a feasible simplex}
+##' \item{-1}{\code{nm_x0notfeasible}: initial x is not feasible (?)}
+##' }
 ##' @export
 Nelder_Mead <- function(ff, x0, xst, xt, lower=rep.int(-Inf, n),
                         upper=rep.int(Inf, n), control=list()) {