Writing decorators

library(adorn)

adorn is a framework for writing decorators; it does not ship any. This vignette defines a few common ones using only the public decorator() API, so they double as examples for writing your own. Copy any of them into your own code.

timed

Call style (the wrapper has ...): the body runs on every call.

timed <- decorator(
  function(f, ..., digits = 3) {
    name <- decorator_context()$name
    start <- proc.time()[["elapsed"]]
    on.exit(message(sprintf(
      "%s took %s s",
      name,
      round(proc.time()[["elapsed"]] - start, digits)
    )))
    f(...)
  },
  name = "timed"
)

slow_add <- timed %@%
  function(x, y = 1) {
    Sys.sleep(0.1)
    x + y
  }
slow_add(2)

#> slow_add took 0.1 s

#> [1] 3

logged

withVisible() keeps functions that return invisible() quiet.

logged <- decorator(
  function(f, ...) {
    name <- decorator_context()$name
    message("-> ", name)
    result <- withVisible(f(...))
    message("<- ", name)
    if (result$visible) result$value else invisible(result$value)
  },
  name = "logged"
)

double <- logged %@% function(x) x * 2
double(21)

#> -> double
#> <- double

#> [1] 42

Decorators stack; the one on the left is outermost.

tracked <- logged %@% timed(digits = 2) %@% function(x) x * 2
tracked(21)

#> -> tracked
#> tracked took 0 s
#> <- tracked

#> [1] 42

decorators(tracked)

#> [1] "logged" "timed" 

memoize

Factory style (no ...): the body runs once, when the function is decorated, so each decorated function gets its own cache. A naive version would key on the raw arguments, making f(1), f(x = 1) and a call that spells out a default three cache entries. This one is adapted from the memoise package. It matches arguments to the formals and fills in defaults before hashing, can ignore arguments with omit_args, takes a custom hash and cache, and keeps invisible() results quiet. The default cache is a cachem memory cache, which evicts the least recently used entries once it passes max_size.

# Adapted from memoise::memoise() (https://github.com/r-lib/memoise).
memoize <- decorator(
  function(
    f,
    omit_args = character(),
    hash = function(x) rlang::hash(x),
    cache = cachem::cache_mem(max_size = 1024 * 1024^2)
  ) {
    # Hash the function once, so each call only hashes its arguments.
    f_hash <- hash(list(formals(f), as.character(body(f))))
    defaults <- Filter(function(x) !identical(x, quote(expr = )), formals(f))

    function(...) {
      # Match values to formals, then add the defaults that were not supplied.
      matched <- as.list(match.call(f, as.call(c(quote(f), list(...)))))[-1L]
      named <- matched[names(matched) %in% names(formals(f))]
      env <- list2env(named, parent = environment(f))
      missing_defaults <- defaults[setdiff(names(defaults), names(matched))]
      args <- c(matched, lapply(missing_defaults, eval, envir = env))
      args[omit_args] <- NULL

      key <- hash(c(f_hash, args))
      res <- cache$get(key)
      if (inherits(res, "key_missing")) {
        res <- withVisible(f(...))
        cache$set(key, res)
      }
      if (res$visible) res$value else invisible(res$value)
    }
  },
  name = "memoize"
)

calls <- 0
area <- memoize(omit_args = "verbose") %@%
  function(w, h = 2, verbose = FALSE) {
    calls <<- calls + 1
    w * h
  }
area(3)
#> [1] 6
area(w = 3)
#> [1] 6
area(3, 2, verbose = TRUE)
#> [1] 6
calls
#> [1] 1

Any cachem-style cache works: cachem::cache_disk() persists across sessions, and cachem::cache_mem(max_age = 60) expires entries.

once

once <- decorator(
  function(f) {
    done <- FALSE
    value <- NULL
    function(...) {
      if (!done) {
        value <<- f(...)
        done <<- TRUE
      }
      value
    }
  },
  name = "once"
)

draw <- once %@% function() runif(1)
identical(draw(), draw())

#> [1] TRUE

retry

retry <- decorator(
  function(f, ..., times = 3, delay = 0) {
    for (i in seq_len(times)) {
      failed <- FALSE
      result <- tryCatch(withVisible(f(...)), error = function(e) {
        failed <<- TRUE
        e
      })
      if (!failed) {
        return(if (result$visible) result$value else invisible(result$value))
      }
      if (i < times && delay > 0) Sys.sleep(delay)
    }
    stop(result)
  },
  name = "retry"
)

attempts <- 0
flaky <- retry(times = 3) %@%
  function() {
    attempts <<- attempts + 1
    if (attempts < 3) {
      stop("boom")
    }
    "ok"
  }
flaky()

#> [1] "ok"

attempts

#> [1] 3