Decorating S3, S4, S7 and R6 methods

library(adorn)

These examples use the timed, logged and memoize decorators from vignette("writing-decorators"), repeated here so this vignette stands alone. The memoize here is a minimal version that keys on the raw arguments and needs no other packages; vignette("writing-decorators") has a fuller one.

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"
)

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"
)

memoize <- decorator(
  function(f) {
    cache <- new.env(parent = emptyenv())
    function(...) {
      key <- paste(deparse(list(...)), collapse = "")
      if (!exists(key, envir = cache, inherits = FALSE)) {
        assign(key, f(...), envir = cache)
      }
      get(key, envir = cache, inherits = FALSE)
    }
  },
  name = "memoize"
)

Defining a method

%@% works wherever you define a function, so it can decorate a method as you write it.

S3

money <- function(x) structure(list(amount = x), class = "money")

print.money <- logged %@% function(x, ...) {
  cat("$", format(x$amount, nsmall = 2), "\n")
  invisible(x)
}

print(money(12.5))
#> -> print.money
#> $ 12.50
#> <- print.money

S4

setClass("Circle", representation(r = "numeric"))
setGeneric("area", function(shape, ...) standardGeneric("area"))
#> [1] "area"

setMethod("area", "Circle", logged %@% function(shape, ...) pi * shape@r^2)

area(new("Circle", r = 2))
#> -> area
#> <- area
#> [1] 12.56637

S7

library(S7)

Dog <- new_class("Dog", properties = list(name = class_character))

speak <- new_generic("speak", "x")
method(speak, Dog) <- logged %@% function(x) paste(x@name, "says woof")

speak(Dog(name = "Rex"))
#> -> method(speak, Dog)
#> <- method(speak, Dog)
#> [1] "Rex says woof"

R6

Decorated methods keep access to self and private, and invisible(self) still chains.

library(R6)

Counter <- R6Class("Counter",
  public = list(
    n = 0,
    add = logged %@% function(k = 1) {
      self$n <- self$n + k
      invisible(self)
    }
  )
)

counter <- Counter$new()
counter$add(2)$add(3)
#> -> add
#> <- add
#> -> add
#> <- add
counter$n
#> [1] 5

A stateful decorator works too. R6 methods belong to the class, so the cache below is shared by every Model object (the key is the argument, not self).

Model <- R6Class("Model", public = list(
  scale = 10,
  predict = memoize %@% function(x) {
    message("computing")
    x * self$scale
  }
))

m <- Model$new()
m$predict(2)
#> computing
#> [1] 20
m$predict(2)
#> [1] 20

Decorating a method that already exists

%@% is for methods you are defining. When the class is already built, perhaps by another package, use decorate() to wrap one of its methods afterwards. Each call adds a layer on the outside, and decorators() lists the stack, outermost first.

S3

Give decorate() the generic’s name as a string and the class. This works for any generic.

format.money <- function(x, ...) paste0("$", x$amount)
decorate("format", timed, class = "money")

format(money(3))
#> format.money took 0 s
#> [1] "$3"

You can also pass the generic function itself with the replacement form, as for the other systems. The generic must call UseMethod() directly, so internal generics such as length() need the string form above.

perimeter <- function(x, ...) UseMethod("perimeter")
perimeter.square <- function(x, ...) 4 * x$side

decorate(perimeter, "square") <- logged

perimeter(structure(list(side = 3), class = "square"))
#> -> perimeter.square
#> <- perimeter.square
#> [1] 12

S4

Give decorate() the generic and the signature.

setClass("Square", representation(side = "numeric"))
setMethod("area", "Square", function(shape, ...) shape@side^2)

decorate(area, logged, signature = "Square")
decorate(area, timed, signature = "Square")

area(new("Square", side = 3))
#> -> area
#> <- area
#> area took 0.001 s
#> [1] 9
decorators(getMethod("area", "Square"))
#> [1] "timed"  "logged"

The replacement form works here too, and mirrors S7’s method(generic, class) <- fn:

decorate(area, "Square") <- logged

area(new("Square", side = 3))
#> -> area
#> -> area
#> <- area
#> area took 0.002 s
#> <- area
#> [1] 9

S7

Give decorate() the generic and the class. The method is wrapped in place.

decorate(speak, timed, class = Dog)

speak(Dog(name = "Rex"))
#> -> method(speak, Dog)
#> <- method(speak, Dog)
#> method(speak, Dog) took 0.002 s
#> [1] "Rex says woof"

The stack can be inspected, and the replacement form mirrors method(generic, class) <- fn:

decorate(speak, Dog) <- memoize

decorators(method(speak, Dog))
#> [1] "memoize" "timed"   "logged"

undecorate() returns the original function. Register it again to remove all the decorators.

method(speak, Dog) <- undecorate(method(speak, Dog))
#> Overwriting method speak(<Dog>)

speak(Dog(name = "Rex"))
#> [1] "Rex says woof"

R6

Give decorate() the name of the method and the class generator as class, the same shape as for S3. Objects created afterwards use the decorated method; objects that already exist keep the old one, because R6 copies methods into each object when it is created.

Resetter <- R6Class("Resetter", public = list(
  n = 0,
  add = function(k = 1) {
    self$n <- self$n + k
    invisible(self)
  },
  reset = function() {
    self$n <- 0
    invisible(self)
  }
))

decorate("add", logged, class = Resetter)

r <- Resetter$new()
r$add(2)$add(3)
#> -> add
#> <- add
#> -> add
#> <- add
r$n
#> [1] 5

Pass several names to decorate several methods at once. Use where for methods that are not public ("public" is the default, the others are "private" and "active").

Safe <- R6Class("Safe",
  public = list(go = function() private$step()),
  private = list(step = function() "ok")
)

decorate("step", logged, class = Safe, where = "private")
Safe$new()$go()
#> -> step
#> <- step
#> [1] "ok"

A method the class only inherits is copied into the class you pass and decorated there. The parent is not changed, as with S7. The copy is a snapshot: decorating the parent again later does not affect it.

Doubler <- R6Class("Doubler", inherit = Resetter)

decorate("reset", timed, class = Doubler)

invisible(Doubler$new()$reset())   # timed
#> reset took 0 s
invisible(Resetter$new()$reset())  # not timed

For public methods the replacement form also works, and takes the same shape as S7’s method(generic, class) <- fn.

decorate(Resetter, "reset") <- logged

invisible(Resetter$new()$reset())
#> -> reset
#> <- reset