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

Question

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

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

我还想在 ruturning 期间（不是在函数调用中）懒惰地取消引用，理想情况下控制哪一侧

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

两者都符合预期。

关于如何改进这段代码并实现第二个目标（在返回的表达式中取消引用），我有几个问题。

第一季度。在这部分最后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)

因为每个dots[[i]] 都是像a == b 这样的单个表达式，我无法进一步分解和操作。定义不被引用的一面甚至更难完成。有什么简单的方法可以实现吗？

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

^{由reprex package (v2.0.0) 于 2021 年 10 月 26 日创建}