[Lme4-commits] r1639 - in pkg/lme4Eigen: R tests

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

Author: bbolker
Date: 2012-03-02 20:28:43 +0100 (Fri, 02 Mar 2012)
New Revision: 1639

Added:
   pkg/lme4Eigen/tests/nadrop.R
Modified:
   pkg/lme4Eigen/R/lmer.R
Log:

  allow for NAs in response when refitting



Modified: pkg/lme4Eigen/R/lmer.R
===================================================================
--- pkg/lme4Eigen/R/lmer.R	2012-03-02 18:42:06 UTC (rev 1638)
+++ pkg/lme4Eigen/R/lmer.R	2012-03-02 19:28:43 UTC (rev 1639)
@@ -1022,11 +1022,22 @@
 }
 
 ##' @S3method refit merMod
-refit.merMod <- function(object, newresp= model.response(model.frame(object)),
-			 ...)
+refit.merMod <- function(object, newresp=NULL, ...)
 {
+
     rr <- object at resp$copy()
 
+    if (!is.null(newresp)) {
+    
+      if (!is.null(na.act <- attr(object at frame,"na.action"))) {
+        ## will only get here if na.action is 'na.omit' or 'na.exclude'
+        if (is.matrix(newresp)) {
+          newresp <- newresp[-na.act,]
+        } else newresp <- newresp[-na.act]
+      }
+
+
+    
     if (isGLMM(object) && rr$family$family=="binomial") {
         if (is.matrix(newresp) && ncol(newresp)==2) {
             ntot <- rowSums(newresp)
@@ -1040,8 +1051,12 @@
             newresp <- as.numeric(newresp)-1
         }
     }
+
     stopifnot(length(newresp <- as.numeric(as.vector(newresp))) == length(rr$y))
     rr$setResp(newresp)
+
+    }
+    
     pp        <- object at pp$copy()
     dc        <- object at devcomp
     nAGQ      <- dc$dims["nAGQ"]

Added: pkg/lme4Eigen/tests/nadrop.R
===================================================================
--- pkg/lme4Eigen/tests/nadrop.R	                        (rev 0)
+++ pkg/lme4Eigen/tests/nadrop.R	2012-03-02 19:28:43 UTC (rev 1639)
@@ -0,0 +1,22 @@
+library(lme4Eigen)
+d <- data.frame(x=runif(100),f=factor(rep(1:10,10)))
+set.seed(101)
+u <- rnorm(10)
+d <- transform(d,y=rnorm(100,1+2*x+u[f],0.2))
+d0 <- d
+d[c(3,5,7),"x"] <- NA
+
+## 'omit' and 'exclude' are the only choices under which
+##  we will see NA values in the results
+fm0 <- lmer(y~x+(1|f),data=d0)
+fm1 <- lmer(y~x+(1|f),data=d)
+fm2 <- lmer(y~x+(1|f),data=d,na.action="na.exclude")
+try(fm3 <- lmer(y~x+(1|f),data=d,na.action="na.pass"))
+
+refit(fm0)
+refit(fm1)
+refit(fm2)
+
+refit(fm0,runif(100))
+refit(fm1,runif(100))
+refit(fm2,runif(100))