feat: Allow comparison of XVector objects (part 2 of 2)

DESCRIPTION

@@ -5,7 +5,7 @@ Description: Provides memory efficient S4 classes for storing sequences
 biocViews: Infrastructure, DataRepresentation
 URL: https://bioconductor.org/packages/XVector
 BugReports: https://github.com/Bioconductor/XVector/issues
-Version: 0.47.1
+Version: 0.47.2
 License: Artistic-2.0
 Encoding: UTF-8
 Author: Hervé Pagès and Patrick Aboyoun

R/SharedVector-class.R

@@ -277,6 +277,26 @@ SharedVector.compare <- function(x1, start1, x2, start2, width)
     .Call2("SharedVector_memcmp",
           x1, start1, x2, start2, width, PACKAGE="XVector")
 
+SharedVector.order <- function(x, decreasing=FALSE){
+    ## will have to add in method arg later
+    ## adding 1L because this method returns 0-indexed values
+    .Call("SharedVector_order",
+        x, length(x), decreasing, PACKAGE="XVector") + 1L
+}
+setMethod("order", "SharedVector",
+    function(..., na.last=TRUE, decreasing=FALSE, method=c("auto", "shell", "radix")){
+        args <- list(...)
+        if (length(args) == 1L) {
+            x <- args[[1L]]
+            SharedVector.order(x, decreasing)
+        } else {
+            args <- unname(args)
+            lapply(args, order,
+                na.last=na.last, decreasing=decreasing, method=method)
+        }
+    }
+)
+
 
 ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ### Low-level copy.
@@ -375,3 +395,7 @@ setMethod("!=", signature(e1="SharedVector", e2="SharedVector"),
     function(e1, e2) address(e1@xp) != address(e2@xp)
 )
 
+setMethod("<=", signature(e1="SharedVector", e2="SharedVector"),
+    function(e1, e2) address(e1@xp) <= address(e2@xp)
+)
+

R/XVector-class.R

@@ -180,7 +180,80 @@ setMethod("bindROWS", "XVector", .concatenate_XVector_objects)
     as.logical(ans)
 }
 
+.XVector.lt_or_equal <- function(x, y)
+{
+    if (class(x) != class(y) || x@length != y@length)
+        return(FALSE)
+    ans <- SharedVector.compare(x@shared, x@offset + 1L,
+                                 y@shared, y@offset + 1L,
+                                 x@length)
+    ans <= 0
+}
+
 setMethod("==", signature(e1="XVector", e2="XVector"),
     function(e1, e2) .XVector.equal(e1, e2)
 )
 
+setMethod("<=", signature(e1="XVector", e2="XVector"),
+    function(e1, e2) .XVector.lt_or_equal(e1, e2)
+)
+
+setMethod("==", signature(e1="XVector", e2="ANY"),
+    function(e1, e2) e1 == as(e2, class(e1))
+)
+setMethod("<=", signature(e1="XVector", e2="ANY"),
+    function(e1, e2) e1 <= as(e2, class(e1))
+)
+
+## These methods are required, otherwise it dispatches to base comparison
+## (which is element-wise)
+setMethod("==", signature(e1="ANY", e2="XVector"),
+    function(e1, e2) e2 == e1
+)
+setMethod("<=", signature(e1="ANY", e2="XVector"),
+    function(e1, e2) !(e2 > e1)
+)
+
+### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+### Parallel comparison
+###
+### order() and sameAsPreviousROW make XVector compatible with pcompare
+###  as defined in S4Vectors
+
+.XVector.order <- function(x, decreasing=FALSE){
+    SharedVector.order(x@shared, decreasing)
+}
+setMethod("order", "XVector",
+    function(..., na.last=TRUE, decreasing=FALSE, method=c("auto", "shell", "radix")){
+        args <- list(...)
+        if (length(args) == 1L) {
+            x <- args[[1L]]
+            .XVector.order(x, decreasing)
+        } else {
+            args <- unname(args)
+            ## do.call("order", args) doesn't work here
+            ## I can't figure out why...this produces the same result
+            lapply(args, order,
+                na.last=na.last, decreasing=decreasing, method=method)
+        }
+    }
+)
+
+.XVector.sameAsPreviousROW <- function(x){
+    if(NROW(x) == 0){
+        logical(0L)
+    } else {
+        c(FALSE, vapply(seq_along(head(x,n=-1L)),
+                        \(i){ x[i] == x[i+1] }, logical(1L)))
+    }
+}
+setMethod("sameAsPreviousROW", "XVector", .XVector.sameAsPreviousROW)
+
+## This methods are defined so that the XVector argument comes first
+## this matters because of how S4Vectors::pcompare is defined; it attempts
+## to coerce the second argument to a list and then concatenate, which can
+## cause weird behavior if the first element is an atomic vector and the
+## second is an XVector object.
+setMethod("pcompare", signature(x="ANY", y="XVector"),
+    function(x, y) -1*callNextMethod(y, x)
+)

man/XVector-class.Rd

@@ -15,6 +15,13 @@
 \alias{as.numeric,XVector-method}
 \alias{show,XVector-method}
 \alias{==,XVector,XVector-method}
+\alias{<=,XVector,XVector-method}
+\alias{>=,XVector,XVector-method}
+\alias{<,XVector,XVector-method}
+\alias{>,XVector,XVector-method}
+\alias{!=,XVector,XVector-method}
+\alias{pcompare,XVector,XVector-method}
+\alias{order,XVector,XVector-method}
 
 % XRaw class, functions and methods:
 \alias{class:XRaw}
@@ -80,6 +87,31 @@
   data when a linear subsequence needs to be extracted.
 }
 
