Silence is_intact_attr() signaling when called indirectly

- added new conditional logic to silence
  signaling messages when `is_intact_attr()`
  is called from within another function (indirectly)
- these messages can be confusing to the
  user when they appear in wrapper functions,
  where `is_intact_attr()` is (sometimes deeply) nested
- fixes #71

Makefile

@@ -32,6 +32,7 @@ test:
 	-e "path <- Sys.getenv('R_LIBS_DEV')" \
 	-e "path <- normalizePath(path, winslash = '/', mustWork = TRUE)" \
 	-e ".libPaths(c(path, .libPaths()))" \
+	-e "rm(path)" \
 	-e "message('Dev mode: ON')" \
 	-e "devtools::test(reporter = 'summary', stop_on_failure = TRUE)"
 
@@ -41,6 +42,7 @@ test_file:
 	-e "path <- Sys.getenv('R_LIBS_DEV')" \
 	-e "path <- normalizePath(path, winslash = '/', mustWork = TRUE)" \
 	-e ".libPaths(c(path, .libPaths()))" \
+	-e "rm(path)" \
 	-e "message('Dev mode: ON')" \
 	-e "devtools::load_all()" \
 	-e "testthat::test_file('$(FILE)', reporter = 'summary', stop_on_failure = TRUE)"

R/is-intact-attr.R

@@ -1,7 +1,7 @@
 #' Are Attributes Intact?
 #'
 #' This function runs a series of checks to determine
-#' if a `"soma_adat"` object has a complete
+#' if a `soma_adat` object has a complete
 #' set of attributes. If not, this indicates that the object has
 #' been modified since the initial [read_adat()] call.
 #' Checks for the presence of both "Header.Meta" and "Col.Meta" in the
@@ -14,8 +14,11 @@
 #' }
 #' If any of the above they are altered or missing, `FALSE` is returned.
 #'
-#' @inheritParams read_adat
 #' @param adat A `soma_adat` object to query.
+#' @param verbose Logical. Should diagnostic information about failures
+#'   be printed to the console? If the default, see [interactive()], is invoked,
+#'   only messages via direct calls are triggered. This prohibits messages
+#'   generated deep in the call stack from bubbling up to the user.
 #' @return Logical. `TRUE` if all checks pass, otherwise `FALSE`.
 #' @seealso [attributes()]
 #' @examples
@@ -24,10 +27,15 @@
 #' is_intact_attr(my_adat)           # TRUE
 #' is_intact_attr(my_adat[, -303L])   # doesn't break atts; TRUE
 #' attributes(my_adat)$Col.Meta$Target <- NULL    # break attributes
-#' is_intact_attr(my_adat, verbose = TRUE)  # FALSE (Target missing)
+#' is_intact_attr(my_adat)  # FALSE (Target missing)
 #' @export
 is_intact_attr <- function(adat, verbose = interactive()) {
 
+  if ( missing(verbose) ) {
+    # only enter branch if non-user defined
+    direct <- sys.parent() < 1L
+    verbose <- direct && verbose
+  }
   atts <- attributes(adat)
   col_meta_checks <- c("SeqId", "Dilution", "Target", "Units")
 

tests/testthat/_snaps/is-intact-attr.md

@@ -0,0 +1,39 @@
+# user defined `verbose =` param overrides internal logic as expected
+
+    Code
+      is_intact_attr(iris, verbose = TRUE)
+    Message
+      x The object is not a `soma_adat` class object: 'data.frame'
+    Output
+      [1] FALSE
+
+---
+
+    Code
+      is_intact_attr(iris, verbose = FALSE)
+    Output
+      [1] FALSE
+
+# verbosity is triggered only when called directly
+
+    Code
+      is_intact_attr(iris)
+    Message
+      x The object is not a `soma_adat` class object: 'data.frame'
+    Output
+      [1] FALSE
+
+---
+
+    Code
+      f1(iris)
+    Output
+      [1] FALSE
+
+---
+
+    Code
+      f2(iris)
+    Output
+      [1] FALSE
+

tests/testthat/helper.R

@@ -60,3 +60,19 @@ mock_adat <- function() {
     row_meta = getMeta(data)
   )
 }
