Attempt S4 dispatch for intersect() and union()

NAMESPACE

@@ -89,8 +89,12 @@ S3method(hashtab,cache_integer64)
 S3method(hashuni,cache_integer64)
 S3method(hashupo,cache_integer64)
 S3method(identical,integer64)
+S3method(intersect,default)
+S3method(intersect,integer64)
 S3method(is.double,default)
 S3method(is.double,integer64)
+S3method(is.element,default)
+S3method(is.element,integer64)
 S3method(is.finite,integer64)
 S3method(is.infinite,integer64)
 S3method(is.na,integer64)
@@ -155,6 +159,10 @@ S3method(rowSums,default)
 S3method(rowSums,integer64)
 S3method(scale,integer64)
 S3method(seq,integer64)
+S3method(setdiff,default)
+S3method(setdiff,integer64)
+S3method(setequal,default)
+S3method(setequal,integer64)
 S3method(shellorder,integer64)
 S3method(shellsort,integer64)
 S3method(shellsortorder,integer64)
@@ -182,6 +190,8 @@ S3method(table,default)
 S3method(table,integer64)
 S3method(tiepos,integer64)
 S3method(trunc,integer64)
+S3method(union,default)
+S3method(union,integer64)
 S3method(unipos,integer64)
 S3method(unique,integer64)
 export("%in%")
@@ -329,6 +339,8 @@ importFrom(graphics,par)
 importFrom(graphics,title)
 importFrom(methods,as)
 importFrom(methods,is)
+importFrom(methods,isGeneric)
+importFrom(methods,selectMethod)
 importFrom(stats,cor)
 importFrom(stats,median)
 importFrom(stats,quantile)

R/bit64-package.R

@@ -704,7 +704,7 @@
 #'   ramsort ramsortorder repeat.time setattr shellorder shellsort
 #'   shellsortorder still.identical
 #' @importFrom graphics barplot par title
-#' @importFrom methods as is
+#' @importFrom methods as is isGeneric selectMethod
 #' @importFrom stats cor median quantile
 #' @importFrom utils head packageDescription strOptions tail getS3method
 #' @export : %in% is.double match order print.cache rank

R/setops64.R

@@ -28,12 +28,22 @@
 #' setequal(x, y)
 #' is.element(x, y)
 #' 
+#' @name sets
 #' @export
 #' @rdname sets
 union = function(x, y) {
+  if ((isS4(x) || isS4(y)) && isGeneric("union"))
+    return(selectMethod("union", c(x=class(x), y=class(y)))(x, y))
   if (!(is.integer64(x) || is.integer64(y)))
-    return(base::union(x, y))
+    return(union.default(x, y))
+  union.integer64(x, y)
+}
+
+#' @exportS3Method union default
+union.default = base::union
 
