R Under development (unstable) (2024-09-06 r87103 ucrt) -- "Unsuffered Consequences"
Copyright (C) 2024 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> library("matrixStats")
> 
> dense_rank <- function(x) match(x, table = sort(unique(x)))
> 
> rowRanks_R <- function(x, ties.method, ..., useNames = NA) {
+   if (ties.method == "dense") {
+     res <- t(apply(x, MARGIN = 1L, FUN = dense_rank))
+   } else {
+     res <- t(apply(x, MARGIN = 1L, FUN = rank, na.last = "keep", ties.method = ties.method))
+   }
+   
+   # Preserve dimnames attribute?
+   dim(res) <- dim(x)
+   dimnames(res) <- if (isTRUE(useNames)) dimnames(x) else NULL
+   
+   res
+ }
> 
> colRanks_R <- function(x, ties.method, preserveShape = FALSE, ..., useNames = NA) {
+   if (ties.method == "dense") {
+     res <- t(apply(x, MARGIN = 2L, FUN = dense_rank))
+   } else {
+     res <- t(apply(x, MARGIN = 2L, FUN = rank, na.last = "keep", ties.method = ties.method))
+   }
+   
+   # Preserve dimnames attribute?
+   tx <- t(x)
+   dim(res) <- dim(tx)
+   dimnames(res) <- if (isTRUE(useNames)) dimnames(tx) else NULL
+   
+   if (preserveShape) res <- t(res)
+   res
+ }
> 
> set.seed(1)
> 
> cat("Consistency checks:\n")
Consistency checks:
> xs <- vector("list", length = 4L)
> for (kk in 1:4) {
+   
+   # Simulate data in a matrix of any shape
+   dim <- sample(40:80, size = 2L)
+   n <- prod(dim)
+   x <- rnorm(n, sd = 10)
+   dim(x) <- dim
+   
+   # Add NAs?
+   if ((kk %% 4) %in% c(3, 0)) {
+     cat("Adding NAs\n")
+     nna <- sample(n, size = 1L)
+     x[sample(length(x), size = nna)] <- NA_real_
+   }
+   
+   # Integer or double?
+   if ((kk %% 4) %in% c(2, 0)) {
+     cat("Coercing to integers\n")
+     storage.mode(x) <- "integer"
+   }
+ 
+   xs[[kk]] <- x
+ } # for (kk ...)
Coercing to integers
Adding NAs
Adding NAs
Coercing to integers
> str(xs)
List of 4
 $ : num [1:43, 1:78] 13.3 12.72 4.15 -15.4 -9.29 ...
 $ : int [1:46, 1:61] 2 11 -16 -5 19 5 26 -13 1 -9 ...
 $ : num [1:42, 1:47] NA -22.3 NA NA NA ...
 $ : int [1:42, 1:78] NA NA NA NA NA NA NA NA NA NA ...
> 
> for (kk in 1:4) {
+   cat("Random test #", kk, "\n", sep = "")
+   x <- xs[[kk]]
+   tx <- t(x)
+   
+   for (ties in c("max", "min", "average", "first", "last", "dense")) {
+     cat(sprintf("ties.method = %s\n", ties))
+     # rowRanks():
+     y1 <- matrixStats::rowRanks(x, ties.method = ties)
+     if (ties != "last" || getRversion() >= "3.3.0") {
+       y2 <- rowRanks_R(x, ties.method = ties)
+       stopifnot(identical(y1, y2))
+     }
+     
+     y3 <- matrixStats::colRanks(tx, ties.method = ties)
+     stopifnot(identical(y1, y3))
+     
+     # colRanks():
+     y1 <- matrixStats::colRanks(x, ties.method = ties)
+     if (ties != "last" || getRversion() >= "3.3.0") {
+       y2 <- colRanks_R(x, ties.method = ties)
+       stopifnot(identical(y1, y2))
+     }
+     
+     y3 <- matrixStats::rowRanks(tx, ties.method = ties)
+     stopifnot(identical(y1, y3))
+   }
+ } # for (kk ...)
Random test #1
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
Random test #2
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
Random test #3
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
Random test #4
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
> 
> # Note, below we know ties.method %in% c("min", "max", "average") is correct
> 
> cat("Consistency checks for random:\n")
Consistency checks for random:
> tolerance <- 0.1
> nsamples <- 10000
> for (kk in 1:4) {
+   cat("Random test #", kk, "\n", sep = "")
+   x <- xs[[kk]]
+   tx <- t(x)
+ 
+   for (ties in c("random")) {
+     cat(sprintf("ties.method = %s\n", ties))
+     
+     ## rowRanks():
+     y0 <- rowRanks_R(x, ties.method = ties)
+     y1 <- matrixStats::rowRanks(x, ties.method = ties)
+     
+     ## Assert symmetric rank differences
+     d <- y1 - y0
+     stopifnot(all(rowSums(d) == 0, na.rm = TRUE))
+     
+     ## Assert within [min, max]
+     y2min <- matrixStats::rowRanks(x, ties.method = "min")
+     y2max <- matrixStats::rowRanks(x, ties.method = "max")
+     stopifnot(all(y1 >= y2min, na.rm = TRUE) && all(y1 <= y2max, na.rm = TRUE))
+     ## Assert near average
+     y1list <- replicate(nsamples, matrixStats::rowRanks(x, ties.method = ties), simplify = FALSE)
+     y1mean <- Reduce(`+`, y1list) / nsamples
+     y2avg <- matrixStats::rowRanks(x, ties.method = "average")
+     stopifnot(all(abs(y1mean - y2avg) < tolerance, na.rm = TRUE))
+ 
+     ## colRanks():
+     y0 <- colRanks_R(x, ties.method = ties)
+     y1 <- matrixStats::colRanks(x, ties.method = ties)
+ 
+     ## Assert symmetric rank differences
+     d <- y1 - y0
+     stopifnot(all(rowSums(d) == 0, na.rm = TRUE))
+ 
+     ## Assert within [min, max]
+     y2min <- matrixStats::colRanks(x, ties.method = "min")
+     y2max <- matrixStats::colRanks(x, ties.method = "max")
+     stopifnot(all(y1 >= y2min, na.rm = TRUE) && all(y1 <= y2max, na.rm = TRUE))
+     y1list <- replicate(nsamples, matrixStats::colRanks(x, ties.method = ties), simplify = FALSE)
+     y1mean <- Reduce(`+`, y1list) / nsamples
+     ## Assert near average
+     y2avg <- matrixStats::colRanks(x, ties.method = "average")
+     stopifnot(all(abs(y1mean - y2avg) < tolerance, na.rm = TRUE))
+   }
+ } # for (kk ...)
Random test #1
ties.method = random
Random test #2
ties.method = random
Random test #3
ties.method = random
Random test #4
ties.method = random
> 
> 
> ## Exception handling
> x <- matrix(1:12, nrow = 3L, ncol = 4L)
> y <- try(rowRanks(x, ties.method = "unknown"), silent = TRUE)
> stopifnot(inherits(y, "try-error"))
> 
> y <- try(colRanks(x, ties.method = "unknown"), silent = TRUE)
> stopifnot(inherits(y, "try-error"))
> 
> dimnames <- list(letters[1:3], LETTERS[1:4])
> for (mode in c("integer", "double")){
+   storage.mode(x) <- mode
+   # Test with and without dimnames on x
+   for (setDimnames in c(TRUE, FALSE)) {
+     if (setDimnames) dimnames(x) <- dimnames
+     else dimnames(x) <- NULL
+     # Check names attribute
+     for (useNames in c(if (!matrixStats:::isUseNamesNADefunct()) NA, TRUE, FALSE)) {
+       for (ties in c("max", "min", "average", "first", "last", "dense", "random")) {
+         cat(sprintf("ties.method = %s\n", ties))
+         # rowRanks():
+         y1 <- matrixStats::rowRanks(x, ties.method = ties, useNames = useNames)
+         if (ties != "last" || getRversion() >= "3.3.0") {
+           y2 <- rowRanks_R(x, ties.method = ties, useNames = useNames)
+           stopifnot(identical(y1, y2))
+         }
+         
+         y3 <- matrixStats::colRanks(t(x), ties.method = ties, useNames = useNames)
+         stopifnot(identical(y1, y3))
+         
+         # colRanks():
+         y1 <- matrixStats::colRanks(x, ties.method = ties, useNames = useNames)
+         if (ties != "last" || getRversion() >= "3.3.0") {
+           y2 <- colRanks_R(x, ties.method = ties, useNames = useNames)
+           stopifnot(identical(y1, y2))
+         }
+         
+         y3 <- matrixStats::rowRanks(t(x), ties.method = ties, useNames = useNames)
+         stopifnot(identical(y1, y3))
+         
+         # Check preserveShape
+         y1 <- matrixStats::colRanks(x, ties.method = ties, preserveShape = TRUE, useNames = useNames)
+         if (ties != "last" || getRversion() >= "3.3.0") {
+           y2 <- colRanks_R(x, ties.method = ties, preserveShape = TRUE, useNames = useNames)
+           stopifnot(identical(y1, y2))
+         }
+       }
+     }
+   }
+ }
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
ties.method = random
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
ties.method = random
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
ties.method = random
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
ties.method = random
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
ties.method = random
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
ties.method = random
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
ties.method = random
ties.method = max
ties.method = min
ties.method = average
ties.method = first
ties.method = last
ties.method = dense
ties.method = random
> 
> proc.time()
   user  system elapsed 
   7.51    1.45    9.25