tests, GH actions [run ci]

R/utils.R

@@ -108,6 +108,10 @@ RHSForm <- function(form, as.form=FALSE) {
 #' @param formula a formula object
 #' @param value replacement value for RHS
 #' @rdname formfuns
+#' @examples
+#' f <- y ~ 1 + x
+#' RHSForm(f) <- quote(2+x^2)
+#' print(f)
 #' @export
 `RHSForm<-` <- function(formula,value) {
     formula[[length(formula)]] <- value
@@ -346,7 +350,8 @@ findbars_x <- function(term,
                 expand_doublevert_method = c("diag_special", "split")) {
 
     expand_doublevert_method <- match.arg(expand_doublevert_method)
-
+
+    term <- RHSForm(term, as.form = TRUE)
     ds <- if (is.null(default.special)) {
               NULL
           } else {

inst/tinytest/test_doubleVertNotation.R

@@ -0,0 +1,73 @@
+library(reformulas)
+
+## "basic intercept + slope '||' works"
+expect_equivalent(
+    findbars(Reaction ~ Days + (Days||Subject)),
+    findbars(Reaction ~ Days + (1|Subject) + (0 + Days|Subject))
+)
+
+## '||' works with nested,  multiple, or interaction terms" 
+## works with nested
+expect_equivalent(findbars(y ~ (x || id / id2)),
+                  findbars(y ~ (1 | id  / id2) + (0 + x | id / id2)))
+
+## works with multiple
+expect_equivalent(findbars(y ~ (x1 + x2  || id / id2) + (x3 | id3) + (x4 || id4)),
+                  findbars(y ~ (1 | id / id2) + (0 + x1 | id / id2) +
+                               (0 + x2 | id / id2) + (x3 | id3) + (1 | id4) +
+                               (0 + x4| id4)))
+## interactions:
+expect_equivalent(findbars(y ~ (x1*x2 || id)),
+                  findbars(y ~ (1 | id) + (0+x1 | id) + (0 + x2 | id) +
+                               (0 + x1:x2 | id)))
+
+## "quoted terms work"
+## used to fail in test-oldRZXFailure.R
+f <- quote(crab.speciesS + crab.sizeS +
+           crab.speciesS:crab.sizeS + (snail.size | plot))
+expect_equivalent(findbars(f)[[1]], (~(snail.size|plot))[[2]][[2]] )
+
+ ## "leaves superfluous '||' alone"
+expect_equivalent(findbars(y ~ z + (0 + x || id)),
+                          findbars(y ~ z + (0 + x  | id)))
+
+
+## "plays nice with parens in fixed or random formulas"
+expect_equivalent(findbars(y ~ (z + x)^2 + (x || id)),
+                  findbars(y ~ (z + x)^2 + (1 | id) + (0 + x | id)))
+
+expect_equivalent(findbars(y ~ ((x || id)) + (x2|id)),
+                  findbars(y ~ (1 | id) + (0 + x | id) + (x2|id)))
+
+## at("update works as expected", {
+## 	m <- lmer(Reaction ~ Days + (Days || Subject), sleepstudy)
+## 	expect_equivalent(fitted(update(m, .~.-(0 + Days | Subject))), 
+##                           fitted(lmer(Reaction ~ Days + (1|Subject), sleepstudy)))
+## })
+
+## "long formulas work"
+form <- log.corti~z.n.fert.females*z.n.males+
+        is.alpha2*(z.infanticide.susceptibility+z.min.co.res+
+                   z.co.res+z.log.tenure)+
+        z.xtime+z.age.at.sample+sin.season+cos.season+
+        (1  +z.n.fert.females
+            +z.n.males
+            +is.alpha2.subordinate
+            +z.infanticide.susceptibility
+            +z.min.co.res
+            +z.log.tenure
+            +z.co.res
+            +z.xtime
+            +z.age.at.sample
+            +sin.season
+            +cos.season
+            +I(z.n.fert.females*z.n.males)
+            +I(is.alpha2.subordinate*z.min.co.res)
+            +I(z.co.res*is.alpha2.subordinate)
+            +I(is.alpha2.subordinate*z.co.res)
+            +int.is.a.log.ten
+            ||monkeyid)
+expStr <- paste(deparse(expandDoubleVerts(form),width=500),collapse="")
+## check: no spurious ~ induced
+expect_equal(1,sum(grepl("~",strsplit(expStr,"")[[1]])))
+

inst/tinytest/test_nobar.R

@@ -0,0 +1,60 @@
+library(reformulas)
+
+rr <- reformulas::RHSForm
+expect_equal(nobars(y~1+(1|g)),                      y~1)
+expect_equal(nobars(y~1|g),                          y~1)
+expect_equal(nobars(y~1+(1||g)),                     y~1)
+expect_equal(nobars(y~1||g),                         y~1)
+expect_equal(nobars(y~1+(x:z|g)),                    y~1)
+expect_equal(nobars(y~1+(x*z|g/h)),                  y~1)
+expect_equal(nobars(y~(1|g)+x+(x|h)),                y~x)
+expect_equal(nobars(y~(1|g)+x+(x+z|h)),              y~x)
+expect_equal(nobars(~1+(1|g)),                        ~1)
+expect_equal(nobars(~(1|g)),                          ~1)
+expect_equal(nobars(rr(y~1+(1|g))),                    1)
+expect_equal(nobars(rr(y~(1|g))),                      1)
+
+nrt <- function(x) length(x$reTrmFormulas)
+
+## basic splitform
+nrt <- function(x) length(x$reTrmFormulas)
+
+expect_equal(nrt(splitForm(y~(x+q))),0) ## reTrms part should be empty
+sf1 <- splitForm(y~(x+q)+(1|f))
+sf2 <- splitForm(y~(x+q)+us(1|f))
+sf3 <- splitForm(y~(x+q)+diag(1|f))
+sf4 <- splitForm(~x+y+(f|g)+cs(1|g))
+expect_equal(nrt(sf1),1)
+expect_equal(sf1$reTrmFormulas,list(quote(1|f)))
+expect_equal(sf1,sf2) 
+expect_equal(sf3$reTrmClasses,"diag")
+expect_equal(sf4$reTrmClasses,c("us","cs"))
+
+
+## test_that("slash terms", {
+sf5 <- splitForm(~x+y+(1|f/g)) 
+sf6 <- splitForm(~x+y+(1|f/g/h))
+sf7 <- splitForm(~x+y+(1|(f/g)/h)) 
+expect_equal(sf5$reTrmClasses, rep("us",2))
+expect_equal(sf6$reTrmClasses, rep("us",3))
+expect_equal(sf6,sf7)
+
+## test_that("grpvar terms", {
+sf8 <- splitForm(~x+y+(1|f*g)) 
+sf9 <- splitForm(~x+y+(1|f+g+h))
+expect_equal(sf8$reTrmClasses,rep("us",3))
+expect_equal(sf8$reTrmFormula,list(quote(1|f),quote(1|g),quote(1|f:g)))
+expect_equal(sf9$reTrmClasses,rep("us",3))
+expect_equal(sf9$reTrmFormula,list(quote(1|f),quote(1|g),quote(1|h)))
+## })
+
+
+## test_that("noSpecial", {
+## handle parentheses in formulas: GH #174
+ff <- y~1+(((us(1|f))))
+expect_equal(noSpecials(ff,delete=FALSE),y~1+(1|f))
+expect_equal(noSpecials(ff),y~1)
+## 'naked' special - left alone: GH #261
+ff2 <- y ~ us
+expect_equal(noSpecials(ff2),ff2)
+

tests/tinytest.R

@@ -0,0 +1,3 @@
+if ( requireNamespace("tinytest", quietly=TRUE) ){
+   tinytest::test_package("reformulas")
+}