Moo*_*per 13 r metaprogramming ellipsis
{rlang} 有一个未导出的函数，可用于捕获省略号参数（名称、表达式和 env）。它为 的魔力提供动力rlang::enquos()。
f <- function(...) rlang:::captureDots()
g <- function(...) f(..., b = z)
g(a = x, y)
#> $a
#> $a$expr
#> x
#>
#> $a$env
#> <environment: R_GlobalEnv>
#>
#>
#> [[2]]
#> [[2]]$expr
#> y
#>
#> [[2]]$env
#> <environment: R_GlobalEnv>
#>
#>
#> $b
#> $b$expr
#> z
#>
#> $b$env
#> <environment: 0x130f8d8a8>
我想隔离，并希望理解这个功能，但我在 C 代码中找不到我的方法，rlang 中有很多这样的功能，而且似乎任何东西都会破坏一切。
我的要求是有一个最小的、高效的、独立的方式来重新创建这个功能（有或没有来自 {rlang} 的灵感）。
在基本 R 中捕获名称和表达式很容易，但获取环境则不然。我不相信没有低级语言就可以做到这一点。
以下是更难的例子：
n <- 1
fun1 <- function(x, ..., y) {
n <- 2
fun2(n, ..., j=x, u = y, v = n)
}
fun2 <- function(u, ..., v) {
n <- 3
rlang:::captureDots()
}
res <- fun1(1, i=n, x = n, y = n)
res
#> [[1]]
#> [[1]]$expr
#> n
#>
#> [[1]]$env
#> <environment: 0x11232d778>
#>
#>
#> [[2]]
#> [[2]]$expr
#> [1] 1
#>
#> [[2]]$env
#> <environment: R_GlobalEnv>
#>
#>
#> $i
#> $i$expr
#> n
#>
#> $i$env
#> <environment: R_GlobalEnv>
#>
#>
#> $j
#> $j$expr
#> x
#>
#> $j$env
#> <environment: 0x11232d778>
lapply(res, function(x) eval(x[[1]], x[[2]]))
#> [[1]]
#> [1] 2
#>
#> [[2]]
#> [1] 1
#>
#> $i
#> [1] 1
#>
#> $j
#> [1] 1
dots <- (function(...) get("..."))(1, i=n, x = n, y = n)
res2 <- with(list(... = dots), fun1(...))
lapply(res2, function(x) eval(x[[1]], x[[2]]))
#> [[1]]
#> [1] 2
#>
#> [[2]]
#> [1] 1
#>
#> $i
#> [1] 1
#>
#> $j
#> [1] 1
foo <- function(...) {
bar <- function() rlang:::captureDots()
bar()
}
foo(a=x)
#> $a
#> $a$expr
#> x
#>
#> $a$env
#> <environment: R_GlobalEnv>
foo2 <- function(...) {
bar <- function(...) rlang:::captureDots()
bar()
}
foo2(a=x)
#> NULL
All*_*ron 14
虽然可以编写一个可以在 R 中迭代调用堆栈的函数，沿途收集调用和环境（请参阅下面的附录），但代码非常复杂，并且存在太多陷阱，例如通过 进行的调用eval，使其成为一种可以在生产代码中使用的强大解决方案。与其尝试从调用堆栈中重新创建点的内容，不如...直接提取并评估对象的内容。
不幸的是，这确实需要少量的编译代码。在 C 代码中，<...>对象被存储为 a ，它是一个专门的PromiseDOTSXP配对列表。每个 Promise 都包含一个未计算的表达式以及应计算该表达式的环境。基础 R 中没有面向用户的函数允许直接从 Promise 中提取环境和表达式；它们需要使用 C 函数和来获取，这些函数可从 Rinternals.h 中访问。我们可以使用 C 函数、和来访问 a 中完整的 Promise 对列表，这些函数也可以在 Rinternals.h 中访问。PRENVPREXPRDOTSXPTAGCARCDR
这意味着我们总共需要 5 个简单的 C 函数：
Rcpp::cppFunction('SEXP cdr(SEXP obj) { return CDR(obj); }')
Rcpp::cppFunction('SEXP car(SEXP obj) { return CAR(obj); }')
Rcpp::cppFunction('SEXP tag(SEXP obj) { return TAG(obj); }')
Rcpp::cppFunction('SEXP prenv(SEXP obj) { return PRENV(obj); }')
Rcpp::cppFunction('SEXP prexpr(SEXP obj) { return PREXPR(obj);}')
尽管为了方便起见，我在这里使用了 Rcpp，但这些函数可以编写在包中的 C 文件中，从而使该解决方案不再具有依赖性。
现在定义了这些函数，我们可以rlang:::captureDots使用以下仅使用基本 R 和上述 C 函数的函数进行模拟：
capture_dots <- function() {
dots <- tryCatch(
get("...", parent.frame()),
error = function(e) list()
)
if(identical(dots, list())) return(list())
li <- c(car(dots), cdr(dots))
first_name <- deparse(tag(dots))
if(first_name != 'NULL') names(li)[1] <- first_name
lapply(li, function(x) {
x <- list(x)
while(inherits(x[[1]], 'promise')) {
env <- prenv(x[[1]])
x <- list(prexpr(x[[1]]))
}
if(is.null(env)) env <- .GlobalEnv
list(expr = x[[1]], env = env)
})
}
（注：感谢OP通过评论提出了一些非常有用的开发和改进此功能的建议）
现在，如果我们运行给定的示例，我们将得到：
实施例1
n <- 1
fun1 <- function(x, ..., y) {
n <- 2
fun2(n, ..., j=x, u = y, v = n)
}
fun2 <- function(u, ..., v) {
n <- 3
capture_dots()
}
res <- fun1(1, i=n, x = n, y = n)
导致
res
#> [[1]]
#> [[1]]$expr
#> n
#>
#> [[1]]$env
#> <environment: 0x0000022784b38020>
#>
#>
#> [[2]]
#> [[2]]$expr
#> [1] 1
#>
#> [[2]]$env
#> <environment: R_GlobalEnv>
#>
#>
#> $i
#> $i$expr
#> n
#>
#> $i$env
#> <environment: R_GlobalEnv>
#>
#>
#> $j
#> $j$expr
#> x
#>
#> $j$env
#> <environment: 0x0000022784b38020>
和
lapply(res, function(x) eval(x[[1]], x[[2]]))
#> [[1]]
#> [1] 2
#>
#> [[2]]
#> [1] 1
#>
#> $i
#> [1] 1
#>
#> $j
#> [1] 1
实施例2
dots <- (function(...) get("..."))(1, i=n, x = n, y = n)
res2 <- with(list(... = dots), fun1(...))
lapply(res2, function(x) eval(x[[1]], x[[2]]))
#> [[1]]
#> [1] 2
#>
#> [[2]]
#> [1] 1
#>
#> $i
#> [1] 1
#>
#> $j
#> [1] 1
实施例3
foo <- function(...) {
bar <- function() capture_dots()
bar()
}
foo(a=x)
#> $a
#> $a$expr
#> x
#>
#> $a$env
#> <environment: R_GlobalEnv>
foo2 <- function(...) {
bar <- function(...) capture_dots()
bar()
}
foo2(a=x)
#> list()
附录
在 R 中完成整个事情需要遍历调用堆栈、获取参数和环境。这对于大多数用例都适用，但当eval堆栈上存在诸如 之类的调用时with，这将不起作用，如第二个示例所示。包含此内容是为了展示如何在基础 R 中完成类似的操作。它可以进一步开发以处理对evaletc 的调用，但已经比上述解决方案复杂得多。
capture_dots2 <- function() {
dots <- tryCatch(
get("...", parent.frame()),
error = function(e) list()
)
if(identical(dots, list())) return(list())
ss <- lapply(sys.status(), function(x) rev(head(x, -2L)))
ss$sys.frames <- c(ss$sys.frames[-1], parent.env(tail(ss$sys.frames, 1)[[1]]))
stack <- list(call_stack = ss$sys.calls, call_frames = ss$sys.frames)
stack$call_stack <- lapply(stack$call_stack, function(x) as.call(as.list(x)))
get_args <- function(x) as.list(x)[nzchar(names(as.list(x)))]
funcs <- rev(lapply(seq_along(stack$call_stack), sys.function))
stack$frml <- lapply(funcs, get_args)
stack$args <- lapply(stack$call_stack, function(x) as.list(x)[-1])
dots <- Map(function(args, frmls) {
if(!'...' %in% names(frmls) || is.null(names(frmls))) return(NULL)
args <- args[!sapply(args, function(x) identical(x, quote(...)))]
if(length(frmls) == 1) return(args)
if(is.null(names(args))) names(args) <- rep("", length(args))
matched_frmls <- which(names(frmls) %in% names(args))
matched_args <- which(names(args) %in% names(frmls))
if(length(matched_args)) args <- args[seq_along(args)[-matched_args]]
if(length(matched_frmls)) frmls <- frmls[seq_along(frmls)[-matched_frmls]]
dot_frml <- which(names(frmls) == "...")
pre_dot <- if(dot_frml == 1) numeric() else seq(dot_frml - 1)
unnamed_args <- which(!nzchar(names(args)))
if(length(unnamed_args) > length(pre_dot) && length(pre_dot) > 0) {
args <- args[-unnamed_args[pre_dot]]
}
args
}, stack$args, stack$frml)
envs <- stack$call_frames[lengths(dots) > 0]
dots <- dots[lengths(dots) > 0]
result <- list()
for(i in seq_along(dots)) {
for(j in rev(seq_along(dots[[i]]))) {
li <- list(expr = dots[[i]][[j]], env = envs[[i]])
if(identical(li$expr, quote(...))) next
nm <- names(dots[[i]])[j]
nms <- names(result)
result <- c(list(li), result)
names(result) <- c(nm, nms)
}
}
rev(result)[order(names(rev(result)))]
}