+\section{Comparison operations on XVector objects}{
+Unlike the R's base vectors, comparing two XVector objects works \emph{atomically} -- that is, it doesn't compare element-by-element, but rather the two vectors as a whole. Thus, the return value of a comparison between two XVector objects will always be a single logical value. Comparison between an XVector and a base vector is performed by coercing the base vector to the same type as the XVector prior to comparison (potentially throwing an error if the comparison is impossible!).
+
+For element-wise comparison, the following are provided:
+
+  \describe{
+    \item{\code{pcompare(x,y)}:}{
+      Compares the elements of two vectors \code{x} and \code{y} in an
+      element-wise fashion. If \code{length(x) != length(y)}, the shorter
+      length vector is recycled to the length of the longer. Returns a
+      vector where the i'th element is:
+      \itemize{
+      \item negative if \code{x[i] < y[i]}
+      \item zero if \code{x[i] == y[i]}
+      \item positive if \code{x[i] > y[i]}
+      } More details are
+      available in the help page available via S4Vectors:
+      \code{\link[S4Vectors]{pcompare}}.
+    }
+    \item{\code{order(..., na.last=TRUE, decreasing=FALSE, method=c("auto", "shell", "radix"))}:}{
+      Returns a permutation vector that rearranges its first argument into ascending or descending order, similar to \code{\link[base]{order}}. Argument \code{na.last} is ignored, since XVector objects do not allow \code{NA} values. Argument \code{method} is currently ignored, but will be implemented in the future. If multiple XVectors are passed, returns a list of permutation vectors for each XVector.
+    }
+  }
+}
+
 \section{Additional Subsetting operations on XVector objects}{
   In the code snippets below, \code{x} is an XVector object.
 
@@ -168,6 +200,26 @@
 
   x3[length(x3):1]
   x3[length(x3):1, drop=FALSE]
+
+  ## ---------------------------------------------------------------------
+  ## C. Comparing XVector OBJECTS
+  ## ---------------------------------------------------------------------
+  xv <- XInteger(5, 1:5)
+  yv <- XInteger(5, 5:1)
+
+  ## Comparison between XVector objects is ATOMIC
+  xv == yv ## FALSE
+  xv <  yv ## TRUE
+
+  ## Element-wise comparison uses pcompare
+  pcompare(xv, yv)  ## -1 -1  0  1  1
+  pcompare(yv, xv)  ##  1  1  0 -1 -1
+  pcompare(xv, 5:1) ## equivalent to pcompare(xv, yv)
+
+  ## Convert to T/F values by comparing against zero:
+  pcompare(xv, yv) <  0 ## element-wise xv <  yv
+  pcomapre(xv, yv) >= 0 ## element-size xv >= yv
+
 }
 
 \keyword{methods}

src/R_init_XVector.c

@@ -29,6 +29,7 @@ static const R_CallMethodDef callMethods[] = {
 	CALLMETHOD_DEF(externalptr_show, 1),
 	CALLMETHOD_DEF(SharedVector_address0, 1),
 	CALLMETHOD_DEF(SharedVector_memcmp, 5),
+	CALLMETHOD_DEF(SharedVector_order, 3),
 	CALLMETHOD_DEF(SharedVector_Ocopy_from_start, 6),
 	CALLMETHOD_DEF(SharedVector_Ocopy_from_subscript, 4),
 	CALLMETHOD_DEF(SharedVector_mcopy, 7),

src/SharedVector_class.c

@@ -259,6 +259,46 @@ SEXP SharedVector_memcmp(SEXP x1, SEXP start1, SEXP x2, SEXP start2, SEXP width)
 	return ans;
 }
 
+SEXP SharedVector_order(SEXP x, SEXP width, SEXP descending)
+{
+	SEXP ans;
+	int nelt, desc;
+	SEXP tag = _get_SharedVector_tag(x);
+	nelt = INTEGER(width)[0];
+	desc = LOGICAL(descending)[0];
+
+	PROTECT(ans = NEW_INTEGER(nelt));
+	int *indices = INTEGER(ans);
+	for(int i=0; i<nelt; i++)
+		indices[i] = i;
+
+	const void *s;
+	int eltsize;
+	int use_double_compar = 0;
+	if (IS_RAW(tag)){
+		s = RAW(tag);
+		eltsize = sizeof(Rbyte);
+	} else if (IS_INTEGER(tag)){
+		s = INTEGER(tag);
+		eltsize = sizeof(int);
+	} else if (IS_NUMERIC(tag)) {
+		s = REAL(tag);
+		eltsize = sizeof(double);
+		use_double_compar = 1;
+	} else {
+		error("XVector internal error in SharedVector_order(): "
+		      "%s: invalid tag type", CHAR(type2str(TYPEOF(tag))));
+	}
+
+	int status = sort_void_array(indices, nelt, s, eltsize, desc,
+																use_double_compar, 0, NULL, NULL);
+	if(status != 1){
+		error("XVector internal error while sorting in SharedVector_order. Please report!");
+	}
+	UNPROTECT(1);
+	return ans;
+}
+
 SEXP SharedVector_Ocopy_from_start(SEXP out, SEXP in, SEXP in_start, SEXP width,
 		SEXP lkup, SEXP reverse)
 {

src/XVector.h

@@ -311,6 +311,8 @@ SEXP SharedVector_memcmp(
 	SEXP width
 );
 
+SEXP SharedVector_order(SEXP x, SEXP width, SEXP descending);
+
 SEXP SharedVector_Ocopy_from_start(
 	SEXP out,
 	SEXP in,