---
title: "Writing decorators"
output: litedown::html_format
vignette: >
  %\VignetteIndexEntry{Writing decorators}
  %\VignetteEngine{litedown::vignette}
  %\VignetteEncoding{UTF-8}
---

```{r setup}
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.

```{r timed}
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)
```

## logged

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

```{r logged}
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)
```

Decorators stack; the one on the left is outermost.

```{r stack}
tracked <- logged %@% timed(digits = 2) %@% function(x) x * 2
tracked(21)
decorators(tracked)
```

## 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](https://github.com/r-lib/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](https://cachem.r-lib.org) memory cache,
which evicts the least recently used entries once it passes `max_size`.

```{r memoize, eval = FALSE}
# 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

```{r 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())
```

## retry

```{r 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()
attempts
```