├── tests ├── testthat │ ├── a │ ├── b │ ├── TestUseTry │ │ ├── tests │ │ │ ├── tests.R │ │ │ └── testthat │ │ │ │ └── test-notry.R │ │ ├── NAMESPACE │ │ ├── R │ │ │ └── notry.R │ │ └── DESCRIPTION │ ├── TestCompiledSubdir │ │ ├── src │ │ │ ├── Makevars │ │ │ └── lib │ │ │ │ └── simple.c │ │ ├── NAMESPACE │ │ ├── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ │ └── test-TestCompiledSubdir.R │ │ ├── R │ │ │ └── TestCompiledSubdir.R │ │ ├── man │ │ │ └── simple.Rd │ │ └── DESCRIPTION │ ├── TestR6 │ │ ├── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ │ └── test-TestR6.R │ │ ├── NAMESPACE │ │ ├── man │ │ │ └── a.Rd │ │ ├── DESCRIPTION │ │ └── R │ │ │ └── TestR6.R │ ├── TestRC │ │ ├── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ │ └── test-TestRC.R │ │ ├── NAMESPACE │ │ ├── man │ │ │ └── a.Rd │ │ ├── DESCRIPTION │ │ └── R │ │ │ └── TestRC.R │ ├── TestPrint │ │ ├── NAMESPACE │ │ ├── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ │ └── test-TestSummary.R │ │ ├── R │ │ │ └── TestPrint.R │ │ ├── man │ │ │ └── test_me.Rd │ │ └── DESCRIPTION │ ├── TestS4 │ │ ├── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ │ └── test-TestS4.R │ │ ├── NAMESPACE │ │ ├── man │ │ │ └── a.Rd │ │ ├── DESCRIPTION │ │ └── R │ │ │ └── TestS4.R │ ├── TestCompiled │ │ ├── NAMESPACE │ │ ├── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ │ └── test-TestCompiled.R │ │ ├── R │ │ │ └── TestCompiled.R │ │ ├── man │ │ │ └── simple.Rd │ │ ├── DESCRIPTION │ │ └── src │ │ │ ├── simple-header.h │ │ │ └── simple.c │ ├── TestSummary │ │ ├── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ │ └── test-TestSummary.R │ │ ├── NAMESPACE │ │ ├── R │ │ │ └── TestSummary.R │ │ ├── man │ │ │ └── test_me.Rd │ │ └── DESCRIPTION │ ├── TestExclusion │ │ ├── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ │ └── test-TestExclusion.R │ │ ├── NAMESPACE │ │ ├── man │ │ │ └── test_me.Rd │ │ ├── DESCRIPTION │ │ └── R │ │ │ └── TestExclusion.R │ ├── test-S4.R │ ├── test-R6.R │ ├── test-RC.R │ ├── test-memoised.R │ ├── test-vectorized.R │ ├── test-file_coverage.R │ ├── test-functions.R │ ├── test-null.R │ ├── test-summary.R │ ├── test-utils.R │ ├── test-package_coverage.R │ ├── test-Compiled.R │ ├── test-braceless.R │ ├── test-print.R │ ├── test-covr.R │ ├── test-gcov.R │ ├── test-trace_calls.R │ ├── test-shine.R │ ├── test-coveralls.R │ ├── test-exclusions.R │ └── test-codecov.R └── testthat.R ├── LICENSE ├── .gitignore ├── .lintr ├── shim_package.sh ├── R ├── vectorized.R ├── RC.R ├── display_name.R ├── S4.R ├── value.R ├── zzz.R ├── data_frame.R ├── replace.R ├── parse_data.R ├── system.R ├── compiled.R ├── trace_calls.R ├── coveralls.R ├── exclusions.R ├── codecov.R ├── summary_functions.R ├── shiny.R ├── utils.R └── covr.R ├── unshim_package.sh ├── .travis.yml ├── man ├── clear_counters.Rd ├── count.Rd ├── key.Rd ├── value.Rd ├── new_counter.Rd ├── percent_coverage.Rd ├── tally_coverage.Rd ├── print.coverage.Rd ├── shine.Rd ├── function_coverage.Rd ├── zero_coverage.Rd ├── trace_calls.Rd ├── system_check.Rd ├── system_output.Rd ├── file_coverage.Rd ├── coveralls.Rd ├── codecov.Rd ├── exclusions.Rd └── package_coverage.Rd ├── .Rbuildignore ├── docker_checker └── Dockerfile ├── Makefile ├── src └── reassign.c ├── NAMESPACE ├── appveyor.yml ├── NEWS.md ├── revdep ├── problems.md └── README.md ├── DESCRIPTION ├── inst └── www │ └── shiny.css ├── cran-comments.md ├── README.md └── vignettes └── how_it_works.Rmd /tests/testthat/a: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/testthat/b: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2014-2016 2 | COPYRIGHT HOLDER: James Hester 3 | -------------------------------------------------------------------------------- /tests/testthat/TestUseTry/tests/tests.R: -------------------------------------------------------------------------------- 1 | TestUseTry::fun() 2 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiledSubdir/src/Makevars: -------------------------------------------------------------------------------- 1 | OBJECTS = lib/simple.o 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .* 2 | *.o 3 | *.so 4 | inst/doc 5 | .Rproj.user 6 | covr.Rproj 7 | -------------------------------------------------------------------------------- /tests/testthat/TestUseTry/tests/testthat/test-notry.R: -------------------------------------------------------------------------------- 1 | expect_true(TestUseTry::fun()) 2 | -------------------------------------------------------------------------------- /.lintr: -------------------------------------------------------------------------------- 1 | linters: with_defaults(line_length_linter(120)) 2 | exclusions: list("inst/doc/how_it_works.R") 3 | -------------------------------------------------------------------------------- /tests/testthat/TestR6/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library("TestR6") 3 | 4 | test_check("TestR6") 5 | -------------------------------------------------------------------------------- /tests/testthat/TestRC/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library("TestRC") 3 | 4 | test_check("TestRC") 5 | -------------------------------------------------------------------------------- /tests/testthat/TestUseTry/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2 (4.1.1): do not edit by hand 2 | 3 | export(fun) 4 | -------------------------------------------------------------------------------- /tests/testthat/TestPrint/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2 (4.1.1): do not edit by hand 2 | 3 | export(test_me) 4 | -------------------------------------------------------------------------------- /tests/testthat/TestPrint/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library("TestPrint") 3 | 4 | test_check("TestPrint") 5 | -------------------------------------------------------------------------------- /tests/testthat/TestS4/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | 3 | suppressPackageStartupMessages(test_check("TestS4")) 4 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiled/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | useDynLib(TestCompiled,simple_) 4 | -------------------------------------------------------------------------------- /tests/testthat/TestR6/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2 (4.1.1): do not edit by hand 2 | 3 | export(TestR6) 4 | export(a) 5 | -------------------------------------------------------------------------------- /tests/testthat/TestSummary/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library("TestSummary") 3 | 4 | test_check("TestSummary") 5 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiled/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library("TestCompiled") 3 | 4 | test_check("TestCompiled") 5 | -------------------------------------------------------------------------------- /tests/testthat/TestExclusion/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library("TestExclusion") 3 | 4 | test_check("TestExclusion") 5 | -------------------------------------------------------------------------------- /tests/testthat/TestRC/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2 (4.1.1): do not edit by hand 2 | 3 | export(a) 4 | exportClasses(TestRC) 5 | -------------------------------------------------------------------------------- /tests/testthat/TestPrint/tests/testthat/test-TestSummary.R: -------------------------------------------------------------------------------- 1 | test_that("test_me works", { 2 | expect_equal(test_me(2, 2), 4) 3 | }) 4 | -------------------------------------------------------------------------------- /tests/testthat/TestSummary/tests/testthat/test-TestSummary.R: -------------------------------------------------------------------------------- 1 | test_that("test_me works", { 2 | expect_equal(test_me(2, 2), 4) 3 | }) 4 | -------------------------------------------------------------------------------- /tests/testthat/TestSummary/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2 (4.1.1): do not edit by hand 2 | 3 | export(dont_test_me) 4 | export(test_me) 5 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiledSubdir/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2 (4.1.1): do not edit by hand 2 | 3 | useDynLib(TestCompiledSubdir,simple_) 4 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiledSubdir/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library("TestCompiledSubdir") 3 | 4 | test_check("TestCompiledSubdir") 5 | -------------------------------------------------------------------------------- /tests/testthat/TestS4/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(a) 4 | export(print2) 5 | exportClasses(TestS4) 6 | -------------------------------------------------------------------------------- /shim_package.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | perl -i -pe 's/\bcovr\b/covrShim/g;s/\bcovr_/covrShim_/g' DESCRIPTION NAMESPACE R/* src/* tests/*R tests/testthat/*R 4 | -------------------------------------------------------------------------------- /R/vectorized.R: -------------------------------------------------------------------------------- 1 | # simple function to test if a function is Vectorized 2 | is_vectorized <- function(x) { 3 | is.function(x) && exists("FUN", environment(x)) 4 | } 5 | -------------------------------------------------------------------------------- /unshim_package.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | perl -i -pe 's/\bcovrShim\b/covr/g;s/\bcovrShim_/covr_/g' DESCRIPTION NAMESPACE R/* src/* tests/*R tests/testthat/*R 4 | -------------------------------------------------------------------------------- /tests/testthat/TestExclusion/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2 (4.1.1): do not edit by hand 2 | 3 | export(dont_test_me) 4 | export(test_exclusion) 5 | export(test_me) 6 | -------------------------------------------------------------------------------- /tests/testthat/TestPrint/R/TestPrint.R: -------------------------------------------------------------------------------- 1 | #' an example function 2 | #' 3 | #' @export 4 | test_me <- function(x, y) { 5 | if (TRUE) { x + y } else { 0 } # nolint 6 | } 7 | -------------------------------------------------------------------------------- /tests/testthat/TestExclusion/tests/testthat/test-TestExclusion.R: -------------------------------------------------------------------------------- 1 | test_that("test_me works", { 2 | expect_equal(test_me(2, 2), 4) 3 | expect_equal(test_exclusion(1), 2) 4 | }) 5 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiled/R/TestCompiled.R: -------------------------------------------------------------------------------- 1 | #' an example function 2 | #' 3 | #' @useDynLib TestCompiled simple_ 4 | simple <- function(x) { 5 | .Call(simple_, x) # nolint 6 | } 7 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiledSubdir/R/TestCompiledSubdir.R: -------------------------------------------------------------------------------- 1 | #' an example function 2 | #' 3 | #' @useDynLib TestCompiledSubdir simple_ 4 | simple <- function(x) { 5 | .Call(simple_, x) # nolint 6 | } 7 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiledSubdir/tests/testthat/test-TestCompiledSubdir.R: -------------------------------------------------------------------------------- 1 | test_that("compiled function simple works", { 2 | expect_equal(simple(1), 1) 3 | expect_equal(simple(2), 1) 4 | expect_equal(simple(3), 1) 5 | expect_equal(simple(-1), -1) 6 | }) 7 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiled/tests/testthat/test-TestCompiled.R: -------------------------------------------------------------------------------- 1 | context("Test") 2 | test_that("compiled function simple works", { 3 | expect_equal(simple(1), 1) 4 | expect_equal(simple(2), 1) 5 | expect_equal(simple(3), 1) 6 | expect_equal(simple(-1), -1) 7 | }) 8 | -------------------------------------------------------------------------------- /tests/testthat/TestSummary/R/TestSummary.R: -------------------------------------------------------------------------------- 1 | #' an example function 2 | #' 3 | #' @export 4 | test_me <- function(x, y){ 5 | if (TRUE) 6 | x + y 7 | else 8 | x - y 9 | } 10 | 11 | #' @export 12 | dont_test_me <- function(x, y){ 13 | x * y 14 | } 15 | -------------------------------------------------------------------------------- /tests/testthat/test-S4.R: -------------------------------------------------------------------------------- 1 | context("S4") 2 | test_that("S4 methods coverage is reported", { 3 | cov <- as.data.frame(package_coverage("TestS4")) 4 | 5 | expect_equal(cov$first_line, c(7, 8, 10, 25, 31, 37)) 6 | 7 | expect_equal(cov$value, c(5, 2, 3, 1, 1, 1)) 8 | }) 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | sudo: false 3 | cache: packages 4 | r: 5 | - oldrel 6 | - release 7 | - devel 8 | 9 | after_success: 10 | - test $TRAVIS_R_VERSION = "3.2.4" && R CMD INSTALL $PKG_TARBALL && source shim_package.sh && Rscript -e 'covr::codecov()' 11 | -------------------------------------------------------------------------------- /tests/testthat/TestR6/man/a.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.1.1): do not edit by hand 2 | % Please edit documentation in R/TestR6.R 3 | \name{a} 4 | \alias{a} 5 | \title{an example function} 6 | \usage{ 7 | a(x) 8 | } 9 | \description{ 10 | an example function 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/TestRC/man/a.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.1.1): do not edit by hand 2 | % Please edit documentation in R/TestRC.R 3 | \name{a} 4 | \alias{a} 5 | \title{an example function} 6 | \usage{ 7 | a(x) 8 | } 9 | \description{ 10 | an example function 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiled/man/simple.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/TestCompiled.R 3 | \name{simple} 4 | \alias{simple} 5 | \title{an example function} 6 | \usage{ 7 | simple(x) 8 | } 9 | \description{ 10 | an example function 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/TestS4/man/a.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/TestS4.R 3 | \name{a} 4 | \alias{a} 5 | \title{an example function} 6 | \usage{ 7 | a(x) 8 | } 9 | \description{ 10 | an example function 11 | } 12 | \examples{ 13 | a(1) 14 | } 15 | 16 | -------------------------------------------------------------------------------- /tests/testthat/TestUseTry/R/notry.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | 3 | fun <- function() { 4 | withCallingHandlers( 5 | signalCondition(simpleError("This Will Exit if `!isTRUE(use_try)`")), 6 | error = function(e) TRUE 7 | ) 8 | 1 + 1 9 | 2 + 2 10 | "hello" 11 | "welcome" 12 | TRUE 13 | } 14 | -------------------------------------------------------------------------------- /tests/testthat/test-R6.R: -------------------------------------------------------------------------------- 1 | context("R6") 2 | 3 | test_that("R6 methods coverage is reported", { 4 | cov <- as.data.frame(package_coverage("TestR6")) 5 | 6 | expect_equal(cov$value, c(5, 2, 3)) 7 | expect_equal(cov$first_line, c(5, 6, 8)) 8 | expect_equal(cov$last_line, c(5, 6, 8)) 9 | }) 10 | -------------------------------------------------------------------------------- /tests/testthat/TestPrint/man/test_me.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.1.1): do not edit by hand 2 | % Please edit documentation in R/TestPrint.R 3 | \name{test_me} 4 | \alias{test_me} 5 | \title{an example function} 6 | \usage{ 7 | test_me(x, y) 8 | } 9 | \description{ 10 | an example function 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/TestSummary/man/test_me.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.1.1): do not edit by hand 2 | % Please edit documentation in R/TestSummary.R 3 | \name{test_me} 4 | \alias{test_me} 5 | \title{an example function} 6 | \usage{ 7 | test_me(x, y) 8 | } 9 | \description{ 10 | an example function 11 | } 12 | 13 | -------------------------------------------------------------------------------- /man/clear_counters.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trace_calls.R 3 | \name{clear_counters} 4 | \alias{clear_counters} 5 | \title{clear all previous counters} 6 | \usage{ 7 | clear_counters() 8 | } 9 | \description{ 10 | clear all previous counters 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/TestExclusion/man/test_me.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.1.1): do not edit by hand 2 | % Please edit documentation in R/TestExclusion.R 3 | \name{test_me} 4 | \alias{test_me} 5 | \title{an example function} 6 | \usage{ 7 | test_me(x, y) 8 | } 9 | \description{ 10 | an example function 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiledSubdir/man/simple.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.1.1): do not edit by hand 2 | % Please edit documentation in R/TestCompiledSubdir.R 3 | \name{simple} 4 | \alias{simple} 5 | \title{an example function} 6 | \usage{ 7 | simple(x) 8 | } 9 | \description{ 10 | an example function 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/test-RC.R: -------------------------------------------------------------------------------- 1 | context("RC") 2 | test_that("RC methods coverage is reported", { 3 | cov <- as.data.frame(package_coverage("TestRC", quiet = FALSE)) 4 | str(cov) 5 | 6 | expect_equal(cov$value, c(5, 2, 3, 1, 1)) 7 | expect_equal(cov$first_line, c(5, 6, 8, 17, 20)) 8 | expect_equal(cov$last_line, c(5, 6, 8, 17, 20)) 9 | }) 10 | -------------------------------------------------------------------------------- /tests/testthat/TestPrint/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: TestPrint 2 | Title: What the Package Does (one line, title case) 3 | Version: 0.0.0.9000 4 | Authors@R: "First Last [aut, cre]" 5 | Description: What the package does (one paragraph) 6 | Depends: 7 | R (>= 3.1.2) 8 | License: What license is it under? 9 | LazyData: true 10 | -------------------------------------------------------------------------------- /man/count.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trace_calls.R 3 | \name{count} 4 | \alias{count} 5 | \title{increment a given counter} 6 | \usage{ 7 | count(key) 8 | } 9 | \arguments{ 10 | \item{key}{generated with \code{\link{key}}} 11 | } 12 | \description{ 13 | increment a given counter 14 | } 15 | 16 | -------------------------------------------------------------------------------- /man/key.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trace_calls.R 3 | \name{key} 4 | \alias{key} 5 | \title{Generate a key for a call} 6 | \usage{ 7 | key(x) 8 | } 9 | \arguments{ 10 | \item{x}{the srcref of the call to create a key for} 11 | } 12 | \description{ 13 | Generate a key for a call 14 | } 15 | 16 | -------------------------------------------------------------------------------- /tests/testthat/TestExclusion/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: TestExclusion 2 | Title: What the Package Does (one line, title case) 3 | Version: 0.0.0.9000 4 | Authors@R: "First Last [aut, cre]" 5 | Description: What the package does (one paragraph) 6 | Depends: 7 | R (>= 3.1.2) 8 | License: What license is it under? 9 | LazyData: true 10 | -------------------------------------------------------------------------------- /tests/testthat/TestSummary/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: TestSummary 2 | Title: What the Package Does (one line, title case) 3 | Version: 0.0.0.9000 4 | Authors@R: "First Last [aut, cre]" 5 | Description: What the package does (one paragraph) 6 | Depends: 7 | R (>= 3.1.2) 8 | License: What license is it under? 9 | LazyData: true 10 | -------------------------------------------------------------------------------- /tests/testthat/TestS4/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: TestS4 2 | Title: What the Package Does (one line, title case) 3 | Version: 0.0.0.9000 4 | Authors@R: "First Last [aut, cre]" 5 | Description: What the package does (one paragraph) 6 | Depends: 7 | R (>= 3.1.2) 8 | License: What license is it under? 9 | LazyData: true 10 | RoxygenNote: 5.0.1 11 | -------------------------------------------------------------------------------- /tests/testthat/TestRC/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: TestRC 2 | Title: What the Package Does (one line, title case) 3 | Version: 0.0.0.9000 4 | Authors@R: "First Last [aut, cre]" 5 | Description: What the package does (one paragraph) 6 | Depends: 7 | R (>= 3.1.2) 8 | License: What license is it under? 9 | LazyData: true 10 | Suggests: 11 | testthat 12 | -------------------------------------------------------------------------------- /tests/testthat/TestUseTry/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: TestUseTry 2 | Title: Test That `use_try` Parameter works 3 | Version: 0.0.0.9000 4 | Authors@R: "First Last [aut, cre]" 5 | Description: What the package does (one paragraph) 6 | Depends: 7 | R (>= 3.1.2) 8 | License: What license is it under? 9 | LazyData: true 10 | Suggests: 11 | testthat 12 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | ops <- options("crayon.enabled" = FALSE, warn = 1) 2 | library(testthat) 3 | library("covr") 4 | 5 | # Skip tests on Solaris as gcc is not in the PATH and I do not have an easy way 6 | # to mimic the CRAN build environment 7 | if (!tolower(Sys.info()[["sysname"]]) == "sunos") { 8 | Sys.setenv("R_TESTS" = "") 9 | test_check("covr") 10 | } 11 | 12 | options(ops) 13 | -------------------------------------------------------------------------------- /tests/testthat/TestExclusion/R/TestExclusion.R: -------------------------------------------------------------------------------- 1 | #' an example function 2 | #' 3 | #' @export 4 | test_me <- function(x, y){ 5 | x + y 6 | } 7 | 8 | # nocov start 9 | #' @export 10 | dont_test_me <- function(x, y){ 11 | x * y 12 | } 13 | # nocov end 14 | 15 | #' @export 16 | test_exclusion <- function(x) { 17 | if (x > 5) { 18 | 1 # nocov 19 | } else { 20 | 2 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /R/RC.R: -------------------------------------------------------------------------------- 1 | replacements_RC <- function(env) { 2 | pat <- paste0("^", classMetaName("")) 3 | unlist(recursive = FALSE, lapply(ls(env, pattern = pat, all.names = TRUE), 4 | function(name) { 5 | class <- get(name, env) 6 | if (extends(class, "envRefClass")) { 7 | lapply(ls(class@refMethods, all.names = TRUE), replacement, env = class@refMethods) 8 | } 9 | })) 10 | } 11 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiledSubdir/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: TestCompiledSubdir 2 | Title: What the Package Does (one line, title case) 3 | Version: 0.0.0.9000 4 | Authors@R: "First Last [aut, cre]" 5 | Description: What the package does (one paragraph) 6 | Depends: 7 | R (>= 3.1.2) 8 | License: What license is it under? 9 | LazyData: true 10 | Suggests: 11 | testthat 12 | -------------------------------------------------------------------------------- /tests/testthat/TestR6/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: TestR6 2 | Title: What the Package Does (one line, title case) 3 | Version: 0.0.0.9000 4 | Authors@R: "First Last [aut, cre]" 5 | Description: What the package does (one paragraph) 6 | Depends: 7 | R (>= 3.1.2) 8 | License: What license is it under? 9 | LazyData: true 10 | Imports: 11 | R6 12 | Suggests: 13 | testthat 14 | -------------------------------------------------------------------------------- /tests/testthat/TestR6/R/TestR6.R: -------------------------------------------------------------------------------- 1 | #' an example function 2 | #' 3 | #' @export 4 | a <- function(x) { 5 | if (x <= 1) { 6 | 1 7 | } else { 8 | 2 9 | } 10 | } 11 | 12 | #' @export 13 | TestR6 <- R6::R6Class("TestR6", # nolint 14 | public = list( 15 | show = function(x) { 16 | 1 + 3 17 | }, 18 | print2 = function(x) { 19 | 1 + 2 20 | } 21 | ) 22 | ) 23 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^covr\.Rproj$ 2 | \.tar\.gz$ 3 | ^travis-tool\.sh$ 4 | ^covr\.Rcheck$ 5 | ^\.travis\.yml$ 6 | ^shim_package\.sh$ 7 | ^unshim_package\.sh$ 8 | Makefile 9 | docker_checker 10 | _dev\.R$ 11 | ^\.lintr$ 12 | ^appveyor\.yml$ 13 | ^wercker\.yml$ 14 | ^\.Rproj\.user$ 15 | ^tests/testthat/.*/.*(o|sl|so|dylib|a|dll|def)$ 16 | ^covr.*$ 17 | ^cran_comments\.md$ 18 | ^revdep/ 19 | ^cran-comments\.md$ 20 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiled/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: TestCompiled 2 | Title: What the Package Does (one line, title case) 3 | Version: 0.0.0.9000 4 | Authors@R: "First Last [aut, cre]" 5 | Description: What the package does (one paragraph) 6 | Depends: 7 | R (>= 3.1.2) 8 | License: What license is it under? 9 | LazyData: true 10 | Suggests: 11 | testthat 12 | RoxygenNote: 5.0.1 13 | -------------------------------------------------------------------------------- /R/display_name.R: -------------------------------------------------------------------------------- 1 | display_name <- function(x) { 2 | stopifnot(inherits(x, "coverage")) 3 | if (length(x) == 0) { 4 | return() 5 | } 6 | 7 | filenames <- vapply(x, function(x) getSrcFilename(x$srcref, full.names = TRUE), character(1)) 8 | if (isTRUE(attr(x, "relative"))) { 9 | rex::re_substitutes(filenames, rex::rex(attr(x, "package")$path, "/"), "") 10 | } else { 11 | filenames 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /man/value.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/value.R 3 | \name{value} 4 | \alias{value} 5 | \title{Retrieve the value from an object} 6 | \usage{ 7 | value(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{object from which to retrieve the value} 11 | 12 | \item{...}{additional arguments passed to methods} 13 | } 14 | \description{ 15 | Retrieve the value from an object 16 | } 17 | 18 | -------------------------------------------------------------------------------- /R/S4.R: -------------------------------------------------------------------------------- 1 | replacements_S4 <- function(env) { 2 | generics <- getGenerics(env) 3 | 4 | unlist(recursive = FALSE, 5 | Map(generics@.Data, generics@package, USE.NAMES = FALSE, 6 | f = function(name, package) { 7 | what <- methodsPackageMetaName("T", paste(name, package, sep = ":")) 8 | 9 | table <- get(what, envir = env) 10 | 11 | lapply(ls(table, all.names = TRUE), replacement, env = table) 12 | }) 13 | ) 14 | } 15 | -------------------------------------------------------------------------------- /tests/testthat/TestRC/R/TestRC.R: -------------------------------------------------------------------------------- 1 | #' an example function 2 | #' 3 | #' @export 4 | a <- function(x) { 5 | if (x <= 1) { 6 | 1 7 | } else { 8 | 2 9 | } 10 | } 11 | 12 | #' @export 13 | TestRC <- setRefClass("TestRC", # nolint 14 | fields = list(name = "character", enabled = "logical"), 15 | methods = list( 16 | show = function(x) { 17 | 1 + 3 18 | }, 19 | print2 = function(x) { 20 | 1 + 2 21 | } 22 | ) 23 | ) 24 | -------------------------------------------------------------------------------- /man/new_counter.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trace_calls.R 3 | \name{new_counter} 4 | \alias{new_counter} 5 | \title{initialize a new counter} 6 | \usage{ 7 | new_counter(src_ref, parent_functions) 8 | } 9 | \arguments{ 10 | \item{src_ref}{a \code{\link[base]{srcref}}} 11 | 12 | \item{parent_functions}{the functions that this srcref is contained in.} 13 | } 14 | \description{ 15 | initialize a new counter 16 | } 17 | 18 | -------------------------------------------------------------------------------- /tests/testthat/TestRC/tests/testthat/test-TestRC.R: -------------------------------------------------------------------------------- 1 | test_that("regular function `a` works as expected", { 2 | expect_equal(a(1), 1) 3 | expect_equal(a(2), 2) 4 | expect_equal(a(3), 2) 5 | expect_equal(a(4), 2) 6 | expect_equal(a(0), 1) 7 | }) 8 | 9 | test_that("TestRC class can be instantiated", { 10 | t1 <- TestRC() # nolint 11 | }) 12 | 13 | test_that("TestRC Methods can be evaluated", { 14 | t1 <- TestRC() # nolint 15 | 16 | t1$show() 17 | print(t1$print2()) 18 | }) 19 | -------------------------------------------------------------------------------- /tests/testthat/TestR6/tests/testthat/test-TestR6.R: -------------------------------------------------------------------------------- 1 | test_that("regular function `a` works as expected", { 2 | expect_equal(a(1), 1) 3 | expect_equal(a(2), 2) 4 | expect_equal(a(3), 2) 5 | expect_equal(a(4), 2) 6 | expect_equal(a(0), 1) 7 | }) 8 | 9 | test_that("TestR6 class can be instantiated", { 10 | t1 <- TestR6$new() # nolint 11 | }) 12 | 13 | test_that("TestR6 Methods can be evaluated", { 14 | t1 <- TestR6$new() # nolint 15 | 16 | t1$show() 17 | print(t1$print2()) 18 | }) 19 | -------------------------------------------------------------------------------- /tests/testthat/test-memoised.R: -------------------------------------------------------------------------------- 1 | context("memoised") 2 | writeLines(con = "s1", 3 | "a <- memoise::memoise(function(x) { 4 | x + 1 5 | })") 6 | 7 | writeLines(con = "t1", 8 | " 9 | a(1) 10 | a(1) 11 | a(1) 12 | a(1) 13 | a(2) 14 | a(3)") 15 | 16 | on.exit(unlink(c("s1", "t1"))) 17 | 18 | test_that("it works on Vectorized functions", { 19 | cov <- file_coverage("s1", "t1") 20 | cov_d <- as.data.frame(cov) 21 | 22 | expect_equal(cov_d$functions, "a") 23 | expect_equal(cov_d$value, 3) 24 | }) 25 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiled/src/simple-header.h: -------------------------------------------------------------------------------- 1 | #define USE_RINTERNALS 2 | #include 3 | #include 4 | #include 5 | 6 | SEXP simple2_(SEXP x) { 7 | double *px, *pout; 8 | 9 | SEXP out = PROTECT(allocVector(REALSXP, 1)); 10 | 11 | px = REAL(x); 12 | pout = REAL(out); 13 | 14 | if (px[0] >= 1) { 15 | pout[0] = 1; 16 | } 17 | else if (px[0] == 0) { 18 | pout[0] = 0; 19 | } else { 20 | pout[0] = -1; 21 | } 22 | UNPROTECT(1); 23 | 24 | return out; 25 | } 26 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiledSubdir/src/lib/simple.c: -------------------------------------------------------------------------------- 1 | #define USE_RINTERNALS 2 | #include 3 | #include 4 | #include 5 | 6 | SEXP simple_(SEXP x) { 7 | double *px, *pout; 8 | 9 | SEXP out = PROTECT(allocVector(REALSXP, 1)); 10 | 11 | px = REAL(x); 12 | pout = REAL(out); 13 | 14 | if (px[0] >= 1) { 15 | pout[0] = 1; 16 | } 17 | else if (px[0] == 0) { 18 | pout[0] = 0; 19 | } else { 20 | pout[0] = -1; 21 | } 22 | UNPROTECT(1); 23 | 24 | return out; 25 | } 26 | -------------------------------------------------------------------------------- /tests/testthat/TestS4/tests/testthat/test-TestS4.R: -------------------------------------------------------------------------------- 1 | test_that("regular function `a` works as expected", { 2 | expect_equal(a(1), 1) 3 | expect_equal(a(2), 2) 4 | expect_equal(a(3), 2) 5 | expect_equal(a(4), 2) 6 | expect_equal(a(0), 1) 7 | }) 8 | 9 | test_that("TestS4 class can be instantiated", { 10 | t1 <- TestS4() # nolint 11 | }) 12 | 13 | test_that("TestS4 Methods can be evaluated", { 14 | t1 <- TestS4() # nolint 15 | 16 | show(t1) 17 | print(print2(t1)) 18 | 19 | print(print2(t1, "hi")) 20 | }) 21 | -------------------------------------------------------------------------------- /man/percent_coverage.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary_functions.R 3 | \name{percent_coverage} 4 | \alias{percent_coverage} 5 | \title{Provide percent coverage of package} 6 | \usage{ 7 | percent_coverage(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{the coverage object returned from \code{\link{package_coverage}}} 11 | 12 | \item{...}{additional arguments passed to \code{\link{tally_coverage}}} 13 | } 14 | \description{ 15 | Print the total percent coverage 16 | } 17 | 18 | -------------------------------------------------------------------------------- /man/tally_coverage.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary_functions.R 3 | \name{tally_coverage} 4 | \alias{tally_coverage} 5 | \title{Tally coverage by line or expression} 6 | \usage{ 7 | tally_coverage(x, by = c("line", "expression")) 8 | } 9 | \arguments{ 10 | \item{x}{the coverage object returned from \code{\link{package_coverage}}} 11 | 12 | \item{by}{whether to tally coverage by line or expression} 13 | } 14 | \description{ 15 | Tally coverage by line or expression 16 | } 17 | 18 | -------------------------------------------------------------------------------- /tests/testthat/TestCompiled/src/simple.c: -------------------------------------------------------------------------------- 1 | #define USE_RINTERNALS 2 | #include 3 | #include 4 | #include 5 | #include "simple-header.h" 6 | 7 | SEXP simple_(SEXP x) { 8 | double *px, *pout; 9 | 10 | SEXP out = PROTECT(allocVector(REALSXP, 1)); 11 | 12 | px = REAL(x); 13 | pout = REAL(out); 14 | 15 | if (px[0] >= 1) { 16 | pout[0] = 1; 17 | } 18 | else if (px[0] == 0) { 19 | pout[0] = 0; 20 | } else { 21 | pout[0] = -1; 22 | } 23 | UNPROTECT(1); 24 | 25 | return out; 26 | } 27 | -------------------------------------------------------------------------------- /docker_checker/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM rocker/r-devel 2 | MAINTAINER james.f.hester@gmail.com 3 | 4 | RUN apt-get update && apt-get install -y --no-install-recommends \ 5 | git \ 6 | libcurl4-openssl-dev \ 7 | nano \ 8 | sudo 9 | 10 | RUN Rscript -e 'install.packages(c("crayon", "devtools", "digest", "testthat", "rex", "roxygen2"))' 11 | 12 | # karl: was needed to test a package of mine 13 | RUN Rscript -e 'install.packages(c("brew", "dplyr", "gdata", "plyr","reshape2","seqinr","stringr","logging", "pryr"))' 14 | 15 | USER docker 16 | WORKDIR /home/docker -------------------------------------------------------------------------------- /tests/testthat/test-vectorized.R: -------------------------------------------------------------------------------- 1 | context("Vectorize") 2 | writeLines(con = "s1", 3 | 'scalar_func <- function(x,y) { 4 | z <- x + y 5 | } 6 | 7 | vector_func <- Vectorize(scalar_func,vectorize.args=c("x","y"),SIMPLIFY=TRUE)') 8 | 9 | writeLines(con = "t1", 10 | "vector_func(1:10, 2)") 11 | 12 | on.exit(unlink(c("s1", "t1"))) 13 | 14 | test_that("it works on Vectorized functions", { 15 | cov <- file_coverage("s1", "t1") 16 | cov_d <- as.data.frame(cov) 17 | 18 | expect_equal(cov_d$functions, "vector_func") 19 | expect_equal(cov_d$value, 10) 20 | }) 21 | -------------------------------------------------------------------------------- /tests/testthat/test-file_coverage.R: -------------------------------------------------------------------------------- 1 | context("file_coverage") 2 | writeLines(con = "s1", 3 | "a <- function(x) { 4 | x + 1 5 | } 6 | 7 | b <- function(x) { 8 | if (x > 1) TRUE 9 | else FALSE 10 | }") 11 | 12 | writeLines(con = "t1", 13 | "a(1) 14 | a(2) 15 | a(3) 16 | b(0) 17 | b(1) 18 | b(2)") 19 | 20 | on.exit(unlink(c("s1", "t1"))) 21 | 22 | test_that("it works on single files", { 23 | cov <- file_coverage("s1", "t1") 24 | cov_d <- as.data.frame(cov) 25 | 26 | expect_equal(cov_d$functions, c("a", "b", "b", "b")) 27 | expect_equal(cov_d$value, c(3, 3, 1, 2)) 28 | }) 29 | -------------------------------------------------------------------------------- /tests/testthat/test-functions.R: -------------------------------------------------------------------------------- 1 | context("evaluated functions") 2 | test_that("function_coverage generates output", { 3 | env <- new.env() 4 | withr::with_options(c("keep.source" = TRUE), { 5 | eval(parse(text = 6 | "fun <- function(x) { 7 | if (isTRUE(x)) { 8 | 1 9 | } else { 10 | 2 11 | } 12 | }"), envir = env) 13 | }) 14 | 15 | t1 <- function_coverage("fun", env = env) 16 | 17 | expect_equal(length(t1), 3) 18 | 19 | expect_equal(length(exclude(t1)), 3) 20 | 21 | expect_equal(length(exclude(t1, "")), 0) 22 | 23 | expect_equal(length(exclude(t1, list("" = 3))), 2) 24 | }) 25 | -------------------------------------------------------------------------------- /R/value.R: -------------------------------------------------------------------------------- 1 | #' Retrieve the value from an object 2 | #' @export 3 | #' @param x object from which to retrieve the value 4 | #' @param ... additional arguments passed to methods 5 | value <- function(x, ...) UseMethod("value") 6 | 7 | #' @export 8 | value.coverage <- function(x, ...) { 9 | vapply(x, value, numeric(1), ...) 10 | } 11 | 12 | #' @export 13 | value.expression_coverage <- function(x, ...) { 14 | x$value 15 | } 16 | 17 | #' @export 18 | value.expression_coverages <- value.coverage 19 | 20 | #' @export 21 | value.line_coverage <- value.expression_coverage 22 | 23 | #' @export 24 | value.line_coverages <- value.expression_coverages 25 | -------------------------------------------------------------------------------- /man/print.coverage.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary_functions.R 3 | \name{print.coverage} 4 | \alias{print.coverage} 5 | \title{Print a coverage object} 6 | \usage{ 7 | \method{print}{coverage}(x, group = c("filename", "functions"), by = "line", 8 | ...) 9 | } 10 | \arguments{ 11 | \item{x}{the coverage object to be printed} 12 | 13 | \item{group}{whether to group coverage by filename or function} 14 | 15 | \item{by}{whether to count coverage by line or expression} 16 | 17 | \item{...}{additional arguments ignored} 18 | } 19 | \description{ 20 | Print a coverage object 21 | } 22 | 23 | -------------------------------------------------------------------------------- /man/shine.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/shiny.R 3 | \name{shine} 4 | \alias{shine} 5 | \title{Display covr results using a shiny app} 6 | \usage{ 7 | shine(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{a coverage dataset} 11 | 12 | \item{...}{additional arguments passed to methods} 13 | } 14 | \description{ 15 | The shiny app is designed to provide local information to coverage 16 | information similar to the coveralls.io website. However it does not and 17 | will not track coverage over time. 18 | } 19 | \examples{ 20 | \dontrun{ 21 | x <- package_coverage() 22 | shine(x) 23 | } 24 | } 25 | 26 | -------------------------------------------------------------------------------- /man/function_coverage.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/covr.R 3 | \name{function_coverage} 4 | \alias{function_coverage} 5 | \title{Calculate test coverage for specific function.} 6 | \usage{ 7 | function_coverage(fun, code = NULL, env = NULL, enc = parent.frame()) 8 | } 9 | \arguments{ 10 | \item{fun}{name of the function.} 11 | 12 | \item{code}{expressions to run.} 13 | 14 | \item{env}{environment the function is defined in.} 15 | 16 | \item{enc}{the enclosing environment which to run the expressions.} 17 | } 18 | \description{ 19 | Calculate test coverage for specific function. 20 | } 21 | 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | RCHECKER=rocker/r-base 2 | FILTER= 3 | 4 | build-docker-checker: 5 | docker build -t $(RCHECKER) docker_checker 6 | 7 | run-rocker: build-docker-checker 8 | -docker rm $(RCHECKER) 9 | docker run --rm -ti -v $(PWD)/..:/home/docker $(RCHECKER) bash 10 | 11 | test: build-docker-checker 12 | docker run --rm -ti -v $(PWD)/..:/home/docker $(RCHECKER) Rscript -e 'devtools::test("covr", "$(FILTER)")' 13 | 14 | 15 | check: build-docker-checker 16 | docker run --rm -ti -v $(PWD)/..:/home/docker $(RCHECKER) Rscript -e 'devtools::check("covr")' 17 | 18 | 19 | rox: build-docker-checker 20 | docker run --rm -ti -v $(PWD)/..:/home/docker $(RCHECKER) Rscript -e 'devtools::document("covr")' -------------------------------------------------------------------------------- /tests/testthat/test-null.R: -------------------------------------------------------------------------------- 1 | context("NULL") 2 | 3 | test_that("coverage of functions with NULL constructs", { 4 | f1 <- function() NULL 5 | f2 <- function() { 6 | NULL 7 | } 8 | f3 <- function() { 9 | if (FALSE) { 10 | NULL 11 | } 12 | } 13 | f4 <- function() { 14 | if (FALSE) 15 | NULL 16 | } 17 | 18 | cv1 <- function_coverage(f1, f1()) 19 | expect_equal(percent_coverage(cv1), 100) 20 | cv2 <- function_coverage(f2, f2()) 21 | expect_equal(percent_coverage(cv2), 100) 22 | cv3 <- function_coverage(f3, f3()) 23 | expect_equal(percent_coverage(cv3), 50) 24 | cv4 <- function_coverage(f4, f4()) 25 | expect_equal(percent_coverage(cv4), 50) 26 | }) 27 | -------------------------------------------------------------------------------- /tests/testthat/TestS4/R/TestS4.R: -------------------------------------------------------------------------------- 1 | #' an example function 2 | #' 3 | #' @export 4 | #' @examples 5 | #' a(1) 6 | a <- function(x) { 7 | if (x <= 1) { 8 | 1 9 | } else { 10 | 2 11 | } 12 | } 13 | 14 | #' @export 15 | TestS4 <- setClass("TestS4", # nolint 16 | slots = list(name = "character", enabled = "logical")) 17 | 18 | #' @export 19 | setGeneric("print2", function(x, y) { 20 | }) 21 | 22 | setMethod("print2", 23 | c(x = "TestS4"), 24 | function(x) { 25 | 1 + 1 26 | }) 27 | 28 | setMethod("print2", 29 | c(x = "TestS4", y = "character"), 30 | function(x, y) { 31 | 1 + 2 32 | }) 33 | 34 | setMethod("show", 35 | c(object = "TestS4"), 36 | function(object) { 37 | 1 + 3 38 | }) 39 | -------------------------------------------------------------------------------- /man/zero_coverage.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary_functions.R 3 | \name{zero_coverage} 4 | \alias{zero_coverage} 5 | \title{Provide locations of zero coverage} 6 | \usage{ 7 | zero_coverage(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{a coverage object returned \code{\link{package_coverage}}} 11 | 12 | \item{...}{additional arguments passed to 13 | \code{\link{tally_coverage}}} 14 | } 15 | \description{ 16 | When examining the test coverage of a package, it is useful to know if there are 17 | any locations where there is \bold{0} test coverage. 18 | } 19 | \details{ 20 | if used within Rstudio this function outputs the results using the 21 | Marker API. 22 | } 23 | 24 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .onLoad <- function(libname, pkgname) { # nolint 2 | op <- options() 3 | op_covr <- list( 4 | covr.gcov = Sys.which("gcov"), 5 | covr.gcov_args = NULL, 6 | covr.exclude_pattern = rex::rex("#", any_spaces, "nocov"), 7 | covr.exclude_start = rex::rex("#", any_spaces, "nocov", any_spaces, "start"), 8 | covr.exclude_end = rex::rex("#", any_spaces, "nocov", any_spaces, "end"), 9 | covr.flags = c(CPPFLAGS = "-g -O0 --coverage", 10 | FFLAGS = "-g -O0 --coverage", 11 | FCFLAGS = "-g -O0 --coverage", 12 | LDFLAGS = "--coverage") 13 | ) 14 | toset <- !(names(op_covr) %in% names(op)) 15 | if (any(toset)) options(op_covr[toset]) 16 | 17 | invisible() 18 | } 19 | -------------------------------------------------------------------------------- /src/reassign.c: -------------------------------------------------------------------------------- 1 | #define USE_RINTERNALS 2 | #include 3 | #include 4 | #include 5 | 6 | 7 | SEXP covr_reassign_function(SEXP name, SEXP env, SEXP old_fun, SEXP new_fun) 8 | { 9 | if (TYPEOF(name) != SYMSXP) error("name must be a symbol"); 10 | if (TYPEOF(env) != ENVSXP) error("env must be an environment"); 11 | if (TYPEOF(old_fun) != CLOSXP) error("old_fun must be a function"); 12 | if (TYPEOF(new_fun) != CLOSXP) error("new_fun must be a function"); 13 | 14 | SET_FORMALS(old_fun, FORMALS(new_fun)); 15 | SET_BODY(old_fun, BODY(new_fun)); 16 | SET_CLOENV(old_fun, CLOENV(new_fun)); 17 | DUPLICATE_ATTRIB(old_fun, new_fun); 18 | 19 | return R_NilValue; 20 | } 21 | 22 | SEXP covr_duplicate_(SEXP x) { 23 | return duplicate(x); 24 | } 25 | -------------------------------------------------------------------------------- /man/trace_calls.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trace_calls.R 3 | \name{trace_calls} 4 | \alias{trace_calls} 5 | \title{trace each call with a srcref attribute} 6 | \usage{ 7 | trace_calls(x, parent_functions = NULL, parent_ref = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{the call} 11 | 12 | \item{parent_functions}{the functions which this call is a child of.} 13 | 14 | \item{parent_ref}{argument used to set the srcref of the current call when recursing} 15 | } 16 | \value{ 17 | a modified expression with count calls inserted before each previous 18 | call. 19 | } 20 | \description{ 21 | This function calls itself recursively so it can properly traverse the AST. 22 | } 23 | \seealso{ 24 | \url{http://adv-r.had.co.nz/Expressions.html} 25 | } 26 | 27 | -------------------------------------------------------------------------------- /tests/testthat/test-summary.R: -------------------------------------------------------------------------------- 1 | context("summary_functions") 2 | 3 | test_that("Summary gives 40% coverage and three lines with zero coverage", { 4 | cv <- package_coverage("TestSummary") 5 | expect_equal(percent_coverage(cv), 40) 6 | expect_equal(nrow(zero_coverage(cv)), 3) 7 | }) 8 | 9 | test_that("percent_coverage", { 10 | old <- getOption("keep.source") 11 | options(keep.source = TRUE) 12 | on.exit(options(keep.source = old), add = TRUE) 13 | 14 | fun <- function() { 15 | x <- 1 16 | if (x > 2) { 17 | print(x) 18 | } 19 | res <- lapply(1:2, function(x) { 20 | x + 1 21 | }) 22 | } 23 | cov <- function_coverage("fun", env = environment(fun), fun()) 24 | 25 | res <- percent_coverage(cov) 26 | expect_equal(res, 83.333333, tolerance = .01) 27 | }) 28 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(as.data.frame,coverage) 4 | S3method(print,coverage) 5 | S3method(print,coverages) 6 | S3method(shine,coverage) 7 | S3method(shine,coverages) 8 | S3method(value,coverage) 9 | S3method(value,expression_coverage) 10 | S3method(value,expression_coverages) 11 | S3method(value,line_coverage) 12 | S3method(value,line_coverages) 13 | export(codecov) 14 | export(coveralls) 15 | export(file_coverage) 16 | export(function_coverage) 17 | export(package_coverage) 18 | export(percent_coverage) 19 | export(shine) 20 | export(tally_coverage) 21 | export(value) 22 | export(zero_coverage) 23 | import(methods) 24 | importFrom(stats,aggregate) 25 | importFrom(stats,na.omit) 26 | importFrom(stats,na.pass) 27 | importFrom(stats,setNames) 28 | importFrom(utils,capture.output) 29 | importFrom(utils,getSrcFilename) 30 | importFrom(utils,relist) 31 | importFrom(utils,str) 32 | useDynLib(covr,covr_duplicate_) 33 | useDynLib(covr,covr_reassign_function) 34 | -------------------------------------------------------------------------------- /man/system_check.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/system.R 3 | \name{system_check} 4 | \alias{system_check} 5 | \title{Run a system command and check if it succeeds.} 6 | \usage{ 7 | system_check(cmd, args = character(), env = character(), quiet = FALSE, 8 | echo = FALSE, ...) 9 | } 10 | \arguments{ 11 | \item{cmd}{the command to run.} 12 | 13 | \item{args}{a vector of command arguments.} 14 | 15 | \item{env}{a named character vector of environment variables. Will be quoted} 16 | 17 | \item{quiet}{if \code{TRUE}, the command output will be echoed.} 18 | 19 | \item{echo}{if \code{TRUE}, the command to run will be echoed.} 20 | 21 | \item{...}{additional arguments passed to \code{\link[base]{system}}} 22 | } 23 | \value{ 24 | \code{TRUE} if the command succeeds, an error will be thrown if the 25 | command fails. 26 | } 27 | \description{ 28 | This function automatically quotes both the command and each 29 | argument so they are properly protected from shell expansion. 30 | } 31 | 32 | -------------------------------------------------------------------------------- /man/system_output.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/system.R 3 | \name{system_output} 4 | \alias{system_output} 5 | \title{Run a system command and capture the output.} 6 | \usage{ 7 | system_output(cmd, args = character(), env = character(), quiet = FALSE, 8 | echo = FALSE, ...) 9 | } 10 | \arguments{ 11 | \item{cmd}{the command to run.} 12 | 13 | \item{args}{a vector of command arguments.} 14 | 15 | \item{env}{a named character vector of environment variables. Will be quoted} 16 | 17 | \item{quiet}{if \code{TRUE}, the command output will be echoed.} 18 | 19 | \item{echo}{if \code{TRUE}, the command to run will be echoed.} 20 | 21 | \item{...}{additional arguments passed to \code{\link[base]{system}}} 22 | } 23 | \value{ 24 | command output if the command succeeds, an error will be thrown if 25 | the command fails. 26 | } 27 | \description{ 28 | This function automatically quotes both the command and each 29 | argument so they are properly protected from shell expansion. 30 | } 31 | 32 | -------------------------------------------------------------------------------- /man/file_coverage.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/covr.R 3 | \name{file_coverage} 4 | \alias{file_coverage} 5 | \title{Calculate test coverage for sets of files} 6 | \usage{ 7 | file_coverage(source_files, test_files, line_exclusions = NULL, 8 | function_exclusions = NULL) 9 | } 10 | \arguments{ 11 | \item{source_files}{Character vector of source files with function 12 | definitions to measure coverage} 13 | 14 | \item{test_files}{Character vector of test files with code to test the 15 | functions} 16 | 17 | \item{line_exclusions}{a named list of files with the lines to exclude from 18 | each file.} 19 | 20 | \item{function_exclusions}{a vector of regular expressions matching function 21 | names to exclude. Example \code{print\\.} to match print methods.} 22 | } 23 | \description{ 24 | The files in \code{source_files} are first sourced in to a new environment 25 | to define functions to be checked. Then they are instrumented to track 26 | coverage and the files in the \code{test_files} are sourced. 27 | } 28 | 29 | -------------------------------------------------------------------------------- /tests/testthat/test-utils.R: -------------------------------------------------------------------------------- 1 | context("as_package") 2 | test_that("it throws error if no package", { 3 | expect_error(as_package("arst11234"), "`path` is invalid:.*arst11234") 4 | }) 5 | 6 | test_that("it returns the package if given the root or child directory", { 7 | 8 | expect_equal(as_package("TestS4")$package, "TestS4") 9 | expect_equal(as_package("TestS4/")$package, "TestS4") 10 | 11 | expect_equal(as_package("TestS4/R")$package, "TestS4") 12 | 13 | expect_equal(as_package("TestS4/tests")$package, "TestS4") 14 | 15 | expect_equal(as_package("TestS4/tests/testthat")$package, "TestS4") 16 | }) 17 | 18 | context("local_branch") 19 | test_that("it works as expected", { 20 | with_mock(`covr:::system_output` = function(...) { "test_branch " }, { 21 | expect_equal(local_branch("TestSummary"), "test_branch") 22 | }) 23 | }) 24 | 25 | context("current_commit") 26 | test_that("it works as expected", { 27 | with_mock(`covr:::system_output` = function(...) { " test_hash" }, { 28 | expect_equal(current_commit("TestSummary"), "test_hash") 29 | }) 30 | }) 31 | -------------------------------------------------------------------------------- /R/data_frame.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | as.data.frame.coverage <- function(x, row.names = NULL, optional = FALSE, sort = TRUE, ...) { 3 | column_names <- c("filename", "functions", "first_line", "first_byte", "last_line", "last_byte", 4 | "first_column", "last_column", "first_parsed", 5 | "last_parsed", "value") 6 | 7 | res <- setNames(c(list(character(0)), rep(list(numeric(0)), times = length(column_names) - 1)), 8 | column_names) 9 | if (length(x)) { 10 | res$filename <- display_name(x) 11 | res$functions <- vapply(x, function(xx) xx$functions[1], character(1)) 12 | 13 | vals <- t(vapply(x, 14 | function(xx) c(xx$srcref, xx$value), 15 | numeric(9), USE.NAMES = FALSE)) 16 | for (i in seq_len(NCOL(vals))) { 17 | res[[i + 2]] <- vals[, i] 18 | } 19 | } 20 | 21 | df <- data.frame(res, stringsAsFactors = FALSE, check.names = FALSE) 22 | 23 | if (sort) { 24 | df <- df[order(df$filename, df$first_line, df$first_byte), ] 25 | } 26 | 27 | rownames(df) <- NULL 28 | df 29 | } 30 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | # DO NOT CHANGE the "init" and "install" sections below 2 | cache: 3 | - C:\RLibrary 4 | 5 | environment: 6 | global: 7 | R_VERSION: release 8 | 9 | # Download script file from GitHub 10 | init: 11 | ps: | 12 | $ErrorActionPreference = "Stop" 13 | Invoke-WebRequest https://raw.githubusercontent.com/jimhester/r-appveyor/patch-1/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" 14 | Import-Module '..\appveyor-tool.ps1' 15 | 16 | install: 17 | ps: Bootstrap 18 | 19 | # Adapt as necessary starting from here 20 | 21 | build_script: 22 | - travis-tool.sh install_deps 23 | 24 | test_script: 25 | - travis-tool.sh run_tests 26 | 27 | on_failure: 28 | - 7z a failure.zip *.Rcheck\* 29 | - appveyor PushArtifact failure.zip 30 | 31 | artifacts: 32 | - path: '*.Rcheck\**\*.log' 33 | name: Logs 34 | 35 | - path: '*.Rcheck\**\*.out' 36 | name: Logs 37 | 38 | - path: '*.Rcheck\**\*.fail' 39 | name: Logs 40 | 41 | - path: '*.Rcheck\**\*.Rout' 42 | name: Logs 43 | 44 | - path: '\*_*.tar.gz' 45 | name: Bits 46 | 47 | - path: '\*_*.zip' 48 | name: Bits 49 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | ## 2.0.2 ## 2 | * Memoised and Vectorized functions now able to be tracked. 3 | 4 | ## 2.0.1 ## 5 | * Support for filtering by function as well as line. 6 | * Now tracks coverage for RC methods 7 | * Rewrote loading and saving to support parallel code and tests including 8 | `quit()` calls. 9 | * Made passing code to function_coverage() and package_coverage() _not_ use 10 | non-standard evaluation. 11 | * `NULL` statements are analyzed for coverage (#156, @krlmlr). 12 | * Finer coverage analysis for brace-less `if`, `while` and `for` statements (#154, @krlmlr). 13 | * Run any combination of coverage types (#104, #133) 14 | * Remove inconsistencies in line counts between shiny app and services (#129) 15 | * Include header files in gcov output (#112) 16 | * Add support for C++11 (#131) 17 | * Always clean gcov files even on failure (#108) 18 | * zero_coverage works with RStudio markers (#119) 19 | * Remove the devtools dependency 20 | 21 | ## 1.3.0 ## 22 | * Set `.libPaths()` in subprocess to match those in calling process (#140, #147). 23 | * Move devtools dependency to suggests, only needed on windows 24 | * move htmltools to suggests 25 | 26 | ## Initial Release ## 27 | -------------------------------------------------------------------------------- /tests/testthat/test-package_coverage.R: -------------------------------------------------------------------------------- 1 | context("package_coverage") 2 | test_that("package_coverage returns an error if the path does not exist", { 3 | expect_error(package_coverage("blah")) 4 | }) 5 | 6 | test_that("package_coverage returns an error if the type is incorrect", { 7 | expect_error( 8 | package_coverage("TestPrint", type = "blah"), 9 | "'arg' should be one of") 10 | 11 | expect_error(package_coverage("TestPrint", type = c("blah", "test")), 12 | "'arg' should be one of") 13 | }) 14 | 15 | test_that("package_coverage can return just tests and vignettes", { 16 | cov <- package_coverage("TestPrint", type = c("tests", "vignettes"), combine_types = FALSE) 17 | 18 | expect_equal(names(cov), c("tests", "vignettes")) 19 | }) 20 | 21 | test_that("package_coverage with type == 'all' returns test, vignette and example coverage", { 22 | cov <- package_coverage("TestPrint", type = "all", combine_types = FALSE) 23 | 24 | expect_equal(names(cov), c("tests", "vignettes", "examples")) 25 | }) 26 | 27 | test_that("package_coverage with type == 'none' runs no test code", { 28 | cov <- package_coverage("TestS4", type = "none") 29 | 30 | expect_equal(percent_coverage(cov), 0.00) 31 | }) 32 | -------------------------------------------------------------------------------- /revdep/problems.md: -------------------------------------------------------------------------------- 1 | # Setup 2 | 3 | ## Platform 4 | 5 | |setting |value | 6 | |:--------|:----------------------------| 7 | |version |R version 3.2.4 (2016-03-10) | 8 | |system |x86_64, darwin13.4.0 | 9 | |ui |X11 | 10 | |language |(EN) | 11 | |collate |en_US.UTF-8 | 12 | |tz |America/New_York | 13 | |date |2016-04-05 | 14 | 15 | ## Packages 16 | 17 | |package |* |version |date |source | 18 | |:-------|:--|:-------|:----|:------| 19 | 20 | # Check results 21 | 1 packages with problems 22 | 23 | ## SpaDES (1.1.1) 24 | Maintainer: Alex M Chubaty 25 | Bug reports: https://github.com/PredictiveEcology/SpaDES/issues 26 | 27 | 1 error | 0 warnings | 0 notes 28 | 29 | ``` 30 | checking package dependencies ... ERROR 31 | Packages required but not available: 32 | ‘archivist’ ‘CircStats’ ‘DiagrammeR’ ‘ff’ ‘ffbase’ ‘fpCompare’ 33 | ‘RandomFields’ ‘raster’ ‘secr’ 34 | 35 | Packages suggested but not available for checking: 36 | ‘fastshp’ ‘rgdal’ ‘tkrplot’ 37 | 38 | See section ‘The DESCRIPTION file’ in the ‘Writing R Extensions’ 39 | manual. 40 | ``` 41 | 42 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: covr 2 | Title: Test Coverage for Packages 3 | Version: 2.0.1.9000 4 | Authors@R: person("Jim", "Hester", email = "james.f.hester@gmail.com", role = c("aut", "cre")) 5 | Description: Track and report code coverage for your package and (optionally) 6 | upload the results to a coverage service like Codecov (http://codecov.io) or 7 | Coveralls (http://coveralls.io). Code coverage is a measure of the amount of 8 | code being exercised by the tests. It is an indirect measure of test quality. 9 | This package is compatible with any testing methodology or framework and tracks 10 | coverage of both R code and compiled C/C++/Fortran code. 11 | URL: https://github.com/jimhester/covr 12 | BugReports: https://github.com/jimhester/covr/issues 13 | Depends: 14 | R (>= 3.1.0), 15 | methods 16 | Imports: 17 | stats, 18 | utils, 19 | jsonlite, 20 | rex, 21 | httr, 22 | crayon, 23 | withr, 24 | memoise 25 | Suggests: 26 | R6, 27 | knitr, 28 | rmarkdown, 29 | shiny (>= 0.11.1), 30 | htmltools, 31 | DT, 32 | testthat, 33 | rstudioapi (>= 0.2), 34 | devtools 35 | License: MIT + file LICENSE 36 | LazyData: true 37 | VignetteBuilder: knitr 38 | RoxygenNote: 5.0.1 39 | -------------------------------------------------------------------------------- /man/coveralls.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/coveralls.R 3 | \name{coveralls} 4 | \alias{coveralls} 5 | \title{Run covr on a package and upload the result to coveralls} 6 | \usage{ 7 | coveralls(..., coverage = NULL, repo_token = Sys.getenv("COVERALLS_TOKEN"), 8 | service_name = Sys.getenv("CI_NAME", "travis-ci"), quiet = TRUE) 9 | } 10 | \arguments{ 11 | \item{...}{arguments passed to \code{\link{package_coverage}}} 12 | 13 | \item{coverage}{an existing coverage object to submit, if \code{NULL}, 14 | \code{\link{package_coverage}} will be called with the arguments from 15 | \code{...}} 16 | 17 | \item{repo_token}{The secret repo token for your repository, 18 | found at the bottom of your repository's page on Coveralls. This is useful 19 | if your job is running on a service Coveralls doesn't support out-of-the-box. 20 | If set to NULL, it is assumed that the job is running on travis-ci} 21 | 22 | \item{service_name}{the CI service to use, if environment variable 23 | \sQuote{CI_NAME} is set that is used, otherwise \sQuote{travis-ci} is used.} 24 | 25 | \item{quiet}{if \code{FALSE}, print the coverage before submission.} 26 | } 27 | \description{ 28 | Run covr on a package and upload the result to coveralls 29 | } 30 | 31 | -------------------------------------------------------------------------------- /tests/testthat/test-Compiled.R: -------------------------------------------------------------------------------- 1 | context("Compiled") 2 | test_that("Compiled code coverage is reported including code in headers", { 3 | skip_on_cran() 4 | cov <- as.data.frame(package_coverage("TestCompiled", relative_path = TRUE)) 5 | 6 | simple_c <- cov[cov$filename == "src/simple.c", ] 7 | expect_equal(simple_c[simple_c$first_line == "10", "value"], 4) 8 | 9 | expect_equal(simple_c[simple_c$first_line == "16", "value"], 3) 10 | 11 | expect_equal(simple_c[simple_c$first_line == "19", "value"], 0) 12 | 13 | expect_equal(simple_c[simple_c$first_line == "21", "value"], 1) 14 | 15 | expect_equal(simple_c[simple_c$first_line == "23", "value"], 4) 16 | 17 | expect_true(all(unique(cov$filename) %in% c("R/TestCompiled.R", "src/simple-header.h", "src/simple.c"))) 18 | }) 19 | 20 | test_that("Source code subdirectories are found", { 21 | skip_on_cran() 22 | cov <- as.data.frame(package_coverage("TestCompiledSubdir", relative_path = TRUE)) 23 | 24 | expect_equal(cov[cov$first_line == "9", "value"], 4) 25 | 26 | expect_equal(cov[cov$first_line == "15", "value"], 3) 27 | 28 | expect_equal(cov[cov$first_line == "18", "value"], 0) 29 | 30 | expect_equal(cov[cov$first_line == "20", "value"], 1) 31 | 32 | expect_equal(cov[cov$first_line == "22", "value"], 4) 33 | }) 34 | -------------------------------------------------------------------------------- /man/codecov.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/codecov.R 3 | \name{codecov} 4 | \alias{codecov} 5 | \title{Run covr on a package and upload the result to codecov.io} 6 | \usage{ 7 | codecov(..., coverage = NULL, base_url = "https://codecov.io", 8 | token = NULL, commit = NULL, branch = NULL, quiet = TRUE) 9 | } 10 | \arguments{ 11 | \item{...}{arguments passed to \code{\link{package_coverage}}} 12 | 13 | \item{coverage}{an existing coverage object to submit, if \code{NULL}, 14 | \code{\link{package_coverage}} will be called with the arguments from 15 | \code{...}} 16 | 17 | \item{base_url}{Codecov url (change for Enterprise)} 18 | 19 | \item{token}{a codecov upload token, if \code{NULL} and the environment 20 | variable \sQuote{CODECOV_TOKEN} is used.} 21 | 22 | \item{commit}{explicitly set the commit this corresponds to, this is looked 23 | up from the service or locally if it is \code{NULL}.} 24 | 25 | \item{branch}{explicitly set the branch this corresponds to, this is looked 26 | up from the service or locally if it is \code{NULL}.} 27 | 28 | \item{quiet}{if \code{FALSE}, print the coverage before submission.} 29 | } 30 | \description{ 31 | Run covr on a package and upload the result to codecov.io 32 | } 33 | \examples{ 34 | \dontrun{ 35 | codecov(path = "test") 36 | } 37 | } 38 | 39 | -------------------------------------------------------------------------------- /R/replace.R: -------------------------------------------------------------------------------- 1 | #' @useDynLib covr covr_duplicate_ 2 | replacement <- function(name, env = as.environment(-1)) { 3 | target_value <- get(name, envir = env) 4 | if (is.function(target_value) && !is.primitive(target_value)) { 5 | if (is_vectorized(target_value)) { 6 | new_value <- target_value 7 | environment(new_value)$FUN <- trace_calls(environment(new_value)$FUN, name) 8 | } else if (memoise::is.memoised(target_value)) { 9 | new_value <- target_value 10 | environment(new_value)$`_f` <- trace_calls(environment(new_value)$`_f`, name) 11 | } else { 12 | new_value <- trace_calls(target_value, name) 13 | } 14 | attributes(new_value) <- attributes(target_value) 15 | 16 | if (isS4(target_value)) { 17 | new_value <- asS4(new_value) 18 | } 19 | 20 | list( 21 | env = env, 22 | name = as.name(name), 23 | orig_value = .Call(covr_duplicate_, target_value), 24 | target_value = target_value, 25 | new_value = new_value 26 | ) 27 | } 28 | } 29 | 30 | #' @useDynLib covr covr_reassign_function 31 | replace <- function(replacement) { 32 | .Call(covr_reassign_function, replacement$name, replacement$env, replacement$target_value, replacement$new_value) 33 | } 34 | 35 | #' @useDynLib covr covr_reassign_function 36 | reset <- function(replacement) { 37 | .Call(covr_reassign_function, replacement$name, replacement$env, replacement$target_value, replacement$orig_value) 38 | } 39 | -------------------------------------------------------------------------------- /tests/testthat/test-braceless.R: -------------------------------------------------------------------------------- 1 | context("braceless") 2 | 3 | test_that("if", { 4 | f <- function(x) { 5 | if (FALSE) 6 | FALSE # never covered, used as anchor 7 | if (x) 8 | TRUE 9 | else 10 | FALSE 11 | } 12 | 13 | expect_equal(diff(zero_coverage(function_coverage(f, f(TRUE)))$line), 14 | c(3, 1)) 15 | expect_equal(diff(zero_coverage(function_coverage(f, f(FALSE)))$line), 2) 16 | expect_equal(length(zero_coverage(function_coverage(f, { f(TRUE); f(FALSE) }))$line), 17 | 1) 18 | }) 19 | 20 | test_that("if complex", { 21 | f <- function(x) { 22 | if (FALSE) 23 | FALSE # never covered, used as anchor 24 | if (x) 25 | x <- TRUE 26 | else 27 | x <- FALSE 28 | } 29 | 30 | expect_equal(diff(zero_coverage(function_coverage(f, f(TRUE)))$line), 31 | c(3, 1)) 32 | expect_equal(diff(zero_coverage(function_coverage(f, f(FALSE)))$line), 33 | 2) 34 | expect_equal(length(zero_coverage(function_coverage(f, { f(TRUE); f(FALSE) }))$line), 35 | 1) 36 | }) 37 | 38 | test_that("switch", { 39 | f <<- function(x) { 40 | switch(x, 41 | a = 1, 42 | b = 2, 43 | c = d <- 1 44 | ) 45 | } 46 | 47 | expect_equal(length(zero_coverage(function_coverage(f, { f("a"); f("b") }))$line), 48 | 1) 49 | expect_equal(length(zero_coverage(function_coverage(f, { f("a"); f("c") }))$line), 50 | 1) 51 | expect_equal(diff(zero_coverage(function_coverage(f, { f("a"); f("d") }))$line), 52 | 1) 53 | }) 54 | -------------------------------------------------------------------------------- /tests/testthat/test-print.R: -------------------------------------------------------------------------------- 1 | context("print function") 2 | test_that("format_percentage works as expected", { 3 | expect_equal(format_percentage(0), crayon::red("0.00%")) 4 | 5 | expect_equal(format_percentage(25), crayon::red("25.00%")) 6 | 7 | expect_equal(format_percentage(51), crayon::red("51.00%")) 8 | 9 | expect_equal(format_percentage(76.5), crayon::yellow("76.50%")) 10 | 11 | expect_equal(format_percentage(86.5), crayon::yellow("86.50%")) 12 | 13 | expect_equal(format_percentage(96.5), crayon::green("96.50%")) 14 | }) 15 | 16 | test_that("print.coverage prints by = \"line\" by default", { 17 | cov <- package_coverage("TestPrint") 18 | 19 | expect_message(print(cov, by = "expression"), 20 | rex::rex("R/TestPrint.R: ", anything, "66.67%")) 21 | 22 | expect_message(print(cov, by = "line"), 23 | rex::rex("TestPrint Coverage: ", anything, "0.00%")) 24 | 25 | expect_message(print(cov, by = "line"), 26 | rex::rex("R/TestPrint.R: ", anything, "0.00%")) 27 | 28 | # test default 29 | expect_message(print(cov), 30 | rex::rex("TestPrint Coverage: ", anything, "0.00%")) 31 | 32 | expect_message(print(cov), 33 | rex::rex("R/TestPrint.R: ", anything, "0.00%")) 34 | }) 35 | test_that("print.coverage prints by = \"line\" by default", { 36 | cov <- package_coverage("TestPrint") 37 | 38 | expect_message(print(cov, group = "functions"), 39 | rex::rex("test_me", anything, "0.00%")) 40 | 41 | expect_message(print(cov, group = "functions", by = "expression"), 42 | rex::rex("test_me", anything, "66.67%")) 43 | }) 44 | -------------------------------------------------------------------------------- /man/exclusions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/exclusions.R 3 | \name{exclusions} 4 | \alias{exclusions} 5 | \title{Exclusions} 6 | \description{ 7 | covr supports a couple of different ways of excluding some or all of a file. 8 | } 9 | \section{Exclusions Argument}{ 10 | 11 | 12 | The exclusions argument to \code{package_coverage()} can be used to exclude some or 13 | all of a file. This argument takes a list of filenames or named ranges to 14 | exclude. 15 | } 16 | 17 | \section{Exclusion Comments}{ 18 | 19 | 20 | In addition you can exclude lines from the coverage by putting special comments 21 | in your source code. This can be done per line or by specifying a range. 22 | The patterns used can be specified by the \code{exclude_pattern}, \code{exclude_start}, 23 | \code{exclude_end} arguments to \code{package_coverage()} or by setting the global 24 | options \code{covr.exclude_pattern}, \code{covr.exclude_start}, \code{covr.exclude_end}. 25 | } 26 | \examples{ 27 | \dontrun{ 28 | # exclude whole file of R/test.R 29 | package_coverage(exclusions = "R/test.R") 30 | 31 | # exclude lines 1 to 10 and 15 from R/test.R 32 | package_coverage(exclusions = list("R/test.R" = c(1:10, 15))) 33 | 34 | # exclude lines 1 to 10 from R/test.R, all of R/test2.R 35 | package_coverage(exclusions = list("R/test.R" = 1:10, "R/test2.R")) 36 | 37 | # single line exclusions 38 | f1 <- function(x) { 39 | x + 1 # nocov 40 | } 41 | 42 | # ranged exclusions 43 | f2 <- function(x) { # nocov start 44 | x + 2 45 | } # nocov end 46 | } 47 | } 48 | 49 | -------------------------------------------------------------------------------- /inst/www/shiny.css: -------------------------------------------------------------------------------- 1 | table tr:hover td { 2 | font-weight:bold;text-decoration:none 3 | } 4 | table tr.covered td{ 5 | background-color:rgba(95,151,68,0.3) 6 | } 7 | table tr:hover.covered .num{ 8 | background-color:rgba(95,151,68,0.7) 9 | } 10 | table tr.missed td{ 11 | background-color:rgba(185,73,71,0.3) 12 | } 13 | table tr:hover.missed .num{ 14 | background-color:rgba(185,73,71,0.7) 15 | } 16 | 17 | table tr.missed:hover td{ 18 | -webkit-box-shadow:0 -2px 0 0 #b94947 inset; 19 | -moz-box-shadow:0 -2px 0 0 #b94947 inset; 20 | box-shadow:0 -2px 0 0 #b94947 inset 21 | } 22 | table tr.covered:hover td{ 23 | -webkit-box-shadow:0 -2px 0 0 #5f9744 inset; 24 | -moz-box-shadow:0 -2px 0 0 #5f9744 inset; 25 | box-shadow:0 -2px 0 0 #5f9744 inset 26 | } 27 | 28 | table tr.never td{ 29 | background-color:transparent 30 | } 31 | 32 | table .num { 33 | border-right: 1px solid rgba(0,0,0,0.1) 34 | } 35 | td.coverage em { 36 | opacity: 0.5; 37 | } 38 | 39 | table td.coverage { 40 | font-weight: bold; 41 | text-align: right; 42 | } 43 | table.table-condensed pre { 44 | background-color: transparent; 45 | margin: 0; 46 | padding: 0; 47 | padding-left: 11px; 48 | border: 0; 49 | font-size: 11px; 50 | } 51 | table.table-condensed { 52 | font-size: 11px; 53 | } 54 | 55 | .coverage-high { 56 | background-color: #5f9744 57 | } 58 | 59 | .coverage-medium { 60 | background-color: #f89406 61 | } 62 | 63 | .coverage-low { 64 | background-color: #b94947 65 | } 66 | 67 | .coverage-box { 68 | color: #fffdfa; 69 | width: 50px; 70 | height: 20px; 71 | text-align: center; 72 | } 73 | -------------------------------------------------------------------------------- /man/package_coverage.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/covr.R 3 | \name{package_coverage} 4 | \alias{package_coverage} 5 | \title{Calculate test coverage for a package} 6 | \usage{ 7 | package_coverage(path = ".", type = c("tests", "vignettes", "examples", 8 | "all", "none"), combine_types = TRUE, relative_path = TRUE, 9 | quiet = TRUE, clean = TRUE, line_exclusions = NULL, 10 | function_exclusions = NULL, code = character(), ..., exclusions) 11 | } 12 | \arguments{ 13 | \item{path}{file path to the package} 14 | 15 | \item{type}{run the package \sQuote{test}, \sQuote{vignette}, 16 | \sQuote{example}, \sQuote{all}, or \sQuote{none}. The default is 17 | \sQuote{test}.} 18 | 19 | \item{combine_types}{If \code{TRUE} (the default) the coverage for all types 20 | is simply summed into one coverage object. If \code{FALSE} separate objects 21 | are used for each type of coverage.} 22 | 23 | \item{relative_path}{whether to output the paths as relative or absolute 24 | paths.} 25 | 26 | \item{quiet}{whether to load and compile the package quietly} 27 | 28 | \item{clean}{whether to clean temporary output files after running.} 29 | 30 | \item{line_exclusions}{a named list of files with the lines to exclude from 31 | each file.} 32 | 33 | \item{function_exclusions}{a vector of regular expressions matching function 34 | names to exclude. Example \code{print\\.} to match print methods.} 35 | 36 | \item{code}{Additional test code to run.} 37 | 38 | \item{...}{Additional arguments passed to \code{\link[tools]{testInstalledPackage}}} 39 | 40 | \item{exclusions}{\sQuote{Deprecated}, please use \sQuote{line_exclusions} instead.} 41 | } 42 | \description{ 43 | Calculate test coverage for a package 44 | } 45 | \seealso{ 46 | exclusions 47 | } 48 | 49 | -------------------------------------------------------------------------------- /tests/testthat/test-covr.R: -------------------------------------------------------------------------------- 1 | context("function_coverage") 2 | test_that("function_coverage", { 3 | 4 | withr::with_options(c(keep.source = TRUE), { 5 | f <- function(x) { 6 | x + 1 7 | } 8 | expect_equal(as.numeric(function_coverage("f", env = environment(f))[[1]]$value), 0) 9 | 10 | expect_equal(as.numeric(function_coverage("f", env = environment(f), f(1))[[1]]$value), 1) 11 | 12 | expect_equal(as.numeric(function_coverage("f", env = environment(f), f(1), f(1))[[1]]$value), 2) 13 | }) 14 | }) 15 | 16 | test_that("function_coverage identity function", { 17 | 18 | withr::with_options(c(keep.source = TRUE), { 19 | fun <- function(x) { 20 | x 21 | } 22 | 23 | cov_num <- function(...) { 24 | as.numeric(function_coverage("fun", env = environment(fun), ...)[[1]]$value) 25 | } 26 | 27 | expect_equal(cov_num(), 0) 28 | expect_equal(cov_num(fun(1)), 1) 29 | }) 30 | }) 31 | 32 | test_that("function_coverage return last expr", { 33 | 34 | withr::with_options(c(keep.source = TRUE), { 35 | fun <- function(x = 1) { 36 | x 37 | x <- 1 38 | } 39 | 40 | cov_fun <- function(...) { 41 | vapply(function_coverage("fun", env = environment(fun), ...), "[[", numeric(1), "value") 42 | } 43 | 44 | expect_equal(as.numeric(cov_fun()), c(0L, 0L)) 45 | expect_equal(as.numeric(cov_fun(fun())), c(1L, 1L)) 46 | }) 47 | }) 48 | 49 | test_that("duplicated first_line", { 50 | withr::with_options(c(keep.source = TRUE), { 51 | 52 | fun <- function() { 53 | res <- lapply(1:2, function(x) { x + 1 }) # nolint 54 | } 55 | cov <- function_coverage("fun", env = environment(fun)) 56 | first_lines <- as.data.frame(cov)$first_line 57 | expect_equal(length(first_lines), 2) 58 | expect_equal(first_lines[1], first_lines[2]) 59 | }) 60 | }) 61 | 62 | context("trace_calls") 63 | test_that("trace calls handles all possibilities", { 64 | expr <- expression(y <- x * 10) 65 | 66 | expect_equal(trace_calls(expr), expr) 67 | 68 | expect_equal(trace_calls(list(expr)), list(expr)) 69 | }) 70 | -------------------------------------------------------------------------------- /R/parse_data.R: -------------------------------------------------------------------------------- 1 | impute_srcref <- function(x, parent_ref) { 2 | if (!is_conditional_or_loop(x)) return(NULL) 3 | if (is.null(parent_ref)) return(NULL) 4 | 5 | pd <- utils::getParseData(parent_ref, includeText = FALSE) 6 | pd_expr <- 7 | pd$line1 == parent_ref[[7L]] & 8 | pd$col1 == parent_ref[[2L]] & 9 | pd$line2 == parent_ref[[8L]] & 10 | pd$col2 == parent_ref[[4L]] & 11 | pd$token == "expr" 12 | pd_expr_idx <- which(pd_expr) 13 | if (length(pd_expr_idx) == 0L) return(NULL) # srcref not found in parse data 14 | 15 | stopifnot(length(pd_expr_idx) == 1L) 16 | expr_id <- pd$id[pd_expr_idx] 17 | pd_child <- pd[pd$parent == expr_id, ] 18 | pd_child <- pd_child[order(pd_child$line1, pd_child$col1), ] 19 | 20 | line_offset <- parent_ref[[7L]] - parent_ref[[1L]] 21 | 22 | make_srcref <- function(from, to = from) { 23 | srcref( 24 | attr(parent_ref, "srcfile"), 25 | c(pd_child$line1[from] - line_offset, 26 | pd_child$col1[from], 27 | pd_child$line2[to] - line_offset, 28 | pd_child$col2[to], 29 | pd_child$col1[from], 30 | pd_child$col2[to], 31 | pd_child$line1[from], 32 | pd_child$line2[to] 33 | )) 34 | } 35 | 36 | switch( 37 | as.character(x[[1L]]), 38 | "if" = { 39 | src_ref <- list( 40 | NULL, 41 | make_srcref(2, 4), 42 | make_srcref(5), 43 | make_srcref(6, 7) 44 | ) 45 | # the fourth component isn't used for an "if" without "else" 46 | src_ref[seq_along(x)] 47 | }, 48 | 49 | "for" = { 50 | list( 51 | NULL, 52 | NULL, 53 | make_srcref(2), 54 | make_srcref(3) 55 | ) 56 | }, 57 | 58 | "while" = { 59 | list( 60 | NULL, 61 | make_srcref(3), 62 | make_srcref(5) 63 | ) 64 | }, 65 | 66 | "switch" = { 67 | c(list(NULL), 68 | list(make_srcref(3)), 69 | Map(make_srcref, 70 | from = seq(7, NROW(pd_child), 4)) 71 | ) 72 | }, 73 | 74 | NULL 75 | ) 76 | } 77 | 78 | is_conditional_or_loop <- function(x) is.symbol(x[[1L]]) && as.character(x[[1L]]) %in% c("if", "for", "else", "switch") 79 | -------------------------------------------------------------------------------- /R/system.R: -------------------------------------------------------------------------------- 1 | #' Run a system command and check if it succeeds. 2 | #' 3 | #' This function automatically quotes both the command and each 4 | #' argument so they are properly protected from shell expansion. 5 | #' @param cmd the command to run. 6 | #' @param args a vector of command arguments. 7 | #' @param env a named character vector of environment variables. Will be quoted 8 | #' @param quiet if \code{TRUE}, the command output will be echoed. 9 | #' @param echo if \code{TRUE}, the command to run will be echoed. 10 | #' @param ... additional arguments passed to \code{\link[base]{system}} 11 | #' @return \code{TRUE} if the command succeeds, an error will be thrown if the 12 | #' command fails. 13 | system_check <- function(cmd, args = character(), env = character(), 14 | quiet = FALSE, echo = FALSE, ...) { 15 | full <- paste(c(shQuote(cmd), lapply(args, shQuote)), collapse = " ") 16 | 17 | if (echo) { 18 | message(wrap_command(full), "\n") 19 | } 20 | 21 | status <- withr::with_envvar(env, 22 | system(full, intern = FALSE, ignore.stderr = quiet, ignore.stdout = quiet, ...) 23 | ) 24 | 25 | if (!identical(as.character(status), "0")) { 26 | stop("Command ", sQuote(full), " failed (", status, ")", call. = FALSE) 27 | } 28 | 29 | invisible(TRUE) 30 | } 31 | 32 | #' Run a system command and capture the output. 33 | #' 34 | #' This function automatically quotes both the command and each 35 | #' argument so they are properly protected from shell expansion. 36 | #' @inheritParams system_check 37 | #' @return command output if the command succeeds, an error will be thrown if 38 | #' the command fails. 39 | system_output <- function(cmd, args = character(), env = character(), 40 | quiet = FALSE, echo = FALSE, ...) { 41 | full <- paste(c(shQuote(cmd), lapply(args, shQuote)), collapse = " ") 42 | 43 | if (echo) { 44 | message(wrap_command(full), "\n") 45 | } 46 | result <- withCallingHandlers(withr::with_envvar(env, 47 | system(full, intern = TRUE, ignore.stderr = quiet, ...) 48 | ), warning = function(w) stop(w)) 49 | 50 | result 51 | } 52 | 53 | wrap_command <- function(x) { 54 | lines <- strwrap(x, getOption("width") - 2, exdent = 2) 55 | continue <- c(rep(" \\", length(lines) - 1), "") 56 | paste(lines, continue, collapse = "\n") 57 | } 58 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Resubmission 2 | This is a resubmission. In this version I have fixed the package URL to be in 3 | the canonical form. 4 | 5 | ## Test environments 6 | * local OS X install, R 3.2.4 7 | * ubuntu 12.04 (on travis-ci), R 3.2.4 8 | * win-builder (devel and release) 9 | 10 | ## R CMD check results 11 | I believe this release should fix the ERRORs on Solaris, but I do not have a 12 | way to test that to be positive. 13 | 14 | There were no ERRORs or WARNINGs. 15 | 16 | There were the following NOTEs: 17 | 18 | * checking dependencies in R code ... NOTE 19 | There are ::: calls to the package's namespace in its code. A package 20 | almost never needs to use ::: for its own objects: 21 | 'count' 22 | 23 | The count function in question is what is used to instrument the test 24 | coverage in the external package. This code is executed in the external 25 | package's namespace, so it needs to be a fully qualified call. This count 26 | function is not exported because it never needs to be called by users. 27 | 28 | * Possibly mis-spelled words in DESCRIPTION: 29 | Codecov (6:51) 30 | Fortran (10:48) 31 | 32 | Both of these words are correctly spelled proper nouns. 33 | 34 | * URL: http://www.appveyor.com 35 | From: README.md 36 | Status: 403 37 | Message: Forbidden 38 | 39 | http://www.appveyor.com is a valid URL, however the IIS server it is running on 40 | does not seem to allow HEAD requests. Running `curl -i http://www.appveyor.com` 41 | returns a valid response, however `-I` does not. 42 | 43 | * URL: https://coveralls.io/repos/new 44 | From: README.md 45 | Status: 403 46 | Message: Forbidden 47 | 48 | https://coveralls.io/repos/new is again a valid URL, however the user needs 49 | authentication in order to access it. It is the proper URL to direct users 50 | towards to enable their repository. 51 | 52 | * URL: https://drone.io 53 | From: README.md 54 | Status: 404 55 | Message: Not Found 56 | 57 | https://drone.io is again a valid URL however similar to the first error their 58 | backend server does not properly support HEAD requests. 59 | 60 | ## Reverse dependencies 61 | 62 | Covr is a development tool only so its code is not actually run when building 63 | any downstream dependencies. Nonetheless I have run R CMD check on the 21 64 | downstream dependencies. There were no relevant Errors. 65 | 66 | Summary at: https://github.com/jimhester/covr/blob/master/revdep/index.md 67 | -------------------------------------------------------------------------------- /tests/testthat/test-gcov.R: -------------------------------------------------------------------------------- 1 | context("gcov") 2 | test_that("parse_gcov parses files properly", { 3 | with_mock( 4 | `base::file.exists` = function(...) TRUE, 5 | `base::readLines` = function(...) c( 6 | " -: 0:Source:simple.c" 7 | ), 8 | `base::normalizePath` = function(...) "simple.c", 9 | expect_equal(parse_gcov("hi.c.gcov"), NULL) 10 | ) 11 | 12 | with_mock( 13 | `base::file.exists` = function(...) TRUE, 14 | `base::readLines` = function(...) c( 15 | " -: 0:Source:simple.c", 16 | " -: 1:#define USE_RINTERNALS" 17 | ), 18 | `base::normalizePath` = function(...) "simple.c", 19 | expect_equal(parse_gcov("hi.c.gcov"), NULL) 20 | ) 21 | 22 | with_mock( 23 | `base::file.exists` = function(...) TRUE, 24 | `base::readLines` = function(...) c( 25 | " -: 0:Source:simple.c", 26 | " -: 0:Graph:simple.gcno", 27 | " -: 0:Data:simple.gcda", 28 | " -: 0:Runs:1", 29 | " -: 0:Programs:1", 30 | " -: 1:#define USE_RINTERNALS", 31 | " -: 2:#include ", 32 | " -: 3:#include ", 33 | " -: 4:#include ", 34 | " -: 5:", 35 | " 4: 6:SEXP simple_(SEXP x) {" 36 | ), 37 | `base::normalizePath` = function(...) "simple.c", 38 | expect_equal(unname(value(parse_gcov("hi.c.gcov"))), 4) 39 | ) 40 | with_mock( 41 | `base::file.exists` = function(...) TRUE, 42 | `base::readLines` = function(...) c( 43 | " -: 0:Source:simple.c", 44 | " -: 0:Graph:simple.gcno", 45 | " -: 0:Data:simple.gcda", 46 | " -: 0:Runs:1", 47 | " -: 0:Programs:1", 48 | " -: 1:#define USE_RINTERNALS", 49 | " -: 2:#include ", 50 | " -: 3:#include ", 51 | " -: 4:#include ", 52 | " -: 5:", 53 | " 4: 6:SEXP simple_(SEXP x) {", 54 | " -: 7: }", 55 | " #####: 8: pout[0] = 0;" # nolint 56 | ), 57 | `base::normalizePath` = function(...) "simple.c", 58 | expect_equal(value(unname(parse_gcov("hi.c.gcov"))), c(4, 0)) 59 | ) 60 | }) 61 | 62 | test_that("clean_gcov correctly clears files", { 63 | with_mock( 64 | `base::list.files` = function(...) c("simple.c.gcov", "simple.gcda", "simple.gcno"), 65 | `base::unlink` = function(...) list(...), 66 | files <- clean_gcov("TestGcov")[[1]], 67 | expect_match(files[1], "simple.c.gcov"), 68 | expect_match(files[2], "simple.gcda"), 69 | expect_match(files[3], "simple.gcno") 70 | ) 71 | }) 72 | -------------------------------------------------------------------------------- /tests/testthat/test-trace_calls.R: -------------------------------------------------------------------------------- 1 | context("trace_calls") 2 | test_that("one-line functions are traced correctly", { 3 | old <- getOption("keep.source") 4 | options(keep.source = TRUE) 5 | on.exit(options(keep.source = old)) 6 | 7 | fun <- function(x) x + 1 8 | 9 | expect_equal(as.character(body(trace_calls(fun))[[2]][[1]]), 10 | c(":::", "covr", "count")) 11 | 12 | fun <- function() 1 13 | 14 | expect_equal(as.character(body(trace_calls(fun))[[2]][[1]]), 15 | c(":::", "covr", "count")) 16 | 17 | expect_equal(body(trace_calls(fun))[[3]], body(fun)) 18 | }) 19 | test_that("one-line functions with no calls are traced correctly", { 20 | old <- getOption("keep.source") 21 | options(keep.source = TRUE) 22 | on.exit(options(keep.source = old)) 23 | 24 | fun <- function(x) x 25 | 26 | expect_equal(as.character(body(trace_calls(fun))[[2]][[1]]), 27 | c(":::", "covr", "count")) 28 | 29 | expect_equal(body(trace_calls(fun))[[3]], body(fun)) 30 | }) 31 | test_that("one-line functions with braces are traced correctly", { 32 | old <- getOption("keep.source") 33 | options(keep.source = TRUE) 34 | on.exit(options(keep.source = old)) 35 | 36 | fun <- function(x) { 37 | x + 1 38 | } 39 | 40 | expect_equal(as.character(body(trace_calls(fun))[[2]][[2]][[1]]), 41 | c(":::", "covr", "count")) 42 | 43 | expect_equal(body(trace_calls(fun))[[2]][[3]], body(fun)[[2]]) 44 | }) 45 | 46 | test_that("one-line functions with no calls and braces are traced correctly", { 47 | old <- getOption("keep.source") 48 | options(keep.source = TRUE) 49 | on.exit(options(keep.source = old)) 50 | 51 | fun <- function() { 52 | 1 53 | } 54 | 55 | e2 <- body(trace_calls(fun))[[2]] 56 | expect_true(length(e2) > 1 && 57 | identical(as.character(e2[[2]][[1]]), c(":::", "covr", "count"))) 58 | 59 | fun <- function(x) { 60 | x 61 | } 62 | 63 | e2 <- body(trace_calls(fun))[[2]] 64 | 65 | # the second expr should be a block 66 | expect_true(length(e2) > 1 && 67 | identical(as.character(e2[[2]][[1]]), c(":::", "covr", "count"))) 68 | }) 69 | 70 | 71 | test_that("last evaled expression is traced", { 72 | old <- getOption("keep.source") 73 | options(keep.source = TRUE) 74 | on.exit(options(keep.source = old)) 75 | 76 | fun <- function() { 77 | x <- 1 78 | x 79 | } 80 | 81 | body <- body(trace_calls(fun)) 82 | 83 | expect_equal(length(body), 3) 84 | 85 | # last expression: the implicit return expression 86 | e3 <- body[[3]] 87 | expect_true(length(e3) > 1 && 88 | identical(as.character(e3[[2]][[1]]), c(":::", "covr", "count"))) 89 | 90 | }) 91 | 92 | test_that("functions with NULL bodies are traced correctly", { 93 | old <- options(keep.source = TRUE) 94 | on.exit(options(old)) 95 | 96 | fun <- function() NULL 97 | 98 | expect_null(trace_calls(fun)()) 99 | }) 100 | -------------------------------------------------------------------------------- /tests/testthat/test-shine.R: -------------------------------------------------------------------------------- 1 | context("shine") 2 | cov <- package_coverage("TestS4", type = "all", combine_types = FALSE) 3 | 4 | test_that("it works with coverage objects", { 5 | with_mock(`shiny::runApp` = function(...) list(...), 6 | res <- shine(cov$tests), 7 | data <- environment(res[[1]]$server)$data, 8 | test_S4 <- data$full[["R/TestS4.R"]], 9 | 10 | expect_equal(test_S4$line, 1:38), 11 | 12 | expect_equal(test_S4$coverage, 13 | c("", "", "", "", "", "", "5", "2", "", "3", "", "", "", "", "", "", 14 | "", "", "", "", "", "", "", "", "1", "", "", "", "", 15 | "", "1", "", "", "", "", "", "1", "")), 16 | 17 | expect_equal(data$file_stats, 18 | x <- data.frame( 19 | Coverage = "
100.00
", 20 | File = "R/TestS4.R", 21 | Lines = 38L, 22 | Relevant = 6L, 23 | Covered = 6L, 24 | Missed = 0L, 25 | `Hits / Line` = "2", 26 | row.names = "R/TestS4.R", 27 | stringsAsFactors = FALSE, 28 | check.names = FALSE)) 29 | ) 30 | }) 31 | 32 | test_that("it works with coverages objects", { 33 | with_mock(`shiny::runApp` = function(...) list(...), 34 | res <- shine(cov), 35 | data <- environment(res[[1]]$server)$data, 36 | 37 | # Test coverage 38 | test_S4_test <- data$tests$full[["R/TestS4.R"]], 39 | expect_equal(test_S4_test$line, 1:38), 40 | 41 | expect_equal(test_S4_test$coverage, 42 | c("", "", "", "", "", "", "5", "2", "", "3", "", "", "", "", "", "", 43 | "", "", "", "", "", "", "", "", "1", "", "", "", "", 44 | "", "1", "", "", "", "", "", "1", "")), 45 | 46 | expect_equal(data$tests$file_stats, 47 | x <- data.frame( 48 | Coverage = "
100.00
", 49 | File = "R/TestS4.R", 50 | Lines = 38L, 51 | Relevant = 6L, 52 | Covered = 6L, 53 | Missed = 0L, 54 | `Hits / Line` = "2", 55 | row.names = "R/TestS4.R", 56 | stringsAsFactors = FALSE, 57 | check.names = FALSE)), 58 | 59 | # Vignette coverage 60 | test_S4_vignette <- data$vignettes$full[["R/TestS4.R"]], 61 | expect_equal(test_S4_vignette$line, 1:38), 62 | 63 | expect_equal(test_S4_vignette$coverage, 64 | c("", "", "", "", "", "", "0", "0", "", "0", "", "", "", "", "", "", 65 | "", "", "", "", "", "", "", "", "0", "", "", "", "", "", "0", "", "", 66 | "", "", "", "0", "")), 67 | 68 | expect_equal(data$vignettes$file_stats, 69 | x <- data.frame( 70 | Coverage = "
0.00
", 71 | File = "R/TestS4.R", 72 | Lines = 38L, 73 | Relevant = 6L, 74 | Covered = 0L, 75 | Missed = 6L, 76 | `Hits / Line` = "0", 77 | row.names = "R/TestS4.R", 78 | stringsAsFactors = FALSE, 79 | check.names = FALSE)) 80 | ) 81 | }) 82 | -------------------------------------------------------------------------------- /R/compiled.R: -------------------------------------------------------------------------------- 1 | # this does not handle LCOV_EXCL_START ect. 2 | parse_gcov <- function(file, package_path = "") { 3 | if (!file.exists(file)) { 4 | return(NULL) 5 | } 6 | 7 | lines <- readLines(file) 8 | source_file <- rex::re_matches(lines[1], rex::rex("Source:", capture(name = "source", anything)))$source 9 | 10 | # retrieve full path to the source files 11 | source_file <- normalize_path(source_file) 12 | 13 | # If the source file does not start with the package path ignore it. 14 | if (!grepl(rex::rex(start, package_path), source_file)) { 15 | return(NULL) 16 | } 17 | 18 | re <- rex::rex(any_spaces, 19 | capture(name = "coverage", some_of(digit, "-", "#", "=")), 20 | ":", any_spaces, 21 | capture(name = "line", digits), 22 | ":" 23 | ) 24 | 25 | matches <- rex::re_matches(lines, re) 26 | # gcov lines which have no coverage 27 | matches$coverage[matches$coverage == "#####"] <- 0 # nolint 28 | 29 | # gcov lines which have parse error, so make untracked 30 | matches$coverage[matches$coverage == "====="] <- "-" 31 | 32 | coverage_lines <- matches$line != "0" & matches$coverage != "-" 33 | matches <- matches[coverage_lines, ] 34 | 35 | values <- as.numeric(matches$coverage) 36 | 37 | # create srcfile reference from the source file 38 | src_file <- srcfilecopy(source_file, readLines(source_file)) 39 | 40 | line_lengths <- vapply(src_file$lines[as.numeric(matches$line)], nchar, numeric(1)) 41 | 42 | if (any(is.na(values))) { 43 | stop("values could not be coerced to numeric ", matches$coverage) 44 | } 45 | 46 | res <- Map(function(line, length, value) { 47 | src_ref <- srcref(src_file, c(line, 1, line, length)) 48 | res <- list(srcref = src_ref, value = value, functions = NA_character_) 49 | class(res) <- "line_coverage" 50 | res 51 | }, 52 | matches$line, line_lengths, values) 53 | 54 | if (!length(res)) { 55 | return(NULL) 56 | } 57 | 58 | names(res) <- lapply(res, function(x) key(x$srcref)) 59 | 60 | class(res) <- "line_coverages" 61 | res 62 | } 63 | 64 | clean_gcov <- function(path) { 65 | src_dir <- file.path(path, "src") 66 | 67 | gcov_files <- list.files(src_dir, 68 | pattern = rex::rex(or(".gcda", ".gcno", ".gcov"), end), 69 | full.names = TRUE, 70 | recursive = TRUE) 71 | 72 | unlink(gcov_files) 73 | } 74 | 75 | run_gcov <- function(path, quiet = TRUE, 76 | gcov_path = getOption("covr.gcov", ""), 77 | gcov_args = getOption("covr.gcov_args", NULL)) { 78 | if (!nzchar(gcov_path)) { 79 | return() 80 | } 81 | 82 | src_path <- normalize_path(file.path(path, "src")) 83 | if (!file.exists(src_path)) { 84 | return() 85 | } 86 | 87 | gcov_inputs <- list.files(path, pattern = rex::rex(".gcno", end), recursive = TRUE, full.names = TRUE) 88 | withr::with_dir(src_path, { 89 | run_gcov <- function(src) { 90 | system_check(gcov_path, 91 | args = c(gcov_args, src, "-o", dirname(src)), 92 | quiet = quiet, echo = !quiet) 93 | } 94 | lapply(gcov_inputs, run_gcov) 95 | gcov_outputs <- list.files(path, pattern = rex::rex(".gcov", end), recursive = TRUE, full.names = TRUE) 96 | structure( 97 | unlist(recursive = FALSE, 98 | lapply(gcov_outputs, parse_gcov, package_path = path)), 99 | class = "coverage") 100 | }) 101 | } 102 | -------------------------------------------------------------------------------- /R/trace_calls.R: -------------------------------------------------------------------------------- 1 | #' trace each call with a srcref attribute 2 | #' 3 | #' This function calls itself recursively so it can properly traverse the AST. 4 | #' @param x the call 5 | #' @param parent_functions the functions which this call is a child of. 6 | #' @param parent_ref argument used to set the srcref of the current call when recursing 7 | #' @seealso \url{http://adv-r.had.co.nz/Expressions.html} 8 | #' @return a modified expression with count calls inserted before each previous 9 | #' call. 10 | trace_calls <- function (x, parent_functions = NULL, parent_ref = NULL) { 11 | if (is.null(parent_functions)) { 12 | parent_functions <- deparse(substitute(x)) 13 | } 14 | recurse <- function(y) { 15 | lapply(y, trace_calls, parent_functions = parent_functions) 16 | } 17 | 18 | if (is.atomic(x) || is.name(x)) { 19 | if (is.null(parent_ref)) { 20 | x 21 | } 22 | else { 23 | if (is_na(x) || is_brace(x)) { 24 | x 25 | } else { 26 | key <- new_counter(parent_ref, parent_functions) # nolint 27 | bquote(`{`(covr:::count(.(key)), .(x))) 28 | } 29 | } 30 | } 31 | else if (is.call(x)) { 32 | if ((identical(x[[1]], as.name("<-")) || identical(x[[1]], as.name("="))) && # nolint 33 | (is.call(x[[3]]) && identical(x[[3]][[1]], as.name("function")))) { 34 | parent_functions <- c(parent_functions, as.character(x[[2]])) 35 | } 36 | src_ref <- attr(x, "srcref") %||% impute_srcref(x, parent_ref) 37 | if (!is.null(src_ref)) { 38 | as.call(Map(trace_calls, x, src_ref, MoreArgs = list(parent_functions = parent_functions))) 39 | } else if (!is.null(parent_ref)) { 40 | key <- new_counter(parent_ref, parent_functions) 41 | bquote(`{`(covr:::count(.(key)), .(as.call(recurse(x))))) 42 | } else { 43 | as.call(recurse(x)) 44 | } 45 | } 46 | else if (is.function(x)) { 47 | fun_body <- body(x) 48 | 49 | if (!is.null(attr(x, "srcref")) && 50 | (is.symbol(fun_body) || !identical(fun_body[[1]], as.name("{")))) { 51 | src_ref <- attr(x, "srcref") 52 | key <- new_counter(src_ref, parent_functions) 53 | fun_body <- bquote(`{`(covr:::count(.(key)), .(trace_calls(fun_body, parent_functions)))) 54 | } else { 55 | fun_body <- trace_calls(fun_body, parent_functions) 56 | } 57 | 58 | new_formals <- trace_calls(formals(x), parent_functions) 59 | if (is.null(new_formals)) new_formals <- list() 60 | formals(x) <- new_formals 61 | body(x) <- fun_body 62 | x 63 | } 64 | else if (is.pairlist(x)) { 65 | as.pairlist(recurse(x)) 66 | } 67 | else if (is.expression(x)) { 68 | as.expression(recurse(x)) 69 | } 70 | else if (is.list(x)) { 71 | recurse(x) 72 | } 73 | else { 74 | message("Unknown language class: ", paste(class(x), collapse = "/"), 75 | call. = FALSE) 76 | x 77 | } 78 | } 79 | 80 | .counters <- new.env(parent = emptyenv()) 81 | 82 | #' initialize a new counter 83 | #' 84 | #' @param src_ref a \code{\link[base]{srcref}} 85 | #' @param parent_functions the functions that this srcref is contained in. 86 | new_counter <- function(src_ref, parent_functions) { 87 | key <- key(src_ref) 88 | .counters[[key]]$value <- 0 89 | .counters[[key]]$srcref <- src_ref 90 | .counters[[key]]$functions <- parent_functions 91 | key 92 | } 93 | 94 | #' increment a given counter 95 | #' 96 | #' @param key generated with \code{\link{key}} 97 | count <- function(key) { 98 | .counters[[key]]$value <- .counters[[key]]$value + 1 99 | } 100 | 101 | #' clear all previous counters 102 | #' 103 | clear_counters <- function() { 104 | rm(envir = .counters, list = ls(envir = .counters)) 105 | } 106 | 107 | #' Generate a key for a call 108 | #' 109 | #' @param x the srcref of the call to create a key for 110 | key <- function(x) { 111 | paste(collapse = ":", c(utils::getSrcFilename(x), x)) 112 | } 113 | 114 | f1 <- function() { 115 | f2 <- function() { 116 | 2 117 | } 118 | f2() 119 | } 120 | -------------------------------------------------------------------------------- /R/coveralls.R: -------------------------------------------------------------------------------- 1 | #' Run covr on a package and upload the result to coveralls 2 | #' @param coverage an existing coverage object to submit, if \code{NULL}, 3 | #' \code{\link{package_coverage}} will be called with the arguments from 4 | #' \code{...} 5 | #' @param ... arguments passed to \code{\link{package_coverage}} 6 | #' @param repo_token The secret repo token for your repository, 7 | #' found at the bottom of your repository's page on Coveralls. This is useful 8 | #' if your job is running on a service Coveralls doesn't support out-of-the-box. 9 | #' If set to NULL, it is assumed that the job is running on travis-ci 10 | #' @param service_name the CI service to use, if environment variable 11 | #' \sQuote{CI_NAME} is set that is used, otherwise \sQuote{travis-ci} is used. 12 | #' @param quiet if \code{FALSE}, print the coverage before submission. 13 | #' @export 14 | coveralls <- function(..., coverage = NULL, 15 | repo_token = Sys.getenv("COVERALLS_TOKEN"), 16 | service_name = Sys.getenv("CI_NAME", "travis-ci"), 17 | quiet = TRUE) { 18 | 19 | if (is.null(coverage)) { 20 | coverage <- package_coverage(..., quiet = quiet) 21 | } 22 | 23 | if (!quiet) { 24 | print(coverage) 25 | } 26 | 27 | service <- tolower(service_name) 28 | 29 | coveralls_url <- "https://coveralls.io/api/v1/jobs" 30 | coverage_json <- to_coveralls(coverage, 31 | repo_token = repo_token, service_name = service) 32 | 33 | result <- httr::POST(url = coveralls_url, 34 | body = list(json_file = httr::upload_file(to_file(coverage_json)))) 35 | 36 | content <- httr::content(result) 37 | if (isTRUE(content$error)) { 38 | stop("Failed to upload coverage data. Reply by Coveralls: ", content$message) 39 | } 40 | content 41 | } 42 | 43 | to_file <- function(x) { 44 | name <- temp_file() 45 | con <- file(name) 46 | writeChar(con = con, x, eos = NULL) 47 | close(con) 48 | name 49 | } 50 | 51 | to_coveralls <- function(x, service_job_id = Sys.getenv("TRAVIS_JOB_ID"), 52 | service_name, repo_token = "") { 53 | 54 | coverages <- per_line(x) 55 | 56 | res <- Map(function(coverage, name) { 57 | list( 58 | "name" = jsonlite::unbox(name), 59 | "source" = jsonlite::unbox(paste(collapse = "\n", coverage$file$file_lines)), 60 | "coverage" = coverage$coverage) 61 | }, coverages, names(coverages), USE.NAMES = FALSE) 62 | 63 | git_info <- switch(service_name, 64 | drone = jenkins_git_info(), # drone has the same env vars as jenkins 65 | jenkins = jenkins_git_info(), 66 | list(NULL) 67 | ) 68 | 69 | payload <- if (!nzchar(repo_token)) { 70 | list( 71 | "service_job_id" = jsonlite::unbox(service_job_id), 72 | "service_name" = jsonlite::unbox(service_name), 73 | "source_files" = res) 74 | } else { 75 | tmp <- list( 76 | "repo_token" = jsonlite::unbox(repo_token), 77 | "source_files" = res) 78 | tmp$git <- list(git_info) 79 | tmp 80 | } 81 | 82 | jsonlite::toJSON(na = "null", payload) 83 | } 84 | 85 | jenkins_git_info <- function() { 86 | # check https://coveralls.zendesk.com/hc/en-us/articles/201350799-API-Reference 87 | # for why and how we are doing this 88 | formats <- c( 89 | id = "%H", 90 | author_name = "%an", 91 | author_email = "%ae", 92 | commiter_name = "%cn", 93 | commiter_email = "%ce", 94 | message = "%s" 95 | ) 96 | head <- lapply(structure( 97 | scan( 98 | sep = "\n", 99 | what = "character", 100 | text = system_output("git", c("log", "-n", "1", 101 | paste0("--pretty=format:", paste(collapse = "%n", formats))) 102 | ), 103 | quiet = TRUE 104 | ), 105 | names = names(formats) 106 | ), jsonlite::unbox) 107 | 108 | remotes <- list(list( 109 | name = jsonlite::unbox("origin"), 110 | url = jsonlite::unbox(Sys.getenv("CI_REMOTE")) 111 | )) 112 | 113 | c(list(branch = jsonlite::unbox(Sys.getenv("CI_BRANCH"))), 114 | head = list(head), 115 | remotes = list(remotes)) 116 | } 117 | -------------------------------------------------------------------------------- /tests/testthat/test-coveralls.R: -------------------------------------------------------------------------------- 1 | context("coveralls") 2 | 3 | ci_vars <- c( 4 | "APPVEYOR" = NA, 5 | "APPVEYOR_BUILD_NUMBER" = NA, 6 | "APPVEYOR_REPO_BRANCH" = NA, 7 | "APPVEYOR_REPO_COMMIT" = NA, 8 | "APPVEYOR_REPO_NAME" = NA, 9 | "BRANCH_NAME" = NA, 10 | "BUILD_NUMBER" = NA, 11 | "BUILD_URL" = NA, 12 | "CI" = NA, 13 | "CIRCLECI" = NA, 14 | "CIRCLE_BRANCH" = NA, 15 | "CIRCLE_BUILD_NUM" = NA, 16 | "CIRCLE_PROJECT_REPONAME" = NA, 17 | "CIRCLE_PROJECT_USERNAME" = NA, 18 | "CIRCLE_SHA1" = NA, 19 | "CI_BRANCH" = NA, 20 | "CI_BUILD_NUMBER" = NA, 21 | "CI_BUILD_URL" = NA, 22 | "CI_COMMIT_ID" = NA, 23 | "CI_NAME" = NA, 24 | "CODECOV_TOKEN" = NA, 25 | "DRONE" = NA, 26 | "DRONE_BRANCH" = NA, 27 | "DRONE_BUILD_NUMBER" = NA, 28 | "DRONE_BUILD_URL" = NA, 29 | "DRONE_COMMIT" = NA, 30 | "GIT_BRANCH" = NA, 31 | "GIT_COMMIT" = NA, 32 | "JENKINS_URL" = NA, 33 | "REVISION" = NA, 34 | "SEMAPHORE" = NA, 35 | "SEMAPHORE_BUILD_NUMBER" = NA, 36 | "SEMAPHORE_REPO_SLUG" = NA, 37 | "TRAVIS" = NA, 38 | "TRAVIS_BRANCH" = NA, 39 | "TRAVIS_COMMIT" = NA, 40 | "TRAVIS_JOB_ID" = NA, 41 | "TRAVIS_JOB_NUMBER" = NA, 42 | "TRAVIS_PULL_REQUEST" = NA, 43 | "TRAVIS_REPO_SLUG" = NA, 44 | "WERCKER_GIT_BRANCH" = NA, 45 | "WERCKER_GIT_COMMIT" = NA, 46 | "WERCKER_GIT_OWNER" = NA, 47 | "WERCKER_GIT_REPOSITORY" = NA, 48 | "WERCKER_MAIN_PIPELINE_STARTED" = NA) 49 | 50 | read_file <- function(file) paste(collapse = "\n", readLines(file)) 51 | 52 | cov <- package_coverage("TestS4") 53 | 54 | test_that("coveralls generates a properly formatted json file", { 55 | 56 | withr::with_envvar(c(ci_vars, "CI_NAME" = "FAKECI"), 57 | with_mock( 58 | `httr:::POST` = function(...) list(...), 59 | `httr::content` = identity, 60 | `httr::upload_file` = function(file) readChar(file, file.info(file)$size), 61 | 62 | res <- coveralls(coverage = cov), 63 | json <- jsonlite::fromJSON(res$body$json_file), 64 | 65 | expect_equal(nrow(json$source_files), 1), 66 | expect_equal(json$service_name, "fakeci"), 67 | expect_match(json$source_files$name, rex::rex("R", one_of("/", "\\"), "TestS4.R")), 68 | expect_equal(json$source_files$source, read_file("TestS4/R/TestS4.R")), 69 | expect_equal(json$source_files$coverage[[1]], 70 | c(NA, NA, NA, NA, NA, NA, 5, 2, NA, 3, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 71 | NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA)) 72 | ) 73 | ) 74 | }) 75 | 76 | test_that("coveralls can spawn a job using repo_token", { 77 | 78 | withr::with_envvar(c(ci_vars, "CI_NAME" = "DRONE"), 79 | with_mock( 80 | `httr:::POST` = function(...) list(...), 81 | `httr::content` = identity, 82 | `httr::upload_file` = function(file) readChar(file, file.info(file)$size), 83 | `covr::system_output` = function(...) paste0(c("a", "b", "c", "d", "e", "f"), collapse = "\n"), 84 | 85 | res <- coveralls(coverage = cov, repo_token = "mytoken"), 86 | json <- jsonlite::fromJSON(res$body$json_file), 87 | 88 | expect_equal(is.null(json$git), FALSE), 89 | expect_equal(nrow(json$source_files), 1), 90 | expect_equal(json$service_name, NULL), 91 | expect_equal(json$repo_token, "mytoken"), 92 | expect_match(json$source_files$name, rex::rex("R", one_of("/", "\\"), "TestS4.R")), 93 | expect_equal(json$source_files$source, read_file("TestS4/R/TestS4.R")), 94 | expect_equal(json$source_files$coverage[[1]], 95 | c(NA, NA, NA, NA, NA, NA, 5, 2, NA, 3, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 96 | NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA)) 97 | ) 98 | ) 99 | }) 100 | 101 | test_that("generates correct payload for Drone and Jenkins", { 102 | 103 | withr::with_envvar(c(ci_vars, "CI_NAME" = "FAKECI", "CI_BRANCH" = "fakebranch", "CI_REMOTE" = "covr"), 104 | with_mock( 105 | `covr::system_output` = function(...) paste0(c("a", "b", "c", "d", "e", "f"), collapse = "\n"), 106 | git <- jenkins_git_info(), 107 | 108 | expect_equal(git$head$id, jsonlite::unbox("a")), 109 | expect_equal(git$head$author_name, jsonlite::unbox("b")), 110 | expect_equal(git$head$author_email, jsonlite::unbox("c")), 111 | expect_equal(git$head$commiter_name, jsonlite::unbox("d")), 112 | expect_equal(git$head$commiter_email, jsonlite::unbox("e")), 113 | expect_equal(git$head$message, jsonlite::unbox("f")), 114 | expect_equal(git$branch, jsonlite::unbox("fakebranch")), 115 | expect_equal(git$remotes[[1]]$name, jsonlite::unbox("origin")), 116 | expect_equal(git$remotes[[1]]$url, jsonlite::unbox("covr")) 117 | 118 | ) 119 | ) 120 | }) 121 | -------------------------------------------------------------------------------- /tests/testthat/test-exclusions.R: -------------------------------------------------------------------------------- 1 | exclude_ops <- list(exclude_pattern = "#TeSt_NoLiNt", 2 | exclude_start = "#TeSt_NoLiNt_StArT", 3 | exclude_end = "#TeSt_NoLiNt_EnD") 4 | 5 | context("parse_exclusions") 6 | test_that("it returns an empty vector if there are no exclusions", { 7 | t1 <- c("this", 8 | "is", 9 | "a", 10 | "test") 11 | expect_equal(do.call(parse_exclusions, c(list(t1), exclude_ops, recursive = F)), numeric(0)) 12 | }) 13 | 14 | test_that("it returns the line if one line is excluded", { 15 | 16 | t1 <- c("this", 17 | "is #TeSt_NoLiNt", 18 | "a", 19 | "test") 20 | expect_equal(do.call(parse_exclusions, c(list(t1), exclude_ops)), c(2)) 21 | 22 | t2 <- c("this", 23 | "is #TeSt_NoLiNt", 24 | "a", 25 | "test #TeSt_NoLiNt") 26 | expect_equal(do.call(parse_exclusions, c(list(t2), exclude_ops)), c(2, 4)) 27 | }) 28 | 29 | test_that("it returns all lines between start and end", { 30 | 31 | t1 <- c("this #TeSt_NoLiNt_StArT", 32 | "is", 33 | "a #TeSt_NoLiNt_EnD", 34 | "test") 35 | expect_equal(do.call(parse_exclusions, c(list(t1), exclude_ops)), c(1, 2, 3)) 36 | 37 | t2 <- c("this #TeSt_NoLiNt_StArT", 38 | "is", 39 | "a #TeSt_NoLiNt_EnD", 40 | "test", 41 | "of", 42 | "the #TeSt_NoLiNt_StArT", 43 | "emergency #TeSt_NoLiNt_EnD", 44 | "broadcast", 45 | "system") 46 | expect_equal(do.call(parse_exclusions, c(list(t2), exclude_ops)), c(1, 2, 3, 6, 7)) 47 | }) 48 | 49 | test_that("it ignores exclude coverage lines within start and end", { 50 | 51 | t1 <- c("this #TeSt_NoLiNt_StArT", 52 | "is #TeSt_NoLiNt", 53 | "a #TeSt_NoLiNt_EnD", 54 | "test") 55 | expect_equal(do.call(parse_exclusions, c(list(t1), exclude_ops)), c(1, 2, 3)) 56 | }) 57 | 58 | test_that("it throws an error if start and end are unpaired", { 59 | 60 | t1 <- c("this #TeSt_NoLiNt_StArT", 61 | "is #TeSt_NoLiNt", 62 | "a", 63 | "test") 64 | expect_error(do.call(parse_exclusions, c(list(t1), exclude_ops)), "but only") 65 | }) 66 | 67 | context("normalize_exclusions") 68 | expect_equal_vals <- function(x, y) { 69 | testthat::expect_equal(unname(x), unname(y)) 70 | } 71 | test_that("it merges two NULL or empty objects as an empty list", { 72 | expect_equal(normalize_exclusions(c(NULL, NULL)), list()) 73 | expect_equal(normalize_exclusions(c(NULL, list())), list()) 74 | expect_equal(normalize_exclusions(c(list(), NULL)), list()) 75 | expect_equal(normalize_exclusions(c(list(), list())), list()) 76 | }) 77 | 78 | test_that("it returns the object if the other is NULL", { 79 | t1 <- list(a = 1:10) 80 | 81 | expect_equal_vals(normalize_exclusions(c(t1, NULL)), t1) 82 | expect_equal_vals(normalize_exclusions(c(NULL, t1)), t1) 83 | }) 84 | 85 | test_that("it returns the union of two non-overlapping lists", { 86 | t1 <- list(a = 1:10) 87 | t2 <- list(a = 20:30) 88 | 89 | expect_equal_vals(normalize_exclusions(c(t1, t2)), list(a = c(1:10, 20:30))) 90 | }) 91 | 92 | test_that("it returns the union of two overlapping lists", { 93 | t1 <- list(a = 1:10) 94 | t2 <- list(a = 5:15) 95 | 96 | expect_equal_vals(normalize_exclusions(c(t1, t2)), list(a = 1:15)) 97 | }) 98 | 99 | test_that("it adds names if needed", { 100 | t1 <- list(a = 1:10) 101 | t2 <- list(b = 5:15) 102 | 103 | expect_equal_vals(normalize_exclusions(c(t1, t2)), list(a = 1:10, b = 5:15)) 104 | }) 105 | 106 | test_that("it handles full file exclusions", { 107 | 108 | expect_equal_vals(normalize_exclusions(list("a")), list(a = Inf)) 109 | 110 | expect_equal_vals(normalize_exclusions(list("a", b = 1)), list(a = Inf, b = 1)) 111 | }) 112 | 113 | test_that("it handles redundant lines", { 114 | 115 | expect_equal_vals(normalize_exclusions(list(a = c(1, 1, 1:10))), list(a = 1:10)) 116 | 117 | expect_equal_vals(normalize_exclusions(list(a = c(1, 1, 1:10), b = 1:10)), list(a = 1:10, b = 1:10)) 118 | }) 119 | 120 | test_that("it handles redundant files", { 121 | 122 | expect_equal_vals(normalize_exclusions(list(a = c(1:10), a = c(10:20))), list(a = 1:20)) 123 | }) 124 | 125 | cov <- package_coverage("TestSummary") 126 | 127 | context("exclude") 128 | test_that("it excludes lines", { 129 | expect_equal(length(cov), 4) 130 | expect_equal(length(exclude(cov, list("R/TestSummary.R" = 5), path = "TestSummary")), 3) 131 | expect_equal(length(exclude(cov, list("R/TestSummary.R" = 13), path = "TestSummary")), 3) 132 | }) 133 | test_that("it preserves the class", { 134 | expect_equal(class(exclude(cov, NULL, path = "TestSummary")), class(cov)) 135 | expect_equal(class(exclude(cov, list("R/TestSummary.R" = 3), path = "TestSummary")), class(cov)) 136 | }) 137 | test_that("function exclusions work", { 138 | expect_equal(length(exclude(cov, NULL, "^test")), 1) 139 | expect_equal(length(exclude(cov, NULL, c("^test", "dont"))), 0) 140 | }) 141 | 142 | test_that("it excludes properly", { 143 | t1 <- package_coverage("TestExclusion") 144 | 145 | expect_equal(length(t1), 3) 146 | 147 | t1 <- package_coverage("TestExclusion", line_exclusions = "R/TestExclusion.R") 148 | 149 | expect_equal(length(t1), 0) 150 | }) 151 | 152 | context("file_exclusions") 153 | test_that("it returns NULL if empty or no file exclusions", { 154 | expect_equal(file_exclusions(NULL, ""), NULL) 155 | 156 | expect_equal(file_exclusions(list("a" = c(1, 2))), NULL) 157 | 158 | expect_equal(file_exclusions(list("a" = c(1, 2), "b" = c(3, 4))), NULL) 159 | }) 160 | test_that("it returns a normalizedPath if the file can be found", { 161 | expect_match(file_exclusions(list("test-exclusions.R"), "."), "test-exclusions.R") 162 | 163 | expect_match( 164 | file_exclusions(list("testthat/test-exclusions.R", "testthat.R"), ".."), 165 | rex::rex(or("test-exclusions.R", "testthat.R"))) 166 | }) 167 | -------------------------------------------------------------------------------- /R/exclusions.R: -------------------------------------------------------------------------------- 1 | #' Exclusions 2 | #' 3 | #' covr supports a couple of different ways of excluding some or all of a file. 4 | #' 5 | #' @section Exclusions Argument: 6 | #' 7 | #' The exclusions argument to \code{package_coverage()} can be used to exclude some or 8 | #' all of a file. This argument takes a list of filenames or named ranges to 9 | #' exclude. 10 | #' 11 | #' @section Exclusion Comments: 12 | #' 13 | #' In addition you can exclude lines from the coverage by putting special comments 14 | #' in your source code. This can be done per line or by specifying a range. 15 | #' The patterns used can be specified by the \code{exclude_pattern}, \code{exclude_start}, 16 | #' \code{exclude_end} arguments to \code{package_coverage()} or by setting the global 17 | #' options \code{covr.exclude_pattern}, \code{covr.exclude_start}, \code{covr.exclude_end}. 18 | 19 | #' @examples 20 | #' \dontrun{ 21 | #' # exclude whole file of R/test.R 22 | #' package_coverage(exclusions = "R/test.R") 23 | #' 24 | #' # exclude lines 1 to 10 and 15 from R/test.R 25 | #' package_coverage(exclusions = list("R/test.R" = c(1:10, 15))) 26 | #' 27 | #' # exclude lines 1 to 10 from R/test.R, all of R/test2.R 28 | #' package_coverage(exclusions = list("R/test.R" = 1:10, "R/test2.R")) 29 | #' 30 | #' # single line exclusions 31 | #' f1 <- function(x) { 32 | #' x + 1 # nocov 33 | #' } 34 | #' 35 | #' # ranged exclusions 36 | #' f2 <- function(x) { # nocov start 37 | #' x + 2 38 | #' } # nocov end 39 | #' } 40 | #' @name exclusions 41 | NULL 42 | 43 | exclude <- function(coverage, 44 | line_exclusions = NULL, 45 | function_exclusions = NULL, 46 | exclude_pattern = getOption("covr.exclude_pattern"), 47 | exclude_start = getOption("covr.exclude_start"), 48 | exclude_end = getOption("covr.exclude_end"), 49 | path = NULL) { 50 | 51 | sources <- traced_files(coverage) 52 | 53 | source_exclusions <- lapply(sources, 54 | function(x) { 55 | parse_exclusions(x$file_lines, exclude_pattern, exclude_start, exclude_end) 56 | }) 57 | 58 | excl <- normalize_exclusions(c(source_exclusions, line_exclusions), path) 59 | 60 | df <- as.data.frame(coverage, sort = FALSE) 61 | 62 | to_exclude <- rep(FALSE, length(coverage)) 63 | 64 | if (!is.null(function_exclusions)) { 65 | to_exclude <- Reduce(`|`, init = to_exclude, 66 | Map(rex::re_matches, function_exclusions, MoreArgs = list(data = df$functions))) 67 | } 68 | 69 | df$full_name <- vapply(coverage, 70 | function(x) { 71 | normalize_path(getSrcFilename(x$srcref, full.names = TRUE)) 72 | }, 73 | character(1)) 74 | 75 | to_exclude <- to_exclude | vapply(seq_len(NROW(df)), 76 | function(i) { 77 | file <- df[i, "full_name"] 78 | which_exclusion <- match(file, names(excl)) 79 | 80 | !is.na(which_exclusion) && 81 | ( 82 | excl[[which_exclusion]] == Inf || 83 | all(seq(df[i, "first_line"], df[i, "last_line"]) %in% excl[[file]]) 84 | ) 85 | }, 86 | logical(1)) 87 | 88 | if (any(to_exclude)) { 89 | coverage <- coverage[!to_exclude] 90 | } 91 | 92 | coverage 93 | } 94 | 95 | parse_exclusions <- function(lines, 96 | exclude_pattern = getOption("covr.exclude"), 97 | exclude_start = getOption("covr.exclude_start"), 98 | exclude_end = getOption("covr.exclude_end")) { 99 | 100 | exclusions <- numeric(0) 101 | 102 | starts <- which(rex::re_matches(lines, exclude_start)) 103 | ends <- which(rex::re_matches(lines, exclude_end)) 104 | 105 | if (length(starts) > 0) { 106 | if (length(starts) != length(ends)) { 107 | stop(length(starts), " starts but only ", length(ends), " ends!") 108 | } 109 | 110 | for (i in seq_along(starts)) { 111 | exclusions <- c(exclusions, seq(starts[i], ends[i])) 112 | } 113 | } 114 | 115 | exclusions <- c(exclusions, which(rex::re_matches(lines, exclude_pattern))) 116 | 117 | sort(unique(exclusions)) 118 | } 119 | 120 | file_exclusions <- function(x, path = NULL) { 121 | excl <- normalize_exclusions(x, path) 122 | 123 | full_files <- vapply(excl, function(x1) length(x1) == 1 && x1 == Inf, logical(1)) 124 | if (any(full_files)) { 125 | names(excl)[full_files] 126 | } else { 127 | NULL 128 | } 129 | } 130 | 131 | normalize_exclusions <- function(x, path = NULL) { 132 | if (is.null(x) || length(x) <= 0) { 133 | return(list()) 134 | } 135 | 136 | # no named parameters at all 137 | if (is.null(names(x))) { 138 | x <- structure(relist(rep(Inf, length(x)), x), names = x) 139 | } else { 140 | unnamed <- names(x) == "" 141 | if (any(unnamed)) { 142 | 143 | # must be character vectors of length 1 144 | bad <- vapply(seq_along(x), 145 | function(i) { 146 | unnamed[i] & (!is.character(x[[i]]) | length(x[[i]]) != 1) 147 | }, 148 | logical(1)) 149 | 150 | if (any(bad)) { 151 | stop("Full file exclusions must be character vectors of length 1. items: ", 152 | paste(collapse = ", ", which(bad)), 153 | " are not!", 154 | call. = FALSE) 155 | } 156 | names(x)[unnamed] <- x[unnamed] 157 | x[unnamed] <- Inf 158 | } 159 | } 160 | 161 | if (!is.null(path)) { 162 | names(x) <- file.path(path, names(x)) 163 | } 164 | names(x) <- normalize_path(names(x)) 165 | 166 | remove_line_duplicates( 167 | remove_file_duplicates( 168 | remove_empty(x) 169 | ) 170 | ) 171 | } 172 | 173 | remove_file_duplicates <- function(x) { 174 | unique_names <- unique(names(x)) 175 | 176 | ## check for duplicate files 177 | if (length(unique_names) < length(names(x))) { 178 | x <- lapply(unique_names, 179 | function(name) { 180 | vals <- unname(unlist(x[names(x) == name])) 181 | if (any(vals == Inf)) { 182 | Inf 183 | } else { 184 | vals 185 | } 186 | }) 187 | 188 | names(x) <- unique_names 189 | } 190 | 191 | x 192 | } 193 | 194 | remove_line_duplicates <- function(x) { 195 | x[] <- lapply(x, unique) 196 | 197 | x 198 | } 199 | 200 | remove_empty <- function(x) { 201 | x[vapply(x, length, numeric(1)) > 0] 202 | } 203 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Covr # 2 | [![Build Status](https://travis-ci.org/jimhester/covr.svg?branch=master)](https://travis-ci.org/jimhester/covr) 3 | [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/jimhester/covr?branch=master&svg=true)](https://ci.appveyor.com/project/jimhester/covr) 4 | [![codecov.io](https://codecov.io/github/jimhester/covr/coverage.svg?branch=master)](https://codecov.io/github/jimhester/covr?branch=master) 5 | [![CRAN version](http://www.r-pkg.org/badges/version/covr)](https://cran.r-project.org/package=covr) 6 | 7 | Track test coverage for your R package and (optionally) upload the results to 8 | [coveralls](https://coveralls.io/) or [codecov](https://codecov.io/). 9 | 10 | # Installation # 11 | ## Codecov ## 12 | If you are already using [Travis-CI](https://travis-ci.org) or [Appveyor CI](http://www.appveyor.com) add the 13 | following to your project's `.travis.yml` to track your coverage results 14 | over time with [Codecov](https://codecov.io). 15 | 16 | ```yml 17 | r_github_packages: 18 | - jimhester/covr 19 | 20 | after_success: 21 | - Rscript -e 'covr::codecov()' 22 | ``` 23 | 24 | To use a different CI service or call `codecov()` locally you can set the 25 | environment variable `CODECOV_TOKEN` to the token generated on codecov.io. 26 | 27 | Codecov currently has support for the following CI systems (\* denotes support 28 | without needing `CODECOV_TOKEN`). 29 | 30 | - [Jenkins](https://jenkins-ci.org) 31 | - [Travis CI\*](https://travis-ci.com) 32 | - [Codeship](https://www.codeship.io/) 33 | - [Circleci\*](https://circleci.com) 34 | - [Semaphore](https://semaphoreapp.com) 35 | - [drone.io](https://drone.io) 36 | - [AppVeyor\*](http://www.appveyor.com) 37 | - [Wercker](http://wercker.com) 38 | 39 | You will also need to enable the repository on [Codecov](https://codecov.io/). 40 | 41 | ## Coveralls ## 42 | 43 | Alternatively you can upload your results to [Coveralls](https://coveralls.io/) 44 | using `coveralls()`. 45 | 46 | ```yml 47 | r_github_packages: 48 | - jimhester/covr 49 | 50 | after_success: 51 | - Rscript -e 'covr::coveralls()' 52 | ``` 53 | 54 | For CI systems not supported by coveralls you need to set the `COVERALLS_TOKEN` 55 | environment variable. It is wise to use a [Secure Variable](http://docs.travis-ci.com/user/environment-variables/#Secure-Variables) 56 | so that it is not revealed publicly. 57 | 58 | Also you will need to turn on coveralls for your project at . 59 | 60 | # Interactive Usage # 61 | 62 | ## Shiny Application ## 63 | A [shiny](http://shiny.rstudio.com/) Application can be used to 64 | view coverage per line. 65 | ```r 66 | cov <- package_coverage() 67 | 68 | shine(cov) 69 | ``` 70 | 71 | If used with `type = "all", combine_types = FALSE` the Shiny Application will 72 | allow you to interactively toggle between Test, Vignette and Example coverage. 73 | 74 | ```r 75 | cov <- package_coverage(type = "all", combine_types = FALSE) 76 | 77 | shine(cov) 78 | ``` 79 | 80 | ## R Command Line ## 81 | ```r 82 | # if your working directory is in the packages base directory 83 | package_coverage() 84 | 85 | # or a package in another directory 86 | cov <- package_coverage("lintr") 87 | 88 | # view results as a data.frame 89 | as.data.frame(cov) 90 | 91 | # zero_coverage() can be used to filter only uncovered lines. 92 | zero_coverage(cov) 93 | ``` 94 | 95 | # Exclusions # 96 | 97 | `covr` supports a couple of different ways of excluding some or all of a file. 98 | 99 | ## Function Exclusions ## 100 | The `function_exclusions` argument to `package_coverage()` can be used to 101 | exclude functions by name. This argument takes a vector of regular expressions 102 | matching functions to exclude. 103 | 104 | ```r 105 | # exclude print functions 106 | package_coverage(function_exclusions = "print\\.") 107 | 108 | # exclude `.onLoad` function 109 | package_coverage(function_exclusions = "\\.onLoad") 110 | ``` 111 | 112 | ## Line Exclusions ## 113 | The `line_exclusions` argument to `package_coverage()` can be used to exclude some or 114 | all of a file. This argument takes a list of filenames or named ranges to 115 | exclude. 116 | 117 | ```r 118 | # exclude whole file of R/test.R 119 | package_coverage(line_exclusions = "R/test.R") 120 | 121 | # exclude lines 1 to 10 and 15 from R/test.R 122 | package_coverage(line_exclusions = list("R/test.R" = c(1:10, 15))) 123 | 124 | # exclude lines 1 to 10 from R/test.R, all of R/test2.R 125 | package_coverage(line_exclusions = list("R/test.R" = c(1, 10), "R/test2.R")) 126 | ``` 127 | 128 | ## Exclusion Comments ## 129 | 130 | In addition you can exclude lines from the coverage by putting special comments 131 | in your source code. 132 | 133 | This can be done per line. 134 | ```r 135 | f1 <- function(x) { 136 | x + 1 # nocov 137 | } 138 | ``` 139 | 140 | Or by specifying a range with a start and end. 141 | ```r 142 | f2 <- function(x) { # nocov start 143 | x + 2 144 | } # nocov end 145 | ``` 146 | 147 | The patterns used can be specified by setting the global options 148 | `covr.exclude_pattern`, `covr.exclude_start`, `covr.exclude_end`. 149 | 150 | 151 | # FAQ # 152 | ## Will covr work with testthat, RUnit, etc... ## 153 | Covr should be compatible with any testing package, it uses 154 | `tools::testInstalledPackage()` to run your packages tests. 155 | 156 | ## Will covr work with alternative compilers such as ICC ## 157 | Covr will _not_ work with `icc`, Intel's compiler as it does not have 158 | [Gcov](https://gcc.gnu.org/onlinedocs/gcc/Gcov.html) compatible output. 159 | 160 | Covr is known to work with clang versions `3.5+` and gcc version `4.2+`. 161 | 162 | If the appropriate gcov version is not on your path you can set the appropriate 163 | location with the `covr.gcov` options. If you set this path to "" it will turn 164 | _off_ coverage of compiled code. 165 | ```r 166 | options(covr.gcov = "path/to/gcov") 167 | ``` 168 | 169 | ## How does covr work? ## 170 | `covr` tracks test coverage by modifying a package's code to add tracking calls 171 | to each call. 172 | 173 | The vignette 174 | [vignettes/how_it_works.Rmd](https://github.com/jimhester/covr/blob/master/vignettes/how_it_works.Rmd) 175 | contains a detailed explanation of the technique and the rational behind it. 176 | 177 | You can view the vignette from within `R` using 178 | 179 | ```r 180 | vignette("how_it_works", package = "covr") 181 | ``` 182 | 183 | ## Why can't covr run during R CMD check ## 184 | Because covr modifies the package code it is possible there are unknown edge 185 | cases where that modification affects the output. In addition when tracking 186 | coverage for compiled code covr compiles the package without optimization, 187 | which _can_ modify behavior (usually due to package bugs which are masked with 188 | higher optimization levels). 189 | 190 | # Alternative Coverage Tools # 191 | - 192 | - 193 | -------------------------------------------------------------------------------- /revdep/README.md: -------------------------------------------------------------------------------- 1 | # Setup 2 | 3 | ## Platform 4 | 5 | |setting |value | 6 | |:--------|:----------------------------| 7 | |version |R version 3.2.4 (2016-03-10) | 8 | |system |x86_64, darwin13.4.0 | 9 | |ui |X11 | 10 | |language |(EN) | 11 | |collate |en_US.UTF-8 | 12 | |tz |America/New_York | 13 | |date |2016-04-05 | 14 | 15 | ## Packages 16 | 17 | |package |* |version |date |source | 18 | |:-------|:--|:-------|:----|:------| 19 | 20 | # Check results 21 | 21 packages 22 | 23 | ## betalink (2.2.1) 24 | Maintainer: Timothee Poisot 25 | 26 | 0 errors | 0 warnings | 0 notes 27 | 28 | ## bnclassify (0.3.2) 29 | Maintainer: Mihaljevic Bojan 30 | Bug reports: http://github.com/bmihaljevic/bnclassify/issues 31 | 32 | 0 errors | 0 warnings | 1 note 33 | 34 | ``` 35 | checking re-building of vignette outputs ... NOTE 36 | Error in re-building vignettes: 37 | ... 38 | pandoc-citeproc: Error in $[38][0]: When expecting a product of 2 values, encountered an Array of 3 elements instead 39 | pandoc: Error running filter /usr/local/bin/pandoc-citeproc 40 | Filter returned error status 1 41 | Error: processing vignette 'introduction.Rmd' failed with diagnostics: 42 | pandoc document conversion failed with error 83 43 | Execution halted 44 | 45 | ``` 46 | 47 | ## bold (0.3.5) 48 | Maintainer: Scott Chamberlain 49 | Bug reports: https://github.com/ropensci/bold/issues 50 | 51 | 0 errors | 0 warnings | 0 notes 52 | 53 | ## cellranger (1.0.0) 54 | Maintainer: Jennifer Bryan 55 | Bug reports: https://github.com/jennybc/cellranger/issues 56 | 57 | 0 errors | 0 warnings | 0 notes 58 | 59 | ## dendextend (1.1.8) 60 | Maintainer: Tal Galili 61 | Bug reports: https://github.com/talgalili/dendextend/issues 62 | 63 | 0 errors | 0 warnings | 3 notes 64 | 65 | ``` 66 | checking package dependencies ... NOTE 67 | Packages which this enhances but not available for checking: 68 | ‘ggdendro’ ‘labeltodendro’ ‘dendroextras’ 69 | 70 | checking installed package size ... NOTE 71 | installed size is 5.7Mb 72 | sub-directories of 1Mb or more: 73 | R 1.0Mb 74 | doc 4.0Mb 75 | 76 | checking Rd cross-references ... NOTE 77 | Packages unavailable to check Rd xrefs: ‘WGCNA’, ‘dendroextras’, ‘moduleColor’, ‘distory’, ‘ggdendro’ 78 | ``` 79 | 80 | ## ggplot2 (2.1.0) 81 | Maintainer: Hadley Wickham 82 | Bug reports: https://github.com/hadley/ggplot2/issues 83 | 84 | 0 errors | 0 warnings | 0 notes 85 | 86 | ## googlesheets (0.2.0) 87 | Maintainer: Jennifer Bryan 88 | Bug reports: https://github.com/jennybc/googlesheets/issues 89 | 90 | 0 errors | 0 warnings | 0 notes 91 | 92 | ## gtable (0.2.0) 93 | Maintainer: Hadley Wickham 94 | 95 | 0 errors | 0 warnings | 0 notes 96 | 97 | ## jqr (0.2.0) 98 | Maintainer: Scott Chamberlain 99 | Bug reports: https://github.com/ropensci/jqr/issues 100 | 101 | 0 errors | 0 warnings | 0 notes 102 | 103 | ## loo (0.1.6) 104 | Maintainer: Jonah Gabry 105 | Bug reports: https://github.com/stan-dev/loo/issues 106 | 107 | 0 errors | 0 warnings | 0 notes 108 | 109 | ## Momocs (1.0.0) 110 | Maintainer: Vincent Bonhomme 111 | Bug reports: https://github.com/vbonhomme/Momocs/issues 112 | 113 | 0 errors | 0 warnings | 1 note 114 | 115 | ``` 116 | checking installed package size ... NOTE 117 | installed size is 5.8Mb 118 | sub-directories of 1Mb or more: 119 | R 1.7Mb 120 | data 1.1Mb 121 | doc 2.2Mb 122 | ``` 123 | 124 | ## optiRum (0.37.3) 125 | Maintainer: Stephanie Locke 126 | Bug reports: https://github.com/stephlocke/optiRum/issues 127 | 128 | 0 errors | 0 warnings | 0 notes 129 | 130 | ## pmc (1.0.1) 131 | Maintainer: Carl Boettiger 132 | Bug reports: https://github.com/cboettig/pmc/issues 133 | 134 | 0 errors | 0 warnings | 1 note 135 | 136 | ``` 137 | checking re-building of vignette outputs ... NOTE 138 | Error in re-building vignettes: 139 | ... 140 | Parameter estimates appear at bounds: 141 | lambda 142 | Warning in fitContinuous(phy = att$cache$phy, model = att$model, ..., ncores = 1) : 143 | Parameter estimates appear at bounds: 144 | lambda 145 | Warning in fitContinuous(phy = att$cache$phy, model = att$model, ..., ncores = 1) : 146 | Parameter estimates appear at bounds: 147 | ... 8 lines ... 148 | Warning in fitContinuous(phy = att$cache$phy, model = att$model, ..., ncores = 1) : 149 | Parameter estimates appear at bounds: 150 | lambda 151 | Warning in fitContinuous(phy = att$cache$phy, model = att$model, ..., ncores = 1) : 152 | Parameter estimates appear at bounds: 153 | lambda 154 | Warning in fitContinuous(phy = att$cache$phy, model = att$model, ..., ncores = 1) : 155 | Parameter estimates appear at bounds: 156 | lambda 157 | 158 | Execution halted 159 | ``` 160 | 161 | ## purrr (0.2.1) 162 | Maintainer: Hadley Wickham 163 | Bug reports: https://github.com/hadley/purrr/issues 164 | 165 | 0 errors | 0 warnings | 0 notes 166 | 167 | ## rvg (0.0.8) 168 | Maintainer: David Gohel 169 | Bug reports: https://github.com/davidgohel/rvg/issues 170 | 171 | 0 errors | 0 warnings | 0 notes 172 | 173 | ## scales (0.4.0) 174 | Maintainer: Hadley Wickham 175 | Bug reports: https://github.com/hadley/scales/issues 176 | 177 | 0 errors | 0 warnings | 0 notes 178 | 179 | ## simmer (3.2.0) 180 | Maintainer: Iñaki Ucar 181 | Bug reports: https://github.com/Enchufa2/simmer/issues 182 | 183 | 0 errors | 0 warnings | 0 notes 184 | 185 | ## SpaDES (1.1.1) 186 | Maintainer: Alex M Chubaty 187 | Bug reports: https://github.com/PredictiveEcology/SpaDES/issues 188 | 189 | 1 error | 0 warnings | 0 notes 190 | 191 | ``` 192 | checking package dependencies ... ERROR 193 | Packages required but not available: 194 | ‘archivist’ ‘CircStats’ ‘DiagrammeR’ ‘ff’ ‘ffbase’ ‘fpCompare’ 195 | ‘RandomFields’ ‘raster’ ‘secr’ 196 | 197 | Packages suggested but not available for checking: 198 | ‘fastshp’ ‘rgdal’ ‘tkrplot’ 199 | 200 | See section ‘The DESCRIPTION file’ in the ‘Writing R Extensions’ 201 | manual. 202 | ``` 203 | 204 | ## svglite (1.1.0) 205 | Maintainer: Hadley Wickham 206 | Bug reports: https://github.com/hadley/svglite/issues 207 | 208 | 0 errors | 0 warnings | 0 notes 209 | 210 | ## tidyr (0.4.1) 211 | Maintainer: Hadley Wickham 212 | Bug reports: https://github.com/hadley/tidyr/issues 213 | 214 | 0 errors | 0 warnings | 0 notes 215 | 216 | ## traits (0.2.0) 217 | Maintainer: Scott Chamberlain 218 | Bug reports: http://www.github.com/ropensci/traits/issues 219 | 220 | 0 errors | 0 warnings | 0 notes 221 | 222 | -------------------------------------------------------------------------------- /R/codecov.R: -------------------------------------------------------------------------------- 1 | #' Run covr on a package and upload the result to codecov.io 2 | #' @param coverage an existing coverage object to submit, if \code{NULL}, 3 | #' \code{\link{package_coverage}} will be called with the arguments from 4 | #' \code{...} 5 | #' @param ... arguments passed to \code{\link{package_coverage}} 6 | #' @param base_url Codecov url (change for Enterprise) 7 | #' @param quiet if \code{FALSE}, print the coverage before submission. 8 | #' @param token a codecov upload token, if \code{NULL} and the environment 9 | #' variable \sQuote{CODECOV_TOKEN} is used. 10 | #' @param commit explicitly set the commit this corresponds to, this is looked 11 | #' up from the service or locally if it is \code{NULL}. 12 | #' @param branch explicitly set the branch this corresponds to, this is looked 13 | #' up from the service or locally if it is \code{NULL}. 14 | #' @export 15 | #' @examples 16 | #' \dontrun{ 17 | #' codecov(path = "test") 18 | #' } 19 | codecov <- function(..., 20 | coverage = NULL, 21 | base_url = "https://codecov.io", 22 | token = NULL, 23 | commit = NULL, 24 | branch = NULL, 25 | quiet = TRUE) { 26 | 27 | if (is.null(coverage)) { 28 | coverage <- package_coverage(quiet = quiet, ...) 29 | } 30 | 31 | if (!quiet) { 32 | print(coverage) 33 | } 34 | 35 | # ------- 36 | # Jenkins 37 | # ------- 38 | if (Sys.getenv("JENKINS_URL") != "") { 39 | # https://wiki.jenkins-ci.org/display/JENKINS/Building+a+software+project 40 | codecov_url <- paste0(base_url, "/upload/v2") # nolint 41 | codecov_query <- list(service = "jenkins", 42 | branch = branch %||% Sys.getenv("GIT_BRANCH"), 43 | commit = commit %||% Sys.getenv("GIT_COMMIT"), 44 | build = Sys.getenv("BUILD_NUMBER"), 45 | build_url = Sys.getenv("BUILD_URL")) 46 | # --------- 47 | # Travis CI 48 | # --------- 49 | } else if (Sys.getenv("CI") == "true" && Sys.getenv("TRAVIS") == "true") { 50 | # http://docs.travis-ci.com/user/ci-environment/#Environment-variables 51 | codecov_url <- paste0(base_url, "/upload/v2") # nolint 52 | codecov_query <- list(branch = branch %||% Sys.getenv("TRAVIS_BRANCH"), 53 | service = "travis", 54 | build = Sys.getenv("TRAVIS_JOB_NUMBER"), 55 | pr = Sys.getenv("TRAVIS_PULL_REQUEST"), 56 | job = Sys.getenv("TRAVIS_JOB_ID"), 57 | slug = Sys.getenv("TRAVIS_REPO_SLUG"), 58 | root = Sys.getenv("TRAVIS_BUILD_DIR"), 59 | commit = commit %||% Sys.getenv("TRAVIS_COMMIT")) 60 | # -------- 61 | # Codeship 62 | # -------- 63 | } else if (Sys.getenv("CI") == "true" && Sys.getenv("CI_NAME") == "codeship") { 64 | # https://www.codeship.io/documentation/continuous-integration/set-environment-variables/ 65 | codecov_url <- paste0(base_url, "/upload/v2") # nolint 66 | codecov_query <- list(service = "codeship", 67 | branch = branch %||% Sys.getenv("CI_BRANCH"), 68 | build = Sys.getenv("CI_BUILD_NUMBER"), 69 | build_url = Sys.getenv("CI_BUILD_URL"), 70 | commit = commit %||% Sys.getenv("CI_COMMIT_ID")) 71 | # --------- 72 | # Circle CI 73 | # --------- 74 | } else if (Sys.getenv("CI") == "true" && Sys.getenv("CIRCLECI") == "true") { 75 | # https://circleci.com/docs/environment-variables 76 | codecov_url <- paste0(base_url, "/upload/v2") # nolint 77 | codecov_query <- list(service = "circleci", 78 | branch = branch %||% Sys.getenv("CIRCLE_BRANCH"), 79 | build = Sys.getenv("CIRCLE_BUILD_NUM"), 80 | owner = Sys.getenv("CIRCLE_PROJECT_USERNAME"), 81 | repo = Sys.getenv("CIRCLE_PROJECT_REPONAME"), 82 | commit = commit %||% Sys.getenv("CIRCLE_SHA1")) 83 | # --------- 84 | # Semaphore 85 | # --------- 86 | } else if (Sys.getenv("CI") == "true" && Sys.getenv("SEMAPHORE") == "true") { 87 | # https://semaphoreapp.com/docs/available-environment-variables.html 88 | codecov_url <- paste0(base_url, "/upload/v2") # nolint 89 | slug_info <- strsplit(Sys.getenv("SEMAPHORE_REPO_SLUG"), "/")[[1]] 90 | codecov_query <- list(service = "semaphore", 91 | branch = branch %||% Sys.getenv("BRANCH_NAME"), 92 | build = Sys.getenv("SEMAPHORE_BUILD_NUMBER"), 93 | owner = slug_info[1], 94 | repo = slug_info[2], 95 | commit = commit %||% Sys.getenv("REVISION")) 96 | # -------- 97 | # drone.io 98 | # -------- 99 | } else if (Sys.getenv("CI") == "true" && Sys.getenv("DRONE") == "true") { 100 | # http://docs.drone.io/env.html 101 | codecov_url <- paste0(base_url, "/upload/v2") # nolint 102 | codecov_query <- list(service = "drone.io", 103 | branch = branch %||% Sys.getenv("DRONE_BRANCH"), 104 | build = Sys.getenv("DRONE_BUILD_NUMBER"), 105 | build_url = Sys.getenv("DRONE_BUILD_URL"), 106 | commit = commit %||% Sys.getenv("DRONE_COMMIT")) 107 | # -------- 108 | # AppVeyor 109 | # -------- 110 | } else if (Sys.getenv("CI") == "True" && Sys.getenv("APPVEYOR") == "True") { 111 | # http://www.appveyor.com/docs/environment-variables 112 | codecov_url <- paste0(base_url, "/upload/v2") # nolint 113 | name_info <- strsplit(Sys.getenv("APPVEYOR_REPO_NAME"), "/")[[1]] 114 | codecov_query <- list(service = "AppVeyor", 115 | branch = branch %||% Sys.getenv("APPVEYOR_REPO_BRANCH"), 116 | build = Sys.getenv("APPVEYOR_BUILD_NUMBER"), 117 | owner = name_info[1], 118 | repo = name_info[2], 119 | commit = commit %||% Sys.getenv("APPVEYOR_REPO_COMMIT")) 120 | # ------- 121 | # Wercker 122 | # ------- 123 | } else if (Sys.getenv("CI") == "true" && Sys.getenv("WERCKER_GIT_BRANCH") != "") { 124 | # http://devcenter.wercker.com/articles/steps/variables.html 125 | codecov_url <- paste0(base_url, "/upload/v2") # nolint 126 | codecov_query <- list(service = "wercker", 127 | branch = branch %||% Sys.getenv("WERCKER_GIT_BRANCH"), 128 | build = Sys.getenv("WERCKER_MAIN_PIPELINE_STARTED"), 129 | owner = Sys.getenv("WERCKER_GIT_OWNER"), 130 | repo = Sys.getenv("WERCKER_GIT_REPOSITORY"), 131 | commit = commit %||% Sys.getenv("WERCKER_GIT_COMMIT")) 132 | # --------- 133 | # Local GIT 134 | # --------- 135 | } else { 136 | codecov_url <- paste0(base_url, "/upload/v2") # nolint 137 | codecov_query <- list(branch = branch %||% local_branch(), 138 | commit = commit %||% current_commit()) 139 | } 140 | 141 | token <- token %||% Sys.getenv("CODECOV_TOKEN") 142 | if (nzchar(token)) { 143 | codecov_query$token <- token 144 | } 145 | 146 | coverage_json <- to_codecov(coverage) 147 | 148 | httr::content(httr::POST(url = codecov_url, query = codecov_query, body = coverage_json, encode = "json")) 149 | } 150 | 151 | to_codecov <- function(x) { 152 | coverages <- lapply(per_line(x), 153 | function(xx) { 154 | xx$coverage <- c(NA, xx$coverage) 155 | xx 156 | }) 157 | 158 | res <- Map(function(coverage, name) { 159 | list( 160 | "name" = jsonlite::unbox(name), 161 | "coverage" = coverage$coverage 162 | ) 163 | }, coverages, names(coverages), USE.NAMES = FALSE) 164 | 165 | jsonlite::toJSON(na = "null", list("files" = res, "uploader" = jsonlite::unbox("R"))) 166 | } 167 | -------------------------------------------------------------------------------- /R/summary_functions.R: -------------------------------------------------------------------------------- 1 | #' Provide percent coverage of package 2 | #' 3 | #' Print the total percent coverage 4 | #' @param x the coverage object returned from \code{\link{package_coverage}} 5 | #' @param ... additional arguments passed to \code{\link{tally_coverage}} 6 | #' @export 7 | percent_coverage <- function(x, ...) { 8 | res <- tally_coverage(x, ...) 9 | 10 | (sum(res$value > 0) / length(res$value)) * 100 11 | } 12 | 13 | #' Tally coverage by line or expression 14 | #' 15 | #' @inheritParams percent_coverage 16 | #' @param by whether to tally coverage by line or expression 17 | #' @export 18 | tally_coverage <- function(x, by = c("line", "expression")) { 19 | df <- as.data.frame(x) 20 | if (NROW(df) == 0) { 21 | return(df) 22 | } 23 | 24 | by <- match.arg(by) 25 | 26 | switch(by, 27 | "line" = { 28 | 29 | # if it already has a line column it has already been tallied. 30 | if (!is.null(df$line)) { 31 | return(df) 32 | } 33 | 34 | # aggregate() can't cope with zero-length data frames anyway. 35 | if (nrow(df) == 0L) { 36 | return(NULL) 37 | } 38 | 39 | # results with NA functions (such as from compiled code) are dropped 40 | # unless NA is a level. 41 | df$functions <- addNA(df$functions) 42 | res <- expand_lines(df) 43 | 44 | res <- aggregate(value ~ filename + functions + line, 45 | data = res, FUN = min, na.action = na.pass) 46 | res$functions <- as.character(res$functions) 47 | 48 | # exclude blank lines from results 49 | if (inherits(x, "coverage")) { 50 | srcfiles <- unique(lapply(x, function(x) attr(x$srcref, "srcfile"))) 51 | 52 | srcfile_names <- vapply(srcfiles, `[[`, character(1), "filename") 53 | 54 | blank_lines <- compact( 55 | setNames(lapply(srcfiles, function(srcfile) attr(srcfile_lines(srcfile), "blanks")), 56 | srcfile_names)) 57 | if (length(blank_lines)) { 58 | blank_lines <- utils::stack(blank_lines) 59 | 60 | non_blanks <- setdiff.data.frame( 61 | res, 62 | blank_lines, 63 | by.x = c("filename", "line"), 64 | by.y = c("ind", "values")) 65 | 66 | res <- res[non_blanks, ] 67 | } 68 | res 69 | } 70 | res[order(res$filename, res$line), ] 71 | }, 72 | 73 | "expression" = df 74 | ) 75 | } 76 | 77 | #' Provide locations of zero coverage 78 | #' 79 | #' When examining the test coverage of a package, it is useful to know if there are 80 | #' any locations where there is \bold{0} test coverage. 81 | #' 82 | #' @param x a coverage object returned \code{\link{package_coverage}} 83 | #' @param ... additional arguments passed to 84 | #' \code{\link{tally_coverage}} 85 | #' @details if used within Rstudio this function outputs the results using the 86 | #' Marker API. 87 | #' @export 88 | zero_coverage <- function(x, ...) { 89 | coverage_data <- tally_coverage(x, ...) 90 | coverage_data <- coverage_data[coverage_data$value == 0, , drop = FALSE] 91 | 92 | res <- coverage_data[ 93 | # need to use %in% rather than explicit indexing because 94 | # tally_coverage returns a df without the columns if 95 | # by is equal to "line" 96 | colnames(coverage_data) %in% 97 | c("filename", 98 | "functions", 99 | "line", 100 | "first_line", 101 | "last_line", 102 | "first_column", 103 | "last_column", 104 | "value")] 105 | 106 | if (getOption("covr.rstudio_source_markers", TRUE) && 107 | rstudioapi::hasFun("sourceMarkers")) { 108 | markers <- markers(coverage_data) 109 | rstudioapi::callFun("sourceMarkers", 110 | name = "covr", 111 | markers = markers, 112 | basePath = attr(x, "package")$path, 113 | autoSelect = "first") 114 | invisible(res) 115 | } else { 116 | res 117 | } 118 | } 119 | 120 | #' Print a coverage object 121 | #' 122 | #' @param x the coverage object to be printed 123 | #' @param group whether to group coverage by filename or function 124 | #' @param by whether to count coverage by line or expression 125 | #' @param ... additional arguments ignored 126 | #' @export 127 | print.coverage <- function(x, group = c("filename", "functions"), by = "line", ...) { 128 | 129 | if (length(x) == 0) { 130 | return() 131 | } 132 | group <- match.arg(group) 133 | 134 | type <- attr(x, "type") 135 | 136 | if (is.null(type) || type == "none") { 137 | type <- NULL 138 | } 139 | 140 | df <- tally_coverage(x, by = by) 141 | 142 | if (!NROW(df)) { 143 | return(invisible()) 144 | } 145 | 146 | percents <- tapply(df$value, df[[group]], FUN = function(x) (sum(x > 0) / length(x)) * 100) 147 | 148 | overall_percentage <- percent_coverage(df, by = by) 149 | 150 | message(crayon::bold( 151 | paste(collapse = " ", 152 | c(attr(x, "package")$package, to_title(type), "Coverage: "))), 153 | format_percentage(overall_percentage)) 154 | 155 | by_coverage <- percents[order(percents, 156 | names(percents))] 157 | 158 | for (i in seq_along(by_coverage)) { 159 | message(crayon::bold(paste0(names(by_coverage)[i], ": ")), 160 | format_percentage(by_coverage[i])) 161 | } 162 | invisible(x) 163 | } 164 | 165 | #' @export 166 | print.coverages <- function(x, ...) { 167 | for (i in seq_along(x)) { 168 | # Add a blank line between consecutive coverage items 169 | if (i != 1) { 170 | message() 171 | } 172 | print(x[[i]], ...) 173 | } 174 | invisible(x) 175 | } 176 | 177 | format_percentage <- function(x) { 178 | color <- if (x >= 90) crayon::green 179 | else if (x >= 75) crayon::yellow 180 | else crayon::red 181 | 182 | color(sprintf("%02.2f%%", x)) 183 | } 184 | 185 | markers <- function(x, ...) UseMethod("markers") 186 | 187 | markers.coverages <- function(x, ...) { 188 | mrks <- unlist(lapply(unname(x), markers), recursive = FALSE) 189 | 190 | mrks <- mrks[order( 191 | vapply(mrks, `[[`, character(1), "file"), 192 | vapply(mrks, `[[`, integer(1), "line"), 193 | vapply(mrks, `[[`, character(1), "message") 194 | )] 195 | 196 | # request source markers 197 | rstudioapi::callFun("sourceMarkers", 198 | name = "covr", 199 | markers = mrks, 200 | basePath = NULL, 201 | autoSelect = "first") 202 | invisible() 203 | } 204 | markers.coverage <- function(x, ...) { 205 | 206 | # generate the markers 207 | markers <- lapply(unname(x), function(xx) { 208 | filename <- getSrcFilename(xx$srcref, full.names = TRUE) 209 | 210 | list( 211 | type = "warning", 212 | file = filename, 213 | line = xx$srcref[1], 214 | column = xx$srcref[2], 215 | message = sprintf("No %s Coverage!", to_title(attr(x, "type"))) 216 | ) 217 | }) 218 | 219 | } 220 | 221 | markers.data.frame <- function(x, type = "test") { # nolint 222 | # generate the markers 223 | markers <- Map(function(filename, line, column) { 224 | list( 225 | type = "warning", 226 | file = filename, 227 | line = line, 228 | column = column %||% 1, 229 | message = sprintf("No %s Coverage!", to_title(type)) 230 | )}, 231 | x$filename, 232 | x$first_line %||% x$line, 233 | x$first_column %||% rep(list(NULL), NROW(x)), 234 | USE.NAMES = FALSE) 235 | } 236 | 237 | # Expand lines given as start and end ranges to enumerate each line 238 | expand_lines <- function(x) { 239 | repeats <- (x$last_line - x$first_line) + 1L 240 | 241 | lines <- unlist(Map(seq, x$first_line, x$last_line)) %||% integer() 242 | 243 | res <- x[rep(seq_len(NROW(x)), repeats), c("filename", "functions", "value")] 244 | res$line <- lines 245 | rownames(res) <- NULL 246 | res 247 | } 248 | -------------------------------------------------------------------------------- /R/shiny.R: -------------------------------------------------------------------------------- 1 | #' Display covr results using a shiny app 2 | #' 3 | #' The shiny app is designed to provide local information to coverage 4 | #' information similar to the coveralls.io website. However it does not and 5 | #' will not track coverage over time. 6 | #' @param x a coverage dataset 7 | #' @param ... additional arguments passed to methods 8 | #' @examples 9 | #' \dontrun{ 10 | #' x <- package_coverage() 11 | #' shine(x) 12 | #' } 13 | #' @export 14 | shine <- function(x, ...) UseMethod("shine") 15 | 16 | shine.default <- function(x, ...) { 17 | stop("shine must be called on a coverage object!", call. = FALSE) 18 | } 19 | 20 | #' @export 21 | shine.coverages <- function(x, ...) { 22 | 23 | loadNamespace("shiny") 24 | 25 | data <- lapply(x, to_shiny_data) 26 | 27 | ui <- shiny::fluidPage( 28 | shiny::includeCSS(system.file("www/shiny.css", package = "covr")), 29 | shiny::column(2, 30 | shiny::radioButtons("type", label = shiny::h3("Coverage Type"), 31 | choices = setNames(names(data), to_title(names(data)))) 32 | ), 33 | shiny::column(8, 34 | shiny::tabsetPanel( 35 | shiny::tabPanel("Files", DT::dataTableOutput(outputId = "file_table")), 36 | shiny::tabPanel("Source", addHighlight(shiny::tableOutput("source_table"))) 37 | ) 38 | ), 39 | title = paste(attr(x, "package")$package, "Coverage")) 40 | 41 | server <- function(input, output, session) { 42 | output$file_table <- DT::renderDataTable( 43 | data[[input$type]]$file_stats, 44 | escape = FALSE, 45 | options = list(searching = FALSE, dom = "t", paging = FALSE), 46 | rownames = FALSE, 47 | callback = DT::JS("table.on('click.dt', 'a', function() { 48 | Shiny.onInputChange('filename', $(this).text()); 49 | $('ul.nav a[data-value=Source]').tab('show'); 50 | });")) 51 | shiny::observe({ 52 | if (!is.null(input$filename)) { 53 | output$source_table <- renderSourceTable(data[[input$type]]$full[[input$filename]]) 54 | } 55 | }) 56 | } 57 | 58 | shiny::runApp(list(ui = ui, server = server), 59 | launch.browser = getOption("viewer", utils::browseURL), 60 | quiet = TRUE 61 | ) 62 | } 63 | 64 | #' @export 65 | shine.coverage <- function(x, ...) { 66 | 67 | loadNamespace("shiny") 68 | 69 | data <- to_shiny_data(x) 70 | 71 | ui <- shiny::fluidPage( 72 | shiny::includeCSS(system.file("www/shiny.css", package = "covr")), 73 | shiny::column(8, offset = 2, 74 | shiny::tabsetPanel( 75 | shiny::tabPanel("Files", DT::dataTableOutput(outputId = "file_table")), 76 | shiny::tabPanel("Source", addHighlight(shiny::tableOutput("source_table"))) 77 | ) 78 | ), 79 | title = paste(attr(x, "package")$package, "Coverage")) 80 | 81 | server <- function(input, output, session) { 82 | output$file_table <- DT::renderDataTable( 83 | data$file_stats, 84 | escape = FALSE, 85 | options = list(searching = FALSE, dom = "t", paging = FALSE), 86 | rownames = FALSE, 87 | callback = DT::JS("table.on('click.dt', 'a', function() { 88 | Shiny.onInputChange('filename', $(this).text()); 89 | $('ul.nav a[data-value=Source]').tab('show'); 90 | });")) 91 | shiny::observe({ 92 | if (!is.null(input$filename)) { 93 | output$source_table <- renderSourceTable(data$full[[input$filename]]) 94 | } 95 | }) 96 | } 97 | 98 | shiny::runApp(list(ui = ui, server = server), 99 | launch.browser = getOption("viewer", utils::browseURL), 100 | quiet = TRUE 101 | ) 102 | } 103 | 104 | to_shiny_data <- function(x) { 105 | coverages <- per_line(x) 106 | 107 | res <- list() 108 | res$full <- lapply(coverages, 109 | function(coverage) { 110 | lines <- coverage$file$file_lines 111 | values <- coverage$coverage 112 | values[is.na(values)] <- "" 113 | data.frame( 114 | line = seq_along(lines), 115 | source = lines, 116 | coverage = values, 117 | stringsAsFactors = FALSE) 118 | }) 119 | nms <- names(coverages) 120 | 121 | # set a temp name if it doesn't exist 122 | nms[nms == ""] <- "" 123 | 124 | names(res$full) <- nms 125 | 126 | res$file_stats <- compute_file_stats(res$full) 127 | 128 | res$file_stats$File <- add_link(names(res$full)) 129 | 130 | res$file_stats <- sort_file_stats(res$file_stats) 131 | 132 | res$file_stats$Coverage <- add_color_box(res$file_stats$Coverage) 133 | 134 | res 135 | } 136 | 137 | compute_file_stats <- function(files) { 138 | do.call("rbind", 139 | lapply(files, 140 | function(file) { 141 | data.frame( 142 | Coverage = sprintf("%.2f", sum(file$coverage > 0) / sum(file$coverage != "") * 100), 143 | Lines = NROW(file), 144 | Relevant = sum(file$coverage != ""), 145 | Covered = sum(file$coverage > 0), 146 | Missed = sum(file$coverage == 0), 147 | `Hits / Line` = sprintf("%.0f", sum(as.numeric(file$coverage), na.rm = TRUE) / sum(file$coverage != "")), 148 | stringsAsFactors = FALSE, 149 | check.names = FALSE) 150 | } 151 | ) 152 | ) 153 | } 154 | 155 | sort_file_stats <- function(stats) { 156 | stats[order(as.numeric(stats$Coverage), -stats$Relevant), 157 | c("Coverage", "File", "Lines", "Relevant", "Covered", "Missed", "Hits / Line")] 158 | } 159 | 160 | add_link <- function(files) { 161 | vapply(files, character(1), FUN = function(file) { 162 | as.character(shiny::a(href = "#", file)) 163 | }) 164 | } 165 | 166 | add_color_box <- function(nums) { 167 | 168 | vapply(nums, character(1), FUN = function(num) { 169 | nnum <- as.numeric(num) 170 | if (nnum > 90) { 171 | as.character(shiny::div(class = "coverage-box coverage-high", num)) 172 | } else if (nnum > 75) { 173 | as.character(shiny::div(class = "coverage-box coverage-medium", num)) 174 | } else { 175 | as.character(shiny::div(class = "coverage-box coverage-low", num)) 176 | } 177 | }) 178 | } 179 | 180 | utils::globalVariables("func", "covr") 181 | 182 | renderSourceTable <- function(expr, env = parent.frame()) { 183 | 184 | shiny::installExprFunction(expr, "func", env) 185 | 186 | shiny::markRenderFunction(shiny::tableOutput, 187 | function() { 188 | data <- func() # nolint 189 | 190 | if (is.null(data) || identical(data, data.frame())) { 191 | return("") 192 | } 193 | 194 | table <- as.character(shiny::tags$table(class = "table-condensed", 195 | shiny::tags$tbody( 196 | lapply(seq_len(NROW(data)), 197 | function(row_num) { 198 | coverage <- data[row_num, "coverage"] 199 | 200 | cov_type <- NULL 201 | if (coverage == 0) { 202 | cov_value <- "!" 203 | cov_type <- "missed" 204 | } else if (coverage > 0) { 205 | cov_value <- shiny::HTML(paste0(data[row_num, "coverage"], "x", collapse = "")) 206 | cov_type <- "covered" 207 | } else { 208 | cov_type <- "never" 209 | cov_value <- "" 210 | } 211 | shiny::tags$tr(class = cov_type, 212 | shiny::tags$td(class = "num", data[row_num, "line"]), 213 | shiny::tags$td(class = "col-sm-12", shiny::pre(class = "language-r", data[row_num, "source"])), 214 | shiny::tags$td(class = "coverage", cov_value) 215 | ) 216 | }) 217 | ) 218 | ) 219 | ) 220 | 221 | paste(sep = "\n", table, "") 226 | }) 227 | } 228 | 229 | addHighlight <- function(x = list()) { 230 | highlight <- htmltools::htmlDependency("highlight.js", "6.2", 231 | system.file(package = "shiny", 232 | "www/shared/highlight"), 233 | script = "highlight.pack.js", 234 | stylesheet = "rstudio.css") 235 | 236 | htmltools::attachDependencies(x, c(htmltools::htmlDependencies(x), list(highlight))) 237 | } 238 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | `%||%` <- function(x, y) { 2 | if (!is.null(x)) { 3 | x 4 | } else { 5 | y 6 | } 7 | } 8 | 9 | compact <- function(x) { 10 | x[vapply(x, length, integer(1)) != 0] 11 | } 12 | 13 | trim <- function(x) { 14 | rex::re_substitutes(x, rex::rex(list(start, spaces) %or% list(spaces, end)), "", global = TRUE) 15 | } 16 | 17 | local_branch <- function(dir = ".") { 18 | withr::with_dir(dir, 19 | branch <- system_output("git", c("rev-parse", "--abbrev-ref", "HEAD")) 20 | ) 21 | trim(branch) 22 | } 23 | 24 | current_commit <- function(dir = ".") { 25 | withr::with_dir(dir, 26 | commit <- system_output("git", c("rev-parse", "HEAD")) 27 | ) 28 | trim(commit) 29 | } 30 | 31 | `[.coverage` <- function(x, i, ...) { 32 | attrs <- attributes(x) 33 | attrs$names <- attrs$names[i] 34 | res <- unclass(x) 35 | res <- res[i] 36 | attributes(res) <- attrs 37 | res 38 | } 39 | 40 | to_title <- function(x) { 41 | rex::re_substitutes(x, 42 | rex::rex(rex::regex("\\b"), capture(any)), 43 | "\\U\\1", 44 | global = TRUE) 45 | } 46 | 47 | srcfile_lines <- memoise::memoise(function(srcfile) { 48 | lines <- getSrcLines(srcfile, 1, Inf) 49 | matches <- rex::re_matches(lines, 50 | rex::rex(start, any_spaces, "#line", spaces, 51 | capture(name = "line_number", digit), spaces, 52 | quotes, capture(name = "filename", anything), quotes)) 53 | 54 | matches <- na.omit(matches) 55 | 56 | filename_match <- which(matches$filename == srcfile$filename) 57 | 58 | if (length(filename_match) == 1) { 59 | 60 | # rownames(matches) is the line number of lines 61 | start <- as.numeric(rownames(matches)[filename_match]) + 1 62 | 63 | # If there is another directive we want to stop at that, otherwise stop at 64 | # the end 65 | end <- if (!is.na(rownames(matches)[filename_match + 1])) { 66 | as.numeric(rownames(matches)[filename_match + 1]) - 1 67 | } else { 68 | length(lines) 69 | } 70 | 71 | # If there are no line directives for the file just use the entire file 72 | } else { 73 | start <- 1 74 | end <- length(lines) 75 | } 76 | 77 | res <- lines[seq(start, end)] 78 | 79 | # Track blank or comment lines so they can be excluded from the result calculations, but only for R files 80 | if (rex::re_matches(srcfile$filename, rex::rex(".", one_of("r", "R"), end))) { 81 | attr(res, "blanks") <- which(rex::re_matches(res, rex::rex(start, any_spaces, maybe("#", anything), end))) 82 | } 83 | res 84 | }) 85 | 86 | traced_files <- function(x) { 87 | res <- list() 88 | filenames <- display_name(x) 89 | for (i in seq_along(x)) { 90 | src_file <- attr(x[[i]]$srcref, "srcfile") 91 | filename <- filenames[[i]] 92 | if (is.null(res[[filename]])) { 93 | lines <- getSrcLines(src_file, 1, Inf) 94 | matches <- rex::re_matches(lines, 95 | rex::rex(start, any_spaces, "#line", spaces, 96 | capture(name = "line_number", digit), spaces, 97 | quotes, capture(name = "filename", anything), quotes)) 98 | 99 | matches <- na.omit(matches) 100 | 101 | filename_match <- which(matches$filename == src_file$filename) 102 | 103 | if (length(filename_match) == 1) { 104 | start <- as.numeric(rownames(matches)[filename_match]) + 1 105 | end <- if (!is.na(rownames(matches)[filename_match + 1])) { 106 | as.numeric(rownames(matches)[filename_match + 1]) - 1 107 | } else { 108 | length(lines) 109 | } 110 | } else { 111 | start <- 1 112 | end <- length(lines) 113 | } 114 | src_file$file_lines <- lines[seq(start, end)] 115 | 116 | res[[filename]] <- src_file 117 | } 118 | } 119 | res 120 | } 121 | 122 | per_line <- function(coverage) { 123 | 124 | files <- traced_files(coverage) 125 | 126 | blank_lines <- lapply(files, function(file) { 127 | which(rex::re_matches(file$file_lines, rex::rex(start, any_spaces, maybe("#", anything), end))) 128 | }) 129 | 130 | file_lengths <- lapply(files, function(file) { 131 | length(file$file_lines) 132 | }) 133 | 134 | res <- lapply(file_lengths, 135 | function(x) { 136 | rep(NA_real_, length.out = x) 137 | }) 138 | 139 | filenames <- display_name(coverage) 140 | for (i in seq_along(coverage)) { 141 | x <- coverage[[i]] 142 | filename <- filenames[[i]] 143 | value <- x$value 144 | for (line in seq(x$srcref[1], x$srcref[3])) { 145 | # if it is not a blank line 146 | if (!line %in% blank_lines[[filename]]) { 147 | 148 | # if current coverage is na or coverage is less than current coverage 149 | if (is.na(res[[filename]][line]) || value < res[[filename]][line]) { 150 | res[[filename]][line] <- value 151 | } 152 | } 153 | } 154 | } 155 | structure( 156 | Map(function(file, coverage) { 157 | structure(list(file = file, coverage = coverage), class = "line_coverage") 158 | }, 159 | files, res), 160 | class = "line_coverages") 161 | } 162 | 163 | if (getRversion() < "3.2.0") { 164 | isNamespaceLoaded <- function(x) x %in% loadedNamespaces() 165 | } 166 | 167 | is_windows <- function() { 168 | .Platform$OS.type == "windows" 169 | } 170 | 171 | as_package <- function(path) { 172 | path <- normalize_path(path) 173 | if (!file.exists(path)) { 174 | stop("`path` is invalid: ", path, call. = FALSE) 175 | } 176 | root <- package_root(path) 177 | 178 | if (is.null(root)) { 179 | stop(sQuote(path), " does not contain a package!", call. = FALSE) 180 | } 181 | 182 | res <- read_description(file.path(root, "DESCRIPTION")) 183 | res$path <- root 184 | 185 | res 186 | } 187 | 188 | package_root <- function(path) { 189 | stopifnot(is.character(path)) 190 | 191 | has_description <- function(path) { 192 | file.exists(file.path(path, "DESCRIPTION")) 193 | } 194 | is_root <- function(path) { 195 | identical(path, dirname(path)) 196 | } 197 | 198 | path <- normalize_path(path) 199 | while (!is_root(path) && !has_description(path)) { 200 | path <- dirname(path) 201 | } 202 | 203 | if (is_root(path)) { 204 | NULL 205 | } else { 206 | path 207 | } 208 | } 209 | 210 | read_description <- function(path) { 211 | if (!length(path) || !file.exists(path)) { 212 | stop("DESCRIPTION file not found at ", sQuote(path), call. = FALSE) 213 | } 214 | 215 | res <- as.list(read.dcf(path)[1, ]) 216 | names(res) <- tolower(names(res)) 217 | res 218 | } 219 | 220 | clean_objects <- function(path) { 221 | files <- list.files(file.path(path, "src"), 222 | pattern = rex::rex(".", 223 | or("o", "sl", "so", "dylib", 224 | "a", "dll", "def"), end), 225 | full.names = TRUE, recursive = TRUE) 226 | unlink(files) 227 | 228 | invisible(files) 229 | } 230 | 231 | # This is not actually an S3 method 232 | # From http://stackoverflow.com/a/34639237/2055486 233 | setdiff.data.frame <- function(x, y, 234 | by = intersect(names(x), names(y)), 235 | by.x = by, by.y = by) { 236 | stopifnot( 237 | is.data.frame(x), 238 | is.data.frame(y), 239 | length(by.x) == length(by.y)) 240 | 241 | !do.call(paste, c(x[by.x], sep = "\30")) %in% do.call(paste, c(y[by.y], sep = "\30")) 242 | } 243 | 244 | `%==%` <- function(x, y) identical(x, y) 245 | 246 | `%!=%` <- function(x, y) !identical(x, y) 247 | 248 | is_na <- function(x) { 249 | !is.null(x) && !is.symbol(x) && is.na(x) 250 | } 251 | 252 | is_brace <- function(x) { 253 | is.symbol(x) && as.character(x) == "{" 254 | } 255 | 256 | modify_name <- function(expr, old, new) { 257 | replace <- function(e) 258 | if (is.name(e) && identical(e, as.name(old))) e <- as.name(new) 259 | else if (length(e) <= 1L) e 260 | else as.call(lapply(e, replace)) 261 | replace(expr) 262 | } 263 | 264 | 265 | # This is the fix for https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16659 266 | match_arg <- base::match.arg 267 | body(match_arg) <- modify_name(body(match_arg), "all", "any") 268 | 269 | # from https://github.com/wch/r-source/blob/2065bd3c09813949e9fa7236d167f1b7ed5c8ba3/src/library/tools/R/check.R#L4134-L4137 270 | env_path <- function(...) { 271 | paths <- c(...) 272 | paste(paths[nzchar(paths)], collapse = .Platform$path.sep) 273 | } 274 | 275 | normalize_path <- function(x) { 276 | path <- normalizePath(x, winslash = "/", mustWork = FALSE) 277 | # Strip any trailing slashes as they are invalid on windows 278 | sub("/*$", "", path) 279 | } 280 | 281 | temp_dir <- function() { 282 | normalize_path(tempdir()) 283 | } 284 | temp_file <- function(pattern = "file", tmpdir = temp_dir(), fileext = "") { 285 | normalize_path(tempfile(pattern, tmpdir, fileext)) 286 | } 287 | -------------------------------------------------------------------------------- /vignettes/how_it_works.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "How does covr work anyway?" 3 | author: "Jim Hester" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{How does covr work anyway} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | \usepackage[utf8]{inputenc} 10 | --- 11 | 12 | # Introduction # 13 | This vignette walks you through the design of covr and breaks down the process 14 | of tracking code execution piece by piece. 15 | 16 | # Other coverage tools # 17 | Prior to writing covr, there were a handful of coverage tools for R code. 18 | [R-coverage](http://r2d2.quartzbio.com/posts/r-coverage-docker.html) by Karl Forner and 19 | [testCoverage](https://github.com/MangoTheCat/testCoverage) by Tom Taverner, Chris Campbell, Suchen Jin were the two 20 | I was most aware of. 21 | 22 | ## R-coverage ## 23 | `R-coverage` provided a very robust solution by modifying 24 | the R source code to instrument the code for each call. Unfortunately this 25 | requires you to patch the R source and getting the changes upstreamed into the 26 | base R distribution would likely be challenging. 27 | 28 | ## Test Coverage ## 29 | `testCoverage` uses an alternate parser of R-3.0 to instrument R 30 | code and record whether the code is run by tests. The package replaces symbols 31 | in the code to be tested with a unique identifier. This is then injected into a 32 | tracing function that will report each time the symbol is called. The first 33 | symbol at each level of the expression tree is traced, allowing the coverage of 34 | code branches to be checked. This is a complicated implementation I do not fully 35 | understand, which is one of the reasons I decided to write `covr`. 36 | 37 | ## Covr ## 38 | Covr takes an approach in-between the two previous tools, modifying the 39 | function definitions by parsing the abstract syntax tree and inserting trace 40 | statements. These modified definitions are then transparently replaced in-place 41 | using C. This allows us to correctly instrument every call and function in a 42 | package without having to resort to alternate parsing or changes to the R 43 | source. 44 | 45 | # Modifying the call tree ## 46 | The core function in covr is 47 | [R/trace_calls.R](https://github.com/jimhester/covr/blob/59e17a5317a0fd69a6701e19317f20e27b6c44f5/R/trace_calls.R#L9-L72). 48 | This function was adapted from 49 | [pryr::modify_lang](https://github.com/hadley/pryr/blob/2ba41e433a59025267570247b933112009691c7a/R/modify-lang.r#L21-L49). 50 | This recursive function modifies each of the leaves (atomic or name objects) of 51 | a R expression by applying a given function to them. For non-leaves we simply 52 | call `modify_lang` recursively in various ways. The logic behind `modify_lang` and 53 | similar functions to parse and modify R's AST is explained in more detail at 54 | [Walking the AST with recursive 55 | functions](http://adv-r.had.co.nz/Expressions.html). 56 | 57 | ```{r eval = FALSE} 58 | modify_lang <- function(x, f, ...) { 59 | recurse <- function(y) { 60 | # if (!is.null(names(y))) names(y) <- f2(names(y)) 61 | lapply(y, modify_lang, f = f, ...) 62 | } 63 | 64 | if (is.atomic(x) || is.name(x)) { 65 | # Leaf 66 | f(x, ...) 67 | } else if (is.call(x)) { 68 | as.call(recurse(x)) 69 | } else if (is.function(x)) { 70 | formals(x) <- modify_lang(formals(x), f, ...) 71 | body(x) <- modify_lang(body(x), f, ...) 72 | x 73 | } else if (is.pairlist(x)) { 74 | # Formal argument lists (when creating functions) 75 | as.pairlist(recurse(x)) 76 | } else if (is.expression(x)) { 77 | # shouldn't occur inside tree, but might be useful top-level 78 | as.expression(recurse(x)) 79 | } else if (is.list(x)) { 80 | # shouldn't occur inside tree, but might be useful top-level 81 | recurse(x) 82 | } else { 83 | stop("Unknown language class: ", paste(class(x), collapse = "/"), 84 | call. = FALSE) 85 | } 86 | } 87 | ``` 88 | 89 | We can use this same framework to instead insert a trace statement before each 90 | call by replacing each call with a call to a counting function followed by the 91 | previous call. Braces (`{`) in R may seem like language syntax, but 92 | they are actually a Primitive function and you can call them like any other 93 | function. 94 | 95 | ```{r} 96 | identical({ 1 + 2; 3 + 4 }, `{`(1 + 2, 3 + 4)) 97 | ``` 98 | Remembering that braces always return the value of the last evaluated 99 | expression we can call a counting function followed by the previous function 100 | substituting `as.call(recurse(x))` in our function above with. 101 | ```{r, eval = FALSE} 102 | `{`(count(), as.call(recurse(x))) 103 | ``` 104 | 105 | ## Source References ## 106 | Now that we have a way to add a counting function to any call in the AST 107 | without changing the output we need a way to determine where in the code source 108 | that function came from. Luckily for us R has a built-in method to provide this 109 | information in the form of source references. When `option(keep.source = 110 | TRUE)` (the default for interactive sessions), a reference to the source code 111 | for functions is stored along with the function definition. This reference is 112 | used to provide the original formatting and comments for the given function 113 | source. In particular each call in a function contains a `srcref` attribute, 114 | which can then be used as a key to count just that call. 115 | 116 | The actual source for `trace_calls` is slightly more complicated because we 117 | want to initialize the counter for each call while we are walking the AST and 118 | there are a few non-calls we also want to count. 119 | 120 | 121 | ## Refining Source References ## 122 | Each statement comes with a source reference. Unfortunately, the following is 123 | counted as one statement: 124 | 125 | ```r 126 | if (x) 127 | y() 128 | ``` 129 | 130 | To work around this, detailed parse data (obtained from a refined version of 131 | `getParseData()`) is analyzed to impute source references at sub-statement 132 | level for `if`, `for` and `while` constructs. 133 | 134 | # Replacing # 135 | After we have our modified function definition how do we re-define the function 136 | to use the updated definition, and ensure that all other functions which call 137 | the old function also use the new definition? You might try redefining the function directly. 138 | 139 | ```{r} 140 | f1 <- function() 1 141 | 142 | f1 <- function() 2 143 | f1() == 2 144 | ``` 145 | 146 | While this does work for the simple case of calling the new function in the 147 | same environment, it fails if the another function calls a function in a 148 | different environment. 149 | ```{r} 150 | env <- new.env() 151 | f1 <- function() 1 152 | env$f2 <- function() f1() + 1 153 | 154 | env$f1 <- function() 2 155 | 156 | env$f2() == 3 157 | ``` 158 | As modifying external environments and correctly restoring them can be tricky 159 | to get correct, we use the C function 160 | [reassign_function](https://github.com/jimhester/covr/blob/9753e0e257b053059b85be90ef6eb614a5af9bba/src/reassign.c#L7-L20), 161 | which is used in `testthat::with_mock()`. This function takes a function name, 162 | environment, old definition, new definition and copies the formals, body, 163 | attributes and environment from the old function to the new function. This 164 | allows you to do an in-place replacement of a given function with a new 165 | function and ensure that all references to the old function will use the new 166 | definition. 167 | 168 | # S4 classes # 169 | R's S3 object oriented classes simply define functions directly in the packages 170 | namespace, so they can be treated the same as any other function. S4 methods 171 | have a more complicated implementation where the function definitions are 172 | placed in an enclosing environment based on the generic method they implement. 173 | This makes getting the function definition more complicated. 174 | ```{r eval = FALSE} 175 | replacements_S4 <- function(env) { 176 | generics <- getGenerics(env) 177 | 178 | unlist(recursive = FALSE, 179 | Map(generics@.Data, generics@package, USE.NAMES = FALSE, 180 | f = function(name, package) { 181 | what <- methodsPackageMetaName("T", paste(name, package, sep = ":")) 182 | 183 | table <- get(what, envir = env) 184 | 185 | lapply(ls(table, all.names = TRUE), replacement, env = table) 186 | }) 187 | ) 188 | } 189 | ``` 190 | `replacements_S4` first gets all the generic functions for the package 191 | environment. Then for each generic function if finds the mangled meta package 192 | name and gets the corresponding environment from the base environment. All of 193 | the functions within this environment are then traced. 194 | 195 | # RC classes # 196 | Similarly to S4 classes reference class (RC) classes define their methods in a 197 | special environment. A similar method is used to add the tracing calls to the 198 | class definition. These calls are then copied to the object methods when the 199 | generator function is run. 200 | 201 | # Compiled code # 202 | ## Gcov ## 203 | Test coverage of compiled code uses a completely different mechanism than that 204 | of R code. Fortunately we can take advantage of 205 | [Gcov](https://gcc.gnu.org/onlinedocs/gcc-4.1.2/gcc/Gcov.html#Gcov), the 206 | built-in coverage tool for [gcc](https://gcc.gnu.org/) and compatible reports 207 | from [clang](http://clang.llvm.org/) versions 3.5 and greater. 208 | 209 | Both of these compilers track execution coverage when given the `--coverage` 210 | flag. In addition it is necessary to turn off compiler optimization `-O0`, 211 | otherwise the coverage output is difficult or impossible to interpret as 212 | multiple lines can be optimized into one, functions can be inlined etc. 213 | 214 | ## Makevars ## 215 | R passes flags defined in `PKG_CFLAGS` to the compiler, however it also has 216 | default flags including `-02` (defined in `$R_HOME/etc/Makeconf`) which need to 217 | be overridden. Unfortunately it is not possible to override the default flags 218 | with environment variables (as the new flags are added to the left of the 219 | defaults rather than the right). However if Make variables are defined in 220 | `~/.R/Makevars` they _are_ used in place of the defaults. 221 | 222 | Therefore we need to temporarily add `-O0 --coverage` to 223 | the Makevars file, then restore the previous state after the coverage is run. 224 | The implementation of this is in 225 | [R/makevars.R](https://github.com/jimhester/covr/blob/9753e0e257b053059b85be90ef6eb614a5af9bba/R/makevars.R). 226 | 227 | ## Subprocess ## 228 | The last hurdle to getting compiled code coverage working properly is that the 229 | coverage output is only produced when the running process ends. Therefore you 230 | cannot run the tests and get the results in the same R process. 231 | `tests::testPackages()` runs a separate R process when running tests, however 232 | we need to modify the package code first before running the tests. 233 | 234 | The current behavior in covr is to install the package to be tested in a 235 | temporary directory, then add calls to the lazy loading code to install a user 236 | hook which modifies the code when it is loaded. We also register a finalizer 237 | which prints the coverage couts when the namespace is unloaded or the R process 238 | exists. These output files are then aggregated together to determine the 239 | coverage. 240 | 241 | This procedure works regardless of the number of child R processes used, so 242 | therefore also works with parallel code. 243 | 244 | # Output Formats # 245 | The output format returned by covr is a very simple one. It consists of a 246 | named character vector, where the names are colon delimited information from 247 | the source references. Namely the file, line and columns the traced call is 248 | from. The value is simply the number of times that given call was called and 249 | the source ref of the original call. There is also an `as.data.frame` method to 250 | make subsetting by various features easy to do 251 | 252 | While `covr` tracks coverage by expression, typically users expect coverage to 253 | be reported by line, so there are functions to convert to line oriented 254 | coverage. 255 | 256 | # Codecov.io and Coveralls.io # 257 | Codecov and Coveralls are a web services to help you track your code coverage 258 | over time, and ensure that all your new code is fully covered. 259 | 260 | They both have simple JSON based APIs to submit and report on coverage. 261 | 262 | # Conclusion # 263 | Covr aims to be a simple easy to understand implementation, hopefully this 264 | vignette helps to explain the rationale behind the package and explain how and 265 | why it works. 266 | -------------------------------------------------------------------------------- /tests/testthat/test-codecov.R: -------------------------------------------------------------------------------- 1 | context("codecov") 2 | ci_vars <- c( 3 | "APPVEYOR" = NA, 4 | "APPVEYOR_BUILD_NUMBER" = NA, 5 | "APPVEYOR_REPO_BRANCH" = NA, 6 | "APPVEYOR_REPO_COMMIT" = NA, 7 | "APPVEYOR_REPO_NAME" = NA, 8 | "BRANCH_NAME" = NA, 9 | "BUILD_NUMBER" = NA, 10 | "BUILD_URL" = NA, 11 | "CI" = NA, 12 | "CIRCLECI" = NA, 13 | "CIRCLE_BRANCH" = NA, 14 | "CIRCLE_BUILD_NUM" = NA, 15 | "CIRCLE_PROJECT_REPONAME" = NA, 16 | "CIRCLE_PROJECT_USERNAME" = NA, 17 | "CIRCLE_SHA1" = NA, 18 | "CI_BRANCH" = NA, 19 | "CI_BUILD_NUMBER" = NA, 20 | "CI_BUILD_URL" = NA, 21 | "CI_COMMIT_ID" = NA, 22 | "CI_NAME" = NA, 23 | "CODECOV_TOKEN" = NA, 24 | "DRONE" = NA, 25 | "DRONE_BRANCH" = NA, 26 | "DRONE_BUILD_NUMBER" = NA, 27 | "DRONE_BUILD_URL" = NA, 28 | "DRONE_COMMIT" = NA, 29 | "GIT_BRANCH" = NA, 30 | "GIT_COMMIT" = NA, 31 | "JENKINS_URL" = NA, 32 | "REVISION" = NA, 33 | "SEMAPHORE" = NA, 34 | "SEMAPHORE_BUILD_NUMBER" = NA, 35 | "SEMAPHORE_REPO_SLUG" = NA, 36 | "TRAVIS" = NA, 37 | "TRAVIS_BRANCH" = NA, 38 | "TRAVIS_COMMIT" = NA, 39 | "TRAVIS_JOB_ID" = NA, 40 | "TRAVIS_JOB_NUMBER" = NA, 41 | "TRAVIS_PULL_REQUEST" = NA, 42 | "TRAVIS_REPO_SLUG" = NA, 43 | "WERCKER_GIT_BRANCH" = NA, 44 | "WERCKER_GIT_COMMIT" = NA, 45 | "WERCKER_GIT_OWNER" = NA, 46 | "WERCKER_GIT_REPOSITORY" = NA, 47 | "WERCKER_MAIN_PIPELINE_STARTED" = NA) 48 | 49 | cov <- package_coverage("TestS4") 50 | 51 | test_that("it generates a properly formatted json file", { 52 | 53 | withr::with_envvar(ci_vars, 54 | with_mock( 55 | `httr::POST` = function(...) list(...), 56 | `httr::content` = identity, 57 | `covr:::local_branch` = function() "master", 58 | `covr:::current_commit` = function() "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3", 59 | 60 | res <- codecov(coverage = cov), 61 | json <- jsonlite::fromJSON(res$body), 62 | 63 | expect_match(json$files$name, "R/TestS4.R"), 64 | expect_equal(json$files$coverage[[1]], 65 | c(NA, NA, NA, NA, NA, NA, NA, 5, 2, NA, 3, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 66 | NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA) 67 | ), 68 | expect_equal(json$uploader, "R") 69 | )) 70 | }) 71 | 72 | test_that("it works with local repos", { 73 | withr::with_envvar(ci_vars, { 74 | 75 | with_mock( 76 | `httr::POST` = function(...) list(...), 77 | `httr::content` = identity, 78 | `covr:::local_branch` = function() "master", 79 | `covr:::current_commit` = function() "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3", 80 | 81 | res <- codecov(coverage = cov), 82 | 83 | expect_match(res$url, "2"), # nolint 84 | expect_match(res$query$branch, "master"), 85 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3") 86 | ) 87 | }) 88 | }) 89 | test_that("it works with local repos and explicit branch and commit", { 90 | withr::with_envvar(ci_vars, { 91 | 92 | with_mock( 93 | `httr::POST` = function(...) list(...), 94 | `httr::content` = identity, 95 | 96 | res <- codecov(coverage = cov, branch = "master", commit = "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3"), 97 | 98 | expect_match(res$url, "/upload/v2"), # nolint 99 | expect_match(res$query$branch, "master"), 100 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3") 101 | ) 102 | }) 103 | }) 104 | test_that("it adds the token to the query if available", { 105 | withr::with_envvar(c( 106 | ci_vars, 107 | "CODECOV_TOKEN" = "codecov_test" 108 | ), 109 | with_mock( 110 | `httr::POST` = function(...) list(...), 111 | `httr::content` = identity, 112 | `covr:::local_branch` = function() "master", 113 | `covr:::current_commit` = function() "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3", 114 | 115 | res <- codecov(coverage = cov), 116 | 117 | expect_match(res$url, "/upload/v2"), # nolint 118 | expect_match(res$query$branch, "master"), 119 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3"), 120 | expect_match(res$query$token, "codecov_test") 121 | ) 122 | ) 123 | }) 124 | test_that("it works with jenkins", { 125 | withr::with_envvar(c( 126 | ci_vars, 127 | "JENKINS_URL" = "jenkins.com", 128 | "GIT_BRANCH" = "test", 129 | "GIT_COMMIT" = "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3", 130 | "BUILD_NUMBER" = "1", 131 | "BUILD_URL" = "http://test.com/tester/test" 132 | ), 133 | 134 | with_mock( 135 | `httr::POST` = function(...) list(...), 136 | `httr::content` = identity, 137 | 138 | res <- codecov(coverage = cov), 139 | 140 | expect_match(res$query$service, "jenkins"), 141 | expect_match(res$query$branch, "test"), 142 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3"), 143 | expect_match(res$query$build, "1"), 144 | expect_match(res$query$build_url, "http://test.com/tester/test") 145 | ) 146 | ) 147 | }) 148 | 149 | test_that("it works with travis normal builds", { 150 | withr::with_envvar(c( 151 | ci_vars, 152 | "CI" = "true", 153 | "TRAVIS" = "true", 154 | "TRAVIS_PULL_REQUEST" = "false", 155 | "TRAVIS_REPO_SLUG" = "tester/test", 156 | "TRAVIS_BRANCH" = "master", 157 | "TRAVIS_JOB_NUMBER" = "100", 158 | "TRAVIS_JOB_ID" = "10", 159 | "TRAVIS_COMMIT" = "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3" 160 | ), 161 | 162 | with_mock( 163 | `httr::POST` = function(...) list(...), 164 | `httr::content` = identity, 165 | 166 | res <- codecov(coverage = cov), 167 | 168 | expect_match(res$query$service, "travis"), 169 | expect_match(res$query$branch, "master"), 170 | expect_match(res$query$job, "10"), 171 | expect_match(res$query$pr, ""), 172 | expect_match(res$query$slug, "tester/test"), 173 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3"), 174 | expect_match(res$query$build, "100") 175 | ) 176 | ) 177 | }) 178 | 179 | test_that("it works with travis pull requests", { 180 | withr::with_envvar(c( 181 | ci_vars, 182 | "CI" = "true", 183 | "TRAVIS" = "true", 184 | "TRAVIS_PULL_REQUEST" = "5", 185 | "TRAVIS_REPO_SLUG" = "tester/test", 186 | "TRAVIS_BRANCH" = "master", 187 | "TRAVIS_JOB_NUMBER" = "100", 188 | "TRAVIS_JOB_ID" = "10", 189 | "TRAVIS_COMMIT" = "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3" 190 | ), 191 | 192 | with_mock( 193 | `httr::POST` = function(...) list(...), 194 | `httr::content` = identity, 195 | 196 | res <- codecov(coverage = cov), 197 | 198 | expect_match(res$query$service, "travis"), 199 | expect_match(res$query$branch, "master"), 200 | expect_match(res$query$job, "10"), 201 | expect_match(res$query$pr, "5"), 202 | expect_match(res$query$slug, "tester/test"), 203 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3"), 204 | expect_match(res$query$build, "100") 205 | ) 206 | ) 207 | }) 208 | 209 | test_that("it works with codeship", { 210 | withr::with_envvar(c( 211 | ci_vars, 212 | "CI" = "true", 213 | "CI_NAME" = "codeship", 214 | "CI_BRANCH" = "master", 215 | "CI_BUILD_NUMBER" = "5", 216 | "CI_BUILD_URL" = "http://test.com/tester/test", 217 | "CI_COMMIT_ID" = "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3" 218 | ), 219 | 220 | with_mock( 221 | `httr::POST` = function(...) list(...), 222 | `httr::content` = identity, 223 | 224 | res <- codecov(coverage = cov), 225 | 226 | expect_match(res$query$service, "codeship"), 227 | expect_match(res$query$branch, "master"), 228 | expect_match(res$query$build, "5"), 229 | expect_match(res$query$build_url, "http://test.com/tester/test"), 230 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3") 231 | ) 232 | ) 233 | }) 234 | test_that("it works with circleci", { 235 | withr::with_envvar(c( 236 | ci_vars, 237 | "CI" = "true", 238 | "CIRCLECI" = "true", 239 | "CIRCLE_BRANCH" = "master", 240 | "CIRCLE_BUILD_NUM" = "5", 241 | "CIRCLE_PROJECT_USERNAME" = "tester", 242 | "CIRCLE_PROJECT_REPONAME" = "test", 243 | "CIRCLE_SHA1" = "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3" 244 | ), 245 | 246 | with_mock( 247 | `httr::POST` = function(...) list(...), 248 | `httr::content` = identity, 249 | 250 | res <- codecov(coverage = cov), 251 | 252 | expect_match(res$query$service, "circleci"), 253 | expect_match(res$query$branch, "master"), 254 | expect_match(res$query$build, "5"), 255 | expect_match(res$query$owner, "tester"), 256 | expect_match(res$query$repo, "test"), 257 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3") 258 | ) 259 | ) 260 | }) 261 | test_that("it works with semaphore", { 262 | withr::with_envvar(c( 263 | ci_vars, 264 | "CI" = "true", 265 | "SEMAPHORE" = "true", 266 | "BRANCH_NAME" = "master", 267 | "SEMAPHORE_BUILD_NUMBER" = "5", 268 | "SEMAPHORE_REPO_SLUG" = "tester/test", 269 | "REVISION" = "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3" 270 | ), 271 | 272 | with_mock( 273 | `httr::POST` = function(...) list(...), 274 | `httr::content` = identity, 275 | 276 | res <- codecov(coverage = cov), 277 | 278 | expect_match(res$query$service, "semaphore"), 279 | expect_match(res$query$branch, "master"), 280 | expect_match(res$query$build, "5"), 281 | expect_match(res$query$owner, "tester"), 282 | expect_match(res$query$repo, "test"), 283 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3") 284 | ) 285 | ) 286 | }) 287 | test_that("it works with drone", { 288 | withr::with_envvar(c( 289 | ci_vars, 290 | "CI" = "true", 291 | "DRONE" = "true", 292 | "DRONE_BRANCH" = "master", 293 | "DRONE_BUILD_NUMBER" = "5", 294 | "DRONE_BUILD_URL" = "http://test.com/tester/test", 295 | "DRONE_COMMIT" = "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3" 296 | ), 297 | 298 | with_mock( 299 | `httr::POST` = function(...) list(...), 300 | `httr::content` = identity, 301 | 302 | res <- codecov(coverage = cov), 303 | 304 | expect_match(res$query$service, "drone.io"), 305 | expect_match(res$query$branch, "master"), 306 | expect_match(res$query$build, "5"), 307 | expect_match(res$query$build_url, "http://test.com/tester/test"), 308 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3") 309 | ) 310 | ) 311 | }) 312 | test_that("it works with AppVeyor", { 313 | withr::with_envvar(c( 314 | ci_vars, 315 | "CI" = "True", 316 | "APPVEYOR" = "True", 317 | "APPVEYOR_REPO_NAME" = "tester/test", 318 | "APPVEYOR_REPO_BRANCH" = "master", 319 | "APPVEYOR_BUILD_NUMBER" = "5", 320 | "APPVEYOR_REPO_COMMIT" = "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3" 321 | ), 322 | 323 | with_mock( 324 | `httr::POST` = function(...) list(...), 325 | `httr::content` = identity, 326 | 327 | res <- codecov(coverage = cov), 328 | 329 | expect_match(res$query$service, "AppVeyor"), 330 | expect_match(res$query$branch, "master"), 331 | expect_match(res$query$build, "5"), 332 | expect_match(res$query$owner, "tester"), 333 | expect_match(res$query$repo, "test"), 334 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3") 335 | ) 336 | ) 337 | }) 338 | test_that("it works with Wercker", { 339 | withr::with_envvar(c( 340 | ci_vars, 341 | "CI" = "true", 342 | "WERCKER_GIT_BRANCH" = "master", 343 | "WERCKER_MAIN_PIPELINE_STARTED" = "5", 344 | "WERCKER_GIT_OWNER" = "tester", 345 | "WERCKER_GIT_REPOSITORY" = "test", 346 | "WERCKER_GIT_COMMIT" = "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3" 347 | ), 348 | 349 | with_mock( 350 | `httr::POST` = function(...) list(...), 351 | `httr::content` = identity, 352 | 353 | res <- codecov(coverage = cov), 354 | 355 | expect_match(res$query$service, "wercker"), 356 | expect_match(res$query$branch, "master"), 357 | expect_match(res$query$build, "5"), 358 | expect_match(res$query$owner, "tester"), 359 | expect_match(res$query$repo, "test"), 360 | expect_match(res$query$commit, "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3") 361 | ) 362 | ) 363 | }) 364 | -------------------------------------------------------------------------------- /R/covr.R: -------------------------------------------------------------------------------- 1 | #' @import methods 2 | #' @importFrom stats aggregate na.omit na.pass setNames 3 | #' @importFrom utils capture.output getSrcFilename relist str 4 | NULL 5 | 6 | rex::register_shortcuts("covr") 7 | 8 | the <- new.env(parent = emptyenv()) 9 | 10 | the$replacements <- list() 11 | 12 | trace_environment <- function(env) { 13 | clear_counters() 14 | 15 | the$replacements <- compact(c( 16 | replacements_S4(env), 17 | replacements_RC(env), 18 | lapply(ls(env, all.names = TRUE), replacement, env = env))) 19 | 20 | lapply(the$replacements, replace) 21 | } 22 | 23 | reset_traces <- function() { 24 | lapply(the$replacements, reset) 25 | } 26 | 27 | save_trace <- function(directory) { 28 | tmp_file <- temp_file("covr_trace_", tmpdir = directory) 29 | saveRDS(.counters, file = tmp_file) 30 | } 31 | 32 | #' Calculate test coverage for specific function. 33 | #' 34 | #' @param fun name of the function. 35 | #' @param env environment the function is defined in. 36 | #' @param code expressions to run. 37 | #' @param enc the enclosing environment which to run the expressions. 38 | #' @export 39 | function_coverage <- function(fun, code = NULL, env = NULL, enc = parent.frame()) { 40 | if (is.function(fun)) { 41 | env <- environment(fun) 42 | 43 | # get name of function, stripping preceding blah:: if needed 44 | fun <- rex::re_substitutes(deparse(substitute(fun)), rex::regex(".*:::?"), "") 45 | } 46 | 47 | clear_counters() 48 | 49 | replacement <- if (!is.null(env)) { 50 | replacement(fun, env) 51 | } else { 52 | replacement(fun) 53 | } 54 | 55 | on.exit({ 56 | reset(replacement) 57 | clear_counters() 58 | }) 59 | 60 | replace(replacement) 61 | eval(code, enc) 62 | structure(as.list(.counters), class = "coverage") 63 | } 64 | 65 | #' Calculate test coverage for sets of files 66 | #' 67 | #' The files in \code{source_files} are first sourced in to a new environment 68 | #' to define functions to be checked. Then they are instrumented to track 69 | #' coverage and the files in the \code{test_files} are sourced. 70 | #' @param source_files Character vector of source files with function 71 | #' definitions to measure coverage 72 | #' @param test_files Character vector of test files with code to test the 73 | #' functions 74 | #' @inheritParams package_coverage 75 | #' @export 76 | file_coverage <- function( 77 | source_files, 78 | test_files, 79 | line_exclusions = NULL, 80 | function_exclusions = NULL) { 81 | 82 | env <- new.env(parent = baseenv()) 83 | 84 | lapply(source_files, 85 | sys.source, keep.source = TRUE, envir = env) 86 | 87 | trace_environment(env) 88 | on.exit({ 89 | reset_traces() 90 | clear_counters() 91 | }) 92 | 93 | lapply(test_files, 94 | sys.source, keep.source = TRUE, envir = env) 95 | coverage <- structure(as.list(.counters), class = "coverage") 96 | 97 | exclude(coverage, 98 | line_exclusions = line_exclusions, 99 | function_exclusions = function_exclusions, 100 | path = NULL) 101 | } 102 | 103 | #' Calculate test coverage for a package 104 | #' 105 | #' @param path file path to the package 106 | #' @param type run the package \sQuote{test}, \sQuote{vignette}, 107 | #' \sQuote{example}, \sQuote{all}, or \sQuote{none}. The default is 108 | #' \sQuote{test}. 109 | #' @param combine_types If \code{TRUE} (the default) the coverage for all types 110 | #' is simply summed into one coverage object. If \code{FALSE} separate objects 111 | #' are used for each type of coverage. 112 | #' @param relative_path whether to output the paths as relative or absolute 113 | #' paths. 114 | #' @param quiet whether to load and compile the package quietly 115 | #' @param clean whether to clean temporary output files after running. 116 | #' @param line_exclusions a named list of files with the lines to exclude from 117 | #' each file. 118 | #' @param function_exclusions a vector of regular expressions matching function 119 | #' names to exclude. Example \code{print\\.} to match print methods. 120 | #' @param code Additional test code to run. 121 | #' @param ... Additional arguments passed to \code{\link[tools]{testInstalledPackage}} 122 | #' @param exclusions \sQuote{Deprecated}, please use \sQuote{line_exclusions} instead. 123 | #' @seealso exclusions 124 | #' @export 125 | package_coverage <- function(path = ".", 126 | type = c("tests", "vignettes", "examples", "all", "none"), 127 | combine_types = TRUE, 128 | relative_path = TRUE, 129 | quiet = TRUE, 130 | clean = TRUE, 131 | line_exclusions = NULL, 132 | function_exclusions = NULL, 133 | code = character(), 134 | ..., 135 | exclusions) { 136 | 137 | if (!missing(exclusions)) { 138 | warning(paste0("`exclusions` is deprecated and will be removed in an upcoming 139 | release. ", "Please use `line_exclusions` instead."), call. = FALSE, 140 | domain = NA) 141 | line_exclusions <- exclusions 142 | } 143 | 144 | pkg <- as_package(path) 145 | 146 | if (missing(type)) { 147 | type <- "tests" 148 | } 149 | 150 | type <- parse_type(type) 151 | 152 | run_separately <- !isTRUE(combine_types) && length(type) > 1 153 | if (run_separately) { 154 | # store the args that were called 155 | called_args <- as.list(match.call())[-1] 156 | 157 | # remove the type 158 | called_args$type <- NULL 159 | res <- list() 160 | for (t in type) { 161 | res[[t]] <- do.call(Recall, c(called_args, type = t)) 162 | attr(res[[t]], "type") <- t 163 | } 164 | 165 | attr(res, "package") <- pkg 166 | class(res) <- "coverages" 167 | return(res) 168 | } 169 | 170 | on.exit(clear_counters()) 171 | 172 | tmp_lib <- temp_file("R_LIBS") 173 | dir.create(tmp_lib) 174 | 175 | flags <- getOption("covr.flags") 176 | 177 | if (is_windows()) { 178 | 179 | # workaround for https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16384 180 | # LDFLAGS is ignored on Windows so we need to also override PKG_LIBS 181 | flags[["PKG_LIBS"]] <- "--coverage" 182 | } 183 | 184 | if (isTRUE(clean)) { 185 | on.exit({ 186 | clean_objects(pkg$path) 187 | clean_gcov(pkg$path) 188 | }, add = TRUE) 189 | } 190 | 191 | # clean any dlls prior to trying to install 192 | clean_objects(pkg$path) 193 | 194 | # install the package in a temporary directory 195 | withr::with_makevars(flags, 196 | utils::install.packages(repos = NULL, lib = tmp_lib, pkg$path, type = "source", INSTALL_opts = c("--example", "--install-tests", "--with-keep.source", "--no-multiarch"), quiet = quiet)) 197 | 198 | # add hooks to the package startup 199 | add_hooks(pkg$package, tmp_lib) 200 | 201 | withr::with_envvar(c( 202 | SHLIB_LIBADD = "--coverage", 203 | R_LIBS_USER = env_path(tmp_lib, Sys.getenv("R_LIBS_USER"))), { 204 | withr::with_libpaths(tmp_lib, action = "prefix", { 205 | withCallingHandlers({ 206 | if ("vignettes" %in% type) { 207 | type <- type[type != "vignettes"] 208 | run_vignettes(pkg, tmp_lib) 209 | } 210 | 211 | if ("examples" %in% type) { 212 | type <- type[type != "examples"] 213 | # testInstalledPackage explicitly sets R_LIBS="" on windows, and does 214 | # not restore it after, so we need to reset it ourselves. 215 | withr::with_envvar(c(R_LIBS = Sys.getenv("R_LIBS")), { 216 | tools::testInstalledPackage(pkg$package, outDir = tmp_lib, types = "examples", lib.loc = tmp_lib, ...) 217 | }) 218 | } 219 | if ("tests" %in% type) { 220 | tools::testInstalledPackage(pkg$package, outDir = tmp_lib, types = "tests", lib.loc = tmp_lib, ...) 221 | } 222 | 223 | run_commands(pkg, tmp_lib, code) 224 | }, 225 | message = function(e) if (quiet) invokeRestart("muffleMessage") else e, 226 | warning = function(e) if (quiet) invokeRestart("muffleWarning") else e) 227 | })}) 228 | 229 | # read tracing files 230 | trace_files <- list.files(path = tmp_lib, pattern = "^covr_trace_[^/]+$", full.names = TRUE) 231 | coverage <- merge_coverage(lapply(trace_files, function(x) as.list(readRDS(x)))) 232 | coverage <- structure(c(coverage, run_gcov(pkg$path, quiet = quiet)), 233 | class = "coverage", 234 | package = pkg, 235 | relative = relative_path) 236 | 237 | exclude(coverage, 238 | line_exclusions = line_exclusions, 239 | function_exclusions = function_exclusions, 240 | path = if (isTRUE(relative_path)) pkg$path else NULL) 241 | } 242 | 243 | # merge multiple coverage outputs together Assumes the order of coverage lines 244 | # is the same in each object, this should always be the case if the objects are 245 | # from the same initial library. 246 | merge_coverage <- function(...) { 247 | objs <- as.list(...) 248 | if (length(objs) == 0) { 249 | return() 250 | } 251 | 252 | x <- objs[[1]] 253 | others <- objs[-1] 254 | 255 | if (getRversion() < "3.2.0") { 256 | lengths <- function(x, ...) vapply(x, length, integer(1L)) 257 | } 258 | stopifnot(all(lengths(others) == length(x))) 259 | 260 | for (y in others) { 261 | for (i in seq_along(x)) { 262 | x[[i]]$value <- x[[i]]$value + y[[i]]$value 263 | } 264 | } 265 | x 266 | } 267 | 268 | parse_type <- function(type) { 269 | type <- match_arg(type, choices = c("tests", "vignettes", "examples", "all", "none"), several.ok = TRUE) 270 | if (type %==% "all") { 271 | type <- c("tests", "vignettes", "examples") 272 | } 273 | 274 | if (length(type) > 1L) { 275 | 276 | if ("all" %in% type) { 277 | stop(sQuote("all"), " must be the only type specified", call. = FALSE) 278 | } 279 | 280 | if ("none" %in% type) { 281 | stop(sQuote("none"), " must be the only type specified", call. = FALSE) 282 | } 283 | } 284 | type 285 | } 286 | 287 | # Run vignettes for a package. This is done in a new process as otherwise the 288 | # finalizer is not called to dump the results. The namespace is first 289 | # explicitly loaded to ensure output even if no vignettes exist. 290 | # @param pkg Package object (from as_package) to run 291 | # @param lib the library path to look in 292 | run_vignettes <- function(pkg, lib) { 293 | outfile <- file.path(lib, paste0(pkg$package, "-Vignette.Rout")) 294 | failfile <- paste(outfile, "fail", sep = "." ) 295 | cat("tools::buildVignettes(dir = '", pkg$path, "')\n", file = outfile, sep = "") 296 | cmd <- paste(shQuote(file.path(R.home("bin"), "R")), 297 | "CMD BATCH --vanilla --no-timing", 298 | shQuote(outfile), shQuote(failfile)) 299 | res <- system(cmd) 300 | if (res != 0) { 301 | stop("Error running Vignettes:\n", paste(readLines(failfile), collapse = "\n")) 302 | } 303 | } 304 | 305 | run_commands <- function(pkg, lib, commands) { 306 | outfile <- file.path(lib, paste0(pkg$package, "-commands.Rout")) 307 | failfile <- paste(outfile, "fail", sep = "." ) 308 | cat( 309 | "library('", pkg$package, "')", 310 | commands, "\n", file = outfile, sep = "") 311 | cmd <- paste(shQuote(file.path(R.home("bin"), "R")), 312 | "CMD BATCH --vanilla --no-timing", 313 | shQuote(outfile), shQuote(failfile)) 314 | res <- system(cmd) 315 | if (res != 0) { 316 | stop("Error running commands:\n", paste(readLines(failfile), collapse = "\n")) 317 | } 318 | } 319 | 320 | # Add hooks to the installed package 321 | # Installed packages have lazy loading code to setup the lazy load database at 322 | # pkg_name/R/pkg_name. This function adds a user level onLoad Hook to the 323 | # package which calls `covr::trace_environment`, so the package environment is 324 | # traced when the package is loaded. 325 | # It also adds a finalizer that saves the tracing information to the package 326 | # namespace environment which is run when the ns is garbage collected or the 327 | # process ends. This ensures the tracing count information will be written 328 | # regardless of how the process terminates. 329 | # @param pkg_name name of the package to add hooks to 330 | # @param lib the library path to look in 331 | add_hooks <- function(pkg_name, lib) { 332 | load_script <- file.path(lib, pkg_name, "R", pkg_name) 333 | lines <- readLines(file.path(lib, pkg_name, "R", pkg_name)) 334 | lines <- append(lines, 335 | c("setHook(packageEvent(pkg, \"onLoad\"), function(...) covr:::trace_environment(ns))", 336 | paste0("reg.finalizer(ns, function(...) { covr:::save_trace(\"", lib, "\") }, onexit = TRUE)")), 337 | length(lines) - 1L) 338 | writeLines(text = lines, con = load_script) 339 | } 340 | --------------------------------------------------------------------------------