docs: Show error source for translation errors

Author: krlmlr

R/handle_desc.R

@@ -2,14 +2,14 @@
 # Handles calls to 'desc' function by
 # - extracting the sort order
 # - removing any desc-function calls from the expressions: desc(colname) -> colname
-handle_desc <- function(dots) {
+handle_desc <- function(dots, call = caller_env()) {
   ascending <- rep(TRUE, length(dots))
 
   for (i in seq_along(dots)) {
     expr <- quo_get_expr(dots[[i]])
     env <- quo_get_env(dots[[i]])
 
-    if (is_desc(expr, env)) {
+    if (is_desc(expr, env, call)) {
       ascending[[i]] <- FALSE
       dots[[i]] <- new_quosure(expr[[2]], env = env)
     }
@@ -18,13 +18,14 @@ handle_desc <- function(dots) {
   list(dots = dots, ascending = ascending)
 }
 
-is_desc <- function(expr, env) {
+is_desc <- function(expr, env, call) {
   if (!is.call(expr)) {
     return(FALSE)
   }
 
   if (expr[[1]] == "desc") {
     if (!identical(eval(expr[[1]], env), dplyr::desc)) {
+      # Error handled elsewhere
       return(FALSE)
     }
   } else if (expr[[1]][[1]] == "::") {
@@ -36,7 +37,7 @@ is_desc <- function(expr, env) {
   }
 
   if (length(expr) > 2) {
-    cli::cli_abort("{.fun desc} must be called with exactly one argument.")
+    cli::cli_abort("Function {.fun desc} must be called with exactly one argument.", call = call)
   }
 
   TRUE

R/relational.R

@@ -78,17 +78,17 @@ rel_try <- function(call, rel, ...) {
   cli::cli_abort("Must use a {.code return()} in {.code rel_try()}.", .internal = TRUE)
 }
 
-rel_translate_dots <- function(dots, data) {
+rel_translate_dots <- function(dots, data, call = caller_env()) {
   if (is.null(names(dots))) {
-    map(dots, rel_translate, data)
+    map(dots, rel_translate, data, call = call)
   } else {
-    imap(dots, rel_translate, data = data)
+    imap(dots, rel_translate, data = data, call = call)
   }
 }
 
 # Currently does not support referring to names created during the `summarise()` call.
 # Also has specific support for `across()`.
-rel_translate_dots_summarise <- function(dots, data) {
+rel_translate_dots_summarise <- function(dots, data, call = caller_env()) {
   stopifnot(
     !is.null(names(dots))
   )
@@ -101,10 +101,22 @@ rel_translate_dots_summarise <- function(dots, data) {
 
     if (is.null(expanded)) {
       new <- names(dots)[[.y]]
-      translation <- list(rel_translate(dots[[.y]], alias = new, data, names_forbidden = .x$new))
+      translation <- list(rel_translate(
+        dots[[.y]],
+        alias = new,
+        data,
+        names_forbidden = .x$new,
+        call = call
+      ))
     } else {
       new <- names(expanded)
-      translation <- imap(expanded, function(expr, name) rel_translate(expr, alias = name, data, names_forbidden = .x$new))
+      translation <- imap(expanded, function(expr, name) rel_translate(
+        expr,
+        alias = name,
+        data,
+        names_forbidden = .x$new,
+        call = call
+      ))
     }
 
     list(

R/translate.R

@@ -1,6 +1,6 @@
 # Documented in `.github/CONTRIBUTING.md`
 
-rel_find_call <- function(fun, env) {
+rel_find_call <- function(fun, env, call = caller_env()) {
   name <- as.character(fun)
 
   if (name[[1]] == "::") {
@@ -106,7 +106,7 @@ rel_find_call <- function(fun, env) {
   # Remember to update limits.Rmd when adding new functions!
 
   if (is.null(pkgs)) {
-    cli::cli_abort("No translation for function {.code {name}}.")
+    cli::cli_abort("No translation for function {.fun {name}}.")
   }
 
   # https://github.com/tidyverse/dplyr/pull/7046
@@ -123,9 +123,9 @@ rel_find_call <- function(fun, env) {
   }
 
   if (length(pkgs) == 1) {
-    cli::cli_abort("Function {.code {name}} does not map to {.code {pkgs}::{name}}.")
+    cli::cli_abort("Function {.fun {name}} does not map to {.fun {pkgs}::{name}}.", call = call)
   } else {
-    cli::cli_abort("Function {.code {name}} does not map to the corresponding function in {.pkg {pkgs}}.")
+    cli::cli_abort("Function {.fun {name}} does not map to the corresponding function in {.pkg {pkgs}}.", call = call)
   }
 }
 
@@ -158,15 +158,18 @@ rel_translate_lang <- function(
   # FIXME: Perform constant folding instead
   partition,
   in_window,
-  need_window
+  need_window,
+  call = caller_env()
 ) {
-  pkg_name <- rel_find_call(expr[[1]], env)
+  pkg_name <- rel_find_call(expr[[1]], env, call = call)
   pkg <- pkg_name[[1]]
   name <- pkg_name[[2]]
 
 
   if (name %in% c(">", "<", "==", ">=", "<=")) {
-    if (length(expr) != 3) cli::cli_abort("Expected three expressions for comparison. Got {length(expr)}")
+    if (length(expr) != 3) {
+      cli::cli_abort("Expected three expressions for comparison. Got {length(expr)}", call = call)
+    }
 
     class_left <- infer_class_of_expr(expr[[2]], data)
     class_right <- infer_class_of_expr(expr[[3]], data)
@@ -185,7 +188,7 @@ rel_translate_lang <- function(
   if (!(name %in% c("wday", "strftime", "lag", "lead"))) {
     if (!is.null(names(expr)) && any(names(expr) != "")) {
       # Fix grepl() logic below when allowing matching by argument name
-      cli::cli_abort("Can't translate named argument {.code {name}({names(expr)[names(expr) != ''][[1]]} = )}.")
+      cli::cli_abort("Can't translate named argument {.code {name}({names(expr)[names(expr) != ''][[1]]} = )}.", call = call)
     }
   }
 
@@ -196,17 +199,17 @@ rel_translate_lang <- function(
     # Hack
     "wday" = {
       if (!is.null(pkg) && pkg != "lubridate") {
-        cli::cli_abort("Don't know how to translate {.code {pkg}::{name}}.")
+        cli::cli_abort("Don't know how to translate {.code {pkg}::{name}}.", call = call)
       }
       def <- lubridate::wday
       call <- match.call(def, expr, envir = env)
       args <- as.list(call[-1])
       bad <- !(names(args) %in% c("x"))
       if (any(bad)) {
-        cli::cli_abort("{name}({names(args)[which(bad)[[1]]]} = ) not supported")
+        cli::cli_abort("{name}({names(args)[which(bad)[[1]]]} = ) not supported", call = call)
       }
       if (!is.null(getOption("lubridate.week.start"))) {
-        cli::cli_abort('{.code wday()} with {.code option("lubridate.week.start")} not supported')
+        cli::cli_abort('{.code wday()} with {.code option("lubridate.week.start")} not supported', call = call)
       }
     },
     "strftime" = {
@@ -215,7 +218,7 @@ rel_translate_lang <- function(
       args <- as.list(call[-1])
       bad <- !(names(args) %in% c("x", "format"))
       if (any(bad)) {
-        cli::cli_abort("{name}({names(args)[which(bad)[[1]]]} = ) not supported")
+        cli::cli_abort("{name}({names(args)[which(bad)[[1]]]} = ) not supported", call = call)
       }
     },
     "%in%" = {
@@ -237,7 +240,7 @@ rel_translate_lang <- function(
       }
 
       if (length(values) > 100) {
-        cli::cli_abort("Can't translate {.code {name}} with more than 100 values.")
+        cli::cli_abort("Can't translate {.code {name}} with more than 100 values.", call = call)
       }
 
       consts <- map(values, do_translate)
@@ -258,7 +261,7 @@ rel_translate_lang <- function(
         if (exists(var_name, envir = env)) {
           return(do_translate(get(var_name, env), in_window = in_window))
         } else {
-          cli::cli_abort("internal: object not found, should also be triggered by the dplyr fallback")
+          cli::cli_abort("object not found, should also be triggered by the dplyr fallback", call = call)
         }
       }
     }
@@ -329,7 +332,7 @@ rel_translate_lang <- function(
 
   if (name == "grepl") {
     if (!inherits(args[[1]], "relational_relexpr_constant")) {
-      cli::cli_abort("Only constant patterns are supported in {.code grepl()}")
+      cli::cli_abort("Only constant patterns are supported in {.code grepl()}", call = call)
     }
   }
 
@@ -353,11 +356,14 @@ rel_translate_lang <- function(
 }
 
 rel_translate <- function(
-    quo, data,
-    alias = NULL,
-    partition = NULL,
-    need_window = FALSE,
-    names_forbidden = NULL) {
+  quo,
+  data,
+  alias = NULL,
+  partition = NULL,
+  need_window = FALSE,
+  names_forbidden = NULL,
+  call = caller_env()
+) {
   if (is_expression(quo)) {
     expr <- quo
     env <- baseenv()
@@ -378,7 +384,7 @@ rel_translate <- function(
       #
       symbol = {
         if (as.character(expr) %in% names_forbidden) {
-          cli::cli_abort("Can't reuse summary variable {.var {as.character(expr)}}.")
+          cli::cli_abort("Can't reuse summary variable {.var {as.character(expr)}}.", call = call)
         }
         if (as.character(expr) %in% names(data)) {
           ref <- as.character(expr)
@@ -399,10 +405,11 @@ rel_translate <- function(
         env,
         partition,
         in_window,
-        need_window
+        need_window,
+        call = call
       ),
       #
-      cli::cli_abort("Internal: Unknown type {.val {typeof(expr)}}")
+      cli::cli_abort("Internal: Unknown type {.val {typeof(expr)}}", call = call)
     )
   }
 

tests/testthat/_snaps/fallback.md

@@ -115,7 +115,7 @@
       duckdb_tibble(a = 1, b = 2) %>% mutate(c = .env$x)
     Message
       i dplyr fallback recorded
-        {"version":"0.3.1","message":"internal: object not found, should also be triggered by the dplyr fallback","name":"mutate","x":{"...1":"numeric","...2":"numeric"},"args":{"dots":{"...3":"...4$...5"},".by":"NULL",".keep":["all","used","unused","none"]}}
+        {"version":"0.3.1","message":"object not found, should also be triggered by the dplyr fallback","name":"mutate","x":{"...1":"numeric","...2":"numeric"},"args":{"dots":{"...3":"...4$...5"},".by":"NULL",".keep":["all","used","unused","none"]}}
     Condition
       Error in `mutate()`:
       i In argument: `c = .env$x`.
@@ -128,7 +128,7 @@
       duckdb_tibble(a = 1, b = 2) %>% mutate(c = foo(a, b))
     Message
       i dplyr fallback recorded
-        {"version":"0.3.1","message":"No translation for function `foo`.","name":"mutate","x":{"...1":"numeric","...2":"numeric"},"args":{"dots":{"...3":"foo(...1, ...2)"},".by":"NULL",".keep":["all","used","unused","none"]}}
+        {"version":"0.3.1","message":"No translation for function `foo()`.","name":"mutate","x":{"...1":"numeric","...2":"numeric"},"args":{"dots":{"...3":"foo(...1, ...2)"},".by":"NULL",".keep":["all","used","unused","none"]}}
     Output
       # A duckplyr data frame: 3 variables
             a     b     c

tests/testthat/_snaps/handle_desc.md

@@ -7,6 +7,18 @@
       ! This operation cannot be carried out by DuckDB, and the input is a frugal duckplyr frame.
       i Use `compute(prudence = "lavish")` to materialize to temporary storage and continue with duckplyr.
       i See `vignette("prudence")` for other options.
-      Caused by error in `rel_find_call()`:
-      ! Function `desc` does not map to `dplyr::desc`.
+      Caused by error in `arrange()`:
+      ! Function `desc()` does not map to `dplyr::desc()`.
+
+# desc() fails for more than one argument
+
+    Code
+      duckdb_tibble(a = 1:3, b = 4:6, .prudence = "frugal") %>% arrange(desc(a, b))
+    Condition
+      Error in `arrange()`:
+      ! This operation cannot be carried out by DuckDB, and the input is a frugal duckplyr frame.
+      i Use `compute(prudence = "lavish")` to materialize to temporary storage and continue with duckplyr.
+      i See `vignette("prudence")` for other options.
+      Caused by error in `arrange()`:
+      ! Function `desc()` must be called with exactly one argument.
 

tests/testthat/_snaps/translate.md

@@ -4,7 +4,7 @@
       rel_translate(quo(c(1, b = 2)))
     Condition
       Error in `rel_find_call()`:
-      ! No translation for function `c`.
+      ! No translation for function `c()`.
 
 # a %in% b
 

tests/testthat/test-handle_desc.R

@@ -24,3 +24,10 @@ test_that("desc() fails if it points elsewhere", {
       arrange(desc(a))
   })
 })
+
+test_that("desc() fails for more than one argument", {
+  expect_snapshot(error = TRUE, {
+    duckdb_tibble(a = 1:3, b = 4:6, .prudence = "frugal") %>%
+      arrange(desc(a, b))
+  })
+})