Add translation to comparison expressions

R/relational-duckdb.R

@@ -393,6 +393,15 @@ to_duckdb_expr <- function(x) {
       }
       out
     },
+    relational_relexpr_comparison = {
+      out <- duckdb$expr_comparison(to_duckdb_exprs(x$exprs), x$cmp_op)
+      if (!is.null(x$alias)) {
+        out <- expr({
+          duckdb$expr_set_alias(tmp_expr, x$alias)
+        })
+      }
+      out
+    },
     relational_relexpr_function = {
       out <- duckdb$expr_function(x$name, to_duckdb_exprs(x$args))
       if (!is.null(x$alias)) {
@@ -454,6 +463,17 @@ to_duckdb_expr_meta <- function(x) {
       }
       out
     },
+    relational_relexpr_comparison = {
+      out <- expr(duckdb$expr_comparison(list(!!!to_duckdb_exprs_meta(x$exprs)), !!x$cmp_op))
+      if (!is.null(x$alias)) {
+        out <- expr({
+          tmp_expr <- !!out
+          duckdb$expr_set_alias(tmp_expr, !!x$alias)
+          tmp_expr
+        })
+      }
+      out
+    },
     relational_relexpr_function = {
       meta_macro_register(x$name)
       out <- expr(duckdb$expr_function(!!x$name, list(!!!to_duckdb_exprs_meta(x$args))))

R/relational-expr.R

@@ -77,6 +77,22 @@ relexpr_function <- function(name, args, alias = NULL) {
   new_relexpr(list(name = name, args = args, alias = alias), class = "relational_relexpr_function")
 }
 
+#' relexpr_comparison
+#'
+#' `relexpr_comparison()` wraps a comparison expression
+#'
+#' @param exprs Expressions to compare, a list of `expr` objects.
+#' @param cmp_op Comparison operator, eg. "<" or "="
+#' @rdname new_relexpr
+#' @return an object of class `"relational_relexpr"`
+#' @export
+relexpr_comparison <- function(exprs, cmp_op) {
+  stopifnot(is_string(cmp_op))
+  stopifnot(is.list(exprs))
+  new_relexpr(list(exprs = exprs, cmp_op = cmp_op), class = "relational_relexpr_comparison")
+}
+
+
 #' relexpr_window
 #'
 #' `relexpr_window()` applies a function over a window,

R/translate.R

@@ -12,7 +12,6 @@ rel_find_call <- function(fun, env) {
 
   # Order from https://docs.google.com/spreadsheets/d/1j3AFOKiAknTGpXU1uSH7JzzscgYjVbUEwmdRHS7268E/edit?gid=769885824#gid=769885824,
   # generated as `expr_result` by 63-gh-detail.R
-
   pkgs <- switch(name,
     # Handled in a special way, not mentioned here
     # "desc" = c("dplyr", "duckplyr"),
@@ -124,11 +123,38 @@ rel_find_call <- function(fun, env) {
   }
 }
 
+infer_type_of_expr <- function(
+    expr,
+    types_data,
+    names_data
+) {
+  if (typeof(expr) == 'symbol') {
+    name <- as.character(expr)
+    col_idx <- which(name == names_data)
+    if (col_idx == 0) stop(paste0("Unable to find column '",name,"'"))
+    return(types_data[col_idx])
+  }
+  return(typeof(expr))
+}
+
+types_are_comparable <- function(types) {
+  # TODO: Incomplete, written for demo
+  left  = types[1]
+  right = types[2]
+
+  if (left == right) return(TRUE)
+  if (left == "integer" && right == "double") return(TRUE)
+  if (left == "double"  && right == "integer") return(TRUE)
+
+  return(FALSE)
+}
+
 rel_translate_lang <- function(
     expr,
     do_translate,
     # FIXME: Perform constant folding instead
     names_data,
+    types_data,
     env,
     # FIXME: Perform constant folding instead
     partition,
@@ -139,6 +165,27 @@ rel_translate_lang <- function(
   pkg <- pkg_name[[1]]
   name <- pkg_name[[2]]
 
+
+  if (name %in% c(">","<","=",">=","<=") && !is.null(types_data)) {
+
+    types <- sapply(
+        expr[2:3],
+        infer_type_of_expr,
+        types_data,
+        names_data
+    )
+
+    if (types_are_comparable(types)) {
+      return(
+        relexpr_comparison(
+          list(do_translate(expr[[2]]), do_translate(expr[[3]]))
+          ,name
+        )
+      )  
+    }
+  }
+
+
   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
@@ -316,6 +363,11 @@ rel_translate <- function(
 
   used <- character()
 
+  types_data = NULL
+  if (hasArg(data) && !is.null(data)) {
+    types_data <- sapply(data,typeof)
+  }
+
   do_translate <- function(expr, in_window = FALSE, top_level = FALSE) {
     stopifnot(!is_quosure(expr))
     switch(typeof(expr),
@@ -345,6 +397,7 @@ rel_translate <- function(
         expr,
         do_translate,
         names_data,
+        types_data,
         env,
         partition,
         in_window,