R meta programming: Paste logic expressions with function call

Question

I'd like to have a function to paste logical expressions

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

I would also like to lazily unquote during ruturning (not in the function call), ideally control which side

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

The solution I got towards the first goal is:

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))

and

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

Both are as expected.

I have a few questions on how to improve this piece of code and achieve the 2nd goal (unquoting by side in returned expression).

Q1. In this part in the last else {...} closure:

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

I have to use prime signs to wrap the !! operator or use UQ function. If I simply give it as !!(dispatch(sep)) or with full function definition as this

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)

It returns error

Error: Quosures can only be unquoted within a quasiquotation context.

  # Bad:
  list(!!myquosure)

  # Good:
  dplyr::mutate(data, !!myquosure)

Testing in global environment

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

works fine without error and returns TRUE. So, why in my code this does not work and I have to use <prime>!!<prime>?

Q2. I have to use the prefix functional version of the logical operators, thus the final expression is recursive function calls to .Primitive("&").

Is there a way to pass & and | as symbols from outside of the function so I get final expression as expr(a == b & c > q & f < g)?

Simply wrapping & and | with ensym or enexpr inside function body generates errors like: Error: unexpected '&' in "expr(&"

Q3. This solution does not support further unquoting within the returned expression such as

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

since each dots[[i]] is a single expression like a == b which I couldn't further decompose and manipulate with. Defining side to be unquoted is even harder to accomplish. Is there any simple way to achieve this?

Answer 1

I think you're looking for a reducing operation:

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

I would defer to Lionel Henry's expertise here in the general approach to your problem, but to have your function do exactly what you are asking, you could try the following approach:

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))
}

This will return actual language objects, with the optional bang-bang operators:

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

And of course these can be evaluated as expected:

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

^{Created on 2021-10-26 by the reprex package (v2.0.0)}