SCM

SCM Repository

[matrix] Diff of /pkg/R/lmer.R
ViewVC logotype

Diff of /pkg/R/lmer.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 775, Mon Jun 13 01:22:28 2005 UTC revision 776, Mon Jun 13 19:45:04 2005 UTC
# Line 177  Line 177 
177    
178            ## The rest of the function applies to generalized linear mixed models            ## The rest of the function applies to generalized linear mixed models
179            gVerb <- getOption("verbose")            gVerb <- getOption("verbose")
180            etaold <- eta <- glm.fit$linear.predictors            eta <- glm.fit$linear.predictors
181            wts <- glm.fit$prior.weights            wts <- glm.fit$prior.weights
182            wtssqr <- wts * wts            wtssqr <- wts * wts
183            offset <- glm.fit$offset            offset <- glm.fit$offset
184            if (is.null(offset)) offset <- numeric(length(eta))            if (is.null(offset)) offset <- numeric(length(eta))
185              off <- numeric(length(eta))
186              mu <- numeric(length(eta))
187    
188            dev.resids <- quote(family$dev.resids(y, mu, wtssqr))            dev.resids <- quote(family$dev.resids(y, mu, wtssqr))
189            linkinv <- quote(family$linkinv(eta))            linkinv <- quote(family$linkinv(eta))
           mu <- eval(linkinv)  
190            mu.eta <- quote(family$mu.eta(eta))            mu.eta <- quote(family$mu.eta(eta))
191            variance <- quote(family$variance(mu))            variance <- quote(family$variance(mu))
192            LMEopt <- get("LMEoptimize<-")            LMEopt <- get("LMEoptimize<-")
# Line 202  Line 203 
203            mer@nc[length(mmats)] <- -mer@nc[length(mmats)]            mer@nc[length(mmats)] <- -mer@nc[length(mmats)]
204    
205            nAGQ <- 0            nAGQ <- 0
           if (method == "Laplace") nAGQ <- 1  
206    
207            devLaplace <- function(pars)            devLaplace <- function(pars)
208                .Call("glmer_devLaplace", pars, GSpt, PACKAGE = "Matrix")                .Call("glmer_devAGQ", pars, GSpt, 1, PACKAGE = "Matrix")
209    
210              devAGQ <- function(pars)
211                  .Call("glmer_devAGQ", pars, GSpt, nAGQ, PACKAGE = "Matrix")
212    
213            if (method == "Laplace") {            if (method == "Laplace") {
214                  nAGQ <- 1
215                nc <- mer@nc                nc <- mer@nc
216                const <- c(rep(FALSE, length(fixInd)),                const <- c(rep(FALSE, length(fixInd)),
217                           unlist(lapply(nc[1:(length(nc) - 2)],                           unlist(lapply(nc[1:(length(nc) - 2)],
# Line 223  Line 227 
227                    optpars <- optimRes$par                    optpars <- optimRes$par
228                    if (optimRes$convergence != 0)                    if (optimRes$convergence != 0)
229                        warning("nlminb failed to converge")                        warning("nlminb failed to converge")
230                      loglik <- -optimRes$objective/2
231                } else {                } else {
232                    optimRes <-                    optimRes <-
233                        optim(PQLpars, devLaplace, method = "L-BFGS-B",                        optim(PQLpars, devLaplace, method = "L-BFGS-B",
234                              lower = ifelse(const, 5e-10, -Inf),                              lower = ifelse(const, 5e-10, -Inf),
235                              control = list(trace = getOption("verbose"),                              control = list(trace = getOption("verbose"),
236                                   reltol = cv$msTol, maxit = cv$msMaxIter))                                             maxit = cv$msMaxIter))
237                    optpars <- optimRes$par                    optpars <- optimRes$par
238                    if (optimRes$convergence != 0)                    if (optimRes$convergence != 0)
239                        warning("optim failed to converge")                        warning("optim failed to converge")
240                      loglik <- -optimRes$value
241                }                }
242    
243                if (gVerb) {                if (gVerb) {
# Line 241  Line 247 
247                    cat("(box constrained) variance coefficients:\n")                    cat("(box constrained) variance coefficients:\n")
248                    print(optimRes$par[-fixInd])                    print(optimRes$par[-fixInd])
249                }                }
               loglik <- -optimRes$objective/2  
250                fxd <- optpars[fixInd]                fxd <- optpars[fixInd]
251                names(fxd) <- names(PQLpars)[fixInd]                names(fxd) <- names(PQLpars)[fixInd]
252            } else {            } else {
# Line 249  Line 254 
254                fxd <- PQLpars[fixInd]                fxd <- PQLpars[fixInd]
255            }            }
256    
257              .Call("glmer_finalize", GSpt, PACKAGE = "Matrix")
258    
259            ## reset flag to skip fixed-effects in subsequent calls            ## reset flag to skip fixed-effects in subsequent calls
260            mer@nc[length(mmats)] <- -mer@nc[length(mmats)]            mer@nc[length(mmats)] <- -mer@nc[length(mmats)]
261    

Legend:
Removed from v.775  
changed lines
  Added in v.776

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge