Implement date type

.github/workflows/R-CMD-check.yaml

@@ -96,6 +96,10 @@ jobs:
           make clean
           R CMD INSTALL .
 
+      - name: Install DuckDB
+        run: |
+         R -e "remotes::install_github('duckdb/[email protected]', subdir ='tools/rpkg', build = FALSE)"
+
       - name: Run R CMD check
         uses: r-lib/actions/check-r-package@v2
         with:

NAMESPACE

@@ -9,6 +9,7 @@ S3method(as.list,substrait_proto_message)
 S3method(as.raw,substrait_proto_message)
 S3method(as_substrait,ArrowTabular)
 S3method(as_substrait,DataType)
+S3method(as_substrait,Date)
 S3method(as_substrait,Field)
 S3method(as_substrait,Message)
 S3method(as_substrait,Schema)
@@ -28,6 +29,7 @@ S3method(as_substrait,substrait_proto_message)
 S3method(collect,SubstraitCompiler)
 S3method(filter,SubstraitCompiler)
 S3method(from_substrait,DataType)
+S3method(from_substrait,Date)
 S3method(from_substrait,RecordBatch)
 S3method(from_substrait,Schema)
 S3method(from_substrait,character)

R/compiler.R

@@ -281,6 +281,10 @@ SubstraitCompiler <- R6::R6Class(
       extension_function$function_anchor
     },
 
+    extension_uri_anchor = function(name){
+      private$extension_uri[[1]]$extension_uri_anchor
+    },
+
     #' @description
     #' Get the extension uri anchor value for a given function
     #'

R/literal.R

@@ -282,6 +282,51 @@ as_substrait.character <- function(x, .ptype = NULL, ...) {
   }
 }
 
+#' @export
+as_substrait.Date <- function(x, .ptype = NULL, ...) {
+  if (is.null(.ptype)) {
+    .ptype <- substrait$Expression$Literal$create(date = NaN)
+  }
+
+  .qualified_name <- make_qualified_name(.ptype)
+
+  if (identical(.qualified_name, "substrait.Expression")) {
+    return(
+      substrait$Expression$create(
+        literal = as_substrait.Date(x, "substrait.Expression.Literal")
+      )
+    )
+  } else if (identical(.qualified_name, "substrait.Type")) {
+    return(substrait_date())
+  }
+
+  if (length(x) == 1 && !("list" %in% names(.ptype))) {
+    switch(.qualified_name,
+      "substrait.Expression.Literal" = {
+        if (is.na(x) && !is.nan(x)) {
+          substrait$Expression$Literal$create(
+            null = substrait_date()
+          )
+        } else {
+          substrait$Expression$Literal$create(date = x)
+        }
+      },
+      NextMethod()
+    )
+  } else {
+    switch(.qualified_name,
+      "substrait.Expression.Literal" = {
+        substrait$Expression$Literal$create(
+          list = substrait$Expression$Literal$List$create(
+            values = lapply(x, as_substrait.Date, .ptype = "substrait.Expression.Literal")
+          )
+        )
+      },
+      NextMethod()
+    )
+  }
+}
+
 #' @export
 from_substrait.double <- function(msg, x, ...) {
   .qualified_name <- make_qualified_name(msg)
@@ -429,3 +474,42 @@ from_substrait.character <- function(msg, x, ...) {
     NextMethod()
   )
 }
+
+#' @export
+from_substrait.Date <- function(msg, x, ...) {
+  .qualified_name <- make_qualified_name(msg)
+  switch(.qualified_name,
+    "substrait.Type" = {
+      type <- names(msg)
+      if (length(type) == 0) {
+        return(Date())
+      }
+
+      if (!identical(type, "date")) {
+        stop(sprintf("Can't convert substrait.Type<%s> to Date() ptype", type))
+      }
+      Date()
+    },
+    "substrait.Expression" = {
+      literal <- msg$literal
+      if (is.null(literal)) {
+        stop("Can't convert non-literal Expression to Date()")
+      }
+
+      from_substrait(literal, x)
+    },
+    "substrait.Expression.Literal" = {
+      lst <- as.list(msg)
+      switch(names(lst)[1],
+        "null" = NA_real_,
+        "list" = {
+          out <- vapply(lst$list$values, from_substrait, Date(1), Date())
+          as.Date(out, origin = "1970-01-01")
+        },
+        as.Date(lst[[1]], origin = "1970-01-01")
+      )
+    },
+    NextMethod()
+  )
+}
+

R/util.R

@@ -100,3 +100,8 @@ with_language <- function(lang, expr) {
   }
   force(expr)
 }
+
+# TODO: this is copied verbatim from lubridate - do we need to acknowledge somewhere?
+Date <- function(length = 0L) {
+    structure(rep.int(NA_real_, length), class = "Date")
+}

tests/testthat/test-literal.R

@@ -562,3 +562,130 @@ test_that("from_substrait() works for character()", {
     c("a string", "another string")
   )
 })
