[Lme4-commits] r1740 - in pkg/lme4: R tests

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

Author: bbolker
Date: 2012-05-16 17:57:42 +0200 (Wed, 16 May 2012)
New Revision: 1740

Added:
   pkg/lme4/tests/lmList.R
Modified:
   pkg/lme4/R/lmList.R
   pkg/lme4/tests/PIRLSfail.R
Log:

  un-try() PIRLS test
  fix confint.lmList, add some tests



Modified: pkg/lme4/R/lmList.R
===================================================================
--- pkg/lme4/R/lmList.R	2012-05-16 03:34:02 UTC (rev 1739)
+++ pkg/lme4/R/lmList.R	2012-05-16 15:57:42 UTC (rev 1740)
@@ -72,9 +72,12 @@
 
 ##' @importFrom stats coef
 ##' @S3method coef lmList
-          ## Extract the coefficients and form a  data.frame if possible
-coef.lmList <- function(object, augFrame = FALSE, data = NULL,
-                        which = NULL, FUN = mean, omitGroupingFactor = TRUE, ...) {
+## Extract the coefficients and form a  data.frame if possible
+## FIXME: commented out nlme stuff (augFrame etc.).  Restore, or delete for good
+coef.lmList <- function(object,
+                        ## augFrame = FALSE, data = NULL,
+                        ##which = NULL, FUN = mean, omitGroupingFactor = TRUE,
+                        ...) {
     coefs <- lapply(object, coef)
     non.null <- !unlist(lapply(coefs, is.null))
     if (sum(non.null) > 0) {
@@ -90,28 +93,28 @@
             }
             coefs <- as.data.frame(co)
             effectNames <- names(coefs)
-            if(augFrame) {
-                if (is.null(data)) {
-                    data <- getData(object)
-                }
-                data <- as.data.frame(data)
-                if (is.null(which)) {
-                    which <- 1:ncol(data)
-                }
-                data <- data[, which, drop = FALSE]
-                ## eliminating columns with same names as effects
-                data <- data[, is.na(match(names(data), effectNames)), drop = FALSE]
-                data <- gsummary(data, FUN = FUN, groups = getGroups(object))
-                if (omitGroupingFactor) {
-                    data <- data[, is.na(match(names(data),
-                                               names(getGroupsFormula(object,
-                                                                      asList = TRUE)))),
-                                 drop = FALSE]
-                }
-                if (length(data) > 0) {
-                    coefs <- cbind(coefs, data[row.names(coefs),,drop = FALSE])
-                }
-            }
+            ## if(augFrame) {
+            ##     if (is.null(data)) {
+            ##         data <- getData(object)
+            ##     }
+            ##     data <- as.data.frame(data)
+            ##     if (is.null(which)) {
+            ##         which <- 1:ncol(data)
+            ##     }
+            ##     data <- data[, which, drop = FALSE]
+            ##     ## eliminating columns with same names as effects
+            ##     data <- data[, is.na(match(names(data), effectNames)), drop = FALSE]
+            ##     data <- gsummary(data, FUN = FUN, groups = getGroups(object))
+            ##     if (omitGroupingFactor) {
+            ##         data <- data[, is.na(match(names(data),
+            ##                                    names(getGroupsFormula(object,
+            ##                                                           asList = TRUE)))),
+            ##                      drop = FALSE]
+            ##     }
+            ##     if (length(data) > 0) {
+            ##         coefs <- cbind(coefs, data[row.names(coefs),,drop = FALSE])
+            ##     }
+            ## }
             attr(coefs, "level") <- attr(object, "level")
             attr(coefs, "label") <- "Coefficients"
             attr(coefs, "effectNames") <- effectNames
@@ -169,6 +172,9 @@
     if (length(object) < 1)
         return(new("lmList.confint", array(numeric(0), c(0,0,0))))
     mCall$object <- object[[1]]
+    ## the old recursive strategy doesn't work with S3 objects --
+    ##  calls "confint.lmList" again instead of calling "confint"
+    mCall[[1]] <- quote(confint)
     template <- eval(mCall)
     val <- array(template, c(dim(template), length(object)),
                  c(dimnames(template), list(names(object))))

Modified: pkg/lme4/tests/PIRLSfail.R
===================================================================
--- pkg/lme4/tests/PIRLSfail.R	2012-05-16 03:34:02 UTC (rev 1739)
+++ pkg/lme4/tests/PIRLSfail.R	2012-05-16 15:57:42 UTC (rev 1740)
@@ -15,7 +15,6 @@
               data = trees513, family = binomial, devFunOnly = TRUE)
 ls.str(environment(dfun))# and you can investigate ...
 
-## FIXME: try() to pass checks
-mmod <- try(glmer(damage ~ species - 1 + (1 | lattice / plot),
-              data = trees513, family = binomial()))
+mmod <- glmer(damage ~ species - 1 + (1 | lattice / plot),
+              data = trees513, family = binomial())
 

Added: pkg/lme4/tests/lmList.R
===================================================================
--- pkg/lme4/tests/lmList.R	                        (rev 0)
+++ pkg/lme4/tests/lmList.R	2012-05-16 15:57:42 UTC (rev 1740)
@@ -0,0 +1,13 @@
+data(Orthodont,package="nlme")
+Orthodont <- as.data.frame(Orthodont)
+library(lme4)
+fm1 <- lmList(Reaction ~ Days | Subject, sleepstudy)
+fm1 <- lmList(Reaction ~ Days | Subject, sleepstudy, pool=TRUE)
+coef(fm1)
+summary(fm1)
+confint(fm1)
+fm2 <- lmList(distance ~ age | Subject, Orthodont)
+coef(fm2)
+## FIXME: add glm example?
+## FIXME: methods(class="lmList") shows a bunch of methods inherited from nlme
+##    that will probably fail ... is there a way to hide these/not import them?