is_what(): suppress error messages and warnings

R/analyse.R

@@ -54,9 +54,7 @@ type_info <- function(x, as_character = FALSE)
     class = class_x, 
     length = length(x),
     text = shorten(paste0("[", seq_along(text), "]", text, collapse = "")),
-    is = if (length(x) == 1L) {
-      suppressWarnings(is_what(x, silent = TRUE))
-    },
+    is = if (length(x) == 1L) is_what(x),
     n_modes = length(mode_x),
     n_classes = length(class_x)
   )

R/utils.R

@@ -41,6 +41,12 @@ get_function_names_matching <- function(pattern = NULL, package = "base")
   grep(pattern, function_names, value = TRUE)
 }
 
+# get_is_function_names --------------------------------------------------------
+get_is_function_names <- function()
+{
+  get_function_names_matching("^is\\.")
+}
+
 # is_what ----------------------------------------------------------------------
 is_what <- function(
   x, 
@@ -59,14 +65,13 @@ is_what <- function(
     # "is.na",
     # "is.na.data.frame" # returns a matrix
   ),
-  silent = FALSE
+  dbg = FALSE
 )
 {
   #  stopifnot(length(x) == 1L)
 
   # Get names of is.* functions within the base package
-  pattern <- "^is\\."
-  is_functions <- get_function_names_matching(pattern)
+  is_functions <- get_is_function_names()
 
   # Which functions are not applicable, i.e. have not exactly one argument "x"
   is_applicable <- sapply(lapply(is_functions, arg_names), identical, "x")
@@ -78,18 +83,25 @@ is_what <- function(
   # Call all remaining is.* functions to x
   is_results <- sapply(is_functions, function(f) {
 
-    result <- try(do.call(f, list(x), quote = TRUE), silent = silent)
+    suppressWarnings(
+      result <- try(
+        expr = do.call(f, list(x), quote = TRUE), 
+        silent = TRUE
+      )
+    )
 
     cat_error <- function(what) {
-      cat_formatted("%s(x) returned %s. Returning FALSE.\n", f, what)
-    } 
+      if (dbg) {
+        cat_formatted("%s(x) returned %s. Returning FALSE.\n", f, what)
+      }
+    }
 
-    if (inherits(result, "try-error")) {
+    if (kwb.utils::isTryError(result)) {
       cat_error("an error")
       return(FALSE)
     }
 
-    if (!isTRUE(result) && !isFALSE(result)) {
+    if (!identical(result, TRUE) && !identical(result, FALSE)) {
       cat_error("neither TRUE nor FALSE")
       return(FALSE)
     }
@@ -98,7 +110,7 @@ is_what <- function(
   })
 
   # Return the names (without "is.") of functions that returned TRUE  
-  gsub(pattern, "", names(which(is_results)))
+  gsub("^is\\.", "", names(which(is_results)))
 }
 
 # remove_first_and_last_slash --------------------------------------------------

tests/testthat/test-function-get_elements_by_type.R

@@ -8,7 +8,7 @@ test_that("get_elements_by_type() works", {
 
   x <- parse(text = "square <- function(x) x * x")
 
-  expect_output(result <- f(x))
+  result <- f(x)
 
   expect_type(result, "list")
   expect_true("language|call|<-|3|" %in% names(result))

tests/testthat/test-function-is_what.R

@@ -1,17 +1,17 @@
 test_that("is_what() works", {
-
-  f <- function(...) {
-    capture.output(result <- kwb.code:::is_what(..., silent = TRUE))
-    result
-  }
+
+  f <- kwb.code:::is_what
 
   check <- function(x) {
-    result <- f(x)
-    expect_true(all(
-      sapply(paste0("is.", result), function(name) do.call(name, list(x)))
-    ))
+    result_1 <- f(x, dbg = FALSE)
+    expect_output(result_2 <- f(x, dbg = TRUE))
+    expect_identical(result_1, result_2)
+    expect_true(all(sapply(
+      X = paste0("is.", result_1), 
+      FUN = function(name) do.call(name, list(x))
+    )))
   }
-  
+
   check(1L)
   check(1)
   check("a")