Added ability to specify additional functions considered as assertions

R/coverage.R

@@ -7,13 +7,16 @@ logger::log_formatter(logger::formatter_sprintf, namespace = "slicingCoverage")
 #' @param test_files Character vector of test files with code to test the functions
 #' @param line_exclusions Currently unsupported
 #' @param function_exclusions Currently unsupported
+#' @param additional_functions Character vector of regular expressions that match
+#' functions that should additionally be considered as assertions
 #'
 #' @export
 file_coverage <- function(
     source_files,
     test_files,
     line_exclusions = NULL,
-    function_exclusions = NULL) {
+    function_exclusions = NULL,
+    additional_functions = c()) {
   stopifnot(missing(line_exclusions), missing(function_exclusions))
 
   logger::log_trace("Tracing coverage", namespace = "slicingCoverage")
@@ -22,22 +25,24 @@ file_coverage <- function(
     test_files = test_files,
   ))
 
-  return(give_me_covr_and_i_do_the_rest(covr_measure, source_files, test_files))
+  return(give_me_covr_and_i_do_the_rest(covr_measure, source_files, test_files, additional_functions))
 }
 
 #' Calculate slicing coverage for a package
 #'
 #' @param path Path to the package
+#' @param additional_functions Character vector of regular expressions that match
+#' functions that should additionally be considered as assertions
 #'
 #' @export
-package_coverage <- function(path = ".") {
+package_coverage <- function(path = ".", additional_functions = c()) {
   sources <- get_pkg_source_files(path)
   tests <- get_pkg_test_files(path)
 
   logger::log_trace("Tracing coverage", namespace = "slicingCoverage")
   covr_measure <- measure(covr::package_coverage(path = path))
 
-  return(give_me_covr_and_i_do_the_rest(covr_measure, sources$files, tests$files))
+  return(give_me_covr_and_i_do_the_rest(covr_measure, sources$files, tests$files, additional_functions))
 }
 
 #' Calculate the maximum possible slicing coverage with the current assertions.

R/flowr_utils.R

@@ -77,8 +77,8 @@ analysis_info_funs <- make_analysis_info_funs()
 init_analysis <- analysis_info_funs$init_analysis
 get_filetoken <- analysis_info_funs$get_filetoken
 
-retrieve_slice <- function(file_filter = NULL) {
-  slicing_points_measure <- measure(gather_slicing_points(file_filter))
+retrieve_slice <- function(file_filter = NULL, additional_functions = c()) {
+  slicing_points_measure <- measure(gather_slicing_points(file_filter, additional_functions))
   query_time <- slicing_points_measure$elapsed_time
   slicing_points <- slicing_points_measure$result
   criteria <- slicing_points$criteria
@@ -127,7 +127,7 @@ retrieve_slice <- function(file_filter = NULL) {
   ))
 }
 
-get_check_function_ids <- function(file_filter = NULL) {
+get_check_function_ids <- function(file_filter = NULL, additional_functions = c()) {
   if (!is.null(file_filter)) {
     logger::log_debug("Only searching for assertions in %s", file_filter, namespace = "slicingCoverage")
   }
@@ -144,7 +144,7 @@ get_check_function_ids <- function(file_filter = NULL) {
           includeUndefinedFiles = TRUE
         ))
       }),
-      arguments = get_all_groups() |> combine_groups()
+      arguments = get_all_groups() |> combine_groups() |> with_user_functions(additional_functions)
     ))
 
     res <- flowr::request_query(con, get_filetoken(), query) |> verify_flowr_response()
@@ -159,9 +159,9 @@ get_check_function_ids <- function(file_filter = NULL) {
   })
 }
 
-gather_slicing_points <- function(file_filter = NULL) {
+gather_slicing_points <- function(file_filter = NULL, additional_functions = c()) {
   logger::log_trace("Searching for slicing points", namespace = "slicingCoverage")
-  check_function_ids <- get_check_function_ids(file_filter)
+  check_function_ids <- get_check_function_ids(file_filter, additional_functions)
   logger::log_debug("Found %d slicing points", length(check_function_ids), namespace = "slicingCoverage")
   criteria <- lapply(check_function_ids, function(id) sprintf("$%s", id))
   return(list(

R/queries.R

@@ -22,6 +22,11 @@ combine_groups <- function(names) {
   return(groups |> lapply(normalize_group) |> unlist(recursive = FALSE))
 }
 
+with_user_functions <- function(query, regexes) {
+  q <- lapply(regexes, function(r) list(callName = r, kind = "user", includeAliases = TRUE))
+  return(c(query, q))
+}
+
 get_all_groups <- function() {
   return(list.files(system.file("queries", package = "slicingCoverage")))
 }

R/utils.R

@@ -249,14 +249,14 @@ get_coverered_and_sliced_srcrefs <- function(slc_coverage) { # nolint: object_le
   ))
 }
 
-give_me_covr_and_i_do_the_rest <- function(covr_measure, sources, tests) { # nolint: object_length_linter, line_length_linter.
+give_me_covr_and_i_do_the_rest <- function(covr_measure, sources, tests, additional_functions = c()) { # nolint: object_length_linter, line_length_linter.
   covr_time <- covr_measure$elapsed_time
   covr <- covr_measure$result
 
   ana_time <- measure(init_analysis(c(sources, tests)), only_time = TRUE)
 
   filter <- sprintf("(%s)", paste(stringr::str_escape(tests), collapse = "|"))
-  slicing_measure <- retrieve_slice(filter)
+  slicing_measure <- retrieve_slice(filter, additional_functions)
   slicing_points <- slicing_measure$slicing_points
   slicing_time <- slicing_measure$slicing_time
   query_time <- slicing_measure$query_time

tests/testthat/test-coverage.R

@@ -301,6 +301,33 @@ test_that("We can find all assertions", {
   }
 })
 
+test_that("We can find all user defined assertions", {
+  file <- file_with_content("")
+  test <- file_with_content("
+    my_assertion <- function(a,b) {}
+    my_assertion(1 + 2, 3)
+  ")
+
+  slicing_points <- file_coverage(file, test, additional_functions =  c("^my_assertion$"))$slicing_points
+  expect_length(slicing_points, 1)
+
+  test <- file_with_content("
+    disguised_assertion <- function(a,b) {}
+    my_cool_assertion <- function(a,b) {}
+    my_uncool_assertion <- function(a,b) {}
+
+    disguised_assertion(1 + 2, 3)
+
+    my_cool_assertion(1 + 2, 3)
+    my_uncool_assertion(1 + 2, 3)
+  ")
+
+  slicing_points <- file_coverage(file, test,
+    additional_functions = c("^disguised_assertion$", "^my_(un)?cool_assertion$")
+  )$slicing_points
+  expect_length(slicing_points, 3)
+})
+
 test_that("code that's called by eval or do.call is not in the slice", {
   file <- file_with_content("
     do_the_add <- function(a,b) a+b