#######################################################################
# seriation - Infrastructure for seriation
# Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
# helper
ndim <- function(x)
length(dim(x))
find_order <- function(x, order, ...) {
if (is.logical(order)) {
if(order)
order <- seriate(x, ...)
else
order <- seriate(x, method = "identity", ...)
}
if (is.character(order))
order <- seriate(x, method = order, ...)
if (!inherits(order, "ser_permutation"))
order <- ser_permutation(order)
# for debugging
#print(order)
order
}
#' Permute the Order in Various Objects
#'
#' Provides the generic function and methods for permuting the order of various
#' objects including vectors, lists, dendrograms (also \code{hclust} objects),
#' the order of observations in a \code{dist} object, the rows and columns of a
#' matrix or data.frame, and all dimensions of an array given a suitable
#' [ser_permutation] object.
#'
#' The permutation vectors in [ser_permutation] are suitable if the number
#' of permutation vectors matches the number of dimensions of \code{x} and if
#' the length of each permutation vector has the same length as the
#' corresponding dimension of \code{x}.
#'
#' For 1-dimensional/1-mode data (list, vector, \code{dist}), \code{order} can
#' also be a single permutation vector of class [ser_permutation_vector]
#' or data which can be automatically coerced to this class (e.g. a numeric
#' vector).
#'
#' For \code{dendrogram} and \code{hclust}, subtrees are rotated to represent
#' the order best possible. If the order is not achieved perfectly then the
#' user is warned. See also [reorder.hclust()] for
#' reordering `hclust` objects.
#'
#' @family permutation
#'
#' @param x an object (a list, a vector, a \code{dist} object, a matrix, an
#' array or any other object which provides \code{dim} and standard subsetting
#' with \code{"["}).
#' @param order an object of class [ser_permutation] which contains
#' suitable permutation vectors for \code{x}. Alternatively, a character string with the
#' name of a seriation method appropriate for `x` can be specified (see [seriate()]).
#' This will perform seriation and permute `x`. The value `TRUE` will permute using the
#' default seriation method.
#' @param margin specifies the dimensions to be permuted as a vector with dimension indices.
#' If `NULL`, \code{order} needs to contain a permutation for all dimensions.
#' If a single margin is specified, then \code{order} can also contain
#' a single permutation vector.
#' \code{margin} are ignored.
#' @param dist the distance matrix used to create the dendrogram. Only needed if
#' order is the name of a seriation method.
#' @param ... if `order` is the name of a seriation method, then additional arguments are
#' passed on to [seriate()].
#' @returns A permuted object of the same class as `x`.
#' @author Michael Hahsler
#' @keywords manip
#' @examples
#' # List data types for permute
#' methods("permute")
#'
#' # Permute matrix
#' m <- matrix(rnorm(10), 5, 2, dimnames = list(1:5, LETTERS[1:2]))
#' m
#'
#' # Permute rows and columns
#' o <- ser_permutation(5:1, 2:1)
#' o
#'
#' permute(m, o)
#'
#' ## permute only columns
#' permute(m, o, margin = 2)
#'
#' ## permute using PCA seriation
#' permute(m, "PCA")
#'
#' ## permute only rows using PCA
#' permute(m, "PCA", margin = 1)
#'
#' # Permute data.frames using heatmap seration (= hierarchical
#' # clustering + optimal leaf ordering)
#' df <- as.data.frame(m)
#' permute(df, "Heatmap")
#'
#' # Permute objects in a dist object
#' d <- dist(m)
#' d
#'
#' permute(d, c(3, 2, 1, 4, 5))
#'
#' permute(d, "Spectral")
#'
#' # Permute a list
#' l <- list(a = 1:5, b = letters[1:3], c = 0)
#' l
#'
#' permute(l, c(2, 3, 1))
#'
#' # Permute to reorder dendrogram (see also reorder.hclust)
#' hc <- hclust(d)
#' plot(hc)
#'
#' plot(permute(hc, 5:1))
#' plot(permute(hc, 5:1, incompartible = "stop"))
#'
#' plot(permute(hc, "OLO", dist = d))
#' plot(permute(hc, "GW", dist = d))
#' plot(permute(hc, "MDS", dist = d))
#' plot(permute(hc, "TSP", dist = d))
#' @export
permute <- function(x, order, ...)
UseMethod("permute")
#' @export
permute.default <- function(x, order, ...)
.permute_kd(x, order, ...)
#' @rdname permute
#' @export
permute.array <- function(x, order, margin = NULL, ...)
.permute_kd(x, order, margin = margin, ...)
#' @rdname permute
#' @export
permute.matrix <- function(x, order, margin = NULL, ...)
.permute_kd(x, order, margin = margin, ...)
#' @rdname permute
#' @export
permute.data.frame <- function(x, order, margin = NULL, ...)
.permute_kd(x, order, margin = margin, ...)
#' @rdname permute
#' @export
permute.table <- function(x, order, margin = NULL, ...)
.permute_kd(x, order, margin = margin, ...)
#' @rdname permute
#' @export
permute.numeric <- function(x, order, ...)
.permute_1d(x, order, ...)
#' @rdname permute
#' @export
permute.character <- function(x, order, ...)
.permute_1d(x, order, ...)
#' @rdname permute
#' @export
permute.list <- function(x, order, ...)
.permute_1d(x, order, ...)
# special cases
#' @rdname permute
#' @export
permute.dist <- function(x, order, ...) {
order <- find_order(x, order, ...)
if (.is_identity_permutation(order[[1]]))
return(x)
.check_dist_perm(x, order)
.rearrange_dist(x, get_order(order, 1))
}
#' @rdname permute
#' @export
permute.dendrogram <- function(x, order, dist = NULL, ...) {
# order can be
# * TRUE/FALSE
# * a numeric vector
# * a ser_permutation of length 1
# * a ser_permutation vector
# * a seriation method (requires dist)
if (is.logical(order)) {
if(!order)
return(x)
else
order <- "OLO"
}
if (is.character(order)) {
if (is.null(dist))
stop("dist need for seriation-based reordering.")
suppressWarnings(order <- seriate(dist, method = order, hclust = x, ...))
}
# modeled after rotate in dendextend. Copied here to reduce the heavy dependency count of dendextend.
# x <- dendextend::rotate(x, order = match(get_order(order), get_order(x)))
rot <- function (x, order, ...)
{
if (length(get_order(order)) != stats::nobs(x))
stop("Length of order and number of leaves in dendrogram do not agree!")
if (missing(order)) {
warning("'order' parameter is missing, returning the tree as it was.")
return(x)
}
labels_x <- labels(x)
order_x <- order.dendrogram(x)
number_of_leaves <- length(order_x)
if (!is.numeric(order)) {
order <- as.character(order)
if (length(intersect(order, labels_x)) != number_of_leaves) {
stop(
"'order' is neither numeric nor a vector with ALL of the labels (in the order you want them to be)"
)
}
order <- match(order, labels_x)
}
weights <- seq_len(number_of_leaves)
weights_for_order <- numeric(number_of_leaves)
weights_for_order[order_x[order]] <- weights
reorder(x, weights_for_order, mean, ...)
}
x <- rot(x, order = match(get_order(order), get_order(x)))
if (any(get_order(x) != get_order(order)))
warning("Dendrogram cannot be perfectly reordered! Using best approximation.")
x
}
#' @rdname permute
#' @export
permute.hclust <- function(x, order, dist = NULL, ...) {
nd <- stats::as.hclust(permute(stats::as.dendrogram(x), order, dist = dist, ...))
x$merge <- nd$merge
x$height <- nd$height
x$order <- nd$order
x
}
# helper
.check_dist_perm <- function(x, order) {
if (inherits(order, "ser_permutation") && length(order) != 1L)
stop("dimensions do not match")
if (attr(x, "Size") != length(get_order(order, 1)))
stop("some permutation vectors do not fit dimension of data")
# check dist
if (isTRUE(attr(x, "Diag")) || isTRUE(attr(x, "Upper")))
stop("'dist' with diagonal or upper triangle matrix not implemented")
}
.check_matrix_perm <- function(x, order) {
if (ndim(x) != length(order))
stop("dimensions do not match")
if (any(dim(x) != sapply(order, length)))
stop("some permutation vectors do not fit dimension of data")
}
.permute_kd <- function(x, order, margin = NULL, ...) {
# DEPRECATED: Compatibility with old permutation for data.frame
if (is.data.frame(x) &&
is.null(margin) &&
!is.character(order) &&
(
inherits(order, "ser_permutation") &&
length(order) == 1 ||
inherits(order, "ser_permutation_vector") || is.integer(order)
)) {
warning(
"permute for data.frames with a single seriation order is now deprecated. Specify the margin as follows: 'permute(x, order, margin = 1)'"
)
margin <- 1
}
if (is.null(margin))
margin <- seq(ndim(x))
else {
margin <- as.integer(margin)
if (!all(margin %in% seq(ndim(x))))
stop("all margins need to specify a valid dimension in x")
}
order <- find_order(x, order, margin = margin, ...)
if (length(order) != ndim(x) && length(order) != length(margin))
stop(
"order needs to contain either orders for all dimensions of x or just orders for the selected margin."
)
# set margins not to be permuted to identity and copy the rest
o <- seriate(x, method = "identity")
if (length(order) < ndim(x)) ### we only have order for specified margins
for(i in seq(length(order)))
o[[margin[i]]] <- order[[i]]
else
for (i in margin)
o[[i]] <- order[[i]]
# expand identity manual permutations (if any)
for (i in which(sapply(o, .is_identity_permutation)))
o[[i]] <- ser_permutation_vector(seq(dim(x)[i]))
# check
.check_matrix_perm(x, o)
perm <- lapply(o, get_order)
do.call("[", c(list(x), perm, drop = FALSE))
}
.permute_1d <- function(x, order, ...) {
if (is.logical(order)) {
if(order)
stop("No default seritation method for vectors avaialble. Specify the order.")
else
return(x)
}
order <- ser_permutation(order)
if (length(order) != 1)
stop("dimensions do not match!")
perm <- get_order(order, 1)
if (length(x) != length(perm))
stop("The permutation vectors do not fit the length of x!")
x[perm]
}
# if we used proxy we would say:
#.rearrange_dist <- function (x, order) x[[order]]
# Note: order can be a subset
.rearrange_dist <- function (x, order) {
# make C call
mode(x) <- "double"
# as.dist seems to make Size numeric and not integer!
attr(x, "Size") <- as.integer(attr(x, "Size"))
mode(order) <- "integer"
d <- .Call("reorder_dist", x, order)
labels <- if (is.null(labels(x)))
NULL
else
labels(x)[order]
structure(
d,
class = "dist",
Size = length(order),
Labels = labels,
Diag = FALSE,
Upper = FALSE,
method = attr(x, "method")
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.