Определение нового класса функций в R

Итак, я изменяю класс некоторых функций, которые я создаю в R, чтобы добавить атрибут описания, и потому, что я хочу использовать генерические средства S3 для обработки всего для меня. В принципе, у меня есть структура вроде

foo <- function(x) x + 1

addFunction <- function(f, description) {
    class(f) <- c("addFunction", "function")
    attr(f, "description") <- description
    f
}

foo <- addFunction(foo, "Add one")

а затем я делаю что-то вроде

description <- function(x) UseMethod("description")
description.default <- function(x) deparse(substitute(x))
description.addFunction <- function(x) attr(x, "description")

Это прекрасно работает, но это не так уж элегантно. Мне интересно, можно ли определить новый класс функций, чтобы экземпляры этого класса могли быть определены в синтаксисе, подобном синтаксису function. Другими словами, можно ли определить addFunction таким образом, что foo генерируется следующим образом:

foo <- addFunction(description = "Add one", x) {
    x + 1
}

(или что-то подобное, у меня нет сильных чувств относительно того, где атрибут должен быть добавлен к функции)?

Спасибо за чтение!


Обновление. Я уже несколько раз экспериментировал с этой идеей, но пока не достиг каких-либо конкретных результатов - так что это всего лишь обзор моих текущих (обновленных) мыслей по этому вопросу:

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

> function2 <- `function`
> identical(`function`, function2)
[1] TRUE
> function(x) x
function(x) x
> function2(x) x
Error: unexpected symbol in "function2(x) x"
> function2(x)
Error: incorrect number of arguments to "function"

Поскольку function() является примитивной функцией, я попытался взглянуть на C-код, определяющий его для получения дополнительных сведений. Меня особенно заинтриговало сообщение об ошибке из вызова function2(x). C-код, лежащий в основе function(),

/* Declared with a variable number of args in names.c */
  SEXP attribute_hidden do_function(SEXP call, SEXP op, SEXP args, SEXP rho)
{
  SEXP rval, srcref;

  if (TYPEOF(op) == PROMSXP) {
    op = forcePromise(op);
    SET_NAMED(op, 2);
  }
  if (length(args) < 2) WrongArgCount("function");
  CheckFormals(CAR(args));
  rval = mkCLOSXP(CAR(args), CADR(args), rho);
  srcref = CADDR(args);
  if (!isNull(srcref)) setAttrib(rval, R_SrcrefSymbol, srcref);
  return rval;
  }

и из этого я заключаю, что по какой-то причине по крайней мере два из четырех аргументов call, op, args и rho теперь требуются. Из подписи do_function() я предполагаю, что четыре аргумента, переданные в do_function, должны быть вызовом, обещанием, списком аргументов, а затем, возможно, средой. Я попробовал много разных комбинаций для function2 (включая настройку до двух из этих аргументов в NULL), но я продолжаю получать одно и то же (новое) сообщение об ошибке:

> function2(call("sum", 2, 1), NULL, list(x=NULL), baseenv())
Error: invalid formal argument list for "function"
> function2(call("sum", 2, 1), NULL, list(x=NULL), NULL)
Error: invalid formal argument list for "function"

Это сообщение об ошибке возвращается из C-функции CheckFormals(), которую я также искал:

/* used in coerce.c */
  void attribute_hidden CheckFormals(SEXP ls)
{
  if (isList(ls)) {
    for (; ls != R_NilValue; ls = CDR(ls))
      if (TYPEOF(TAG(ls)) != SYMSXP)
        goto err;
    return;
  }
  err:
    error(_("invalid formal argument list for \"function\""));
  }

Я вообще не владею C, поэтому отсюда я не совсем уверен, что делать дальше.

Итак, это мои обновленные вопросы:

  • Почему function и function2 не ведут себя одинаково? Зачем мне нужно вызвать function2, используя другой синтаксис, когда они считается идентичным в R?
  • Каковы правильные аргументы function2 такой, что function2([arguments]) будет фактически определять функцию?

Ответ 1

Некоторые ключевые слова в R, такие как if и function, имеют специальный синтаксис в том, как вызываются базовые функции. Легко использовать if как функцию, если желательно, например.

`if`(1 == 1, "True", "False")

эквивалентно

if (1 == 1) {
  "True"
} else {
  "False"
}

function сложнее. Там какая-то помощь в этом на предыдущем вопросе.

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

# Your S3 methods
description <- function(x) UseMethod("description")
description.default <- function(x) deparse(substitute(x))
description.addFunction <- function(x) attr(x, "description")

# Creates the pairlist for arguments, handling arguments with no defaults
# properly. Also brings in the description
addFunction <- function(description, ...) {
  args <- eval(substitute(alist(...)))
  tmp <- names(args)
  if (is.null(tmp)) tmp <- rep("", length(args))
  names(args)[tmp==""] <- args[tmp==""]
  args[tmp==""] <- list(alist(x=)$x)
  list(args = as.pairlist(args), description = description)
}

# Actually creates the function using the structure created by addFunction and the body
`%{%` <- function(args, body) {
  stopifnot(is.pairlist(args$args), class(substitute(body)) == "{")
  f <- eval(call("function", args$args, substitute(body), parent.frame()))
  class(f) <- c("addFunction", "function")
  attr(f, "description") <- args$description
  f
}

# Example. Note that the braces {} are mandatory even for one line functions

foo <- addFunction(description = "Add one", x) %{% {
  x + 1
}

foo(1)
#[1] 2