Bug: Hotfix issue with rhs interactions with 1 contrast introduced in #…

…169 + shorten enw_formula test snapshots
epinowcast · Dec 5, 2022 · e2651e7 · e2651e7
1 parent 8d60c59
commit e2651e7
Show file tree

Hide file tree

Showing 3 changed files with 139 additions and 5 deletions.
diff --git a/R/formula-tools.R b/R/formula-tools.R
@@ -429,15 +429,24 @@ construct_re <- function(re, data) {
   random_int <- rep(FALSE, length(random))
   for (i in seq_along(random)) {
     current_random <- strsplit(random[i], ":")[[1]]
-    expanded_random <- c(expanded_random, current_random)
+
     if (length(current_random) > 1) {
       if (length(current_random) > 2) {
         stop(
           "Interactions between more than 2 variables are not currently supported on the right hand side of random effects" # nolint
         )
       }
-      random_int[i] <- TRUE
+      if (length(unique(data[[current_random[2]]])) < 2) {
+      message(
+        "A random effect using ", current_random[2],
+        " is not possible as this variable has fewer than 2 unique values."
+      )
+      random[i] <- current_random[1]
+      }else {
+        random_int[i] <- TRUE
+      }
     }
+    expanded_random <- c(expanded_random, current_random)
   }
   expanded_random <- unique(expanded_random)
   # detect if random effect interactions are present

diff --git a/tests/testthat/_snaps/enw_formula.md b/tests/testthat/_snaps/enw_formula.md
@@ -1012,6 +1012,117 @@
       [26] 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42
       
       
+      attr(,"class")
+      [1] "enw_formula" "list"       
+
+# enw_formula can return a random effects formula with an internal
+           interaction with only one contrast by falling back to no interaction
+
+    Code
+      suppressMessages(enw_formula(~ 1 + (1 + month | day_of_week:age_group), data[
+        age_group == "00+"]))
+    Output
+      $formula
+      [1] "~1 + (1 + month | day_of_week:age_group)"
+      
+      $parsed_formula
+      $parsed_formula$fixed
+      [1] "1"
+      
+      $parsed_formula$random
+      $parsed_formula$random[[1]]
+      1 + month | day_of_week:age_group
+      
+      
+      $parsed_formula$rw
+      character(0)
+      
+      
+      $expanded_formula
+      [1] "~1 + day_of_week + month:day_of_week"
+      
+      $fixed
+      $fixed$formula
+      [1] "~1 + day_of_week + month:day_of_week"
+      
+      $fixed$design
+        (Intercept) day_of_weekFriday day_of_weekMonday day_of_weekSaturday
+      1           1                 0                 0                   0
+      2           1                 1                 0                   0
+      3           1                 0                 0                   1
+      4           1                 0                 0                   0
+      5           1                 0                 1                   0
+      6           1                 0                 0                   0
+      7           1                 0                 0                   0
+      8           1                 0                 0                   0
+        day_of_weekSunday day_of_weekThursday day_of_weekTuesday day_of_weekWednesday
+      1                 0                   1                  0                    0
+      2                 0                   0                  0                    0
+      3                 0                   0                  0                    0
+      4                 1                   0                  0                    0
+      5                 0                   0                  0                    0
+      6                 0                   0                  1                    0
+      7                 0                   0                  0                    1
+      8                 0                   1                  0                    0
+        day_of_weekFriday:month day_of_weekMonday:month day_of_weekSaturday:month
+      1                       0                       0                         0
+      2                       1                       0                         0
+      3                       0                       0                         1
+      4                       0                       0                         0
+      5                       0                       1                         0
+      6                       0                       0                         0
+      7                       0                       0                         0
+      8                       0                       0                         0
+        day_of_weekSunday:month day_of_weekThursday:month day_of_weekTuesday:month
+      1                       0                         0                        0
+      2                       0                         0                        0
+      3                       0                         0                        0
+      4                       1                         0                        0
+      5                       0                         0                        0
+      6                       0                         0                        1
+      7                       0                         0                        0
+      8                       0                         1                        0
+        day_of_weekWednesday:month
+      1                          0
+      2                          0
+      3                          0
+      4                          0
+      5                          0
+      6                          0
+      7                          1
+      8                          0
+      
+      $fixed$index
+       [1] 1 2 3 4 5 6 7 8 2 3 4
+      
+      
+      $random
+      $random$formula
+      [1] "~0 + fixed + day_of_week + month__day_of_week"
+      
+      $random$design
+         fixed day_of_week month__day_of_week
+      1      0           1                  0
+      2      0           1                  0
+      3      0           1                  0
+      4      0           1                  0
+      5      0           1                  0
+      6      0           1                  0
+      7      0           1                  0
+      8      0           0                  1
+      9      0           0                  1
+      10     0           0                  1
+      11     0           0                  1
+      12     0           0                  1
+      13     0           0                  1
+      14     0           0                  1
+      attr(,"assign")
+      [1] 1 2 3
+      
+      $random$index
+       [1]  1  2  3  4  5  6  7  8  9 10 11 12 13 14
+      
+      
       attr(,"class")
       [1] "enw_formula" "list"       
 

diff --git a/tests/testthat/test-enw_formula.R b/tests/testthat/test-enw_formula.R
@@ -9,20 +9,34 @@ obs <- enw_filter_report_dates(
 obs <- enw_filter_reference_dates(obs, include_days = 10)
 pobs <- enw_preprocess_data(obs, by = c("age_group", "location"))
 data <- pobs$metareference[[1]]
+datas <-  data[age_group %in% c("00+", "15-34")]
 
 test_that("enw_formula can return a basic fixed effects formula", {
-  expect_snapshot(enw_formula(~ 1 + age_group, data))
+  expect_snapshot(enw_formula( ~ 1 + age_group, data))
 })
 
 test_that("enw_formula can return a basic random effects formula", {
-  expect_snapshot(enw_formula(~ 1 + (1 | age_group), data))
+  expect_snapshot(
+    enw_formula(~ 1 + (1 | age_group),  data)
+  )
 })
 
 test_that("enw_formula can return a random effects formula with an internal
            interaction", {
-  expect_snapshot(enw_formula(~ 1 + (1 + month | day_of_week:age_group), data))
+  expect_snapshot(
+    enw_formula(~ 1 + (1 + month | day_of_week:age_group), data)
+  )
 })
 
+test_that("enw_formula can return a random effects formula with an internal
+           interaction with only one contrast by falling back to no interaction", {
+  expect_snapshot(
+    suppressMessages(enw_formula(
+      ~ 1 + (1 + month | day_of_week:age_group),
+      data[age_group == "00+"]
+    ))
+  )
+})
 
 test_that("enw_formula cannot return a random effects formula with multiple
            internal interaction", {