seconds_timeout

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: proffer
 Title: Profile R Code and Visualize with 'Pprof'
-Version: 0.2.1.9000
+Version: 0.2.1.9001
 Encoding: UTF-8
 Language: en-US
 License: MIT + file LICENSE
@@ -43,6 +43,7 @@ Imports:
   pingr (>= 2.0.1),
   processx (>= 3.4.0),
   profile (>= 1.0),
+  R.utils,
   RProtoBuf (>= 0.4.14),
   utils,
   withr (>= 2.1.2)

NAMESPACE

@@ -12,6 +12,7 @@ export(serve_rprof)
 export(test_pprof)
 export(to_pprof)
 export(to_rprof)
+importFrom(R.utils,withTimeout)
 importFrom(RProtoBuf,readProtoFiles)
 importFrom(cli,cli_alert_danger)
 importFrom(cli,cli_alert_info)

NEWS.md

@@ -1,6 +1,6 @@
-# proffer 0.2.1.9000 (development)
-
+# proffer 0.2.1.9001 (development)
 
+* Add `seconds_timeout`.
 
 # proffer 0.2.1
 

R/package.R

@@ -19,6 +19,7 @@
 #' @importFrom parallelly freePort
 #' @importFrom processx process
 #' @importFrom profile read_rprof write_pprof
+#' @importFrom R.utils withTimeout
 #' @importFrom RProtoBuf readProtoFiles
 #' @importFrom utils browseURL Rprof
 #' @importFrom withr with_path

R/pprof.R

@@ -40,6 +40,7 @@ test_pprof <- function(
 #'   Results are collected with [record_pprof()].
 #' @return A `processx::process$new()` handle. Use this handle
 #'   to take down the server with `$kill()`.
+#' @inheritParams record_rprof
 #' @inheritParams serve_pprof
 #' @param expr R code to run and profile.
 #' @param ... Additional arguments passed on to [Rprof()]
@@ -53,13 +54,18 @@ test_pprof <- function(
 #' }
 pprof <- function(
   expr,
+  seconds_timeout = Inf,
   host = "localhost",
   port = proffer::random_port(),
   browse = interactive(),
   verbose = TRUE,
   ...
 ) {
-  pprof <- record_pprof(expr, ...)
+  pprof <- record_pprof(
+    expr = expr,
+    seconds_timeout = seconds_timeout,
+    ...
+  )
   serve_pprof(
     pprof = pprof,
     host = host,

R/record.R

@@ -4,18 +4,25 @@
 #'   Profiles are recorded with [record_rprof()]
 #'   and then converted with [to_pprof()].
 #' @return Path to a file with pprof samples.
-#' @param expr An R expression to profile.
+#' @inheritParams record_rprof
 #' @param pprof Path to a file with pprof samples.
 #'   Also returned from the function.
-#' @param ... Additional arguments passed on to [Rprof()]
-#'   via [record_rprof()].
 #' @examples
 #' if (identical(Sys.getenv("PROFFER_EXAMPLES"), "true")) {
 #' # Returns a path to pprof samples.
 #' record_pprof(replicate(1e2, sample.int(1e4)))
 #' }
-record_pprof <- function(expr, pprof = tempfile(), ...) {
-  rprof <- record_rprof(expr, ...)
+record_pprof <- function(
+  expr,
+  seconds_timeout = Inf,
+  pprof = tempfile(),
+  ...
+) {
+  rprof <- record_rprof(
+    expr = expr,
+    seconds_timeout = seconds_timeout,
+    ...
+  )
   to_pprof(rprof, pprof = pprof)
   pprof
 }
@@ -25,6 +32,10 @@ record_pprof <- function(expr, pprof = tempfile(), ...) {
 #' @description Run R code and record Rprof samples.
 #' @return Path to a file with Rprof samples.
 #' @param expr An R expression to profile.
+#' @param seconds_timeout Maximum number of seconds of elapsed time
+#'   to profile `expr`. When the timeout is reached, `proffer` stops running
+#'   `expr` and returns the profiling samples taken during the
+#'   `seconds_timeout` time window.
 #' @param rprof Path to a file with Rprof samples.
 #'   Also returned from the function.
 #' @param ... Additional arguments passed on to [Rprof()].
@@ -33,10 +44,15 @@ record_pprof <- function(expr, pprof = tempfile(), ...) {
 #' # Returns a path to Rprof samples.
 #' record_rprof(replicate(1e2, sample.int(1e4)))
 #' }
-record_rprof <- function(expr, rprof = tempfile(), ...) {
+record_rprof <- function(
+  expr,
+  seconds_timeout = Inf,
+  rprof = tempfile(),
+  ...
+) {
   on.exit(Rprof(NULL))
   Rprof(filename = rprof, ...)
-  expr
+  R.utils::withTimeout(expr, timeout = seconds_timeout, onTimeout = "silent")
   rprof
 }
 

tests/local/test-interactive.R

@@ -38,6 +38,14 @@ test_that("pprof()", {
   px$kill()
 })
 
+test_that("pprof() can time out", {
+  skip("interactive only")
+  start <- as.numeric(proc.time()["elapsed"])
+  px <- pprof(while (TRUE) slow_function(), seconds_timeout = 5)
+  message(as.numeric(proc.time()["elapsed"]) - start)
+  px$kill()
+})
+
 test_that("test_pprof()", {
   skip("interactive only")
   # Should launch a browser and show a message.