inst/unitTests/test_Vector-comparison.R

In S4Vectors: Foundation of vector-like and list-like containers in Bioconductor

test_Vector_comparison <- function() {
    # Creating a dummy Vector class, and implementing the
    # minimum operations required to get all comparison methods.
    setClass("AaronStuff", contains="Vector", slots=c(stuff="integer"))
    setMethod("parallel_slot_names", "AaronStuff", function(x) c("stuff", callNextMethod()))

    setMethod("sameAsPreviousROW", "AaronStuff", function(x) sameAsPreviousROW(x@stuff))
    setMethod("order", "AaronStuff",
        function(..., na.last = TRUE, decreasing = FALSE, method = c("auto", "shell", "radix")) {
            everything <- list(...)
            everything <- lapply(everything, slot, "stuff")
            do.call(order, c(everything, list(na.last=na.last, decreasing=decreasing, method=method)))
        }
    )

    x <- as.integer(c(9,1,3,5,6,3,2,7,6,3,2,21))
    a <- new("AaronStuff", stuff=x)

    # Basic checks.
    checkIdentical(order(x), order(a))

    checkIdentical(sameAsPreviousROW(x), c(FALSE, x[-1]==head(x, -1)))
    checkIdentical(sameAsPreviousROW(x), sameAsPreviousROW(a))

    sx <- sort(x)
    checkIdentical(sameAsPreviousROW(sx), c(FALSE, sx[-1]==head(sx, -1)))
    checkIdentical(sameAsPreviousROW(sx), sameAsPreviousROW(sort(a)))

    checkIdentical(sameAsPreviousROW(x[0]), logical(0)) # robust to empty inputs.
    checkIdentical(sameAsPreviousROW(a[0]), logical(0))

    checkIdentical(sameAsPreviousROW(c(NA, 1L, 2L)), logical(3)) # robust to NA values.
    checkIdentical(sameAsPreviousROW(c(NA, NA, 2L)), c(FALSE, TRUE, FALSE))
    checkIdentical(sameAsPreviousROW(c(NA, NA, NaN, NaN)), c(FALSE, TRUE, FALSE, TRUE))

    # Checking selfmatch.
    checkIdentical(selfmatch(x), match(x, x))
    checkIdentical(selfmatch(a), selfmatch(x))
    checkIdentical(selfmatch(a[0]), integer(0))

    # Checking xtfrm.
    checkIdentical(order(xtfrm(a)), order(x))
    checkIdentical(rank(xtfrm(a)), rank(x)) # checking ties are the same.

    # Checking match.
    y <- as.integer(c(7, 2, 4, 4, 6, 5, 9, 6, 4))
    b <- new("AaronStuff", stuff=y)

    checkIdentical(match(a, b), match(x, y))
    checkIdentical(match(b, a), match(y, x))

    # Checking pcompare.
    ref <- pcompare(x, rev(x))
    checkEqualsNumeric(ref, sign(x - rev(x)))
    checkIdentical(ref, pcompare(a, rev(a)))

    checkIdentical(pcompare(a, a), integer(length(a)))
    checkIdentical(pcompare(a, new("AaronStuff", stuff=x-1L)), rep(1L, length(a)))
    checkIdentical(pcompare(a, new("AaronStuff", stuff=x+1L)), rep(-1L, length(a)))

    checkIdentical(pcompare(x, x), integer(length(x)))
    checkIdentical(pcompare(x, x-1L), rep(1L, length(x)))
    checkIdentical(pcompare(x, x+1L), rep(-1L, length(x)))
}