Определить класс S4, наследуемый от функции

Question

Я пытаюсь написать класс S4, который специально возвращает числовой вектор той же длины, что и ввод. я думаю, что я близок; проблема, с которой я столкнулся сейчас, заключается в том, что я могу создавать новые классы только из функций, которые живут в моем 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”

Преимущество прямого наследования класса от функции заключается в возможности использовать их как обычные функции:

      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

Почему возникает ошибка при передаче функций за пределы глобальной среды?

Answer 1

Это не работает для sqrtпотому что sqrt primitive.

Я не знаю ни одной функции, которая принимает только один аргумент и не является примитивной. Поэтому я урезал вашу валидность, чтобы продемонстрировать, как ваш код работает с другими функциями из предварительно загруженных пакетов:

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

Вот результаты для версии по умолчанию mean

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

Вот обходной путь, изменив initializeчтобы ваш класс ловил примитивы и превращал их в замыкания:

      #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                                    
                                              
      })     

Я получил следующие результаты

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

РЕДАКТИРОВАТЬ:
в комментариях @ekoam предлагает более общую версию initilaize для вашего класса:

      setMethod("initialize", "TransFunc", function(.Object, ...) 
 {maybe_transfunc <- callNextMethod();
      if (is.primitive(maybe_transfunc)) 
          .Object@.Data <- maybe_transfunc 
      else .Object <- maybe_transfunc; 
 .Object})  

РЕДАКТИРОВАТЬ 2:

Подход, предложенный @ekoam, не поддерживает новый класс. Например:

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

Первый предложенный метод работает и поддерживает новый класс. Как обсуждалось в комментариях, другой подход заключается в том, чтобы перехватывать примитивы во время конструктора, а не создавать собственный метод инициализации:

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