+
+# temporarily mask the base::interactive function
+# with new value: lgl
+with_interactive <- function(lgl, code) {
+  old <- base::interactive      # save the old function
+  new <- function() return(lgl) # set new hard-coded return value
+  unlockBinding("interactive", as.environment("package:base"))  # unlock
+  # hack base::interactive with 'new'
+  assign("interactive", new, envir = as.environment('package:base'))
+  on.exit({
+    # undo cleanup when closes
+    unlockBinding("interactive", as.environment("package:base"))
+    assign("interactive", old, envir = as.environment('package:base'))
+  })
+  force(code)   # execute code in new state
+}

tests/testthat/test-is-intact-attr.R

@@ -1,8 +1,9 @@
 
 # generate mock `soma_adat`
 df <- mock_adat()
-withr::local_options(list(usethis.quiet = TRUE))   # silence signalling
 
+# silence signalling for below tests
+withr::local_options(list(usethis.quiet = TRUE))
 
 test_that("TRUE returned when attributes look good", {
   expect_true(is_intact_attr(df))
@@ -13,10 +14,13 @@ test_that("FALSE returned when attributes <= 3 in length", {
   expect_false(is_intact_attr(df, TRUE))
 })
 
-test_that("FALSE returned when Col.Meta or Header.Meta are missing", {
+test_that("FALSE returned when Header.Meta is missing", {
   x <- df
   attributes(x)$Col.Meta <- NULL
   expect_false(is_intact_attr(x, TRUE))
+})
+
+test_that("FALSE returned when Col.Meta is missing", {
   x <- df
   attributes(x)$Header.Meta <- NULL
   expect_false(is_intact_attr(x, TRUE))
@@ -36,3 +40,35 @@ test_that("FALSE when Col.Meta is not a tibble", {
   attr(df, "Col.Meta") <- as.list(attr(df, "Col.Meta"))
   expect_false(is_intact_attr(df, TRUE))
 })
+
+test_that("user defined `verbose =` param overrides internal logic as expected", {
+  withr::local_options(list(usethis.quiet = FALSE))   # allow oops
+  expect_snapshot( is_intact_attr(iris, verbose = TRUE) )
+  expect_snapshot( is_intact_attr(iris, verbose = FALSE) )
+})
+
+test_that("verbosity is triggered only when called directly", {
+  withr::local_options(list(usethis.quiet = FALSE))  # allow oops
+  .env <- parent.frame(sys.nframe())        # env at top of the stack
+  # assign functions for use in local scope below
+  .env$with_interactive <- with_interactive
+  .env$f1 <- function(x) is_intact_attr(x)  # 1 level
+  .env$f2 <- function(x) f1(x)              # 2 levels
+
+  local(envir = .env, {
+    # direct call (signals >> oops)
+    with_interactive(TRUE, expect_snapshot(is_intact_attr(iris)))
+  })
+
+  local(envir = .env, {
+    with_interactive(TRUE, expect_snapshot(f1(iris))) # 1 level away
+  })
+
+  local(envir = .env, {
+    with_interactive(TRUE, expect_snapshot(f2(iris))) # 2 levels away
+  })
+
+  rm(f1, f2, with_interactive, envir = .env)  # clean up leftover functions
+  expect_equal(ls(envir = .env), character(0))  # test successful cleanup
+
+})

tests/testthat/test-with-interactive.R

@@ -0,0 +1,10 @@
+
+test_that("interactive session can be forced ON, but only within temp scope", {
+  with_interactive(TRUE, {
+    expect_true(interactive())
+  })
+  with_interactive(FALSE, {
+    expect_false(interactive())
+  })
+  expect_false(interactive())   # FALSE during testthat
+})