R元编程:用函数调用粘贴逻辑表达式

Question

我想要一个粘贴逻辑表达式的函数

paste_logic(a == b, c > q, f < g, sep = and) 
# should return
# expr(a == b & c > q & f < g)

我还想在Ruturn期间(不是在函数调用中)惰性地取消引用，理想情况下控制的哪一侧

paste_expr(paste_expr(a == b, c > q, f < g, sep = and, side = right)
# should return
# expr(a == !!b & c > !!q & f < !!g)

我实现第一个目标的解决方案是：

paste_logic <- function(sep, ...) {
dots <- enquos(...)
sep <- enexpr(sep)
dispatch <- function(symbol) if (symbol == expr(and)) `&` else `|`
if (length(dots) == 1) {
dots[[1]]
} else {
expr(`!!`(dispatch(sep))(!!(dots[[1]]), !!paste_logic(sep, !!!dots[-1])))
}
}

paste_logic(and, a > b, c == d, k == f) 
# returns
# .Primitive("&")(~a > b, .Primitive("&")(~c == d, ~k == f))

和

a <- 1
b <- 2
c <- 3
d <- 3
k <- 9
f <- 10
eval_tidy(paste_logic(and, a > b, c == d, k == f))
# returns FALSE
eval_tidy(paste_logic(or, a > b, c == d, k == f))
# returns TRUE

两者都如预期。

关于如何改进这段代码并实现第二个目标，我有几个问题(在返回的表达式中并列)。

Q1。在上一个else {...}闭包的这一部分中：

expr(`!!`(dispatch(sep))(!!(dots[[1]]), !!paste_logic(sep, !!!dots[-1])))

我必须使用素数来包装!!运算符或使用UQ函数。如果我简单地把它作为!!(dispatch(sep))，或者用完整的函数定义作为这个

paste_logic <- function(sep, ...) {
dots <- enquos(...)
sep <- enexpr(sep)
dispatch <- function(symbol) if (symbol == expr(and)) `&` else `|`
if (length(dots) == 1) {
dots[[1]]
} else {
expr(!!(dispatch(sep))(!!(dots[[1]]), !!paste_logic(!!sep, !!!dots[-1])))
}
}
paste_logic(or, a > b, c == d, k == f)

它返回错误

Error: Quosures can only be unquoted within a quasiquotation context.
# Bad:
list(!!myquosure)
# Good:
dplyr::mutate(data, !!myquosure)

全球环境下的测试

a <- 1
b <- 2
c <- `&`
expr(!!(c)(!!a, !!n))

工作正常，没有错误并返回TRUE。那么，为什么在我的代码中这不起作用，而我必须使用<prime>!!<prime>呢？

第二季度。我必须使用逻辑运算符的前缀函数版本，因此最后的表达式是对.Primitive("&")的递归函数调用。

有没有一种方法可以将&和|作为符号从函数外部传递，这样我就可以得到expr(a == b & c > q & f < g)的最终表达式？

在函数体内部简单地用ensym或enexpr包装&和|会产生以下错误：Error: unexpected '&' in "expr(&"

第三季度。此解决方案不支持在返回的表达式(如)中进一步取消查询

expr(a == !!b & c > !!q & f < !!g)

因为每个CCD_ 16都是像CCD_。定义未被引用的一方甚至更难实现。有什么简单的方法可以做到这一点吗？

Answer 1

我认为您正在寻找一种减少操作：

exprs_reduce <- function(xs, op) {
n <- length(xs)
if (n == 0) {
return(NULL)
}
if (n == 1) {
return(xs[[1]])
}
# Replace `call()` by `call2()` to support inlined functions
purrr::reduce(xs, function(out, new) call(op, out, new))
}
exprs_reduce(alist(), "&")
#> NULL
exprs_reduce(alist(foo), "&")
#> foo
exprs_reduce(alist(foo, bar), "&")
#> foo & bar
exprs_reduce(alist(foo, bar, baz), "|")
#> foo | bar | baz

Answer 2

在解决问题的一般方法中，我会听从Lionel Henry的专业知识，但要让您的功能完全按照您的要求执行，您可以尝试以下方法：

library(rlang)
paste_logic <- function(sep, ..., side = "none")
{
elements <- as.list(match.call())[-1]
sep <- elements$sep
elements <- elements[!nzchar(names(elements))]
sep <- if(sep == expr(and)) " & " else " | "
if(side == "right") {
elements <- lapply(elements, function(x) {
x <- as.character(x); 
x[3] <- paste0("!!", x[3]); 
str2lang(paste(x[c(2, 1, 3)], collapse = " "))})
}
if(side == "left") {
elements <- lapply(elements, function(x) {
x <- as.character(x); 
x[2] <- paste0("!!", x[2]); 
str2lang(paste(x[c(2, 1, 3)], collapse = " "))})
}
result <- do.call(function(...) paste(..., sep = sep), 
lapply(elements, capture.output))
return(str2lang(result))
}

这将返回实际的语言对象，并带有可选的bang-bang运算符：

paste_logic(and, a == b, c > q, f < g)
#> a == b & c > q & f < g
paste_logic(or, a == b, c > q, f < g)
#> a == b | c > q | f < g
paste_logic(and,  a == b, c > q, f < g, side = "left")
#> !!a == b & !!c > q & !!f < g
paste_logic(and,  a == b, c > q, f < g, side = "right")
#> a == !!b & c > !!q & f < !!g

当然，这些可以按照预期进行评估：

a <- 1
b <- 2
c <- 3
d <- 3
k <- 9
f <- 10
eval_tidy(paste_logic(and, a > b, c == d, k == f))
#> [1] FALSE
eval_tidy(paste_logic(or, a > b, c == d, k == f))
#> [1] TRUE

^{创建于2021-10-26由reprex包(v2.0.0)}