.Cache <- new.env()
.checkDpi <- function ()
{
if (!exists("dpiDevice",.Cache) || !identical(.Cache$dpiDevice,getOption("device")))
{
.Cache$dpiDevice <- getOption("device")
deviceFunction <- try(match.fun(.Cache$dpiDevice), silent=TRUE)
if (is.function(deviceFunction) && ("dpi" %in% names(formals(deviceFunction))))
.Cache$dpi <- structure(c(72,72), explicit=TRUE)
else
{
dev.new(width=1, height=1)
.Cache$dpi <- structure(dev.size(units="px"), explicit=FALSE)
dev.off()
}
}
return (.Cache$dpi)
}
.checkAttribs <- function (x, ...)
{
result <- list(...)
attribs <- attributes(x)
for (name in names(attribs))
result[[name]] <- attribs[[name]]
return (result)
}
#' Display a 2D image
#'
#' This function displays a 2D greyscale or RGB colour image. It is a wrapper
#' around \code{image}, with more sensible defaults for images. It is (S3)
#' generic. A method for 3D arrays is provided, which assumes that the third
#' dimension corresponds to channel (grey/alpha for two channels, red/green/
#' blue for three, red/green/blue/alpha for four).
#'
#' Relative to the defaults for \code{image} (from the \code{graphics}
#' package), this function transposes and then inverts the matrix along the
#' y-direction, uses a grey colour scale, fills the entire device with the
#' image, and tries to size the image correctly given the dot pitch of the
#' display. Unfortunately the latter is not always possible, due to downstream
#' limitations.
#'
#' If \code{x} has attributes \code{"range"}, \code{"background"}, \code{"asp"}
#' or \code{"dpi"}, these are respected.
#'
#' @param x An R object. For the default method, it must be coercible to a
#' numeric matrix.
#' @param transpose Whether to transpose the matrix before display. This is
#' usually necessary due to the conventions of \code{image}.
#' @param useRaster Whether to use raster graphics if possible. This is
#' generally preferred for speed. Passed to \code{image}.
#' @param add Whether to add the image to an existing plot. If \code{TRUE},
#' zero values in the image will be converted to \code{NA}s for plotting
#' purposes, to make them transparent. This will not affect the original
#' image data.
#' @param col The colour scale to use. The default is 256 grey levels. The
#' array method overrides this appropriately.
#' @param max The maximum colour value for each channel. If \code{NULL}, the
#' default, this is taken from the \code{"range"} attribute, if there is one,
#' otherwise it is 255 for integer-mode arrays, and 1 otherwise. Passed to
#' \code{\link{rgb}}.
#' @param \dots Additional arguments to \code{image}, or the default method.
#' @return This function is called for its side-effect of displaying an image
#' on a new R device.
#'
#' @author Jon Clayden <code@@clayden.org>
#' @export
display <- function (x, ...)
{
UseMethod("display")
}
#' @rdname display
#' @export
display.default <- function (x, transpose = TRUE, useRaster = TRUE, add = FALSE, col = grey(0:255/255), ...)
{
dpiDevice <- .checkDpi()
attribs <- .checkAttribs(x, background="grey70", range=range(x[is.finite(x)]), asp=ncol(x)/nrow(x), dpi=dpiDevice)
if (is.null(attr(x,"asp")) && !is.null(attr(x,"dpi")))
attribs$asp <- (ncol(x) * attribs$dpi[1]) / (nrow(x) * attribs$dpi[2])
x <- as.matrix(x)
if (transpose)
{
x <- t(x)
attribs$asp <- 1 / attribs$asp
}
if (add)
{
x[x==0] <- NA
image(x[1:nrow(x),ncol(x):1], col=col, useRaster=useRaster, zlim=sort(attribs$range), add=TRUE, ...)
}
else
{
newDevice <- getOption("mmand.display.newDevice", TRUE)
if (newDevice && attr(dpiDevice,"explicit") && attribs$dpi[1] == attribs$dpi[2])
dev.new(width=nrow(x)/attribs$dpi[1], height=ncol(x)/attribs$dpi[2], dpi=attribs$dpi[1])
else if (newDevice)
dev.new(width=nrow(x)/attribs$dpi[1], height=ncol(x)/attribs$dpi[2])
oldPars <- par(mai=c(0,0,0,0), bg=attribs$background)
image(x[1:nrow(x),ncol(x):1], col=col, asp=attribs$asp, useRaster=useRaster, zlim=sort(attribs$range), add=FALSE, ...)
par(oldPars)
}
invisible(NULL)
}
#' @rdname display
#' @export
display.matrix <- function (x, ...)
{
display.default(x, ...)
}
#' @rdname display
#' @export
display.array <- function (x, max = NULL, ...)
{
if (length(dim(x)) == 2)
return (display.default(x, ...))
else if (length(dim(x)) != 3)
stop("Only three-dimensional arrays may be displayed")
mode <- storage.mode(x)
if (is.null(max))
{
if (is.null(attr(x, "range")))
max <- ifelse(mode == "integer", 255L, 1)
else
max <- max(attr(x, "range"))
}
dim3 <- dim(x)[3]
if (dim3 == 1L)
display.default(drop(x), ...)
else
{
x[x < 0] <- as(0, mode)
x[x > max] <- max
if (dim3 == 2L)
cols <- rgb(x[,,1], x[,,1], x[,,1], x[,,2], maxColorValue=max)
else if (dim3 == 3L)
cols <- rgb(x[,,1], x[,,2], x[,,3], maxColorValue=max)
else if (dim3 == 4L)
cols <- rgb(x[,,1], x[,,2], x[,,3], x[,,4], maxColorValue=max)
else
stop("Third dimension should not be greater than 4")
uniqueCols <- unique(cols)
indices <- match(cols, uniqueCols)
dim(indices) <- dim(x)[1:2]
attr(indices, "range") <- c(1L, length(uniqueCols))
for (attrib in c("background","asp","dpi"))
attr(indices, attrib) <- attr(x, attrib)
display.default(indices, col=uniqueCols, ...)
}
}
#' Show an ASCII art representation of a 2D image or matrix
#'
#' This function prints a rough, text-only representation of an image argument
#' to the R terminal, mapping image intensities to a 10-level pseudo-greyscale.
#' The image is first rescaled to fit into the terminal or other specified
#' width, and downsampled in the row direction to correct for nonsquare
#' character shapes.
#'
#' The result is a compact representation of a matrix that can be used for
#' visualising kernel arrays, sparse matrices and other non-images.
#'
#' @note If the terminal does not used a fixed-width font, the result is
#' unlikely to be useful.
#'
#' @param x An object that can be coerced to a numeric matrix or array. 3D
#' arrays with third dimension no greater than 4 will be taken as
#' multichannel 2D images, and their channels averaged before display.
#' Plain vectors and 1D arrays will be treated as single-row matrices.
#' @param invert By default the mapping uses heavier type for brighter areas.
#' If this option is \code{TRUE}, the sense of the scale will be reversed.
#' @param width The width of sketch to draw, in characters.
#' @param squash The factor by which to scale the row direction of the image.
#' Generally this should be markedly less than one, to preserve the aspect
#' ratio of the image, since most fixed-width font characters are taller than
#' they are wide.
#' @return This function is called for the side-effect of printing an ASCII
#' representation of its argument.
#'
#' @examples
#' sketch(shapeKernel(c(9,15), type="diamond"))
#' sketch(shapeKernel(c(9,15), type="diamond"), squash=1)
#' @author Jon Clayden <code@@clayden.org>
#' @seealso \code{\link{display}}
#' @export
sketch <- function (x, invert = FALSE, width = getOption("width"), squash = 0.5)
{
# Ref: http://paulbourke.net/dataformats/asciiart/
scale <- unlist(strsplit(" .:-=+*#%@", "", fixed=TRUE))
if (invert)
scale <- rev(scale)
n <- length(scale)
attribs <- .checkAttribs(x, range=range(x[is.finite(x)]))
x <- drop(as.array(x))
if (length(dim(x)) == 1)
dim(x) <- c(1, length(x))
else if (length(dim(x)) == 3 && dim(x)[3] < 5)
x <- apply(x, 1:2, mean)
else if (length(dim(x)) > 3)
stop("Only 2D single-channel or multichannel images may be sketched")
scaleFactors <- c(squash, 1)
if (ncol(x) > width)
scaleFactors <- scaleFactors * width / ncol(x)
x <- rescale(x, scaleFactors, triangleKernel())
indices <- round((x - min(attribs$range)) * (n-1) / (max(attribs$range) - min(attribs$range))) + 1
chars <- structure(scale[indices], dim=dim(x))
apply(chars, 1, function(line) cat(paste0(paste(line,collapse=""),"\n")))
invisible(NULL)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.