Define S4 class inheriting from function

Question

I'm trying to write an S4 class that specifically returns a numeric vector of the same length as the input. I think I'm close; the problem I'm having now is that I can only create new classes from functions that live in my GlobalEnv.

library(S4Vectors) setClass("TransFunc", contains = c("function"), prototype = function(x) x) TransFunc <- function(x) { if (missing(x)) return(new("TransFunc")) new2("TransFunc", x) } .TransFunc.validity <- function(object) { msg <- NULL if (length(formals(object)) > 1) { msg <- c(msg, "TransFunc must only have one argument.") } res1 <- object(1:5) res2 <- object(1:6) if (length(res1) != 5 || length(res2) != 6) { msg <- c(msg, "TransFunc output length must equal input length.") } if (!class(res1) %in% c("numeric", "integer")) { msg <- c(msg, "TransFunc output must be numeric for numeric inputs.") } if (is.null(msg)) return(TRUE) msg } setValidity2(Class = "TransFunc", method = .TransFunc.validity) mysqrt <- TransFunc(function(x) sqrt(x)) mysqrt <- TransFunc(sqrt) ## Errors... why?? ## Error in initialize(value, ...) : ## 'initialize' method returned an object of class “function” instead ## of the required class “TransFunc”

The benefit to having a class inherit from function directly is the ability to use them as regular functions:

mysqrt(1:5) ## [1] 1.000000 1.414214 1.732051 2.000000 2.236068 body(mysqrt) <- expression(sqrt(x)^2) mysqrt(1:10) ## [1] 1 2 3 4 5 6 7 8 9 10

Why does it error when passing functions outside the global env?

dayne · Accepted Answer · 2022-01-18 23:05:10Z

It does not work for sqrt because sqrt is primitive.

I am not aware of any functions that take only one argument and aren't primitive. Therefore I cut your validity down to demonstrate how your code works with other functions from the preloaded packages:

 #using your class definition and counstructor .TransFunc.validity <- function(object) { msg <- NULL res1 <- object(1:5) if (!class(res1) %in% c("numeric", "integer")) { msg <- c(msg, "TransFunc output must be numeric for numeric inputs.") } if (is.null(msg)) return(TRUE) msg } setValidity2(Class = "TransFunc", method = .TransFunc.validity)

Here are the results for the default version of mean

mymean <- TransFunc(mean.default) mymean(1:5) [1] 3

Here is a workaround by modifying initialize for your class to catch primitives and turn them into closures:

#I modified the class definition to use slots instead of prototype setClass("TransFunc", contains = c("function")) TransFunc <- function(x) { if (missing(x)) return(new("TransFunc")) new2("TransFunc", x) } # Keeping your validity I changed initilalize to: setMethod("initialize", "TransFunc", function(.Object, .Data = function(x) x , ...) { if(typeof(.Data) %in% c("builtin", "special")) .Object <- callNextMethod(.Object, function(x) return(.Data(x)),...) else .Object <- callNextMethod(.Object, .Data, ...) .Object })

I got the following results

mysqrt <- TransFunc(sqrt) mysqrt(1:5) [1] 1.000000 1.414214 1.732051 2.000000 2.236068

EDIT:
in the comments @ekoam proposes a more general version of initilaize for your class:

setMethod("initialize", "TransFunc", function(.Object, ...) {maybe_transfunc <- callNextMethod(); if (is.primitive(maybe_transfunc)) [email protected] <- maybe_transfunc else .Object <- maybe_transfunc; .Object})

EDIT 2:

The approach given by @ekoam doesn't maintain the new class. For example:

mysqrt <- TransFunc(sqrt) mysqrt # An object of class "TransFunc" # function (x) .Primitive("sqrt") mysqrt # function (x) .Primitive("sqrt")

The first proposed method DOES work and maintains the new class. As discussed in the comments, another approach is to catch primitives during the constructor, rather than creating a custom initialize method:

library(pryr) TransFunc <- function(x) { if (missing(x)) return(new("TransFunc")) if (is.primitive(x)) { f <- function(y) x(y) # This line isn't strictly necessary, but the actual call # will be obscured and printed as 'x(y)' requiring something # like pryr::unenclose() to understand the behavior. f <- make_function(formals(f), substitute_q(body(f), environment(f))) } else { f <- x } new2("TransFunc", f) }

Great solution. I think we can further generalize it by callNextMethod before the if conditions to use the default method first and then test whether the returned value is primitive or not. In this way, we do not have to manually construct a new anonymous function. Something like this: setMethod("initialize", "TransFunc", function(.Object, ...) {maybe_transfunc <- callNextMethod(); if (is.primitive(maybe_transfunc)) [email protected] <- maybe_transfunc else .Object <- maybe_transfunc; .Object})
With the code in my comment and OP's original setClass(...) and TransFunc, I ran TransFunc(sqrt) and even TransFunc(substitute) and received the expected output. I think as long as the initialize method does not reach the return step, it will not throw an error. Perhaps try the code above on your computer? @GradaGukovic
@dayne since writing my response I realized that the best solution from the point of view of defensive programming is most likely to leave initialize alone and catch primitive functions in the costructor i.e. TransFunc <- function(x) { if (missing(x)) return(new("TransFunc")); if(is.primitive(x)) x <- function(y) return(x(y)); new2("TransFunc", x); } But I am horribly busy and I have no time to test this right now.
The approach worked, although with an extra step so the behavior isn't hidden. Any thoughts on the benefit of one approach vs another?
@dayne I think that modifying the constructor is nicer because it treats the issue, where it appears instead of where it causes the problem. Also I am not a big fan of messing with low-level functionality like initialize(). This makes the code harder to read and maintain. I came up with the initial solution by working up from the traceback() instead of working down from the definition of the class.

Collectives™ on Stack Overflow

Define S4 class inheriting from function

1 Answer 1

9 Comments

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

9 Comments

Related