Simpler approaching to removing call suffix

NEWS.md

@@ -1,5 +1,6 @@
 # profvis (development version)
 
+* New technique for trimming uninteresting frames from the stack (#130). This requires a new evaluationg model where the code you supply to `profvis()` is turned into the body of a zero-argument anonymous function that is then called by profvis. This subtly changes the semantics of evaluation, but it's very unlikely to affect the type of code that you are typically profiling.
 * Bundled `highlight.js` updated to the latest version 11.10.0.
 * The CSS for profvis code is scoped so that it does not affect other blocks of code, such as those from RMarkdown or Quarto (@wch, #140).
 * profvis now relies on R 4.0.0.

R/profvis.R

@@ -8,10 +8,15 @@
 #' corresponding data file as the `prof_input` argument to
 #' `profvis()`.
 #'
-#' @param expr Expression to profile. Not compatible with `prof_input`.
+#' @param expr Expression to profile. The expression will be turned into the
+#'   body of a zero-argument anonymous function which is then called repeatedly
+#'   as needed.
+#'
 #'   The expression is repeatedly evaluated until `Rprof()` produces
 #'   an output. It can _be_ a quosure injected with [rlang::inject()] but
 #'   it cannot _contain_ injected quosures.
+#'
+#'   Not compatible with `prof_input`.
 #' @param interval Interval for profiling samples, in seconds. Values less than
 #'   0.005 (5 ms) will probably not result in accurate timings
 #' @param prof_output Name of an Rprof output file or directory in which to save
@@ -171,12 +176,16 @@
     if (remove_on_exit) {
       on.exit(unlink(prof_output), add = TRUE)
     }
-    repeat {
-      # Work around https://github.com/r-lib/rlang/issues/1749
-      eval(substitute(delayedAssign("expr", expr_q, eval.env = env)))
 
+    # We call the quoted expression directly inside a function to make it
+    # easy to detect in both raw and simplified stack traces. The simplified
+    # case is particularly tricky because evaluating a promise fails to create
+    # a call on the trailing edges of the tree returned by simplification
+    `__profvis_execute__` <- new_function(list(), expr_q, env)
+
+    repeat {
       inject(Rprof(prof_output, !!!rprof_args))
-      cnd <- with_profvis_handlers(expr)
+      cnd <- with_profvis_handlers(`__profvis_execute__`())
       Rprof(NULL)
 
       lines <- readLines(prof_output)
@@ -188,12 +197,7 @@
       }
     }
 
-    # Must be in the same handler context as `expr` above to get the
-    # full stack suffix
-    with_profvis_handlers({
-      suffix <- rprof_current_suffix(env, simplify)
-      lines <- gsub(suffix, "", lines)
-    })
+    lines <- gsub('"__profvis_execute__".*$', "", lines)
   } else {
     # If we got here, we were provided a prof_input file instead of expr
     expr_source <- NULL
@@ -308,3 +312,8 @@
   if (!quoted) { expr <- substitute(expr) } # force quoted
   shinyRenderWidget(expr, profvisOutput, env, quoted = TRUE)
 }
+
+
+has_event <- function() {
+  getRversion() >= "4.4.0"
+}

tests/testthat/helper-profvis.R

@@ -1,23 +1,13 @@
-
 TEST_PAUSE_TIME <- 0.050
 
-cat_rprof <- function(expr, ..., rerun = "pause") {
-  out <- inject(rprof_lines({{ expr }}, ..., rerun = rerun))
-  out <- modal_value0(out)
-
-  if (is_null(out)) {
-    abort("Unexpected profile")
-  }
-
-  cat(paste0(out, "\n"))
-}
-
-repro_profvis <- function(expr, ..., rerun = "pause", interval = 0.010) {
-  inject(profvis({{ expr }}, ..., rerun = rerun, interval = interval))
+call_stacks <- function(x) {
+  prof <- x$x$message$prof
+  stacks <- split(prof$label, prof$time)
+  vapply(stacks, paste, "", collapse = " ")
 }
 
-zap_trailing_space <- function(lines) {
-  gsub(" $", "", lines)
+modal_call <- function(x) {
+  modal_value0(call_stacks(x))
 }
 
 profile_calls <- function(x) {

tests/testthat/test-profvis.R

@@ -1,16 +1,39 @@
-test_that("Irrelevant stack is trimmed from profiles (#123)", {
+test_that("irrelevant stack trimmed from function calls (#123)", {
   skip_on_cran()
   skip_on_covr()
 
   f <- function() pause(TEST_PAUSE_TIME)
+  g <- function() f()
 
-  out <- repro_profvis(f(), simplify = FALSE)
-  expect_equal(profile_mode(out), "pause f")
+  out <- profvis(g(), simplify = TRUE, rerun = "pause")
+  expect_equal(profile_mode(out), "pause f g")
+
+  out <- profvis(g(), simplify = FALSE, rerun = "pause")
+  expect_equal(profile_mode(out), "pause f g")
+})
+
+test_that("irrelevant stack trimmed from inlined code (#130)", {
+  skip_on_cran()
+  skip_on_covr()
+
+  out <- profvis(for (i in 1:1e4) rnorm(100), simplify = TRUE, rerun = "rnorm")
+  expect_equal(profile_mode(out), "rnorm")
+
+  out <- profvis(for (i in 1:1e4) rnorm(100), simplify = FALSE, rerun = "rnorm")
+  expect_equal(profile_mode(out), "rnorm")
+})
 
-  out <- profvis(f(), simplify = TRUE, rerun = "pause", interval = 0.005)
+test_that("strips stack above profvis", {
+  skip_on_cran()
+  skip_on_covr()
+
+  f <- function() pause(TEST_PAUSE_TIME)
+  profvis_wrap <- function(...) profvis(...)
+
+  out <- profvis_wrap(f(), simplify = TRUE, rerun = "pause")
   expect_equal(profile_mode(out), "pause f")
 
-  out <- repro_profvis(f(), simplify = TRUE)
+  out <- profvis_wrap(f(), simplify = FALSE, rerun = "pause")
   expect_equal(profile_mode(out), "pause f")
 })
 
@@ -21,7 +44,7 @@ test_that("defaults to elapsed timing", {
 
   f <- function() Sys.sleep(TEST_PAUSE_TIME)
 
-  out <- repro_profvis(f(), rerun = "Sys.sleep")
+  out <- profvis(f(), rerun = "Sys.sleep")
   expect_equal(profile_mode(out), "Sys.sleep f")
 })
 
@@ -30,6 +53,9 @@ test_that("expr and prof_input are mutually exclusive", {
 })
 
 test_that("can capture profile of code with error", {
+  skip_on_cran()
+  skip_on_covr()
+
   f <- function() {
     pause(TEST_PAUSE_TIME)
     stop("error")