1library("testthat") 2library("lme4") 3 4context("data= argument and formula evaluation") 5 6## intercept context-dependent errors ... it's too bad that 7## these errors differ between devtools::test() and 8## R CMD check, but finding the difference is too much 9## of a nightmare 10## n.b. could break in other locales *if* we ever do internationalization ... 11data_RE <- "(bad 'data'|variable lengths differ)" 12 13test_that("glmerFormX", { 14 set.seed(101) 15 n <- 50 16 x <- rbinom(n, 1, 1/2) 17 y <- rnorm(n) 18 z <- rnorm(n) 19 r <- sample(1:5, size=n, replace=TRUE) 20 d <- data.frame(x,y,z,r) 21 22 F <- "z" 23 rF <- "(1|r)" 24 modStr <- (paste("x ~", "y +", F, "+", rF)) 25 modForm <- as.formula(modStr) 26 27 ## WARNING: these drop/environment tests are extremely sensitive to environment 28 ## they may fail/not fail, or fail differently, within a "testthat" environment vs. 29 ## when run interactively 30 expect_that(m_data.3 <- glmer( modStr , data=d, family="binomial"), is_a("glmerMod")) 31 expect_that(m_data.4 <- glmer( "x ~ y + z + (1|r)" , data=d, family="binomial"), is_a("glmerMod")) 32 ## interactively: (interactive() is TRUE {i.e. doesn't behave as I would expect} within testing environment ... 33 ## if (interactive()) { 34 ## AICvec <- c(77.0516381151634, 75.0819116367084, 75.1915023640827) 35 ## expect_equal(drop1(m_data.3)$AIC,AICvec) 36 ## expect_equal(drop1(m_data.4)$AIC,AICvec) 37 ## } else { 38 ## in test environment [NOT test_ 39 expect_error(drop1(m_data.3),data_RE) 40 expect_error(drop1(m_data.4),data_RE) 41 ##} 42}) 43 44test_that("glmerForm", { 45 set.seed(101) 46 n <- 50 47 x <- rbinom(n, 1, 1/2) 48 y <- rnorm(n) 49 z <- rnorm(n) 50 r <- sample(1:5, size=n, replace=TRUE) 51 d <- data.frame(x,y,z,r) 52 53 F <- "z" 54 rF <- "(1|r)" 55 modStr <- (paste("x ~", "y +", F, "+", rF)) 56 modForm <- as.formula(modStr) 57 58 ## formulas have environments associated, but character vectors don't 59 ## data argument not specified: 60 ## should work, but documentation warns against it 61 62 expect_that(m_nodata.0 <- glmer( x ~ y + z + (1|r) , family="binomial"), is_a("glmerMod")) 63 expect_that(m_nodata.1 <- glmer( as.formula(modStr) , family="binomial"), is_a("glmerMod")) 64 expect_that(m_nodata.2 <- glmer( modForm , family="binomial"), is_a("glmerMod")) 65 expect_that(m_nodata.3 <- glmer( modStr , family="binomial"), is_a("glmerMod")) 66 expect_that(m_nodata.4 <- glmer( "x ~ y + z + (1|r)" , family="binomial"), is_a("glmerMod")) 67 68 ## apply drop1 to all of these ... 69 m_nodata_List <- list(m_nodata.0, 70 m_nodata.1,m_nodata.2,m_nodata.3,m_nodata.4) 71 d_nodata_List <- lapply(m_nodata_List,drop1) 72 73 rm(list=c("x","y","z","r")) 74 75 ## data argument specified 76 expect_that(m_data.0 <- glmer( x ~ y + z + (1|r) , data=d, family="binomial"), is_a("glmerMod")) 77 expect_that(m_data.1 <- glmer( as.formula(modStr) , data=d, family="binomial"), is_a("glmerMod")) 78 expect_that(m_data.2 <- glmer( modForm , data=d, family="binomial"), is_a("glmerMod")) 79 expect_that(m_data.3 <- glmer( modStr , data=d, family="binomial"), is_a("glmerMod")) 80 expect_that(m_data.4 <- glmer( "x ~ y + z + (1|r)" , data=d, family="binomial"), is_a("glmerMod")) 81 82 ff <- function() { 83 set.seed(101) 84 n <- 50 85 x <- rbinom(n, 1, 1/2) 86 y <- rnorm(n) 87 z <- rnorm(n) 88 r <- sample(1:5, size=n, replace=TRUE) 89 d2 <- data.frame(x,y,z,r) 90 glmer( x ~ y + z + (1|r), data=d2, family="binomial") 91 } 92 m_data.5 <- ff() 93 94 ff2 <- function() { 95 set.seed(101) 96 n <- 50 97 x <- rbinom(n, 1, 1/2) 98 y <- rnorm(n) 99 z <- rnorm(n) 100 r <- sample(1:5, size=n, replace=TRUE) 101 glmer( x ~ y + z + (1|r), family="binomial") 102 } 103 m_data.6 <- ff2() 104 105 106 m_data_List <- list(m_data.0,m_data.1,m_data.2,m_data.3,m_data.4,m_data.5,m_data.6) 107 badNums <- 4:5 108 d_data_List <- lapply(m_data_List[-badNums],drop1) 109 110 ## these do NOT fail if there is a variable 'd' living in the global environment -- 111 ## they DO fail in the testthat context 112 expect_error(drop1(m_data.3),data_RE) 113 expect_error(drop1(m_data.4),data_RE) 114 115 ## expect_error(lapply(m_data_List[4],drop1)) 116 ## expect_error(lapply(m_data_List[5],drop1)) 117 ## d_data_List <- lapply(m_data_List,drop1,evalhack="parent") ## fails on element 1 118 ## d_data_List <- lapply(m_data_List,drop1,evalhack="formulaenv") ## fails on element 4 119 ## d_data_List <- lapply(m_data_List,drop1,evalhack="nulldata") ## succeeds 120 ## drop1(m_data.5,evalhack="parent") ## 'd2' not found 121 ## drop1(m_data.5,evalhack="nulldata") ## 'x' not found (d2 is in environment ...) 122 ## should we try to make update smarter ... ?? 123 124 ## test equivalence of (i vs i+1) for all models, all drop1() results 125 for (i in 1:(length(m_nodata_List)-1)) { 126 expect_equivalent(m_nodata_List[[i]],m_nodata_List[[i+1]]) 127 expect_equivalent(d_nodata_List[[i]],d_nodata_List[[i+1]]) 128 } 129 130 expect_equivalent(m_nodata_List[[1]],m_data_List[[1]]) 131 expect_equivalent(d_nodata_List[[1]],d_data_List[[1]]) 132 133 for (i in 1:(length(m_data_List)-1)) { 134 expect_equivalent(m_data_List[[i]],m_data_List[[i+1]]) 135 } 136 ## allow for dropped 'bad' vals 137 for (i in 1:(length(d_data_List)-1)) { 138 expect_equivalent(d_data_List[[i]],d_data_List[[i+1]]) 139 } 140 141}) 142 143 144test_that("lmerForm", { 145 146 set.seed(101) 147 148 x <- rnorm(10) 149 y <- rnorm(10) 150 z <- rnorm(10) 151 r <- sample(1:3, size=10, replace=TRUE) 152 d <- data.frame(x,y,z,r) 153 154 ## example from Joehanes Roeby 155 m2 <- suppressWarnings(lmer(x ~ y + z + (1|r), data=d)) 156 ff <- function() { 157 m1 <- suppressWarnings(lmer(x ~ y + z + (1|r), data=d)) 158 return(anova(m1)) 159 } 160 161 ff1 <- Reaction ~ Days + (Days|Subject) 162 fm1 <- lmer(ff1, sleepstudy) 163 fun <- function () { 164 ff1 <- Reaction ~ Days + (Days|Subject) 165 fm1 <- suppressWarnings(lmer(ff1, sleepstudy)) 166 return (anova(fm1)) 167 } 168 anova(m2) 169 ff() 170 expect_equal(anova(m2),ff()) 171 anova(fm1) 172 fun() 173 expect_equal(anova(fm1),fun()) 174 175 ## test deparsing of long RE terms 176 varChr <- paste0("varname_",outer(letters,letters,paste0)[1:100]) 177 rvars <- varChr[1:9] 178 form <- as.formula(paste("y ~",paste(varChr,collapse="+"), 179 "+", 180 paste0("(",paste(rvars,collapse="+"),"|f)"))) 181 ff <- lme4:::reOnly(form) 182 environment(ff) <- .GlobalEnv 183 expect_equal(ff, 184 ~(varname_aa + varname_ba + varname_ca + varname_da + varname_ea + 185 varname_fa + varname_ga + varname_ha + varname_ia | f)) 186}) 187 188test_that("lapply etc.", { 189 ## copied from dplyr 190 failwith <- function (default = NULL, f, quiet = FALSE) { 191 function(...) { 192 out <- default 193 try(out <- f(...), silent = quiet) 194 out 195 } 196 } 197 lmer_fw <- failwith(NULL,function(...) lmer(...) ,quiet=TRUE) 198 expect_is(lmer_fw(Yield ~ 1|Batch, Dyestuff, REML = FALSE), 199 "merMod") 200 ## GH 369 201 listOfFormulas <- list( 202 cbind(incidence, size - incidence) ~ 1 + (1 | herd), 203 cbind(incidence, size - incidence) ~ period + (1 | herd)) 204 expect_is(lapply(listOfFormulas,glmer,family=binomial,data=cbpp),"list") 205}) 206 207test_that("formula and data validation work with do.call() in artificial environment", { 208 ## This ensures compatibility of lmer when it's called from the 209 ## C-level Rf_eval() with an environment that doesn't exist on the 210 ## stack (i.e. C implementation in magrittr 2.0) 211 e <- new.env() 212 e$. <- mtcars 213 expect_is( 214 do.call(lme4::lmer, list("disp ~ (1 | cyl)", quote(.)), envir = e), 215 "merMod" 216 ) 217 218 fn <- function(data) { 219 lme4::lmer("disp ~ (1 | cyl)", data = data) 220 } 221 expect_is( 222 do.call(fn, list(quote(.)), envir = e), 223 "merMod" 224 ) 225}) 226