klmr/box support (#526)

* increment version

* an app with box modules example

* boilerplate for box coverage test

* ready to write box support

* now works with basic box modules

* Forgot an s

Co-authored-by: Jakub Nowicki <[email protected]>

* Smaller version increment as suggested

Co-authored-by: Jakub Nowicki <[email protected]>

* got it to work!

* added support for R6 classes attached as box modules

* increment dev version

* forgot to update the unit test with R6 modules attached

* some refactoring to clean up code

* tests for klmr/box attached modules, functions, three dots, and aliases

* a little bit of cleanup

* code cleanup. finally broke the unlist puzzle

* clean up nested ((

* test: Fix box cache cleaning in tests.

* chore: Add box to suggested dependencies.

* chore: Update package version.

* added entry in NEWS.md

* Trigger CICD

* Another CI test trigger pr (#21)

* Added `replacements_box()` for `klmr/box` support.
* Extracted `traverse_R6()` from `replacements_R6()` to reuse code in `replacements_box()`.
* R6 class box modules test cases separated to handle a known R6 issues with `r-devel`. `skip_if(is_r_devel())` is used in the R6 test cases.

* Update to covr 3.6.3 (#23)

* Adjusted DESCRIPTION and NEWS.md
* Different condition to skip tests
* Bump version for release

---------

Co-authored-by: Jim Hester <[email protected]>

* box 1.2.0 released with backports compatibility fixes

---------

Co-authored-by: Jakub Nowicki <[email protected]>
Co-authored-by: Jakub Nowicki <[email protected]>
Co-authored-by: Jim Hester <[email protected]>

DESCRIPTION

@@ -1,7 +1,7 @@
 Encoding: UTF-8
 Package: covr
 Title: Test Coverage for Packages
-Version: 3.6.4.9000
+Version: 3.6.4.9001
 Authors@R: c(
     person("Jim", "Hester", email = "[email protected]", role = c("aut", "cre")),
     person("Willem", "Ligtenberg", role = "ctb"),
@@ -68,7 +68,8 @@ Suggests:
     parallel,
     memoise,
     mockery,
-    covr
+    covr,
+    box (>= 1.2.0)
 License: MIT + file LICENSE
 VignetteBuilder: knitr
 RoxygenNote: 7.2.3

NEWS.md

@@ -1,5 +1,7 @@
 # covr (development version)
 
+* Added support for `klmr/box` modules. This works best with `file_coverage()`. (@radbasa, #491)
+
 # covr 3.6.4
 
 * Fix for a failing test on CRAN

R/R6.R

@@ -2,18 +2,22 @@ replacements_R6 <- function(env) {
   unlist(recursive = FALSE, eapply(env, all.names = TRUE,
     function(obj) {
       if (inherits(obj, "R6ClassGenerator")) {
-        unlist(recursive = FALSE, eapply(obj,
-          function(o) {
-            if (inherits(o, "list")) {
-              lapply(names(o),
-                  function(f_name) {
-                  f <- get(f_name, o)
-                  if (inherits(f, "function")) {
-                    replacement(f_name, env = env, target_value = f)
-                  }
-})
+        traverse_R6(obj, env)
       }
     }))
 }
-    }))
+
+traverse_R6 <- function(obj, env) {
+    unlist(recursive = FALSE, eapply(obj,
+       function(o) {
+         if (inherits(o, "list")) {
+           lapply(names(o),
+                  function(f_name) {
+                    f <- get(f_name, o)
+                    if (inherits(f, "function")) {
+                      replacement(f_name, env = env, target_value = f)
+                    }
+                  })
+         }
+       }))
 }

R/box.R

@@ -0,0 +1,32 @@
+replacements_box <- function(env) {
+  unlist(recursive = FALSE, eapply(env, all.names = TRUE,
+      function(obj) {
+        if (inherits(attr(obj, "spec"), "box$mod_spec")) {
+          obj_impl <- attr(obj, "namespace")
+          compact(
+            c(
+              lapply(ls(obj_impl),
+                function(f_name) {
+                  f <- get(f_name, obj_impl)
+                  if (inherits(f, "function")) {
+                    replacement(f_name, env = obj, target_value = f)
+                  }
+                }
+              ),
+              unlist(recursive = FALSE,
+                lapply(ls(obj_impl),
+                  function(f_name) {
+                    f <- get(f_name, obj_impl)
+                    if (inherits(f, "R6ClassGenerator")) {
+                      traverse_R6(f, obj)
+                    }
+                  }
+                )
+              )
+            )
+          )
+        }
+      }
+    )
+  )
+}

R/covr.R

@@ -93,6 +93,7 @@ trace_environment <- function(env) {
       replacements_S4(env),
       replacements_RC(env),
       replacements_R6(env),
+      replacements_box(env),
       lapply(ls(env, all.names = TRUE), replacement, env = env)))
 
   lapply(the$replacements, replace)

tests/testthat/Testbox/app/app.R

@@ -0,0 +1,8 @@
+options(box.path = file.path(getwd()))
+# remove box cache
+loaded_mods <- loadNamespace("box")$loaded_mods
+rm(list = ls(loaded_mods), envir = loaded_mods)
+
+box::use(
+  app/modules/module
+)

tests/testthat/Testbox/app/modules/module.R

@@ -0,0 +1,14 @@
+#' an example function
+#'
+#' @export
+a <- function(x) {
+  if (x <= 1) {
+    1
+  } else {
+    2
+  }
+}
+
+private_function <- function(x) {
+  x ^ 2
+}

tests/testthat/Testbox/tests/testthat.R

@@ -0,0 +1,8 @@
+options(box.path = file.path(getwd()))
+# remove box cache
+loaded_mods <- loadNamespace("box")$loaded_mods
+rm(list = ls(loaded_mods), envir = loaded_mods)
+
+library(testthat)
+
+test_dir("tests/testthat")

tests/testthat/Testbox/tests/testthat/test-module.R

@@ -0,0 +1,23 @@
+box::use(
+  testthat[test_that, expect_equal]
+)
+
+box::use(
+  app/modules/module
+)
+
+impl <- attr(module, "namespace")
+
+test_that("regular function `a` works as expected", {
+  expect_equal(module$a(1), 1)
+  expect_equal(module$a(2), 2)
+  expect_equal(module$a(3), 2)
+  expect_equal(module$a(4), 2)
+  expect_equal(module$a(0), 1)
+})
+
+test_that("private function works as expected", {
+  expect_equal(impl$private_function(2), 4)
+  expect_equal(impl$private_function(3), 9)
+  expect_equal(impl$private_function(4), 16)
+})

tests/testthat/Testbox_R6/app/app.R

@@ -0,0 +1,8 @@
+options(box.path = file.path(getwd()))
+# remove box cache
+loaded_mods <- loadNamespace("box")$loaded_mods
+rm(list = ls(loaded_mods), envir = loaded_mods)
+
+box::use(
+  app/modules/moduleR6
+)

tests/testthat/Testbox_R6/app/modules/moduleR6.R

@@ -0,0 +1,11 @@
+#' @export
+TestR6 <- R6::R6Class("TestR6", # nolint
+                      public = list(
+                        show = function(x) {
+                          1 + 3
+                        },
+                        print2 = function(x) {
+                          1 + 2
+                        }
+                      )
+)

tests/testthat/Testbox_R6/tests/testthat.R

@@ -0,0 +1,8 @@
+options(box.path = file.path(getwd()))
+# remove box cache
+loaded_mods <- loadNamespace("box")$loaded_mods
+rm(list = ls(loaded_mods), envir = loaded_mods)
+
+library(testthat)
+
+test_dir("tests/testthat")

tests/testthat/Testbox_R6/tests/testthat/test-moduleR6.R

@@ -0,0 +1,23 @@
+box::use(
+  testthat[test_that, expect_equal, expect_s3_class]
+)
+
+box::use(
+  app/modules/moduleR6
+)
+
+test_that("TestR6 class can be instantiated", {
+  skip_if(is_r_devel())
+  t1 <- moduleR6$TestR6$new() # nolint
+
+  expect_s3_class(t1, "R6")
+  expect_s3_class(t1, "TestR6")
+  })
+
+test_that("TestR6 Methods can be evaluated", {
+  skip_if(is_r_devel())
+  t1 <- moduleR6$TestR6$new() # nolint
+
+  expect_equal(t1$show(), 4)
+  expect_equal(print(t1$print2()), 3)
+})

tests/testthat/Testbox_attached_modules_functions/app/app.R

@@ -0,0 +1,8 @@
+options(box.path = file.path(getwd()))
+# remove box cache
+loaded_mods <- loadNamespace("box")$loaded_mods
+rm(list = ls(loaded_mods), envir = loaded_mods)
+
+box::use(
+  app/modules/module
+)

tests/testthat/Testbox_attached_modules_functions/app/modules/module.R

@@ -0,0 +1,19 @@
+#' an example function
+#'
+#' @export
+a <- function(x) {
+  if (x <= 1) {
+    1
+  } else {
+    2
+  }
+}
+
+#' @export
+b <- function(x) {
+  return(x * 2)
+}
+
+private_function <- function(x) {
+  x ^ 2
+}

tests/testthat/Testbox_attached_modules_functions/tests/testthat.R

@@ -0,0 +1,8 @@
+options(box.path = file.path(getwd()))
+# remove box cache
+loaded_mods <- loadNamespace("box")$loaded_mods
+rm(list = ls(loaded_mods), envir = loaded_mods)
+
+library(testthat)
+
+test_dir("tests/testthat")

tests/testthat/Testbox_attached_modules_functions/tests/testthat/test-aliased_functions.R

@@ -0,0 +1,15 @@
+box::use(
+  testthat[test_that, expect_equal]
+)
+
+box::use(
+  app/modules/module[x = a]
+)
+
+test_that("attached regular function `a` works as expected", {
+  expect_equal(x(1), 1)
+  expect_equal(x(2), 2)
+  expect_equal(x(3), 2)
+  expect_equal(x(4), 2)
+  expect_equal(x(0), 1)
+})

tests/testthat/Testbox_attached_modules_functions/tests/testthat/test-aliased_modules.R

@@ -0,0 +1,15 @@
+box::use(
+  testthat[test_that, expect_equal]
+)
+
+box::use(
+  x = app/modules/module
+)
+
+test_that("attached regular function `a` works as expected", {
+  expect_equal(x$a(1), 1)
+  expect_equal(x$a(2), 2)
+  expect_equal(x$a(3), 2)
+  expect_equal(x$a(4), 2)
+  expect_equal(x$a(0), 1)
+})

tests/testthat/Testbox_attached_modules_functions/tests/testthat/test-attached_functions.R

@@ -0,0 +1,15 @@
+box::use(
+  testthat[test_that, expect_equal]
+)
+
+box::use(
+  app/modules/module[a]
+)
+
+test_that("attached regular function `a` works as expected", {
+  expect_equal(a(1), 1)
+  expect_equal(a(2), 2)
+  expect_equal(a(3), 2)
+  expect_equal(a(4), 2)
+  expect_equal(a(0), 1)
+})

tests/testthat/Testbox_attached_modules_functions/tests/testthat/test-three_dots.R

@@ -0,0 +1,21 @@
+box::use(
+  testthat[test_that, expect_equal]
+)
+
+box::use(
+  app/modules/module[...]
+)
+
+test_that("attached regular function `a` works as expected", {
+  expect_equal(a(1), 1)
+  expect_equal(a(2), 2)
+  expect_equal(a(3), 2)
+  expect_equal(a(4), 2)
+  expect_equal(a(0), 1)
+})
+
+test_that("attached regular function `b` works as expected", {
+  expect_equal(b(1), 2)
+  expect_equal(b(2), 4)
+  expect_equal(b(3), 6)
+})

tests/testthat/Testbox_attached_modules_functions_R6/app/app.R

@@ -0,0 +1,8 @@
+options(box.path = file.path(getwd()))
+# remove box cache
+loaded_mods <- loadNamespace("box")$loaded_mods
+rm(list = ls(loaded_mods), envir = loaded_mods)
+
+box::use(
+  app/modules/moduleR6
+)

tests/testthat/Testbox_attached_modules_functions_R6/app/modules/moduleR6.R

@@ -0,0 +1,11 @@
+#' @export
+TestR6 <- R6::R6Class("TestR6", # nolint
+                      public = list(
+                        show = function(x) {
+                          1 + 3
+                        },
+                        print2 = function(x) {
+                          1 + 2
+                        }
+                      )
+)

tests/testthat/Testbox_attached_modules_functions_R6/tests/testthat.R

@@ -0,0 +1,8 @@
+options(box.path = file.path(getwd()))
+# remove box cache
+loaded_mods <- loadNamespace("box")$loaded_mods
+rm(list = ls(loaded_mods), envir = loaded_mods)
+
+library(testthat)
+
+test_dir("tests/testthat")

tests/testthat/Testbox_attached_modules_functions_R6/tests/testthat/test-attached_R6.R

@@ -0,0 +1,23 @@
+box::use(
+  testthat[test_that, expect_equal, expect_s3_class]
+)
+
+box::use(
+  app/modules/moduleR6[TestR6]
+)
+
+test_that("TestR6 class can be instantiated", {
+  skip_if(is_r_devel())
+  t1 <- TestR6$new() # nolint
+
+  expect_s3_class(t1, "R6")
+  expect_s3_class(t1, "TestR6")
+})
+
+test_that("TestR6 Methods can be evaluated", {
+  skip_if(is_r_devel())
+  t1 <- TestR6$new() # nolint
+
+  expect_equal(t1$show(), 4)
+  expect_equal(t1$print2(), 3)
+})

tests/testthat/test-box-R6.R

@@ -0,0 +1,21 @@
+context("box-R6")
+
+loaded_mods <- loadNamespace("box")$loaded_mods
+rm(list = ls(loaded_mods), envir = loaded_mods)
+
+test_that("R6 box module coverage is reported", {
+  # Similar to test-R6.R, there is some sort of bug that causes this test
+  # to fail during R CMD check in R-devel, not sure why, and can't reproduce
+  # it interactively
+  skip_if(is_r_devel())
+  withr::with_dir("Testbox_R6", {
+    cov <- as.data.frame(file_coverage(
+        source_files = "app/app.R",
+        test_files = list.files("tests/testthat", full.names = TRUE)))
+
+    expect_equal(cov$value, c(1, 1))
+    expect_equal(cov$first_line, c(5, 8))
+    expect_equal(cov$last_line, c(5, 8))
+    expect_true("show" %in% cov$functions)
+  })
+})