+#' @exportS3Method union integer64
+union.integer64 = function(x, y) {
   target_class = target_class(list(x, y))
   # try using the benefit of integer64 caching, if possible. I.e. call unique() before as().
   x = unique(x)
@@ -56,13 +66,23 @@ union = function(x, y) {
   unique(c(x, y))
 }
 
+
 #' @export
 #' @rdname sets
 intersect = function(x, y) {
   if (is.null(x) || is.null(y)) return(NULL)
+  if ((isS4(x) || isS4(y)) && isGeneric("intersect"))
+    return(selectMethod("intersect", c(x=class(x), y=class(y)))(x, y))
   if (!(is.integer64(x) || is.integer64(y)))
-    return(base::intersect(x, y))
+    return(intersect.default(x, y))
+  intersect.integer64(x, y)
+}
+
+#' @exportS3Method intersect default
+intersect.default = base::intersect
 
+#' @exportS3Method intersect integer64
+intersect.integer64 = function(x, y) {
   target_class = target_class(list(x, y))
   x = unique(x)
   class_x = class(x)[1L]
@@ -87,9 +107,18 @@ intersect = function(x, y) {
 #' @export
 #' @rdname sets
 setequal = function(x, y) {
+  if ((isS4(x) || isS4(y)) && isGeneric("setequal"))
+    return(selectMethod("setequal", c(x=class(x), y=class(y)))(x, y))
   if (!(is.integer64(x) || is.integer64(y)))
-    return(base::setequal(x, y))
+    return(setequal.default(x, y))
+  setequal.integer64(x, y)
+}
+
+#' @exportS3Method setequal default
+setequal.default = base::setequal
 
+#' @exportS3Method setequal integer64
+setequal.integer64 = function(x, y) {
   x = unique(x)
   y = unique(y)
   length_x = length(x)
@@ -109,9 +138,18 @@ setequal = function(x, y) {
 #' @export
 #' @rdname sets
 setdiff = function(x, y) {
+  if ((isS4(x) || isS4(y)) && isGeneric("setdiff"))
+    return(selectMethod("setdiff", c(x=class(x), y=class(y)))(x, y))
   if (!(is.integer64(x) || is.integer64(y)))
-    return(base::setdiff(x, y))
+    return(setdiff.default(x, y))
+  setdiff.integer64(x, y)
+}
+
+#' @exportS3Method setdiff default
+setdiff.default = base::setdiff
 
+#' @exportS3Method setdiff integer64
+setdiff.integer64 = function(x, y) {
   class_x = class(x)[1L]
   if (class_x %in% c("POSIXct", "Date"))
     x = unclass(x)
@@ -138,9 +176,18 @@ setdiff = function(x, y) {
 #' @export
 #' @rdname sets
 is.element = function(el, set) {
+  if ((isS4(el) || isS4(set)) && isGeneric("is.element"))
+    return(selectMethod("is.element", c(el=class(el), set=class(set)))(el, set))
   if (!(is.integer64(el) || is.integer64(set)))
-    return(base::is.element(el, set))
+    return(is.element.default(el, set))
+  is.element.integer64(el, set)
+}
+
+#' @exportS3Method is.element default
+is.element.default = base::is.element
 
+#' @exportS3Method is.element integer64
+is.element.integer64 = function(el, set) {
   target_class = target_class(list(el, set))
   class_el = class(el)[1L]
   if (class_el != target_class) {

tests/testthat/test-setops64.R

@@ -320,3 +320,63 @@ test_that("is.element works (additional cases)", {
   expect_true(is.element(NA_integer64_, NA))
 
 })
+
+test_that("S3 dispatch happens for classes extending integer64 (#298)", {
+  x = 1:2
+  y = as.integer64(2:3)
+  class(y) = c('foo', 'integer64')
+  expect_identical(intersect(x, y), as.integer64(2L))
+  expect_identical(union(x, y), as.integer64(1:3))
+  expect_identical(setdiff(x, y), 1L)
+})
+
+# This test has to be the last test, because it adds a generic (e.g. intersect), which cannot be removed properly during R CMD CHECK. 
+# If removeGeneric() is called the following test have base::intersect instead of bit64::intersect as 'generic'.
+# This even applies for the two runs per 'method' within the test.
+with_parameters_test_that("S4 and S3 dispatch still happens for classes extending {dataType} (#301)", {
+  x = as(1:2, dataType)
+  y = as.integer64(2:3)
+
+  # S4
+  methods::setClass("TestS4", representation(data=dataType))
+  methods::setGeneric(method)
+  methods::setMethod(
+    method,
+    signature=c("TestS4", "integer64"),
+    function(x, y) "Successfully routed to S4 method A!"
+  )
+  methods::setMethod(
+    method,
+    signature=c("TestS4", "TestS4"),
+    function(x, y) "Successfully routed to S4 method B!"
+  )
+  # Instantiate test objects
+  xS4 = methods::new("TestS4", data=x)
+  fun = get(method)
+  expect_identical(fun(xS4, y), "Successfully routed to S4 method A!")
+  # NB: nanoival class is "complex64" -- it kludges complex to be a pair
+  #   of integer64 vectors, but there is no complex64 class, so it just
+  #   shows up on the inheritance chain as 'complex' --> need to ensure
+  #   S4 gets invoked when possible even if the inputs don't directly test
+  #   as being is("integer64").
+  expect_identical(fun(xS4, xS4), "Successfully routed to S4 method B!")
+
+  # S3
+  yS3 = y
+  class(yS3) = c('foo', 'integer64')
+  actual_result = fun(x, yS3)
+  expected_result = fun(as.integer(x), as.integer(y))
+  if (!(dataType == "integer" && method == "setdiff"))
+    expected_result = as.integer64(expected_result)
+  expect_identical(actual_result, expected_result)
+
+  # cleanup
+  methods::removeMethod(method, signature=c("TestS4", "integer64"))
+  methods::removeMethod(method, signature=c("TestS4", "TestS4"))
+  methods::removeClass("TestS4")
+},
+.cases=expand.grid(
+  dataType=c("integer", "integer64"),
+  method=c("intersect", "union", "setdiff"),
+  stringsAsFactors=FALSE
+))