+
+test_that("as_substrait() works for Date", {
+
+  input_date <- as.Date(19320, origin = "1970-01-01")
+
+  # The substrait.Type representation of a Date() is a Type with the
+  # date member set and unknown nullability
+  expect_identical(
+    as_substrait(input_date, "substrait.Type"),
+    substrait_date()
+  )
+
+  # The Substrait representation of a non-NA Date(1)
+  # as an Expression is a Literal with the date member set
+  expect_identical(
+    as_substrait(input_date, "substrait.Expression"),
+    substrait$Expression$create(
+      literal = substrait$Expression$Literal$create(date = input_date)
+    )
+  )
+
+  # The Substrait representation of an NA Date(1)
+  # as an Expression is a Literal with the null member set
+  # to the appropriate type.
+  expect_identical(
+    as_substrait(structure(NA, class = "Date")),
+    substrait$Expression$Literal$create(
+      null = substrait_date()
+    )
+  )
+
+  # The default representation of a Date(1) is a Literal with the
+  # date payload set.
+  expect_identical(
+    as_substrait(input_date),
+    substrait$Expression$Literal$create(date = 19320)
+  )
+
+  # The representation of a Date(n) is a Literal$List() of Literals
+  # (which we can create by lapplying along the Date())
+  expect_identical(
+    as_substrait(
+      c(input_date, as.Date(19321, origin = "1970-01-01")),
+      substrait$Expression$Literal$create(list = substrait_proto_auto())
+    ),
+    substrait$Expression$Literal$create(
+      list = substrait$Expression$Literal$List$create(
+        values = list(
+          as_substrait(input_date),
+          as_substrait(as.Date(19321, origin = "1970-01-01"))
+        )
+      )
+    )
+  )
+
+  # Check that we fail when an unexpected type is requested
+  expect_error(as_substrait(input_date, "substrait.NotAType"), "Can't create substrait")
+  expect_error(as_substrait(c(input_date, input_date), "substrait.NotAType"), "Can't create substrait")
+})
+
+test_that("from_substrait() works for Date()", {
+  expect_identical(
+    from_substrait(substrait_date(), Date()),
+    Date()
+  )
+
+  expect_identical(
+    from_substrait(substrait$Type$create(), Date()),
+    Date()
+  )
+
+  expect_error(
+    from_substrait(substrait_i32(), Date()),
+    "Can't convert substrait.Type"
+  )
+
+  # Check that we can extract a Date() from an Expression with the literal
+  # member set.
+  expect_identical(
+    from_substrait(
+      substrait$Expression$create(
+        literal = substrait$Expression$Literal$create(date = 19320)
+      ),
+      Date()
+    ),
+    as.Date(19320, origin = "1970-01-01")
+  )
+
+  # Check that we can extract a double() from a Literal with the date
+  # member set.
+  expect_identical(
+    from_substrait(
+      substrait$Expression$Literal$create(date = 19320),
+      Date()
+    ),
+    as.Date(19320, origin = "1970-01-01")
+  )
+
+  # Check that we can extract a Date() from an Expression with
+  # the null member set.
+  expect_identical(
+    from_substrait(
+      substrait$Expression$Literal$create(
+        null = substrait_date()
+      ),
+      Date()
+    ),
+    NA_real_
+  )
+
+  # Check that we can extract a Date(n) from a Literal with
+  # the list member set.
+  expect_identical(
+    from_substrait(
+      substrait$Expression$Literal$create(
+        list = substrait$Expression$Literal$List$create(
+          values = list(
+            as_substrait(19320),
+            as_substrait(19321)
+          )
+        )
+      ),
+      Date()
+    ),
+    c(as.Date(19320, origin = "1970-01-01"), as.Date(19321, origin = "1970-01-01"))
+  )
+})

tests/testthat/test-pkg-arrow.R

@@ -31,6 +31,37 @@ test_that("ArrowSubstraitCompiler$plan() generates the correct extension URIs",
   )
 })
 
+test_that("ArrowSubstraitCompiler$plan() generates the correct extension URIs", {
+  df <- tibble::tibble(x = 1:3)
+
+  compiler <- arrow_substrait_compiler(df) %>%
+    substrait_select(x1 = x > 2, x2 = x + 2)
+
+  plan <- compiler$plan()
+  expect_length(plan$extension_uris, 2)
+
+  expect_identical(plan$extensions[[1]]$extension_function$name, "gt")
+  expect_identical(
+    plan$extensions[[1]]$extension_function$extension_uri_reference,
+    # uri reference for "add"
+    2
+  )
+
+  expect_identical(plan$extensions[[2]]$extension_function$name, "add")
+  expect_identical(
+    plan$extensions[[2]]$extension_function$extension_uri_reference,
+    # uri reference for "comparison"
+    1
+  )
+
+  out_df <- as.data.frame(compiler$evaluate())
+
+  expect_identical(
+    out_df,
+    tibble::tibble(x1 = c(FALSE, FALSE, TRUE), x2 = c(3, 4, 5))
+  )
+})
+
 test_that("substrait_compiler() creates an ArrowSubstraitCompiler for ArrowTabular", {
   rb <- arrow::record_batch(
     a_field = arrow::Array$create(integer(), arrow::int32())