Ответ 1
Мы можем развернуть аргументы ...
с помощью match.call
, а затем оценить и сохранить аргументы в environment
, которые не будут копировать значения. Поскольку объекты environment
требуют имен для всех элементов и не сохраняют их порядок, нам нужно сохранить отдельный вектор имен упорядоченных тегов в дополнение к (необязательным) формальным именам аргументов. Реализовано здесь с использованием атрибутов:
argsenv <- function(..., parent=parent.frame()) {
cl <- match.call(expand.dots=TRUE)
e <- new.env(parent=parent)
pf <- parent.frame()
JJ <- seq_len(length(cl) - 1)
tagnames <- sprintf(".v%d", JJ)
for (i in JJ) e[[tagnames[i]]] <- eval(cl[[i+1]], envir=pf)
attr(e, "tagnames") <- tagnames
attr(e, "formalnames") <- names(cl)[-1]
class(e) <- c("environment", "argsenv")
e
}
Теперь мы можем использовать его в наших функциях вместо list(...)
:
f <- function(...) {
dots <- argsenv(...)
# Let print them out.
for (i in seq_along(attr(dots, "tagnames"))) {
cat(i, ": name=", attr(dots, "formalnames")[i], "\n", sep="")
print(dots[[attr(dots, "tagnames")[i]]])
}
}
> f(10, a=20)
1: name=
[1] 10
2: name=a
[1] 20
Итак, он работает, но не позволяет ли он копировать?
g1 <- function(...) {
dots <- list(...)
for (x in dots) .Internal(inspect(x))
}
> z <- 10
> .Internal(inspect(z))
@10d854908 14 REALSXP g0c1 [NAM(2)] (len=1, tl=0) 10
> g1(z)
@10dcdaba8 14 REALSXP g0c1 [NAM(2)] (len=1, tl=0) 10
> g1(z, z)
@10dcbb558 14 REALSXP g0c1 [NAM(2)] (len=1, tl=0) 10
@10dcd53d8 14 REALSXP g0c1 [NAM(2)] (len=1, tl=0) 10
>
g2 <- function(...) {
dots <- argsenv(...);
for (x in attr(dots, "tagnames")) .Internal(inspect(dots[[x]]))
}
> .Internal(inspect(z))
@10d854908 14 REALSXP g0c1 [MARK,NAM(2)] (len=1, tl=0) 10
> g2(z)
@10d854908 14 REALSXP g0c1 [MARK,NAM(2)] (len=1, tl=0) 10
> g2(z, z)
@10d854908 14 REALSXP g0c1 [MARK,NAM(2)] (len=1, tl=0) 10
@10d854908 14 REALSXP g0c1 [MARK,NAM(2)] (len=1, tl=0) 10
Вы можете реализовать это на S4 с слотами вместо атрибутов, определить для него всевозможные методы (length
, [
, [[
, c
и т.д.) и превратить его в полнофункциональный, заменяя замену универсального типа для list
. Но это еще одна должность.
Боковое примечание. Вы можете избежать mapply
/Map
, переписав все такие вызовы как lapply(seq_along(v1) function(i) FUN(v1[[i]], v2[[i]],
... )
, но при этом много работы и не делает ваш код в пользу элегантности и читаемость. Вместо этого мы можем переписать функции mapply
/Map
, используя argsenv
и некоторые манипуляции с выражением, чтобы сделать именно это внутри:
mapply2 <- function(FUN, ..., MoreArgs=NULL, SIMPLIFY=TRUE, USE.NAMES=TRUE) {
FUN <- match.fun(FUN)
args <- argsenv(...)
tags <- attr(args, "tagnames")
iexpr <- quote(.v1[[i]])
iargs <- lapply(tags, function(x) { iexpr[[2]] <- as.name(x); iexpr })
names(iargs) <- attr(args, "formalnames")
iargs <- c(iargs, as.name("..."))
icall <- quote(function(i, ...) FUN())[-4]
icall[[3]] <- as.call(c(quote(FUN), iargs))
ifun <- eval(icall, envir=args)
lens <- sapply(tags, function(x) length(args[[x]]))
maxlen <- if (length(lens) == 0) 0 else max(lens)
if (any(lens != maxlen)) stop("Unequal lengths; recycle not implemented")
answer <- do.call(lapply, c(list(seq_len(maxlen), ifun), MoreArgs))
# The rest is from the original mapply code.
if (USE.NAMES && length(tags)) {
arg1 <- args[[tags[1L]]]
if (is.null(names1 <- names(arg1)) && is.character(arg1)) names(answer) <- arg1
else if (!is.null(names1)) names(answer) <- names1
}
if (!identical(SIMPLIFY, FALSE) && length(answer))
simplify2array(answer, higher = (SIMPLIFY == "array"))
else answer
}
# Original Map code, but calling mapply2 instead.
Map2 <- function (f, ...) {
f <- match.fun(f)
mapply2(FUN=f, ..., SIMPLIFY=FALSE)
}
Вы даже можете назвать их mapply
/Map
в своем пространстве пакетов/глобальных пространств, чтобы затенять версии base
и не нужно изменять остальную часть вашего кода. Реализация здесь только пропускает неравномерную функцию переустановки длины, которую вы могли бы добавить, если хотите.