#######################################################################
# 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.
## ser_permutation_vector represents a single permutation represented as an
## integer vector or a hclust object.
## Constructor
## x can be
## * an integer vector
## * a hclust or dendrogram object (leaf order)
## * NA represents the identity permutation
## * a ser_permutation (list) of length 1
#' Class ser_permutation_vector -- A Single Permutation Vector for Seriation
#'
#' The class `ser_permutation_vector`
#' represents a single permutation vector.
#'
#' A permutation vector
#' maps a set of \eqn{n} objects \eqn{\{O_1, O_2, ..., O_n\}}{{O_1, O_2, ..., O_n}} onto itself.
#'
#' __Ordering Representation:__
#' In \pkg{seriation} we represent a permutation \eqn{\pi}{\pi}
#' as a vector which lists the objects' indices in their permuted order. This can
#' be seen as replacing the object in position \eqn{i} with the object
#' in position \eqn{\pi(i)}.
#' For example, the permutation vector \eqn{\langle3, 1, 2\rangle}{<3, 1, 2>} indicates that in
#' first position is the object with index 3 then the object with index 1 and finally
#' the object with index 2. This representation is often called a (re)arrangement or ordering.
#' The ordering can be extracted from a permutation vector object
#' via [get_order()]. Such an ordering can be directly used
#' to subset the list of original objects with `"["` to apply the permutation.
#'
#' __Rank Representation:__
#' An alternative way to specify a permutation is via a list of the ranks
#' of the objects after permutation. This representation is often called
#' a map or substitution. Ranks can be extracted from a permutation vector using [get_rank()].
#'
#' __Permutation Matrix:__
#' Another popular representation is a permutation matrix which performs
#' permutations using matrix multiplication. A permutation matrix can be obtained
#' using [get_permutation_matrix()].
#'
#' `ser_permutation_vector` objects are usually packed into
#' a [ser_permutation] object
#' which is a collection (a `list`) of \eqn{k} permutation vectors for \eqn{k}-mode data.
#'
#' The constructor `ser_permutation_vector()`
#' checks if the permutation vector is valid
#' (i.e. if all integers occur exactly once).
#'
#' @family permutation
#'
#' @param x,object an object if class `ser_permutation_vector`.
#' Options for the constructor are:
#' (1) an integer permutation vector,
#' (2) an object of class [hclust],
#' (3) a numeric vector with a MDS configuration, or
#' (4) `NA` to indicate a identity permutation.
#' @param method a string representing the method used to obtain the
#' permutation vector.
#' @param ... further arguments.
#'
#' @returns The constructor `ser_permutation_vector()` returns an
#' object a `ser_permutation_vector`
#' @author Michael Hahsler
#'
#' @examples
#' o <- structure(sample(10), names = paste0("X", 1:10))
#' o
#'
#' p <- ser_permutation_vector(o, "random")
#' p
#'
#' ## some methods
#' length(p)
#' get_method(p)
#' get_order(p)
#' get_rank(p)
#' get_permutation_matrix(p)
#'
#' r <- rev(p)
#' r
#' get_order(r)
#'
#' ## create a symbolic identity permutation vector (with unknown length)
#' ## Note: This can be used to permute an object, but methods
#' ## like length and get_order are not available.
#' ip <- ser_permutation_vector(NA)
#' ip
#' @keywords classes
#' @export
ser_permutation_vector <- function(x, method = NULL) {
if (inherits(x, "ser_permutation_vector"))
return(x)
if (inherits(x, "hclust") || inherits(x, "dendrogram")) {
# nothing to do
} else if (length(x) == 1 && is.na(x)) {
x <- NA_integer_
attr(x, "method") <- "identity permutation"
} else if (is.integer(x)) { # permutation vector
# do nothing
} else if (is.numeric(x)) { # a configuration
ats <- attributes(x) ### preserve attributes
nm <- names(x)
x <- order(x)
attributes(x) <- ats
names(x) <- nm
} else if (inherits(x, "ser_permutation") && length(x) == 1) {
x <- x[[1]]
} else {
stop("x does not contain a supported permutation.")
}
if (!is.null(method))
attr(x, "method") <- method
class(x) <- c("ser_permutation_vector", class(x))
.valid_permutation_vector(x)
x
}
#' @rdname ser_permutation_vector
#' @param recursive ignored
#' @export
c.ser_permutation_vector <- function(..., recursive = FALSE)
do.call("ser_permutation", list(...))
## reverse
#' @rdname ser_permutation_vector
#' @export
rev.ser_permutation_vector <- function(x) {
if (inherits(x, "hclust")) {
ser_permutation_vector(stats::as.hclust(rev(stats::as.dendrogram(x))), method = get_method(x))
}
else
ser_permutation_vector(rev(get_order(x)), method = get_method(x))
}
#' @rdname ser_permutation_vector
#' @param printable a logical; prints "unknown" instead of `NULL` for non-existing methods.
#' @export
get_method <- function(x, printable = FALSE) {
method <- attr(x, "method")
if (printable && is.null(method))
method <- "unknown"
method
}
## print et al
#' @rdname ser_permutation_vector
#' @export
length.ser_permutation_vector <- function(x) {
if (!.is_identity_permutation(x))
length(get_order(x))
else
0L
}
#' @rdname ser_permutation_vector
#' @export
print.ser_permutation_vector <-
function(x, ...)
{
writeLines(c(
gettextf("object of class %s",
paste(sQuote(class(
x
)), collapse = ", ")),
gettextf("contains a permutation vector of length %d", length(x)),
gettextf("used seriation method: '%s'",
get_method(x, printable = TRUE))
))
invisible(x)
}
## fake summary (we don't really provide a summary,
## but summary produces now a reasonable result --- same as print)
#' @rdname ser_permutation_vector
#' @export
summary.ser_permutation_vector <- function(object, ...) {
object
}
## helpers
## an identity permutation is a single NA.
.is_identity_permutation <- function(x) is.na(x[1])
## calls stop if the vector is not valid
.valid_permutation_vector <- function(x) {
## identity vector is always valid
if (.is_identity_permutation(x))
return(invisible(TRUE))
## valid permutations have a get_order function implemented
perm <- get_order(x)
valid <- TRUE
tab <- table(perm)
if (any(tab != 1))
valid <- FALSE
if (length(tab) != length(perm)
|| any(names(tab) != sequence(length(perm))))
valid <- FALSE
if (!valid)
stop("Invalid permutation vector!\nVector: ",
paste(perm, collapse = ", "))
invisible(valid)
}
.valid_permutation_matrix <- function(x) {
if (any(rowSums(x) != 1) || any(colSums(x) != 1) ||
any(x != 1 & x != 0))
stop("Not a valid permutation matrix")
invisible(TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.