diff --git a/NAMESPACE b/NAMESPACE index d80abdf..27a788f 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/bit64-package.R b/R/bit64-package.R index dbac467..e693715 100644 --- a/R/bit64-package.R +++ b/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 diff --git a/R/setops64.R b/R/setops64.R index 78deb9a..3af2e26 100644 --- a/R/setops64.R +++ b/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) { diff --git a/man/sets.Rd b/man/sets.Rd index e93b18f..2ecedca 100644 --- a/man/sets.Rd +++ b/man/sets.Rd @@ -1,6 +1,7 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/setops64.R -\name{union} +\name{sets} +\alias{sets} \alias{union} \alias{intersect} \alias{setequal} diff --git a/tests/testthat/test-setops64.R b/tests/testthat/test-setops64.R index 91c6ccb..0b86b25 100644 --- a/tests/testthat/test-setops64.R +++ b/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 +))