[Lme4-commits] r1708 - pkg/lme4/R

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

Author: dmbates
Date: 2012-04-20 01:44:25 +0200 (Fri, 20 Apr 2012)
New Revision: 1708

Modified:
   pkg/lme4/R/lmer.R
   pkg/lme4/R/utilities.R
Log:
Get glmer converging with nAGQ=1


Modified: pkg/lme4/R/lmer.R
===================================================================
--- pkg/lme4/R/lmer.R	2012-04-18 18:59:21 UTC (rev 1707)
+++ pkg/lme4/R/lmer.R	2012-04-19 23:44:25 UTC (rev 1708)
@@ -359,9 +359,7 @@
         devfun <- function(pars) {
             resp$updateMu(lp0)
             pp$setTheta(as.double(pars[dpars])) # initial pars are theta
-            beta0 <- as.numeric(pars[-dpars]) # trailing pars are beta
-            pp$setBeta0(beta0)
-            resp$setOffset(baseOffset + pp$X %*% beta0)
+            resp$setOffset(baseOffset + pp$X %*% as.numeric(pars[-dpars]))
             pwrssUpdate(pp, resp, tol=tolPwrss, uOnly=TRUE)
         }
         environment(devfun) <- rho
@@ -371,7 +369,6 @@
                        rho$lower, control=control, rho=rho,
                        adj=TRUE, verbose=verbose)
     }
-
     mkMerMod(environment(devfun), opt, reTrms, fr, mc)
 }## {glmer}
 
@@ -580,8 +577,6 @@
     oldpdev <- .Machine$double.xmax
     repeat {
         pdev <- RglmerWrkIter(pp, resp, uOnly)
-        cat(sprintf("uOnly: %d, theta = %g, oldpdev = %g, pdev = %g\n",
-                    uOnly, pp$theta[1], oldpdev, pdev))
         ## check convergence first so small increases don't trigger errors
         if (abs((oldpdev - pdev) / pdev) < tol)
             break
@@ -591,10 +586,7 @@
         }
         oldpdev <- pdev
     }
-    value <- resp$Laplace(pp$ldL2(), 0., pp$sqrL(1))
-    cat(sprintf("Laplace approximation (using GLM deviance, not drsum) = %g\n",
-                value))
-    value
+    resp$Laplace(pp$ldL2(), 0., pp$sqrL(1))
 }
 
 ## create a deviance evaluation function that uses the sigma parameters

Modified: pkg/lme4/R/utilities.R
===================================================================
--- pkg/lme4/R/utilities.R	2012-04-18 18:59:21 UTC (rev 1707)
+++ pkg/lme4/R/utilities.R	2012-04-19 23:44:25 UTC (rev 1708)
@@ -519,6 +519,11 @@
     sqrLenU <- pp$sqrL(fac)
     wrss    <- resp$wrss()
     pwrss   <- wrss + sqrLenU
+    beta    <- pp$beta(fac)
+    if (rcl != "lmerResp") {
+        pars <- opt$par
+        if (length(pars) > length(pp$theta)) beta <- pars[-(seq_along(pp$theta))]
+    }
     cmp <- c(ldL2=pp$ldL2(), ldRX2=pp$ldRX2(), wrss=wrss,
              ussq=sqrLenU, pwrss=pwrss,
              drsum=if (rcl=="glmResp") resp$resDev() else NA,
@@ -530,6 +535,6 @@
              tolPwrss=rho$tolPwrss)
     new(switch(rcl, lmerResp="lmerMod", glmResp="glmerMod", nlsResp="nlmerMod"),
         call=mc, frame=fr, flist=reTrms$flist, cnms=reTrms$cnms,
-        Gp=reTrms$Gp, theta=pp$theta, beta=pp$beta(fac), u=pp$u(fac),
+        Gp=reTrms$Gp, theta=pp$theta, beta=beta, u=pp$u(fac),
         lower=reTrms$lower, devcomp=list(cmp=cmp, dims=dims), pp=pp, resp=resp)
 }