#######################################################################
# 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.
#' Plot a Bertin Matrix
#'
#' Plot a data matrix of cases and variables. Each value is represented by a
#' symbol. Large values are highlighted. Note that Bertin arranges the cases
#' horizontally and the variables as rows. The matrix can be rearranged using
#' seriation techniques to make structure in the data visible (see Falguerolles
#' et al 1997).
#'
#' The plot is organized as a matrix of symbols. The symbols are drawn by a
#' panel function, where all symbols of a row are drawn by one call of the
#' function (using vectorization). The interface for the panel function is
#' `panel.myfunction(value, spacing, hl)`. `value` is the vector of
#' values for a row scaled between 0 and 1, `spacing` contains the
#' relative space between symbols and `hl` is a logical vector indicating
#' which symbol should be highlighted.
#'
#' Cut lines can be added to an existing Bertin plot using
#' `bertin_cut_line(x = NULL, y = NULL)`. `x`/`y` is can be a
#' number indicating where to draw the cut line between two columns/rows. If
#' both `x` and `y` is specified then one can select a row/column and
#' the other can select a range to draw a line which does only span a part of
#' the row/column. It is important to call `bertinplot()` with the option
#' `pop = FALSE`.
#'
#' `ggbertinplot()` calls [ggpimage()] and all additional parameters are
#' passed on.
#'
#' @family plots
#' @param x a data matrix. Note that following Bertin, columns are variables
#' and rows are cases. This behavior can be reversed using `reverse = TRUE`
#' in `options`.
#' @param order an object of class `ser_permutation` to rearrange `x`
#' before plotting. If `NULL`, no rearrangement is performed.
#' @param panel.function a function to produce the symbols. Currently available
#' functions are `panel.bars` (default), `panel.circles`,
#' `panel.rectangles`, `panel.tiles` and `panel.lines`. For
#' circles and squares neg. values are represented by a dashed border. For
#' blocks all blocks are the same size (can be used with `shading = TRUE`).
#' @param geom visualization type. Available ggplot2 geometries are: `"tile"`,
#' `"rectangle"`, `"circle"`, `"line"`, `"bar"`, `"none"`.
#' @param highlight a logical scalar indicating whether to use highlighting.
#' If `TRUE`, all variables with values greater than the variable-wise
#' mean are highlighted. To control highlighting, also a logical matrix or a
#' matrix with colors with the same dimensions as `x` can be supplied.
#' @param row_labels,col_labels a logical indicating if row and column labels
#' in `x` should be displayed. If `NULL` then labels are displayed
#' if the `x` contains the appropriate dimname and the number of labels is
#' 25 or less. A character vector of the appropriate length with labels can
#' also be supplied.
#' @param flip_axes logical indicating whether to swap cases and variables in
#' the plot. The default (`TRUE`) is to plot cases as columns and
#' variables as rows.
#' @param prop logical; change the aspect ratio so cells in the image have a
#' equal width and height.
#' @param col,y and x in `bertin_cut_line()` are for adding a line to a `bertinplot()` (not ggplot2-based).
#' @param value,spacing,hl are used internally for the panel functions.
#' @param ...
#' `ggbertinplot()`: further parameters are passed on to [ggpimage()].
#'
#' `bertinplot()`: further parameters can include:
#' - `xlab, ylab` labels (default: use labels from `x`).
#' - `spacing` relative space between symbols (default: 0.2).
#' - `shading` use gray shades to encode value instead of
#' highlighting (default: `FALSE`).
#' - `shading.function` a function that accepts a single argument in range \eqn{[.1, .8]}
#' and returns a valid corresponding color (e.g., using [rgb()]).
#' - `frame` plot a grid to separate symbols (default: `FALSE`).
#' - `mar` margins (see [par()]).
#' - `gp_labels` `gpar` object for labels (see [gpar()])
#' - `gp_panels` `gpar` object for panels (see [gpar()]).
#' - `newpage` a logical indicating whether to start
#' the plot on a new page (see [grid.newpage()]).
#' - `pop` a logical indicating whether to pop the created viewports
#' (see [pop.viewport()])?
#'
#' @returns Nothing.
#'
#' @author Michael Hahsler
#' @references de Falguerolles, A., Friedrich, F., Sawitzki, G. (1997): A
#' Tribute to J. Bertin's Graphical Data Analysis. In: Proceedings of the
#' SoftStat '97 (Advances in Statistical Software 6), 11--20.
#' @keywords hplot cluster
#' @examples
#' data("Irish")
#' scale_by_rank <- function(x) apply(x, 2, rank)
#' x <- scale_by_rank(Irish[,-6])
#'
#' # Use the the sum of absolute rank differences
#' order <- c(
#' seriate(dist(x, "minkowski", p = 1)),
#' seriate(dist(t(x), "minkowski", p = 1))
#' )
#'
#' # Plot
#' bertinplot(x, order)
#'
#' # Some alternative displays
#' bertinplot(x, order, panel = panel.tiles, shading_col = bluered(100), highlight = FALSE)
#' bertinplot(x, order, panel = panel.circles, spacing = -.2)
#' bertinplot(x, order, panel = panel.rectangles)
#' bertinplot(x, order, panel = panel.lines)
#'
#' # Plot with cut lines (we manually set the order here)
#' order <- ser_permutation(c(6L, 9L, 29L, 10L, 32L, 22L, 2L, 35L,
#' 24L, 30L, 33L, 25L, 37L, 36L, 8L, 27L, 4L, 39L, 3L, 40L, 38L,
#' 1L, 31L, 34L, 28L, 23L, 5L, 11L, 7L, 41L, 13L, 26L, 17L, 15L,
#' 12L, 20L, 14L, 18L, 19L, 16L, 21L),
#' c(4L, 2L, 1L, 6L, 7L, 8L, 5L, 3L))
#'
#' bertinplot(x, order, pop=FALSE)
#' bertin_cut_line(, 4) ## horizontal line between rows 4 and 5
#' bertin_cut_line(, 7) ## separate "Right to Life" from the rest
#' bertin_cut_line(18, c(0, 4)) ## separate a block of large values (vertically)
#'
#' # ggplot2-based plots
#' if (require("ggplot2")) {
#' library(ggplot2)
#'
#' # Default plot uses bars and highlighting values larger than the mean
#' ggbertinplot(x, order)
#'
#' # highlight values in the 4th quartile
#' ggbertinplot(x, order, highlight = quantile(x, probs = .75))
#'
#' # Use different geoms. "none" lets the user specify their own geom.
#' # Variables set are row, col and x (for the value).
#'
#' ggbertinplot(x, order, geom = "tile", prop = TRUE)
#' ggbertinplot(x, order, geom = "rectangle")
#' ggbertinplot(x, order, geom = "rectangle", prop = TRUE)
#' ggbertinplot(x, order, geom = "circle")
#' ggbertinplot(x, order, geom = "line")
#'
#' # Tiles with diverging color scale
#' ggbertinplot(x, order, geom = "tile", prop = TRUE) +
#' scale_fill_gradient2(midpoint = mean(x))
#'
#' # Custom geom (geom = "none"). Defined variables are row, col, and x for the value
#' ggbertinplot(x, order, geom = "none", prop = FALSE) +
#' geom_point(aes(x = col, y = row, size = x, color = x > 30), pch = 15) +
#' scale_size(range = c(1, 10))
#'
#' # Use a ggplot2 theme with theme_set()
#' old_theme <- theme_set(theme_minimal() +
#' theme(panel.grid = element_blank())
#' )
#' ggbertinplot(x, order, geom = "bar")
#' theme_set(old_theme)
#' }
#' @export
bertinplot <- function(x,
order = NULL,
panel.function = panel.bars,
highlight = TRUE,
row_labels = TRUE,
col_labels = TRUE,
flip_axes = TRUE,
...) {
if (!is.matrix(x))
stop("Argument 'x' must be a matrix.")
# add ... to options
options <- list(...)
options$panel.function <- panel.function
options <- .get_parameters(
options,
list(
panel.function = panel.bars,
flip_axes = TRUE,
frame = FALSE,
spacing = 0.2,
margins = c(5, 4, 8, 8),
gp_labels = gpar(),
gp_panels = gpar(),
shading = NULL,
shading_col = .sequential_pal(100),
newpage = TRUE,
pop = TRUE
)
)
## panel.blocks has no spacing!
if (identical(options$panel.function, panel.blocks))
options$spacing <- 0
if (is.null(options$shading))
if (identical(options$panel.function, panel.blocks)) {
options$shading <- TRUE
} else {
options$shading <- FALSE
}
## order
if (!is.null(order))
x <- permute(x, order)
## note: Bertin switched cols and rows for his display!
# change x and y?
if (flip_axes)
x <- t(x)
## highlight
if (is.logical(highlight) && highlight)
highlight <- mean(x, na.rm = TRUE)
## clear page
if (options$newpage)
grid.newpage()
## create outer viewport
xlim <- c(options$spacing, ncol(x) + 1 - options$spacing)
pushViewport(
plotViewport(
margins = options$mar,
layout = grid.layout(nrow(x), 1),
xscale = xlim,
yscale = c(0, nrow(x)),
default.units = "native",
name = "bertin"
)
)
# shading and highlighting
if (options$shading)
col <- .map_color(x, options$shading_col)
else
col <- matrix(1, nrow = nrow(x), ncol = ncol(x))
if (highlight)
col[x < highlight] <- NA
# map to [0, 1]
x <- map(x)
for (variable in seq(nrow(x))) {
value <- x[variable,]
hl <- col[variable,]
## handle neg. values
if (identical(options$panel.function, panel.bars) ||
identical(options$panel.function, panel.lines)) {
ylim <- c(min(value, 0, na.rm = TRUE),
max(value, 0, na.rm = TRUE) + options$spacing)
} else{
ylim <- c(0,
max(abs(value), 0.1, na.rm = TRUE))
}
pushViewport(
viewport(
layout.pos.col = 1,
layout.pos.row = variable,
xscale = xlim,
yscale = ylim,
default.units = "native",
gp = options$gp_panels
)
)
## call panel function
options$panel.function(value, options$spacing, hl)
## do frame
if (options$frame)
grid.rect(
x = seq(length(value)),
width = 1,
default.units = "native",
gp = gpar(fill = NA)
)
upViewport(1)
}
spacing_corr <-
if (options$spacing <= 0)
- options$spacing + 0.2
else
0
if (col_labels)
grid.text(
colnames(x),
x = seq(ncol(x)),
y = nrow(x) + spacing_corr,
rot = 90,
just = "left",
default.units = "native",
gp = options$gp_labels
)
if (row_labels)
grid.text(
rev(rownames(x)),
x = 1 + spacing_corr / ncol(x) / 4,
y = 0.5:(nrow(x) - 0.5) / nrow(x),
just = "left",
default.units = "npc",
gp = options$gp_labels
)
if (options$pop)
popViewport(1)
else
upViewport(1)
}
#' @rdname bertinplot
#' @export
panel.bars <- function(value, spacing, hl) {
grid.rect(
x = seq(length(value)),
y = spacing / 2,
width = 1 - spacing,
height = value * (1 - spacing),
just = c("centre", "bottom"),
default.units = "native",
gp = gpar(fill = hl)
)
}
#' @rdname bertinplot
#' @export
panel.circles <- function(value, spacing, hl) {
## neg. values are dashed
lty <- as.integer(value < 0) + 1L
lty[!is.finite(lty)] <- 0L
value <- abs(value)
value[value == 0] <- NA ### hide empty squares
grid.circle(
x = seq(length(value)),
y = unit(.5, "npc"),
r = value / 2 * (1 - spacing),
default.units = "native",
gp = gpar(fill = hl, lty = lty)
)
}
#' @rdname bertinplot
#' @export
panel.rectangles <- function(value, spacing, hl) {
## neg. values are dashed
lty <- as.integer(value < 0) + 1L
lty[!is.finite(lty)] <- 0L
value[value == 0] <- NA ### hide emply squares
grid.rect(
x = seq(length(value)),
width = value * (1 - spacing),
height = value * (1 - spacing),
default.units = "native",
just = c("centre", "center"),
gp = gpar(fill = hl, lty = lty)
)
}
#' @rdname bertinplot
#' @export
panel.squares <- panel.rectangles
#' @rdname bertinplot
#' @export
panel.tiles <- function(value, spacing, hl) {
grid.rect(
x = seq(length(value)),
width = 1,
height = unit(1, "npc"),
default.units = "native",
just = c("centre", "center"),
gp = gpar(fill = hl)
)
}
#' @rdname bertinplot
#' @export
panel.blocks <- panel.tiles
### hl is ignored
#' @rdname bertinplot
#' @export
panel.lines <- function(value, spacing, hl) {
grid.lines(
x = seq(length(value)),
y = value * (1 - spacing),
default.units = "native"
)
}
## add cut lines manually to a bertin plot
#' @rdname bertinplot
#' @export
bertin_cut_line <- function(x = NULL,
y = NULL,
col = "red") {
if (length(x) < 2)
x <- rep(x, 2)
if (length(y) < 2)
y <- rep(y, 2)
## find the bertin Viewport
if (inherits(try(seekViewport("bertin"), silent = TRUE)
, "try-error")) {
stop("bertinplot() needs to be called with options = list(pop = FALSE) first!")
}
if (is.null(x))
x <- unit(c(0, 1), units = "npc")
else
x <- x + .5
if (is.null(y))
y <- unit(c(0, 1), units = "npc")
else
y <- y
grid.lines(
x = x,
y = y,
default.units = "native",
gp = gpar(col = col, lwd = 2)
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.