Merge pull request #463 from dgkf/dev/linked_testrefs

Author: jimhester

DESCRIPTION

@@ -1,7 +1,7 @@
 Encoding: UTF-8
 Package: covr
 Title: Test Coverage for Packages
-Version: 3.5.1.9000
+Version: 3.5.1.9001
 Authors@R: c(
     person("Jim", "Hester", email = "[email protected]", role = c("aut", "cre")),
     person("Willem", "Ligtenberg", role = "ctb"),
@@ -25,6 +25,7 @@ Authors@R: c(
     person("Chris", "Campbell", role = "ctb"),
     person("David", "Hugh-Jones", role = "ctb"),
     person("Qin", "Wang", role = "ctb"),
+    person("Doug", "Kelkhoff", role = "ctb"),
     person("Ivan", "Sagalaev", role = c("ctb", "cph"), comment = "highlight.js library"),
     person("Mark", "Otto", role = "ctb", comment = "Bootstrap library"),
     person("Jacob", "Thornton", role = "ctb", comment = "Bootstrap library"),

NAMESPACE

@@ -36,6 +36,7 @@ importFrom(stats,na.pass)
 importFrom(stats,setNames)
 importFrom(utils,capture.output)
 importFrom(utils,getParseData)
+importFrom(utils,getSrcDirectory)
 importFrom(utils,getSrcFilename)
 importFrom(utils,getSrcref)
 importFrom(utils,head)

NEWS.md

@@ -1,5 +1,11 @@
 # covr (development version)
 
+* Added `covr.record_tests` option. When `TRUE`, this enables the recording of
+  the trace of the tests being executed and adds an itemization of which tests
+  result in the exeuction of each trace. For more details see
+  `?covr.record_tests`
+  `?covr.record_tests` (@dgkf, #463)
+
 * `package_coverage()` now sets the environment variable `R_TESTS` to the tests-startup.R file like R CMD check does (#420)
 
 * `codecov()` is now more robust when `coverage` is not the output from `package_coverage()` and `token` is not provided (#456)

R/covr.R

@@ -15,6 +15,66 @@
 #' # If run with no arguments `report()` implicitly calls `package_coverage()`
 #' report()
 #' ```
+#'
+#' @section Package options:
+#'
+#' `covr` uses the following [options()] to configure behaviour:
+#'
+#' \itemize{
+#'   \item `covr.covrignore`: A filename to use as an ignore file,
+#'     listing glob-style wildcarded paths of files to ignore for coverage
+#'     calculations. Defaults to the value of environment variable
+#'     `COVR_COVRIGNORE`, or `".covrignore"`  if the neither the option nor the
+#'     environment variable are set.
+#'
+#'   \item `covr.exclude_end`: Used along with `covr.exclude_start`, an optional
+#'     regular expression which ends a line-exclusion region. For more
+#'     details, see `?exclusions`.
+#'
+#'   \item `covr.exclude_pattern`: An optional line-exclusion pattern. Lines
+#'     which match the pattern will be excluded from coverage. For more details,
+#'     see `?exclusions`.
+#'
+#'   \item `covr.exclude_start`: Used along with `covr.exclude_end`, an optional
+#'     regular expression which starts a line-exclusion region. For more
+#'     details, see `?exclusions`.
+#'
+#'   \item `covr.filter_non_package`: If `TRUE` (the default behavior), coverage
+#'     of files outside the target package are filtered from coverage output.
+#'
+#'   \item `covr.fix_parallel_mcexit`:
+#'
+#'   \item `covr.flags`:
+#'
+#'   \item `covr.gcov`: If the appropriate gcov version is not on your path you
+#'     can use this option to set the appropriate location. If set to "" it will
+#'     turn off coverage of compiled code.
+#'
+#'   \item `covr.gcov_additional_paths`:
+#'
+#'   \item `covr.gcov_args`:
+#'
+#'   \item `covr.icov`:
+#'
+#'   \item `covr.icov_args`:
+#'
+#'   \item `covr.icov_flags`:
+#'
+#'   \item `covr.icov_prof`:
+#'
+#'   \item `covr.rstudio_source_markers`: A logical value. If `TRUE` (the
+#'     default behavior), source markers are displayed within the RStudio IDE
+#'     when using `zero_coverage`.
+#'
+#'   \item `covr.record_tests`: If `TRUE` (default `NULL`), record a listing of
+#'     top level test expressions and associate tests with `covr` traces
+#'     evaluated during the test's execution. For more details, see
+#'     `?covr.record_tests`.
+#'
+#'   \item `covr.showCfunctions`:
+#' }
+#'
+#'
 "_PACKAGE"
 
 #' @import methods
@@ -47,6 +107,26 @@ save_trace <- function(directory) {
   saveRDS(.counters, file = tmp_file)
 }
 
+#' Convert a counters object to a coverage object
+#' 
+#' @param counters An environment of covr trace results to convert to a coverage
+#'   object. If `counters` is not provided, the `covr` namespace value
+#'   `.counters` is used. 
+#' @param ... Additional attributes to include with the coverage object.
+#'
+as_coverage <- function(counters = NULL, ...) {
+  if (missing(counters))
+    counters <- .counters
+
+  counters <- as.list(counters)
+
+  # extract optional tests 
+  tests <- counters$tests
+  counters$tests <- NULL
+
+  structure(counters, tests = tests, ..., class = "coverage")
+}
+
 #' Calculate test coverage for a specific function.
 #'
 #' @param fun name of the function.
@@ -81,7 +161,7 @@ function_coverage <- function(fun, code = NULL, env = NULL, enc = parent.frame()
     eval(code, enc)
   )
 
-  structure(as.list(.counters), class = "coverage")
+  as_coverage(as.list(.counters))
 }
 
 #' Calculate test coverage for sets of files
@@ -121,7 +201,7 @@ file_coverage <- function(
       sys.source, keep.source = TRUE, envir = env)
   )
 
-  coverage <- structure(as.list(.counters), class = "coverage")
+  coverage <- as_coverage(.counters)
 
   exclude(coverage,
     line_exclusions = line_exclusions,
@@ -178,7 +258,7 @@ environment_coverage <- function(
       sys.source, keep.source = TRUE, envir = exec_env)
   )
 
-  coverage <- structure(as.list(.counters), class = "coverage")
+  coverage <- as_coverage(.counters)
 
   exclude(coverage,
     line_exclusions = line_exclusions,
@@ -382,10 +462,11 @@ package_coverage <- function(path = ".",
     res <- run_icov(pkg$path, quiet = quiet)
   }
 
-  coverage <- structure(c(coverage, res),
-      class = "coverage",
-      package = pkg,
-      relative = relative_path)
+  coverage <- as_coverage(
+    c(coverage, res),
+    package = pkg,
+    relative = relative_path
+  )
 
   if (!clean) {
     attr(coverage, "library") <- install_path
@@ -454,29 +535,46 @@ show_failures <- function(dir) {
 # merge multiple coverage files together. Assumes the order of coverage lines
 # is the same in each object, this should always be the case if the objects are
 # from the same initial library.
-merge_coverage <- function(files) {
-  nfiles <- length(files)
-  if (nfiles == 0) {
-    return()
-  }
+merge_coverage <- function(x) {
+  UseMethod("merge_coverage")
+}
 
-  x <- suppressWarnings(readRDS(files[1]))
-  x <- as.list(x)
-  if (nfiles == 1) {
-    return(x)
+merge_coverage.character <- function(files) {
+  coverage_objs <- lapply(files, function(f) {
+    as.list(suppressWarnings(readRDS(f)))
+  })
+  merge_coverage(coverage_objs)
+}
+
+merge_coverage.list <- function(coverage_objs) {
+  if (length(coverage_objs) == 0) {
+    return()
   }
 
+  x <- coverage_objs[[1]]
   names <- names(x)
-  for (i in 2:nfiles) {
-    y <- suppressWarnings(readRDS(files[i]))
+
+  for (y in tail(coverage_objs, -1L)) {
+    # align tests from coverage objects
+    test_idx <- match(names(y$tests), Filter(nchar, names(x$tests)))
+    new_test_idx <- if (!length(test_idx)) seq_along(y$tests) else which(is.na(test_idx))
+    test_idx[new_test_idx] <- length(x$tests) + seq_along(new_test_idx)
+
+    # append any tests that we haven't encountered in previous objects
+    x$tests <- append(x$tests, y$tests[new_test_idx])
+    y$tests <- NULL
+
     for (name in intersect(names, names(y))) {
       x[[name]]$value <- x[[name]]$value + y[[name]]$value
+      y[[name]]$tests[,1] <- test_idx[y[[name]]$tests[,1]]
+      x[[name]]$tests <- rbind(x[[name]]$tests, y[[name]]$tests)
     }
+
     for (name in setdiff(names(y), names)) {
       x[[name]] <- y[[name]]
     }
+
     names <- union(names, names(y))
-    y <- NULL
   }
 
   x
@@ -550,13 +648,16 @@ run_commands <- function(pkg, lib, commands) {
 # @param pkg_name name of the package to add hooks to
 # @param lib the library path to look in
 # @param fix_mcexit whether to add the fix for mcparallel:::mcexit
-add_hooks <- function(pkg_name, lib, fix_mcexit = FALSE) {
+add_hooks <- function(pkg_name, lib, fix_mcexit = FALSE,
+  record_tests = isTRUE(getOption("covr.record_tests", FALSE))) {
+
   trace_dir <- paste0("Sys.getenv(\"COVERAGE_DIR\", \"", lib, "\")")
 
   load_script <- file.path(lib, pkg_name, "R", pkg_name)
   lines <- readLines(file.path(lib, pkg_name, "R", pkg_name))
   lines <- append(lines,
-    c("setHook(packageEvent(pkg, \"onLoad\"), function(...) covr:::trace_environment(ns))",
+    c(paste0("setHook(packageEvent(pkg, \"onLoad\"), function(...) options(covr.record_tests = ", record_tests, "))"),
+      "setHook(packageEvent(pkg, \"onLoad\"), function(...) covr:::trace_environment(ns))",
       paste0("reg.finalizer(ns, function(...) { covr:::save_trace(", trace_dir, ") }, onexit = TRUE)")),
     length(lines) - 1L)
 

R/trace_calls.R

@@ -101,6 +101,7 @@ trace_calls <- function (x, parent_functions = NULL, parent_ref = NULL) {
 }
 
 .counters <- new.env(parent = emptyenv())
+.current_test <- new.env(parent = emptyenv())
 
 #' initialize a new counter
 #'
@@ -112,6 +113,14 @@ new_counter <- function(src_ref, parent_functions) {
   .counters[[key]]$value <- 0
   .counters[[key]]$srcref <- src_ref
   .counters[[key]]$functions <- parent_functions
+
+  if (isTRUE(getOption("covr.record_tests", FALSE))) {
+    .counters[[key]]$tests <- matrix(
+      numeric(0L),
+      ncol = 2,
+      dimnames = list(c(), c("test", "depth")))
+  }
+
   key
 }
 
@@ -120,14 +129,16 @@ new_counter <- function(src_ref, parent_functions) {
 #' @param key generated with [key()]
 #' @keywords internal
 count <- function(key) {
-  .counters[[key]]$value <- .counters[[key]]$value + 1
+  .counters[[key]]$value <- .counters[[key]]$value + 1L
+  if (isTRUE(getOption("covr.record_tests"))) count_test(key)
 }
 
 #' clear all previous counters
 #'
 #' @keywords internal
 clear_counters <- function() {
   rm(envir = .counters, list = ls(envir = .counters))
+  rm(envir = .current_test, list = ls(envir = .current_test))
 }
 
 #' Generate a key for a  call