R/matrix-order.R

In houyunhuang/ggtriangle: Fast processing of matrix heatmap

#' Reorder Matrices
#' @description  Tries to find an order for matrix by different cluster methods.
#' @param x a matrix-like object.
#' @param cluster.method a character string with the name of agglomeration method.
#'     Defaults to "complete" for numeric matrix, to "osa" for other type matrix.
#' @param ... extra params passing to \code{\link[stats]{hclust}}.
#' @return a list of new order.
#' @importFrom stats dist hclust setNames
#' @importFrom utils modifyList
#' @examples
#' m <- matrix(rnorm(25), nrow = 5)
#' matrix_reorder(m)
#' m1 <- matrix(sample(LETTERS[1:4], 100, replace = TRUE), nrow = 10)
#' matrix_reorder(m1)
#' @seealso \code{\link[stats]{hclust}}, \code{\link[stringdist]{stringdist}}.
#' @export
matrix_reorder <- function(x,
                           cluster.method = NULL,
                           ...)
{
  if(!is.matrix(x)) x <- as.matrix(x)
  if(is.numeric(x)) {
    cluster.method <- cluster.method %||% "complete"
    row_hc <- hclust(dist(x), cluster.method, ...)
    col_hc <- hclust(dist(t(x)), cluster.method, ...)
  } else {
    cluster.method <- cluster.method %||% "osa"
    row_hc <- hclust(string_dist(x, cluster.method, ...))
    col_hc <- hclust(string_dist(t(x), cluster.method, ...))
  }
  structure(.Data = list(row.ord = row_hc$order, col.ord = col_hc$order),
            hclust = list(row.hc = row_hc, col.hc = col_hc))
}

#' @noRd
#' @importFrom stats hclust as.dist
#' @importFrom stringdist stringdist
string_dist <- function(x, method = "osa", ...) {
  if(!is.matrix(x)) x <- as.matrix(x)
  n <- nrow(x)
  d <- matrix(nrow = n, ncol = n)
  for(i in seq_len(n)) {
    for (j in seq_len(n)) {
      if(i < j) next()
      temp <- stringdist::stringdist(x[i, ], x[j, ], method, ...)
      d[i, j] <- d[j, i] <- sqrt(t(temp) %*% temp)
    }
  }
  as.dist(d)
}

#' @noRd
extract_order <- function(x, ...) {
  UseMethod("extract_order", x)
}
#' @noRd
#' @method extract_order hclust
extract_order.hclust <- function(x, ...) {
  x$order
}
#' @noRd
#' @method extract_order dendrogram
extract_order.dendrogram <- function(x, ...) {
  as.numeric(unlist(x, FALSE, FALSE))
}