-
Notifications
You must be signed in to change notification settings - Fork 115
/
covr.R
586 lines (504 loc) · 18.8 KB
/
covr.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
#' covr: Test coverage for packages
#'
#' covr tracks and reports code coverage for your package and (optionally)
#' upload the results to a coverage service like 'Codecov' <https://codecov.io> or
#' 'Coveralls' <https://coveralls.io>. Code coverage is a measure of the amount of
#' code being exercised by a set of tests. It is an indirect measure of test
#' quality and completeness. This package is compatible with any testing
#' methodology or framework and tracks coverage of both R code and compiled
#' C/C++/FORTRAN code.
#'
#' A coverage report can be used to inspect coverage for each line in your
#' package. Using `report()` requires the additional dependencies `DT` and `htmltools`.
#'
#' ```r
#' # If run with no arguments `report()` implicitly calls `package_coverage()`
#' report()
#' ```
"_PACKAGE"
#' @import methods
#' @importFrom stats aggregate na.omit na.pass setNames
#' @importFrom utils capture.output getSrcFilename relist str head
NULL
the <- new.env(parent = emptyenv())
the$replacements <- list()
trace_environment <- function(env) {
clear_counters()
the$replacements <- compact(c(
replacements_S4(env),
replacements_RC(env),
replacements_R6(env),
lapply(ls(env, all.names = TRUE), replacement, env = env)))
lapply(the$replacements, replace)
}
reset_traces <- function() {
lapply(the$replacements, reset)
}
save_trace <- function(directory) {
tmp_file <- temp_file("covr_trace_", tmpdir = directory)
saveRDS(.counters, file = tmp_file)
}
#' Calculate test coverage for a specific function.
#'
#' @param fun name of the function.
#' @param code expressions to run.
#' @param env environment the function is defined in.
#' @param enc the enclosing environment which to run the expressions.
#' @export
function_coverage <- function(fun, code = NULL, env = NULL, enc = parent.frame()) {
if (is.function(fun)) {
env <- environment(fun)
# get name of function, stripping preceding blah:: if needed
fun <- rex::re_substitutes(deparse(substitute(fun)), rex::regex(".*:::?"), "")
}
clear_counters()
replacement <- if (!is.null(env)) {
replacement(fun, env)
} else {
replacement(fun)
}
on.exit({
reset(replacement)
clear_counters()
})
replace(replacement)
withr::with_envvar(c("R_COVR" = "true"),
eval(code, enc)
)
structure(as.list(.counters), class = "coverage")
}
#' Calculate test coverage for sets of files
#'
#' The files in `source_files` are first sourced into a new environment
#' to define functions to be checked. Then they are instrumented to track
#' coverage and the files in `test_files` are sourced.
#' @param source_files Character vector of source files with function
#' definitions to measure coverage
#' @param test_files Character vector of test files with code to test the
#' functions
#' @param parent_env The parent environment to use when sourcing the files.
#' @inheritParams package_coverage
#' @export
file_coverage <- function(
source_files,
test_files,
line_exclusions = NULL,
function_exclusions = NULL,
parent_env = parent.frame()) {
env <- new.env(parent = parent_env)
withr::with_options(c("keep.parse.data.pkgs" = TRUE), {
lapply(source_files,
sys.source, keep.source = TRUE, envir = env)
})
trace_environment(env)
on.exit({
reset_traces()
clear_counters()
})
withr::with_envvar(c("R_COVR" = "true"),
lapply(test_files,
sys.source, keep.source = TRUE, envir = env)
)
coverage <- structure(as.list(.counters), class = "coverage")
exclude(coverage,
line_exclusions = line_exclusions,
function_exclusions = function_exclusions,
path = NULL)
}
#' Calculate coverage of code directly
#'
#' This function is useful for testing, and is a thin wrapper around
#' [file_coverage()] because parseData is not populated properly
#' unless the functions are defined in a file.
#' @param source_code A character vector of source code
#' @param test_code A character vector of test code
#' @inheritParams file_coverage
#' @param ... Additional arguments passed to [file_coverage()]
#' @export
code_coverage <- function(
source_code,
test_code,
line_exclusions = NULL,
function_exclusions = NULL,
...) {
src <- tempfile("source.R")
test <- tempfile("test.R")
on.exit(file.remove(src, test))
cat(source_code, file = src)
cat(test_code, file = test)
file_coverage(src, test, line_exclusions = line_exclusions,
function_exclusions = function_exclusions, ...)
}
#' Calculate coverage of an environment
#'
#' @param env The environment to be instrumented.
#' @inheritParams file_coverage
#' @export
environment_coverage <- function(
env = parent.frame(),
test_files,
line_exclusions = NULL,
function_exclusions = NULL) {
exec_env <- new.env(parent = env)
trace_environment(env)
on.exit({
reset_traces()
clear_counters()
})
withr::with_envvar(c("R_COVR" = "true"),
lapply(test_files,
sys.source, keep.source = TRUE, envir = exec_env)
)
coverage <- structure(as.list(.counters), class = "coverage")
exclude(coverage,
line_exclusions = line_exclusions,
function_exclusions = function_exclusions,
path = NULL)
}
#' Calculate test coverage for a package
#'
#' This function calculates the test coverage for a development package on the
#' `path`. By default it runs only the package tests, but it can also run
#' vignette and example code.
#'
#' @details
#' This function uses [tools::testInstalledPackage()] to run the
#' code, if you would like to test your package in another way you can set
#' `type = "none"` and pass the code to run as a character vector to the
#' `code` parameter.
#'
#' #ifdef unix
#' Parallelized code using \pkg{parallel}'s [mcparallel()] needs to
#' use a patched `parallel:::mcexit`. This is done automatically if the
#' package depends on \pkg{parallel}, but can also be explicitly set using the
#' environment variable `COVR_FIX_PARALLEL_MCEXIT` or the global option
#' `covr.fix_parallel_mcexit`.
#' #endif
#'
#' @param path file path to the package.
#' @param type run the package \sQuote{tests}, \sQuote{vignettes},
#' \sQuote{examples}, \sQuote{all}, or \sQuote{none}. The default is
#' \sQuote{tests}.
#' @param combine_types If `TRUE` (the default) the coverage for all types
#' is simply summed into one coverage object. If `FALSE` separate objects
#' are used for each type of coverage.
#' @param relative_path whether to output the paths as relative or absolute
#' paths.
#' @param quiet whether to load and compile the package quietly, useful for
#' debugging errors.
#' @param clean whether to clean temporary output files after running, mainly
#' useful for debugging errors.
#' @param line_exclusions a named list of files with the lines to exclude from
#' each file.
#' @param function_exclusions a vector of regular expressions matching function
#' names to exclude. Example `print\\\.` to match print methods.
#' @param code A character vector of additional test code to run.
#' @param ... Additional arguments passed to [tools::testInstalledPackage()].
#' @param exclusions \sQuote{Deprecated}, please use \sQuote{line_exclusions} instead.
#' @param pre_clean whether to delete all objects present in the src directory before recompiling
#' @param install_path The path the instrumented package will be installed to
#' and tests run in. By default it is a path in the R sessions temporary
#' directory. It can sometimes be useful to set this (along with `clean =
#' FALSE`) to help debug test failures.
#' @seealso [exclusions()] For details on excluding parts of the
#' package from the coverage calculations.
#' @export
package_coverage <- function(path = ".",
type = c("tests", "vignettes", "examples", "all", "none"),
combine_types = TRUE,
relative_path = TRUE,
quiet = TRUE,
clean = TRUE,
line_exclusions = NULL,
function_exclusions = NULL,
code = character(),
install_path = temp_file("R_LIBS"),
...,
exclusions, pre_clean=TRUE) {
if (!missing(exclusions)) {
warning(paste0("`exclusions` is deprecated and will be removed in an upcoming
release. ", "Please use `line_exclusions` instead."), call. = FALSE,
domain = NA)
line_exclusions <- exclusions
}
pkg <- as_package(path)
if (missing(type)) {
type <- "tests"
}
type <- parse_type(type)
run_separately <- !isTRUE(combine_types) && length(type) > 1
if (run_separately) {
# store the args that were called
called_args <- as.list(match.call())[-1]
# remove the type
called_args$type <- NULL
res <- list()
for (t in type) {
res[[t]] <- do.call(Recall, c(called_args, type = t))
attr(res[[t]], "type") <- t
}
attr(res, "package") <- pkg
class(res) <- "coverages"
return(res)
}
dir.create(install_path)
flags <- getOption("covr.flags")
# check for compiler
if (!uses_icc()) {
flags <- getOption("covr.flags")
}
else {
if (length(getOption("covr.icov")) > 0L) {
flags <- getOption("covr.icov_flags")
# clean up old icov files
unlink(file.path(pkg$path, "src","*.dyn"))
unlink(file.path(pkg$path, "src","pgopti.*"))
} else {
stop("icc is not available")
}
}
if (isTRUE(clean)) {
on.exit({
clean_objects(pkg$path)
clean_gcov(pkg$path)
clean_parse_data()
unlink(install_path, recursive = TRUE)
}, add = TRUE)
}
# clean any dlls prior to trying to install
if (isTRUE(pre_clean)) clean_objects(pkg$path)
# install the package in a temporary directory
withr::with_makevars(flags, assignment = "+=",
utils::install.packages(repos = NULL,
lib = install_path,
pkg$path,
type = "source",
INSTALL_opts = c("--example",
"--install-tests",
"--with-keep.source",
"--with-keep.parse.data",
"--no-staged-install",
"--no-multiarch"),
quiet = quiet))
# add hooks to the package startup
add_hooks(pkg$package, install_path,
fix_mcexit = should_enable_parallel_mcexit_fix(pkg))
libs <- env_path(install_path, .libPaths())
withr::with_envvar(
c(R_DEFAULT_PACKAGES = "datasets,utils,grDevices,graphics,stats,methods",
R_LIBS = libs,
R_LIBS_USER = libs,
R_LIBS_SITE = libs,
R_COVR = "true"), {
withCallingHandlers({
if ("vignettes" %in% type) {
type <- type[type != "vignettes"]
run_vignettes(pkg, install_path)
}
out_dir <- file.path(install_path, pkg$package)
if ("examples" %in% type) {
type <- type[type != "examples"]
# testInstalledPackage explicitly sets R_LIBS="" on windows, and does
# not restore it after, so we need to reset it ourselves.
withr::with_envvar(c(R_LIBS = Sys.getenv("R_LIBS")), {
result <- tools::testInstalledPackage(pkg$package, outDir = out_dir, types = "examples", lib.loc = install_path, ...)
if (result != 0L) {
show_failures(out_dir)
}
})
}
if ("tests" %in% type) {
result <- tools::testInstalledPackage(pkg$package, outDir = out_dir, types = "tests", lib.loc = install_path, ...)
if (result != 0L) {
show_failures(out_dir)
}
}
# We always run the commands file (even if empty) to load the package and
# initialize all the counters to 0.
run_commands(pkg, install_path, code)
},
message = function(e) if (quiet) invokeRestart("muffleMessage") else e,
warning = function(e) if (quiet) invokeRestart("muffleWarning") else e)
})
# read tracing files
trace_files <- list.files(path = install_path, pattern = "^covr_trace_[^/]+$", full.names = TRUE)
coverage <- merge_coverage(trace_files)
if (!uses_icc()) {
res <- run_gcov(pkg$path, quiet = quiet, clean = clean)
} else {
res <- run_icov(pkg$path, quiet = quiet)
}
coverage <- structure(c(coverage, res),
class = "coverage",
package = pkg,
relative = relative_path)
if (!clean) {
attr(coverage, "library") <- install_path
}
if (getOption("covr.filter_non_package", TRUE)) {
coverage <- filter_non_package_files(coverage)
}
# Exclude generated files from Rcpp and cpp11 to avoid redundant coverage information
line_exclusions <- c(
"src/RcppExports.cpp",
"R/RcppExports.R",
"src/cpp11.cpp",
"R/cpp11.R",
line_exclusions,
parse_covr_ignore()
)
exclude(coverage,
line_exclusions = line_exclusions,
function_exclusions = function_exclusions,
path = if (isTRUE(relative_path)) pkg$path else NULL)
}
#' Convert a coverage dataset to a list
#'
#' @param x a coverage dataset, defaults to running `package_coverage()`.
#' @return A list containing coverage result for each individual file and the whole package
#' @export
coverage_to_list <- function(x = package_coverage()){
covr_df <- tally_coverage(x)
file_result <- tapply(covr_df$value, covr_df$filename,
FUN = function(x) round(sum(x > 0) / length(x) * 100, digits = 2))
total_result <- round(sum(covr_df$value > 0) / nrow(covr_df) * 100, digits = 2)
return(list(filecoverage = file_result, totalcoverage = total_result))
}
show_failures <- function(dir) {
fail_files <- list.files(dir, pattern = "fail$", recursive = TRUE, full.names = TRUE)
for (file in fail_files) {
lines <- readLines(file)
# Skip header lines (until first >)
lines <- lines[seq(which.min(grepl("^>", lines)), length(lines))]
# R will only show options("warning.length") number of characters in an
# error, so show the last characters of that number
error_header <- paste0("Failure in `", file, "`\n")
# 9 is the length of `Error: ` + newline + NUL maybe?
error_length <- getOption("warning.length") - 9
error_body <- paste(lines, collapse = "\n")
header_len <- nchar(error_header, "bytes")
body_len <- nchar(error_body, "bytes")
error_body <- substr(error_body, body_len - (error_length - header_len), body_len)
cnd <- structure(list(message = paste0(error_header, error_body)), class = c("covr_error", "error", "condition"))
stop(cnd)
}
}
# 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()
}
x <- suppressWarnings(readRDS(files[1]))
x <- as.list(x)
if (nfiles == 1) {
return(x)
}
names <- names(x)
for (i in 2:nfiles) {
y <- suppressWarnings(readRDS(files[i]))
for (name in intersect(names, names(y))) {
x[[name]]$value <- x[[name]]$value + y[[name]]$value
}
for (name in setdiff(names(y), names)) {
x[[name]] <- y[[name]]
}
names <- union(names, names(y))
y <- NULL
}
x
}
parse_type <- function(type) {
type <- match_arg(type, choices = c("tests", "vignettes", "examples", "all", "none"), several.ok = TRUE)
if (type %==% "all") {
type <- c("tests", "vignettes", "examples")
}
if (length(type) > 1L) {
if ("all" %in% type) {
stop(sQuote("all"), " must be the only type specified", call. = FALSE)
}
if ("none" %in% type) {
stop(sQuote("none"), " must be the only type specified", call. = FALSE)
}
}
type
}
# Run vignettes for a package. This is done in a new process as otherwise the
# finalizer is not called to dump the results. The namespace is first
# explicitly loaded to ensure output even if no vignettes exist.
# @param pkg Package object (from as_package) to run
# @param lib the library path to look in
run_vignettes <- function(pkg, lib) {
outfile <- file.path(lib, paste0(pkg$package, "-Vignette.Rout"))
failfile <- paste(outfile, "fail", sep = "." )
cat("tools::buildVignettes(dir = '", pkg$path, "')\n", file = outfile, sep = "")
cmd <- paste(shQuote(file.path(R.home("bin"), "R")),
"CMD BATCH --vanilla --no-timing",
shQuote(outfile), shQuote(failfile))
res <- system(cmd)
if (res != 0) {
show_failures(dirname(failfile))
} else {
file.rename(failfile, outfile)
}
}
run_commands <- function(pkg, lib, commands) {
outfile <- file.path(lib, paste0(pkg$package, "-commands.Rout"))
failfile <- paste(outfile, "fail", sep = "." )
cat(
"library('", pkg$package, "')\n",
commands, "\n", file = outfile, sep = "")
cmd <- paste(shQuote(file.path(R.home("bin"), "R")),
"CMD BATCH --vanilla --no-timing",
shQuote(outfile), shQuote(failfile))
res <- system(cmd)
if (res != 0L) {
show_failures(dirname(failfile))
} else {
file.rename(failfile, outfile)
}
}
# Add hooks to the installed package
# Installed packages have lazy loading code to setup the lazy load database at
# pkg_name/R/pkg_name. This function adds a user level onLoad Hook to the
# package which calls `covr::trace_environment`, so the package environment is
# traced when the package is loaded.
# It also adds a finalizer that saves the tracing information to the package
# namespace environment which is run when the ns is garbage collected or the
# process ends. This ensures the tracing count information will be written
# regardless of how the process terminates.
# @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) {
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))",
paste0("reg.finalizer(ns, function(...) { covr:::save_trace(", trace_dir, ") }, onexit = TRUE)")),
length(lines) - 1L)
if (fix_mcexit) {
lines <- append(lines, sprintf("covr:::fix_mcexit('%s')", trace_dir))
}
writeLines(text = lines, con = load_script)
}
#' @export
`[.coverage` <- function(x, ...) {
structure(NextMethod(), class = "coverage")
}
#' Determine if code is being run in covr
#'
#' covr functions set the environment variable `R_COVR` when they are running.
#' [in_covr()] returns `TRUE` if this environment variable is set and `FALSE`
#' otherwise.
#' @export
#' @examples
#' if (require(testthat)) {
#' testthat::skip_if(in_covr())
#' }
in_covr <- function() {
identical(Sys.getenv("R_COVR"), "true")
}