Improve $ handling (#1430)

Fixes #1368

NAMESPACE

@@ -119,7 +119,6 @@ S3method(escape,Date)
 S3method(escape,POSIXt)
 S3method(escape,blob)
 S3method(escape,character)
-S3method(escape,data.frame)
 S3method(escape,dbplyr_catalog)
 S3method(escape,dbplyr_schema)
 S3method(escape,dbplyr_table_ident)
@@ -131,7 +130,6 @@ S3method(escape,integer)
 S3method(escape,integer64)
 S3method(escape,list)
 S3method(escape,logical)
-S3method(escape,reactivevalues)
 S3method(escape,sql)
 S3method(explain,tbl_sql)
 S3method(flatten_query,base_query)

NEWS.md

@@ -1,5 +1,10 @@
 # dbplyr (development version)
 
+* Clearer error if you attempt to embed non-atomic vectors inside of a generated 
+  query (#1368).
+
+* `x$name` never attempts to evaluate `name` (#1368).
+
 * `rows_patch(in_place = FALSE)` now works when more than one column should be
   patched (@gorcha, #1443).
 

R/backend-.R

@@ -61,7 +61,13 @@ base_scalar <- sql_translator(
     }
   },
 
-  `$`   = sql_infix(".", pad = FALSE),
+  `$`   = function(x, name) {
+    if (!is.sql(x)) {
+      cli_abort("{.code $} can only subset database columns, not inlined values.")
+    }
+    glue_sql2(sql_current_con(), "{x}.{.col name}")
+  },
+
   `[[`   = function(x, i) {
     # `x` can be a table, column or even an expression (e.g. for json)
     i <- enexpr(i)

R/escape.R

@@ -137,16 +137,6 @@ escape.list <- function(x, parens = TRUE, collapse = ", ", con = NULL) {
   sql_vector(pieces, parens, collapse, con = con)
 }
 
-#' @export
-escape.data.frame <- function(x, parens = TRUE, collapse = ", ", con = NULL) {
-  error_embed("a data.frame", "df$x")
-}
-
-#' @export
-escape.reactivevalues <- function(x, parens = TRUE, collapse = ", ", con = NULL) {
-  error_embed("shiny inputs", "input$x")
-}
-
 # Also used in default_ops() for reactives
 error_embed <- function(type, expr) {
   cli_abort(c(

R/tidyeval.R

@@ -66,7 +66,7 @@ partial_eval <- function(call, data, env = caller_env(), vars = NULL, error_call
     data <- lazy_frame(!!!rep_named(data, list(logical())))
   }
 
-  if (is_atomic(call) || is_null(call) || blob::is_blob(call)) {
+  if (is_sql_literal(call)) {
     call
   } else if (is_symbol(call)) {
     partial_eval_sym(call, data, env)
@@ -89,6 +89,10 @@ partial_eval <- function(call, data, env = caller_env(), vars = NULL, error_call
   }
 }
 
+is_sql_literal <- function(x) {
+  is_atomic(x) || is_null(x) || blob::is_blob(x)
+}
+
 capture_dot <- function(.data, x) {
   partial_eval(enquo(x), data = .data)
 }
@@ -153,7 +157,20 @@ partial_eval_sym <- function(sym, data, env) {
   if (name %in% vars) {
     sym
   } else if (env_has(env, name, inherit = TRUE)) {
-    eval_bare(sym, env)
+    val <- eval_bare(sym, env)
+
+    # Handle common failure modes
+    if (inherits(val, "data.frame")) {
+      error_embed("a data.frame", paste0(name, "$x"))
+    } else if (inherits(val, "reactivevalues")) {
+      error_embed("shiny inputs", paste0(name, "$x"))
+    }
+
+    if (is_sql_literal(val)) {
+      unname(val)
+    } else {
+      error_embed(obj_type_friendly(val), name)
+    }
   } else {
     cli::cli_abort(
       "Object {.var {name}} not found.",
@@ -213,6 +230,10 @@ partial_eval_call <- function(call, data, env) {
       eval_bare(call[[2]], env)
     } else if (is_call(call, "remote")) {
       call[[2]]
+    } else if (is_call(call, "$")) {
+      # Only the 1st argument is evaluated
+      call[[2]] <- partial_eval(call[[2]], data = data, env = env)
+      call
     } else {
       call[-1] <- lapply(call[-1], partial_eval, data = data, env = env)
       call

tests/testthat/_snaps/backend-.md

@@ -11,6 +11,35 @@
       Error in `a[[TRUE]]`:
       ! Can only index with strings and numbers
 
+# $ doesn't evaluate second argument
+
+    Code
+      lazy_frame(x = 1, y = 1) %>% filter(x == y$id)
+    Output
+      <SQL>
+      SELECT `df`.*
+      FROM `df`
+      WHERE (`x` = `y`.`id`)
+
+---
+
+    Code
+      lazy_frame(x = 1) %>% filter(x == y$id)
+    Condition
+      Error in `filter()`:
+      i In argument: `x == y$id`
+      Caused by error:
+      ! Cannot translate a list to SQL.
+      i Do you want to force evaluation in R with (e.g.) `!!y` or `local(y)`?
+
+# useful error if $ used with inlined value
+
+    Code
+      lazy_frame(x = 1) %>% filter(x == y$id)
+    Condition
+      Error in `1$id`:
+      ! `$` can only subset database columns, not inlined values.
+
 # can translate case insensitive like
 
     Code

tests/testthat/_snaps/escape.md

@@ -1,21 +1,3 @@
-# shiny objects give useful errors
-
-    Code
-      lf %>% filter(a == input$x) %>% show_query()
-    Condition
-      Error:
-      ! Cannot translate shiny inputs to SQL.
-      i Do you want to force evaluation in R with (e.g.) `!!input$x` or `local(input$x)`?
-
----
-
-    Code
-      lf %>% filter(a == x()) %>% show_query()
-    Condition
-      Error:
-      ! Cannot translate a shiny reactive to SQL.
-      i Do you want to force evaluation in R with (e.g.) `!!foo()` or `local(foo())`?
-
 # con must not be NULL
 
     Code
@@ -32,12 +14,3 @@
       Error in `sql_vector()`:
       ! `con` must not be NULL.
 
-# data frames give useful errors
-
-    Code
-      escape(mtcars, con = simulate_dbi())
-    Condition
-      Error:
-      ! Cannot translate a data.frame to SQL.
-      i Do you want to force evaluation in R with (e.g.) `!!df$x` or `local(df$x)`?
-

tests/testthat/_snaps/tidyeval.md

@@ -0,0 +1,31 @@
+# other objects get informative error
+
+    Code
+      capture_dot(lf, input)
+    Condition
+      Error:
+      ! Cannot translate shiny inputs to SQL.
+      i Do you want to force evaluation in R with (e.g.) `!!input$x` or `local(input$x)`?
+    Code
+      capture_dot(lf, x())
+    Output
+      x()
+    Code
+      capture_dot(lf, df)
+    Condition
+      Error:
+      ! Cannot translate a data.frame to SQL.
+      i Do you want to force evaluation in R with (e.g.) `!!df$x` or `local(df$x)`?
+    Code
+      capture_dot(lf, l)
+    Condition
+      Error:
+      ! Cannot translate an empty list to SQL.
+      i Do you want to force evaluation in R with (e.g.) `!!l` or `local(l)`?
+    Code
+      capture_dot(lf, mean)
+    Condition
+      Error:
+      ! Cannot translate a function to SQL.
+      i Do you want to force evaluation in R with (e.g.) `!!mean` or `local(mean)`?
+

tests/testthat/test-backend-.R

@@ -78,6 +78,17 @@ test_that("can translate subsetting", {
   })
 })
 
+test_that("$ doesn't evaluate second argument", {
+  y <- list(id = 1)
+
+  expect_snapshot(lazy_frame(x = 1, y = 1) %>% filter(x == y$id))
+  expect_snapshot(lazy_frame(x = 1) %>% filter(x == y$id), error = TRUE)
+})
+
+test_that("useful error if $ used with inlined value", {
+  y <- 1
+  expect_snapshot(lazy_frame(x = 1) %>% filter(x == y$id), error = TRUE)
+})
 
 # window ------------------------------------------------------------------
 

tests/testthat/test-escape.R

@@ -108,24 +108,11 @@ test_that("factors are translated", {
 
 # Helpful errors --------------------------------------------------------
 
-test_that("shiny objects give useful errors", {
-  lf <- lazy_frame(a = 1)
-  input <- structure(list(), class = "reactivevalues")
-  x <- structure(function() "y", class = "reactive")
-
-  expect_snapshot(error = TRUE, lf %>% filter(a == input$x) %>% show_query())
-  expect_snapshot(error = TRUE, lf %>% filter(a == x()) %>% show_query())
-})
-
 test_that("con must not be NULL", {
   expect_snapshot(error = TRUE, escape("a"))
   expect_snapshot(error = TRUE, sql_vector("a"))
 })
 
-test_that("data frames give useful errors", {
-  expect_snapshot(error = TRUE, escape(mtcars, con = simulate_dbi()))
-})
-
 # names_to_as() -----------------------------------------------------------
 
 test_that("names_to_as() doesn't alias when ident name and value are identical", {

tests/testthat/test-tidyeval.R

@@ -14,13 +14,37 @@ test_that("simple expressions left as is", {
   expect_equal(capture_dot(lf, FALSE), FALSE)
 })
 
-test_that("existing non-variables get inlined", {
+test_that("existing atomic non-variables get inlined", {
   lf <- lazy_frame(x = 1:10, y = 1:10)
 
   n <- 10
   expect_equal(capture_dot(lf, x + n), expr(x + 10))
 })
 
+test_that("other objects get informative error", {
+  lf <- lazy_frame(a = 1)
+
+  input <- structure(list(), class = "reactivevalues")
+  x <- structure(function() "y", class = "reactive")
+  l <- list()
+  df <- data.frame(x = 1)
+
+  expect_snapshot({
+    capture_dot(lf, input)
+    capture_dot(lf, x())
+    capture_dot(lf, df)
+    capture_dot(lf, l)
+    capture_dot(lf, mean)
+  }, error = TRUE)
+})
+
+test_that("names are stripped", {
+  lf <- lazy_frame(x = "a")
+  y <- c(x = "a", "b")
+
+  expect_equal(partial_eval(quote(x %in% y), lf), expr(x %in% !!c("a", "b")))
+})
+
 test_that("using environment of inlined quosures", {
   lf <- lazy_frame(x = 1:10, y = 1:10)