Implement across() translation

Fixes #480

NEWS.md

@@ -1,5 +1,7 @@
 # dbplyr (development version)
 
+* `across()` now translated into individual SQL statements (#480).
+
 * Experimental new SAP HANA backend (#233). Requires the latest
   version of odbc.
 

R/partial-eval.R

@@ -73,12 +73,23 @@ partial_eval <- function(call, vars = character(), env = caller_env()) {
 partial_eval_dots <- function(dots, vars) {
   stopifnot(inherits(dots, "quosures"))
 
-  lapply(dots, function(x) {
-    new_quosure(
-      partial_eval(get_expr(x), vars = vars, env = get_env(x)),
-      get_env(x)
-    )
-  })
+  dots <- lapply(dots, partial_eval_quo, vars = vars)
+
+  # Flatten across() calls
+  is_list <- vapply(dots, is.list, logical(1))
+  dots[!is_list] <- lapply(dots[!is_list], list)
+  names(dots)[is_list] <- ""
+
+  unlist(dots, recursive = FALSE)
+}
+
+partial_eval_quo <- function(x, vars) {
+  expr <- partial_eval(get_expr(x), vars, get_env(x))
+  if (is.list(expr)) {
+    lapply(expr, new_quosure, env = get_env(x))
+  } else {
+    new_quosure(expr, get_env(x))
+  }
 }
 
 partial_eval_sym <- function(sym, vars, env) {
@@ -142,6 +153,8 @@ partial_eval_call <- function(call, vars, env) {
     } else {
       eval_bare(idx, env)
     }
+  } else if (is_call(call, "across")) {
+    partial_eval_across(call, vars, env)
   } else {
     # Process call arguments recursively, unless user has manually called
     # remote/local
@@ -155,7 +168,54 @@ partial_eval_call <- function(call, vars, env) {
       call
     }
   }
+}
+
+partial_eval_across <- function(call, vars, env) {
+  call <- match.call(dplyr::across, call, expand.dots = FALSE, envir = env)
+
+  tbl <- as_tibble(rep_named(vars, list(logical())))
+  cols <- syms(vars)[tidyselect::eval_select(call$.cols, tbl, allow_rename = FALSE)]
+
+  .fns <- eval(call$.fns, env)
+
+  if (is.function(.fns)) {
+    .fns <- find_fun(.fns)
+  } else if (is.list(.fns)) {
+    .fns <- purrr::map_chr(.fns, find_fun)
+  } else if (is.character(.fns)) {
+    # as is
+  } else {
+    abort("Unsupported `.fns` for dbplyr::across()")
+  }
+  funs <- set_names(syms(.fns), .fns)
+
+  # Generate grid of expressions
+  out <- vector("list", length(cols) * length(.fns))
+  k <- 1
+  for (i in seq_along(cols)) {
+    for (j in seq_along(funs)) {
+      out[[k]] <- expr((!!funs[[j]])(!!cols[[i]], !!!call$...))
+      k <- k + 1
+    }
+  }
+
+  .names <- eval(call$.names, env)
+  names(out) <- across_names(cols, names(funs), .names, env)
+  out
+}
+
+across_names <- function(cols, funs, names = NULL, env = parent.frame()) {
+  if (length(funs) == 1) {
+    names <- names %||% "{.col}"
+  } else {
+    names <- names %||% "{.col}_{.fn}"
+  }
 
+  glue_env <- child_env(env,
+    .col = rep(cols, each = length(funs)),
+    .fn = rep(funs %||% seq_along(funs), length(cols))
+  )
+  glue(names, .envir = glue_env)
 }
 
 find_fun <- function(fun) {

tests/testthat/_snaps/partial-eval.md

@@ -0,0 +1,54 @@
+# across() translated to individual components
+
+    Code
+      lf %>% summarise(across(everything(), "log"))
+    Output
+      <SQL>
+      SELECT LN(`a`) AS `a`, LN(`b`) AS `b`
+      FROM `df`
+
+---
+
+    Code
+      lf %>% summarise(across(everything(), log))
+    Output
+      <SQL>
+      SELECT LN(`a`) AS `a`, LN(`b`) AS `b`
+      FROM `df`
+
+---
+
+    Code
+      lf %>% summarise(across(everything(), list(log)))
+    Output
+      <SQL>
+      SELECT LN(`a`) AS `a`, LN(`b`) AS `b`
+      FROM `df`
+
+---
+
+    Code
+      lf %>% summarise(across(everything(), "log", base = 2))
+    Output
+      <SQL>
+      SELECT LOG(2.0, `a`) AS `a`, LOG(2.0, `b`) AS `b`
+      FROM `df`
+
+---
+
+    Code
+      lf %>% summarise(across(everything(), c("log", "exp")))
+    Output
+      <SQL>
+      SELECT LN(`a`) AS `a_log`, EXP(`a`) AS `a_exp`, LN(`b`) AS `b_log`, EXP(`b`) AS `b_exp`
+      FROM `df`
+
+---
+
+    Code
+      lf %>% summarise(across(everything(), c("log", "exp"), .names = "{.fn}_{.col}"))
+    Output
+      <SQL>
+      SELECT LN(`a`) AS `log_a`, EXP(`a`) AS `exp_a`, LN(`b`) AS `log_b`, EXP(`b`) AS `exp_b`
+      FROM `df`
+

tests/testthat/test-partial-eval.R

@@ -41,3 +41,18 @@ test_that("fails with multi-classes", {
   x <- structure(list(), class = c('a', 'b'))
   expect_error(partial_eval(x), "Unknown input type", fixed = TRUE)
 })
+
+# across() ----------------------------------------------------------------
+
+test_that("across() translated to individual components", {
+  # test partial_eval_across() indirectly via SQL generation
+  lf <- lazy_frame(a = 1, b = 2)
+  expect_snapshot(lf %>% summarise(across(everything(), "log")))
+  expect_snapshot(lf %>% summarise(across(everything(), log)))
+  expect_snapshot(lf %>% summarise(across(everything(), list(log))))
+
+  expect_snapshot(lf %>% summarise(across(everything(), "log", base = 2)))
+
+  expect_snapshot(lf %>% summarise(across(everything(), c("log", "exp"))))
+  expect_snapshot(lf %>% summarise(across(everything(), c("log", "exp"), .names = "{.fn}_{.col}")))
+})