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 during 7#' the recursion. 8#' @seealso <http://adv-r.had.co.nz/Expressions.html> 9#' @return a modified expression with count calls inserted before each previous 10#' call. 11#' @keywords internal 12trace_calls <- function (x, parent_functions = NULL, parent_ref = NULL) { 13 14 # Construct the calls by hand to avoid a NOTE from R CMD check 15 count <- function(key, val) { 16 call("if", TRUE, 17 call("{", 18 as.call(list(call(":::", as.symbol("covr"), as.symbol("count")), key)), 19 val 20 ) 21 ) 22 } 23 24 if (is.null(parent_functions)) { 25 parent_functions <- deparse(substitute(x)) 26 } 27 recurse <- function(y) { 28 lapply(y, trace_calls, parent_functions = parent_functions) 29 } 30 31 if (is.atomic(x) || is.name(x)) { 32 if (is.null(parent_ref)) { 33 x 34 } 35 else { 36 if (is_na(x) || is_brace(x)) { 37 x 38 } else { 39 key <- new_counter(parent_ref, parent_functions) # nolint 40 count(key, x) 41 } 42 } 43 } 44 else if (is.call(x)) { 45 src_ref <- attr(x, "srcref") %||% impute_srcref(x, parent_ref) 46 if ((identical(x[[1]], as.name("<-")) || identical(x[[1]], as.name("="))) && # nolint 47 (is.call(x[[3]]) && identical(x[[3]][[1]], as.name("function")))) { 48 parent_functions <- c(parent_functions, as.character(x[[2]])) 49 } 50 51 # do not try to trace curly curly 52 if (identical(x[[1]], as.name("{")) && length(x) == 2 && is.call(x[[2]]) && identical(x[[2]][[1]], as.name("{"))) { 53 as.call(x) 54 } else if (!is.null(src_ref)) { 55 as.call(Map(trace_calls, x, src_ref, MoreArgs = list(parent_functions = parent_functions))) 56 } else if (!is.null(parent_ref)) { 57 key <- new_counter(parent_ref, parent_functions) 58 count(key, as.call(recurse(x))) 59 } else { 60 as.call(recurse(x)) 61 } 62 } 63 else if (is.function(x)) { 64 65 # We cannot trace primitive functions 66 if (is.primitive(x)) { 67 return(x) 68 } 69 70 fun_body <- body(x) 71 72 if (!is.null(attr(x, "srcref")) && 73 (is.symbol(fun_body) || !identical(fun_body[[1]], as.name("{")))) { 74 src_ref <- attr(x, "srcref") 75 key <- new_counter(src_ref, parent_functions) 76 fun_body <- count(key, trace_calls(fun_body, parent_functions)) 77 } else { 78 fun_body <- trace_calls(fun_body, parent_functions) 79 } 80 81 new_formals <- trace_calls(formals(x), parent_functions) 82 if (is.null(new_formals)) new_formals <- list() 83 formals(x) <- new_formals 84 body(x) <- fun_body 85 x 86 } 87 else if (is.pairlist(x)) { 88 as.pairlist(recurse(x)) 89 } 90 else if (is.expression(x)) { 91 as.expression(recurse(x)) 92 } 93 else if (is.list(x)) { 94 recurse(x) 95 } 96 else { 97 message("Unknown language class: ", paste(class(x), collapse = "/"), 98 call. = FALSE) 99 x 100 } 101} 102 103.counters <- new.env(parent = emptyenv()) 104 105#' initialize a new counter 106#' 107#' @param src_ref a [base::srcref()] 108#' @param parent_functions the functions that this srcref is contained in. 109#' @keywords internal 110new_counter <- function(src_ref, parent_functions) { 111 key <- key(src_ref) 112 .counters[[key]]$value <- 0 113 .counters[[key]]$srcref <- src_ref 114 .counters[[key]]$functions <- parent_functions 115 key 116} 117 118#' increment a given counter 119#' 120#' @param key generated with [key()] 121#' @keywords internal 122count <- function(key) { 123 .counters[[key]]$value <- .counters[[key]]$value + 1 124} 125 126#' clear all previous counters 127#' 128#' @keywords internal 129clear_counters <- function() { 130 rm(envir = .counters, list = ls(envir = .counters)) 131} 132 133#' Generate a key for a call 134#' 135#' @param x the srcref of the call to create a key for 136#' @keywords internal 137key <- function(x) { 138 paste(collapse = ":", c(get_source_filename(x), x)) 139} 140 141f1 <- function() { 142 f2 <- function() { 143 2 144 } 145 f2() 146} 147