stopwatch is an experimental R package for high-precision profiling. The package introduces “tickers,” which temporarily mock an inputted function with a wrapper of the function that records the elapsed time of the call to the inputted function and stores it for later exploration.
This package is experimental and quite unsafe. Use with caution! I wrote this package for my own purposes and it is quite buggy outside of the context I’m interested in using it in.
You can install the development version of stopwatch like so:
pak::pak("simonpcouch/stopwatch")
As an example, we’ll fit a linear model, timing how long the call to stats::lm() takes. First, loading the package:
Now, we set up a “ticker” for stats::lm() like so:
lm_ticker <- tick("lm", "stats")
The result is a ticker:
lm_ticker #> A <ticker> for `stats::lm()`.
Also, though, tick() has provided a new binding to the stats::lm() function:
stats::lm
#> function (...)
#> {
#> timings <- bench::system_time({
#> res <- eval(call2(ticker_fn(ticker), ...))
#> })[[measure]]
#> ticks_[[as.character(ticker)]] <- c(ticks_[[as.character(ticker)]],
#> timings)
#> res
#> }
#> <bytecode: 0x125285218>
#> <environment: 0x125266bb8>
The new binding for stats::lm() calls the original stats::lm() definition, but wraps that call in bench::system_time(), which returns high-precision timings for its input. It then stores the resulting timings before returning the output from the original stats::lm() call.
So, moving on to fitting that linear model:
lm_res <- stats::lm(mpg ~ ., mtcars)
Again, the result is the same as it would be if we had called stats::lm() without establishing a ticker for it (albeit with a different call):
coef(lm_res) #> (Intercept) cyl disp hp drat wt #> 12.30337416 -0.11144048 0.01333524 -0.02148212 0.78711097 -3.71530393 #> qsec vs am gear carb #> 0.82104075 0.31776281 2.52022689 0.65541302 -0.19941925
The benefit, though, is that we now have information on how long the call to stats::lm() took:
ticks(lm_ticker) #> [1] 0.001956
For as long as the function is enticked, it will record timings for every call:
lm_res2 <- stats::lm(mpg ~ ., mtcars) lm_res3 <- stats::lm(mpg ~ ., mtcars) ticks(lm_ticker) #> [1] 0.001956 0.000603 0.000555
To restore the function to it’s previous definition (and erase the timings associated with the ticker), use untick():
untick(lm_ticker)
stats::lm
#> function (formula, data, subset, weights, na.action, method = "qr",
#> model = TRUE, x = FALSE, y = FALSE, qr = TRUE, singular.ok = TRUE,
#> contrasts = NULL, offset, ...)
#> {
#> ret.x <- x
#> ret.y <- y
#> cl <- match.call()
#> mf <- match.call(expand.dots = FALSE)
#> m <- match(c("formula", "data", "subset", "weights", "na.action",
#> "offset"), names(mf), 0L)
#> mf <- mf[c(1L, m)]
#> mf$drop.unused.levels <- TRUE
#> mf[[1L]] <- quote(stats::model.frame)
#> mf <- eval(mf, parent.frame())
#> if (method == "model.frame")
#> return(mf)
#> else if (method != "qr")
#> warning(gettextf("method = '%s' is not supported. Using 'qr'",
#> method), domain = NA)
#> mt <- attr(mf, "terms")
#> y <- model.response(mf, "numeric")
#> w <- as.vector(model.weights(mf))
#> if (!is.null(w) && !is.numeric(w))
#> stop("'weights' must be a numeric vector")
#> offset <- model.offset(mf)
#> mlm <- is.matrix(y)
#> ny <- if (mlm)
#> nrow(y)
#> else length(y)
#> if (!is.null(offset)) {
#> if (!mlm)
#> offset <- as.vector(offset)
#> if (NROW(offset) != ny)
#> stop(gettextf("number of offsets is %d, should equal %d (number of observations)",
#> NROW(offset), ny), domain = NA)
#> }
#> if (is.empty.model(mt)) {
#> x <- NULL
#> z <- list(coefficients = if (mlm) matrix(NA_real_, 0,
#> ncol(y)) else numeric(), residuals = y, fitted.values = 0 *
#> y, weights = w, rank = 0L, df.residual = if (!is.null(w)) sum(w !=
#> 0) else ny)
#> if (!is.null(offset)) {
#> z$fitted.values <- offset
#> z$residuals <- y - offset
#> }
#> }
#> else {
#> x <- model.matrix(mt, mf, contrasts)
#> z <- if (is.null(w))
#> lm.fit(x, y, offset = offset, singular.ok = singular.ok,
#> ...)
#> else lm.wfit(x, y, w, offset = offset, singular.ok = singular.ok,
#> ...)
#> }
#> class(z) <- c(if (mlm) "mlm", "lm")
#> z$na.action <- attr(mf, "na.action")
#> z$offset <- offset
#> z$contrasts <- attr(x, "contrasts")
#> z$xlevels <- .getXlevels(mt, mf)
#> z$call <- cl
#> z$terms <- mt
#> if (model)
#> z$model <- mf
#> if (ret.x)
#> z$x <- x
#> if (ret.y)
#> z$y <- y
#> if (!qr)
#> z$qr <- NULL
#> z
#> }
#> <bytecode: 0x12534df90>
#> <environment: namespace:stats>
In this example, of course, we could have just called stats::lm() inside of bench::system_time() ourselves and gone on our way. The utility of the package arises when the enticked function is called inside of other functions, such as if we fitted the linear model using the parsnip wrapper parsnip::linear_reg() or resampled the model using tune::fit_resamples().
While stopwatch() looks to testthat::local_mocked_bindings() in most of its principles, it diverges in a couple places. Most importantly, tickers do not clear themselves via exit handlers and must be cleared manually. It is possible to withr::defer({untick(ticker)}) after creating a ticker, and I recommend doing so.
The package does not play nicely with recursive functions.
The package struggles with search paths. I use the package to entick functions from external, non-base packages, and it’s most effective for that use case.
You may be interested in more principled alternatives to this package.
testthat::local_mocked_bindings(), which implements a principled mocking framework.profvis::profvis() for profiling with R.prof_tbl <- function(expr, ..., interval = 0.01) {
file <- withr::local_tempfile()
evalq({
on.exit(Rprof(NULL), add = TRUE, after = FALSE)
Rprof(file, ..., interval = interval, filter.callframes = TRUE)
expr
})
out <- summaryRprof(file)
out_tbl <- tibble::as_tibble(out$by.total, rownames = "fn")
out_tbl |>
dplyr::mutate(fn = gsub("\"", "", fn)) |>
dplyr::arrange(dplyr::desc(self.pct))
}
RetroSearch is an open source project built by @garambo | Open a GitHub Issue
Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo
HTML:
3.2
| Encoding:
UTF-8
| Version:
0.7.4