Impute srcrefs for subexpressions

NEWS.md

@@ -1,3 +1,5 @@
+* Finer coverage analysis for braceless `if`, `while` and `for` statements (#154, @krlmlr).
+
 ## 1.3.0 ##
 * Set `.libPaths()` in subprocess to match those in calling process (#140, #147).
 * Move devtools dependency to suggests, only needed on windows

R/covr.R

@@ -291,6 +291,8 @@ run_tests <- function(pkg, tmp_lib, dots, type, quiet, use_try = TRUE) {
   }
   withr::with_libpaths(tmp_lib, action = "prefix", {
     ns_env <- loadNamespace(pkg$package)
+    repair_parse_data(ns_env)
+
     env <- new.env(parent = ns_env) # nolint
 
     # directories for vignettes and examples

R/parse_data.R

@@ -0,0 +1,112 @@
+repair_parse_data <- function(env) {
+  srcref <- lapply(as.list(env), attr, "srcref")
+  srcfile <- lapply(srcref, attr, "srcfile")
+  parse_data <- compact(lapply(srcfile, "[[", "parseData"))
+  if (length(parse_data) == 0L) {
+    warning(paste("Parse data not found, coverage may be inaccurate. Try",
+                  "declaring a function in the last file of your R package."),
+            call. = FALSE)
+    return()
+  }
+
+  if (!all_identical(parse_data)) {
+    warning("Ambiguous parse data, coverage may be inaccurate.",
+            call. = FALSE)
+  }
+
+  original <- compact(lapply(srcfile, "[[", "original"))
+  if (!all_identical(parse_data)) {
+    warning("Ambiguous original file, coverage may be inaccurate.",
+            call. = FALSE)
+  }
+
+  original[[1]][["parseData"]] <- parse_data[[1L]]
+}
+
+get_parse_data <- function(x) {
+  if (inherits(x, "srcref"))
+    get_parse_data(attr(x, "srcfile"))
+  else if (exists("original", x))
+    get_parse_data(x$original)
+  else if (exists("covr_parse_data", x))
+    x$covr_parse_data
+  else if (!is.null(data <- x[["parseData"]])) {
+    tokens <- attr(data, "tokens")
+    data <- t(unclass(data))
+    colnames(data) <- c("line1", "col1", "line2", "col2",
+                        "terminal", "token.num", "id", "parent")
+    x$covr_parse_data <-
+      data.frame(data[, -c(5, 6), drop = FALSE], token = tokens,
+                 terminal = as.logical(data[, "terminal"]),
+                 stringsAsFactors = FALSE)
+    x$covr_parse_data
+  }
+}
+
+
+impute_srcref <- function(x, parent_ref) {
+  if (length(as.character(x[[1L]])) != 1L) return()
+
+  if (is.null(parent_ref)) return(NULL)
+  pd <- get_parse_data(parent_ref)
+  pd_expr <-
+    pd$line1 == parent_ref[[7L]] &
+    pd$col1 == parent_ref[[2L]] &
+    pd$line2 == parent_ref[[8L]] &
+    pd$col2 == parent_ref[[4L]] &
+    pd$token == "expr"
+  pd_expr_idx <- which(pd_expr)
+  if (length(pd_expr_idx) == 0L) return(NULL) # srcref not found in parse data
+
+  stopifnot(length(pd_expr_idx) == 1L)
+  expr_id <- pd$id[pd_expr_idx]
+  pd_child <- pd[pd$parent == expr_id, ]
+
+  line_offset <- parent_ref[[7L]] - parent_ref[[1L]]
+
+  make_srcref <- function(from, to = from) {
+    srcref(
+      attr(parent_ref, "srcfile"),
+      c(pd_child$line1[from] - line_offset,
+        pd_child$col1[from],
+        pd_child$line2[to] - line_offset,
+        pd_child$col2[to],
+        pd_child$col1[from],
+        pd_child$col2[to],
+        pd_child$line1[from],
+        pd_child$line2[to]
+      ))
+  }
+
+  switch(
+    as.character(x[[1L]]),
+    "if" = {
+      src_ref <- list(
+        NULL,
+        make_srcref(2, 4),
+        make_srcref(5),
+        make_srcref(6, 7)
+      )
+      src_ref[seq_along(x)]
+    },
+
+    "for" = {
+      list(
+        NULL,
+        NULL,
+        make_srcref(2),
+        make_srcref(3)
+      )
+    },
+
+    "while" = {
+      list(
+        NULL,
+        make_srcref(3),
+        make_srcref(5)
+      )
+    },
+
+    NULL
+  )
+}

R/trace_calls.R

@@ -33,7 +33,7 @@ trace_calls <- function (x, parent_functions = NULL, parent_ref = NULL) {
         (is.call(x[[3]]) && identical(x[[3]][[1]], as.name("function")))) {
       parent_functions <- c(parent_functions, as.character(x[[2]]))
     }
-    src_ref <- attr(x, "srcref")
+    src_ref <- attr(x, "srcref") %||% impute_srcref(x, parent_ref)
     if (!is.null(src_ref)) {
       as.call(Map(trace_calls, x, src_ref, MoreArgs = list(parent_functions = parent_functions)))
     } else if (!is.null(parent_ref)) {

R/utils.R

@@ -10,6 +10,10 @@ compact <- function(x) {
   x[vapply(x, length, integer(1)) != 0]
 }
 
+all_identical <- function(x) {
+  all(vapply(x, identical, logical(1L), x[[1L]]))
+}
+
 dots <- function(...) {
   eval(substitute(alist(...)))
 }

tests/testthat/TestSummary/R/TestSummary.R

@@ -2,7 +2,10 @@
 #'
 #' @export
 test_me <- function(x, y){
-  x + y
+  if (TRUE)
+    x + y
+  else
+    x - y
 }
 
 #' @export

tests/testthat/test-R6.R

@@ -5,5 +5,5 @@ test_that("R6 methods coverage is reported", {
 
   expect_equal(cov$value, c(5, 2, 3))
   expect_equal(cov$first_line, c(5, 6, 8))
-  expect_equal(cov$last_line, c(9, 6, 8))
+  expect_equal(cov$last_line, c(5, 6, 8))
 })

tests/testthat/test-RC.R

@@ -4,5 +4,5 @@ test_that("RC methods coverage is reported", {
 
   expect_equal(cov$value, c(5, 2, 3))
   expect_equal(cov$first_line, c(5, 6, 8))
-  expect_equal(cov$last_line, c(9, 6, 8))
+  expect_equal(cov$last_line, c(5, 6, 8))
 })

tests/testthat/test-codecov.R

@@ -62,7 +62,7 @@ test_that("it generates a properly formatted json file", {
 
       expect_match(json$files$name, rex::rex("R", one_of("/", "\\"), "TestS4.R")),
       expect_equal(json$files$coverage[[1]],
-        c(NA, NA, NA, NA, NA, NA, NA, 5, 2, 5, 3, 5, NA, NA, NA, NA, NA, NA, NA, NA, NA,
+        c(NA, NA, NA, NA, NA, NA, NA, 5, 2, NA, 3, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
           NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA)
         ),
       expect_equal(json$uploader, "R")

tests/testthat/test-coveralls.R

@@ -67,7 +67,7 @@ test_that("coveralls generates a properly formatted json file", {
       expect_match(json$source_files$name, rex::rex("R", one_of("/", "\\"), "TestS4.R")),
       expect_equal(json$source_files$source, read_file("TestS4/R/TestS4.R")),
       expect_equal(json$source_files$coverage[[1]],
-        c(NA, NA, NA, NA, NA, NA, 5, 2, 5, 3, 5, NA, NA, NA, NA, NA, NA, NA, NA, NA,
+        c(NA, NA, NA, NA, NA, NA, 5, 2, NA, 3, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
           NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA))
     )
   )
@@ -92,7 +92,7 @@ test_that("coveralls can spawn a job using repo_token", {
       expect_match(json$source_files$name, rex::rex("R", one_of("/", "\\"), "TestS4.R")),
       expect_equal(json$source_files$source, read_file("TestS4/R/TestS4.R")),
       expect_equal(json$source_files$coverage[[1]],
-        c(NA, NA, NA, NA, NA, NA, 5, 2, 5, 3, 5, NA, NA, NA, NA, NA, NA, NA, NA, NA,
+        c(NA, NA, NA, NA, NA, NA, 5, 2, NA, 3, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
           NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA, NA, NA, NA, NA, 1, NA))
     )
   )

tests/testthat/test-exclusions.R

@@ -126,9 +126,9 @@ context("exclude")
 test_that("it excludes lines", {
   t1 <- package_coverage("TestSummary")
 
-  expect_equal(length(t1), 2)
-  expect_equal(length(exclude(t1, list("R/TestSummary.R" = 5), path = "TestSummary")), 1)
-  expect_equal(length(exclude(t1, list("R/TestSummary.R" = 10), path = "TestSummary")), 1)
+  expect_equal(length(t1), 4)
+  expect_equal(length(exclude(t1, list("R/TestSummary.R" = 5), path = "TestSummary")), 3)
+  expect_equal(length(exclude(t1, list("R/TestSummary.R" = 13), path = "TestSummary")), 3)
 })
 test_that("it preserves the class", {
   t1 <- package_coverage("TestSummary")

tests/testthat/test-shine.R

@@ -10,7 +10,7 @@ test_that("it works with coverage objects", {
     expect_equal(test_S4$line, 1:38),
 
     expect_equal(test_S4$coverage,
-      c("", "", "", "", "", "", "5", "2", "5", "3", "5", "", "", "", "", "",
+      c("", "", "", "", "", "", "5", "2", "", "3", "", "", "", "", "", "",
       "", "", "", "", "", "", "", "", "1", "", "", "", "",
       "", "1", "", "", "", "", "", "1", "")),
 
@@ -19,10 +19,10 @@ test_that("it works with coverage objects", {
         Coverage = "<div class=\"coverage-box coverage-high\">100.00</div>",
         File = "<a href=\"#\">R/TestS4.R</a>",
         Lines = 38L,
-        Relevant = 8L,
-        Covered = 8L,
+        Relevant = 6L,
+        Covered = 6L,
         Missed = 0L,
-        `Hits / Line` = "3",
+        `Hits / Line` = "2",
         row.names = "R/TestS4.R",
         stringsAsFactors = FALSE,
         check.names = FALSE))
@@ -39,7 +39,7 @@ test_that("it works with coverages objects", {
     expect_equal(test_S4_test$line, 1:38),
 
     expect_equal(test_S4_test$coverage,
-      c("", "", "", "", "", "", "5", "2", "5", "3", "5", "", "", "", "", "",
+      c("", "", "", "", "", "", "5", "2", "", "3", "", "", "", "", "", "",
       "", "", "", "", "", "", "", "", "1", "", "", "", "",
       "", "1", "", "", "", "", "", "1", "")),
 
@@ -48,10 +48,10 @@ test_that("it works with coverages objects", {
         Coverage = "<div class=\"coverage-box coverage-high\">100.00</div>",
         File = "<a href=\"#\">R/TestS4.R</a>",
         Lines = 38L,
-        Relevant = 8L,
-        Covered = 8L,
+        Relevant = 6L,
+        Covered = 6L,
         Missed = 0L,
-        `Hits / Line` = "3",
+        `Hits / Line` = "2",
         row.names = "R/TestS4.R",
         stringsAsFactors = FALSE,
         check.names = FALSE)),
@@ -61,7 +61,7 @@ test_that("it works with coverages objects", {
     expect_equal(test_S4_vignette$line, 1:38),
 
     expect_equal(test_S4_vignette$coverage,
-      c("", "", "", "", "", "", "0", "0", "0", "0", "0", "", "", "", "", "",
+      c("", "", "", "", "", "", "0", "0", "", "0", "", "", "", "", "", "",
         "", "", "", "", "", "", "", "", "0", "", "", "", "", "", "0", "", "",
         "", "", "", "0", "")),
 
@@ -70,9 +70,9 @@ test_that("it works with coverages objects", {
         Coverage = "<div class=\"coverage-box coverage-low\">0.00</div>",
         File = "<a href=\"#\">R/TestS4.R</a>",
         Lines = 38L,
-        Relevant = 8L,
+        Relevant = 6L,
         Covered = 0L,
-        Missed = 8L,
+        Missed = 6L,
         `Hits / Line` = "0",
         row.names = "R/TestS4.R",
         stringsAsFactors = FALSE,

tests/testthat/test-summary.R

@@ -1,13 +1,9 @@
 context("summary_functions")
 
-test_that("Summary gives 50% coverage", {
-  expect_equal(percent_coverage(package_coverage("TestSummary")), 50)
-})
-
-zero_Summary <- zero_coverage(package_coverage("TestSummary"))
-
-test_that("Summary gives 1 lines with 0 coverage", {
-  expect_equal(nrow(zero_Summary), 1)
+test_that("Summary gives 20% coverage and four lines with zero coverage", {
+  cv <- package_coverage("TestSummary")
+  expect_equal(percent_coverage(cv), 20)
+  expect_equal(nrow(zero_coverage(cv)), 4)
 })
 
 test_that("percent_coverage", {
@@ -27,5 +23,5 @@ test_that("percent_coverage", {
   cov <- function_coverage("fun", env = environment(fun), fun())
 
   res <- percent_coverage(cov)
-  expect_equal(res, 85.71429, tolerance = .01)
+  expect_equal(res, 83.333333, tolerance = .01)
 })

vignettes/how_it_works.Rmd

@@ -117,6 +117,20 @@ The actual source for `trace_calls` is slightly more complicated because we
 want to initialize the counter for each call while we are walking the AST and
 there are a few non-calls we also want to count.
 
+
+## Refining Source References ##
+Each statement comes with a source reference. Unfortunately, the following is
+counted as one statement:
+
+```r
+if (x)
+  y()
+```
+
+To work around this, detailed parse data (obtained from a refined version of
+`getParseData()`)  is analyzed to impute source references at sub-statement
+level for `if`, `for` and `while` constructs.
+
 # Replacing #
 After we have our modified function definition how do we re-define the function
 to use the updated definition, and ensure that all other functions which call