Callable S3/S4 Object in R

S4 Example

For S4, we can mark a new S4 class contains (inherits) the “function” class. Here I use an example with IRanges just for illustration.

suppressPackageStartupMessages(library(IRanges))

setClass("IsOverlapWithMe", contains = c("IRanges", "function"))
# The constructor
IsOverlapWithMe <- function (ir) {
    ans <- as(ir, "IsOverlapWithMe")
    ans@.Data <- function (x) {
        this <- sys.function()
        if (sum(countOverlaps(x, this)))
            TRUE
        else
            FALSE
    }
    ans
}
f <- IsOverlapWithMe(IRanges(1, 10))
f
## IsOverlapWithMe object with 1 range and 0 metadata columns:
##           start       end     width
##       <integer> <integer> <integer>
##   [1]         1        10        10

The resulting f is almost same with a normal IRanges. The S4 methods for IRanges can also be applied to it.

start(f)
## [1] 1
end(f)
## [1] 10
width(f)
## [1] 10
shift(f, 10)
## IsOverlapWithMe object with 1 range and 0 metadata columns:
##           start       end     width
##       <integer> <integer> <integer>
##   [1]        11        20        10

However, it is callable, and it returns a boolean value indicating whether the argument overlaps with itself.

f(IRanges(11, 20))
## [1] FALSE
f(IRanges(9, 20))
## [1] TRUE

Lambdify

The following is a function converting a formula to a function. The expression (in the formula) will be stored as an attribute of the resulting function and be evaluated when the resulting function is invoked.

lambdify <- function (formula, ...) {
    expr <- formula[[length(formula)]]

    default.args    <- match.call(expand.dots = FALSE)$...
    additional.args <- all.vars(expr)[! all.vars(expr) %in% names(default.args)]

    args <- c(
        setNames(rep(list(quote(expr=)), length(additional.args)), additional.args),
        default.args
    )

    ans <- function () {
        expr <- attr(sys.function(), "expr")
        eval(expr)
    }
    formals(ans)     <- args
    environment(ans) <- parent.frame()

    attr(ans, "expr") <- expr
    class(ans) <- "lambdified"
    ans
}

print.lambdified <- function (x, ...) {
    cat(sprintf("Lambdified Function from Expression %s\n",
                dQuote(deparse(attr(x, "expr")))))
    print.function(`attributes<-`(x, NULL), ...)
    invisible(x)
}

lambdify(~ a * x + y)
## Lambdified Function from Expression "a * x + y"
## function (a, x, y) 
## {
##     expr <- attr(sys.function(), "expr")
##     eval(expr)
## }

That’s it. We can also specify default arguments with this function.

lamb <- lambdify(~ a * x + y, a = 2 * x)
lamb
## Lambdified Function from Expression "a * x + y"
## function (x, y, a = 2 * x) 
## {
##     expr <- attr(sys.function(), "expr")
##     eval(expr)
## }

lamb(3, 4)
## [1] 22
identical(
    lamb(3, 4),
    with(list(x = 3, y = 4, a = 2 * 3),
         eval(a * x + y))
)
## [1] TRUE

Relevant Packages

I think this approach can only be meaningful in practice when creating special user interface. So far I have seen two packages using this kind of approach.

One is the crayon package for colored terminal output. The functions to generate “colored string” store their “styles” as attributes of the functions, in the function body, sys.function() is used to access the function and further the styles.

library(crayon)
crayon::blue
## Crayon style function, blue: example output.
body(crayon::blue)
## {
##     my_styles <- attr(sys.function(), "_styles")
##     text <- mypaste(...)
##     if (has_color()) {
##         for (st in rev(my_styles)) {
##             text <- st$open %+% gsub(st$close, st$open, text, 
##                 fixed = TRUE) %+% st$close
##         }
##     }
##     text
## }
attributes(crayon::blue)
## $`_styles`
## $`_styles`$blue
## $`_styles`$blue$open
## [1] "\033[34m"
## 
## $`_styles`$blue$close
## [1] "\033[39m"
## 
## 
## 
## $class
## [1] "crayon"

Another one is the memoise package for caching function results. The produced “memoised function” store the caching methods and the original function in the parent environment and access them in function body directly. This approach is different from storing variables in attributes/slots, but the idea can be considered similar.

library(memoise)
func  <- function (x, y) x + y
mfunc <- memoise::memoise(func)
mfunc
## Memoised Function:
## function (x, y) x + y
body(mfunc)
## {
##     called_args <- as.list(match.call())[-1]
##     default_args <- Filter(function(x) !identical(x, quote(expr = )), 
##         as.list(formals()))
##     default_args <- default_args[setdiff(names(default_args), 
##         names(called_args))]
##     args <- c(lapply(called_args, eval, parent.frame()), lapply(default_args, 
##         eval, envir = environment()))
##     hash <- `_cache`$digest(c(body(`_f`), args, lapply(`_additional`, 
##         function(x) eval(x[[2L]], environment(x)))))
##     if (`_cache`$has_key(hash)) {
##         res <- `_cache`$get(hash)
##     }
##     else {
##         res <- withVisible(`_f`(x = x, y = y))
##         `_cache`$set(hash, res)
##     }
##     if (res$visible) {
##         res$value
##     }
##     else {
##         invisible(res$value)
##     }
## }
ls(environment(mfunc))
## [1] "_additional" "_cache"      "_f"

Summary

1. Store variables in attributes/slots of the function.
2. Use sys.function in function body to access the invoked function.