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