inst/data-raw/plot.matrix.131.R
In sigbertklinke/plot.matrix: Visualizes a Matrix as Heatmap
#' plot.matrix
#'
#' Visualizes a matrix with a colored heatmap and optionally a color key. It distinguishes between numeric and non-numeric matrices.
#' You may need to modify \code{mar} with the \code{\link[graphics]{par}} command from its default \code{c(5.1,4.1,4.1,2.1)}.
#' For further see the vignette \code{vignettes('plot.matrix')}
#'
#' @details
#' A color key is drawn if either \code{key} (defaults to \code{list(cex=1)}) or \code{fmt.key}
#' (defaults to \code{NULL}) is not \code{NULL}.
#'
#' If you want to plot the matrix entries you must set either \code{digits} or \code{fmt}.
#' For a non-numeric matrix \code{digits} gives the length of the string printed, a negative value
#' results in right-justified string. For a numeric matrix \code{digits} determines the number of
#' decimal places, a negative value uses a "exponential" decimal notation. You may set format
#' strings \code{fmt} and \code{fmt.key} directly. Settings \code{digits} leads to the following
#' format strings (\code{n} the absolute value of \code{digits}):
#'
#' \tabular{ll}{
#' \code{x} numeric and \code{digits>0}:\tab \code{"\%+.nf"}\cr
#' \code{x} numeric and \code{digits<0}:\tab \code{"\%+.ne"}\cr
#' \code{x} non-numeric and \code{digits>0}:\tab \code{"\%+ns"}\cr
#' \code{x} non-numeric and \code{digits<0}:\tab \code{"\%-ns"}\cr
#' }
#'
#' If no colors are given then the \code{\link[grDevices]{heat.colors}} will be used. Alternatively you may specify your own color function
#' that delivers a vector with \code{n} colors if called by \code{col(n)}. The final colors and breaks used
#' depend if \code{plot.matrix} gets a numeric or non-numeric matrix.
#'
#' \strong{Numeric matrix:} In general it must hold \code{length(col)+1==length(breaks)}.
#' \describe{
#' \item{1. \code{breaks==NULL} and \code{col==NULL}}{The colors are taken from \code{heat.colors(10)} and the eleven breaks are calculated as an equidistant grid
#' between \code{min(x)} and \code{max(x)}.}
#' \item{2. \code{breaks==NULL} and \code{col} is a color function}{Ten colors are taken from the color function and eleven breaks are calculated as an equidistant grid
#' between \code{min(x)} and \code{max(x)}.}
#' \item{3. \code{breaks==NULL} and \code{col} is a vector of colors}{The \code{length(col)+1} breaks are calculated as an equidistant grid
#' between \code{min(x)} and \code{max(x)}.}
#' \item{4. \code{breaks} are given and \code{col==NULL}}{The colors are taken from \code{heat.colors(length(breaks)-1)}.}
#' \item{5. \code{breaks} are given and \code{col} is a color function}{The \code{length(breaks)-1} colors are taken from the color function.}
#' \item{6. \code{breaks} are given and \code{col} is a vector of colors}{If not \code{length(col)+1==length(breaks)} holds then
#' the \code{length(col)+1} breaks are calculated as an equidistant grid between \code{min(breaks)} and \code{max(breaks)}.}
#' }
#'
#' \strong{Non-numeric matrix:} In general it must hold \code{length(col)==length(breaks)}. At first the number of unique elements in \code{x} is determined: \code{nu}.
#' \describe{
#' \item{1. \code{breaks==NULL} and \code{col==NULL}}{The colors are taken from \code{heat.colors(nu)} and the breaks are set to the unique elements of \code{x}.}
#' \item{2. \code{breaks==NULL} and \code{col} is a color function}{The \code{nu} colors are taken from color function and the breaks are set to the unique elements of \code{x}.}
#' \item{3. \code{breaks==NULL} and \code{col} is a vector of colors}{The \code{length(col)} breaks are calculated as an equidistant grid
#' between \code{min(x)} and \code{max(x)}.}
#' \item{4. \code{breaks} are given and \code{color==NULL}}{The colors are taken from \code{heat.colors(length(breaks))}.}
#' \item{5. \code{breaks} are given and \code{color} is a color function}{The \code{length(breaks)} colors are taken from color function.}
#' \item{6. \code{breaks} are given and \code{color} is a vector of colors}{If not \code{length(colors)==length(breaks)} holds then
#' either \code{breaks} or \code{color} is shorten to the shorter of both.}
#' }
#'
#' @note The use of \code{fmt} or \code{fmt.key} have the same restrictions as the use of \code{fmt} in \code{\link[base]{sprintf}}:
#'
#' \emph{The format string is passed down the OS's sprintf function, and incorrect formats can cause the latter to crash the R process.
#' R does perform sanity checks on the format, but not all possible user errors on all platforms have been tested, and some might
#' be terminal.}
#'
#' @param x matrix
#' @param y unused
#' @param digits number of digits for numeric data or length of string for non-numeric data
#' @param col a vector of colors or a function, e.g. \code{\link[grDevices]{heat.colors}} with one parameter \code{n}
#' @param breaks breaks for numeric values or values for \code{col}
#' @param key list of parameters used for \code{\link[graphics]{axis}}. If set to \code{NULL} then no information will be plotted. Instead of \code{key=list(side=4)} you may use \code{key=4} or \code{key="right"}.
#' @param axis.key as \code{key}
#' @param na.col color for missing value (default: white)
#' @param fmt.cell format string for writring matrix entries, overwrites \code{digits}, defaults to \code{NULL}
#' @param fmt.key format string for writring key entries, overwrites \code{digits}, defaults to \code{fmt}
#' @param polygon.cell list of parameters used for \code{\link[graphics]{polygon}} for heatmap
#' @param polygon.key list of parameters used for \code{\link[graphics]{polygon}} for key
#' @param text.cell list of parameters used for \code{\link[graphics]{text}} for matrix entries
#' @param axis.col list of parameters used for \code{\link[graphics]{axis}} for axis of matrix columns. Instead of \code{axis.col=list(side=1)} you may use \code{axis.col=1} or \code{axis.col="bottom"}.
#' @param axis.row list of parameters used for \code{\link[graphics]{axis}} for axis of matrix rows. Instead of \code{axis.row=list(side=2)} you may use \code{axis.row=2} or \code{axis.col="left"}.
#' @param ... further parameter given to the \code{\link[graphics]{plot}} command
#' @return a plot
#' @importFrom grDevices heat.colors col2rgb
#' @importFrom graphics axis polygon text
#' @importFrom utils modifyList
#' @export
#'
#' @aliases plot
#' @examples
#' par(mar=c(5.1, 4.1, 4.1, 4.1))
#' # numeric matrix
#' x <- matrix(runif(50), nrow=10)
#' plot(x)
#' plot(x, key=NULL)
#' plot(x, key=list(cex.axis=0.5, tick=FALSE))
#' plot(x, digits=3)
#' plot(x, breaks=c(0,1), digits=3, cex=0.6)
#' # logical matrix
#' m <- matrix(runif(50)<0.5, nrow=10)
#' plot(m)
#' plot(m, col=c("red", "blue"))
#' plot(m, key=NULL, digits=1)
#' # character matrix
#' s <- matrix(sample(letters[1:10], 50, replace=TRUE), nrow=10)
#' plot(s)
#' plot(s, col=topo.colors)
#' plot(s, digits=10)
#' plot(s, digits=1, col=heat.colors(5), breaks=letters[1:5])
#' plot(s, digits=1, col=heat.colors(5), breaks=c('a', 'c', 'e', 'g', 'i'))
#' # contingency table
#' tab <- table(round(rnorm(100)), round(rnorm(100)))
#' plot(unclass(tab))
#' # chisquare test residuals
#' cst <- chisq.test(apply(HairEyeColor, 1:2, sum))
#' col <- colorRampPalette(c("blue", "white", "red"))
#' plot(cst$residuals, col=col, breaks=c(-7,7))
plot.matrix <- function(x, y=NULL, breaks=NULL, col=NULL, na.col="white",
#
digits=NA,
fmt.cell=NULL,
fmt.key=NULL,
#
polygon.cell=NULL,
polygon.key=NULL,
#
text.cell=NULL,
#
key=list(side=4, las=1),
axis.col=list(side=1),
axis.row=list(side=2),
axis.key=NULL,
#
...) {
# from https://stackoverflow.com/questions/13289009/check-if-character-string-is-a-valid-color-representation
areColors <- function(x) {
sapply(x, function(X) {
tryCatch(is.matrix(col2rgb(X)),
error = function(e) FALSE)
})
}
#
createAxis <- function(defaults, globals, args) {
if (is.null(defaults)) res <- list()
if (!is.null(globals)) res <- modifyList(defaults, globals)
if (is.numeric(args)) {
if (args %in% 1:4) res$side <- args
}
if (is.character(args)) {
side <- pmatch(axis.col, c("bottom", "left", "top", "right"))
if (!is.na(side)) res$side <- args
}
if (is.list(args)) res <- modifyList(res, args)
res
}
#
main <- paste(deparse(substitute(x)), collapse = "\n")
## determine color type: set of colors (=1) or color function (=2)
coltype <- 0
if (is.null(col)) {
col <- heat.colors
coltype <- 2
} else if (is.function(col)) {
coltype <- 2
} else if (all(areColors(col))) {
coltype <- 1
}
if (!coltype) stop('non convertible color type')
## determine matrix type: numerical (=1) or non-numerical (=2)
matrixtype <- 0
if (('numeric' %in% class(x[1,1])) | (('integer' %in% class(x[1,1])))) {
matrixtype <- 1
#
if (is.null(breaks)) {
if (coltype==1) {
breaks <- seq(from=min(x, na.rm=TRUE), to=max(x, na.rm=TRUE), length.out=length(col)+1)
}
if (coltype==2) {
col <- col(10)
coltype <- 1
breaks <- seq(from=min(x, na.rm=TRUE), to=max(x, na.rm=TRUE), length.out=length(col)+1)
}
} else {
if (coltype==1) {
if (length(col)+1!=length(breaks)) breaks <- seq(from=min(breaks, na.rm=TRUE), to=max(breaks, na.rm=TRUE), length.out=length(col)+1)
}
if (coltype==2) {
if (length(breaks)<3) {
col <- col(10)
coltype <- 1
breaks <- seq(from=min(breaks, na.rm=TRUE), to=max(breaks, na.rm=TRUE), length.out=length(col)+1)
} else {
col <- col(length(breaks)-1)
coltype <- 1
}
}
}
if (length(col)+1!=length(breaks)) stop("colors and breaks do not match")
} else {
matrixtype <- 2
v <- factor(x)
x <- matrix(v, ncol=ncol(x))
if (coltype==1) {
if (is.null(breaks)) breaks <- levels(v)
if (length(col)<length(breaks)) breaks <- breaks[1:length(col)]
if (length(breaks)<length(col)) col <- col[1:length(breaks)]
}
if (coltype==2) {
if (is.null(breaks)) breaks <- levels(v)
col <- col(length(breaks))
}
if (length(col)!=length(breaks)) stop("colors and breaks do not match")
}
if (!matrixtype) stop('non convertible data type')
## prepare formats
if (is.null(fmt.cell)) {
if (!is.na(digits)) {
if (matrixtype==1) fmt.cell <- if (digits<0) sprintf("%%+.%.0fe", -digits) else sprintf("%%+.%.0ff", digits)
if (matrixtype==2) fmt.cell <- if (digits<0) sprintf("%%+.%.0fs", -digits) else sprintf("%%+.%.0fs", digits)
}
}
if (is.null(fmt.key)) {
if (!is.na(digits)) {
if (matrixtype==1) fmt.key <- if (digits<0) sprintf("%%+.%.0fe", -digits) else sprintf("%%+.%.0ff", digits)
if (matrixtype==2) fmt.key <- if (digits<0) sprintf("%%+.%.0fs", -digits) else sprintf("%%+.%.0fs", digits)
}
}
## shall we plot the key?
if (!(is.null(key) && is.null(fmt.key) && is.null(polygon.key) && is.null(axis.key))) {
if (is.null(axis.key)) {
axis.key <- if (is.null(key)) list() else key
if (is.null(axis.key$side)) axis.key$side <- 4
}
if (is.null(fmt.key)) {
if (matrixtype==1) {
digits <- as.integer(2-log10(diff(breaks)[1]))
fmt.key <- if (digits<0) sprintf("%%+.%.0fe", -digits) else sprintf("%%+.%.0ff", digits)
}
if (matrixtype==2) {
fmt.key <- "%s"
}
}
}
## prepare basic plot
args <- ellipsis <- list(...)
apar <- c('cex.axis', 'col.axis', 'col.ticks', 'font', 'font.axis', 'hadj', 'las',
'lwd.ticks', 'line' , 'outer', 'padj', 'tck', 'tcl', 'tick')
ppar <- c('border', 'density', 'angle')
tpar <- c('cex', 'font', 'vfont')
#
args[apar] <- NULL
args[ppar] <- NULL
args$x <- c(0.5, ncol(x)+0.5)
args$y <- c(0.5, nrow(x)+0.5)
args$type <- 'n'
if (is.null(args$main)) args$main <- main
if (is.null(args$axes)) args$axes <- FALSE
dimn <- names(dimnames(x))
if (is.null(args$xlab)) args$xlab <- if (is.null(dimn[2])) 'Column' else dimn[2]
if (is.null(args$ylab)) args$ylab <- if (is.null(dimn[2])) 'Row' else dimn[1]
d <- c(0,0,0,0,0)
if (!is.null(axis.key)) d[axis.key$side] <- 1
if (is.null(args$xlim)) args$xlim <- c(0.5-d[2], ncol(x)+0.5+d[4])
if (is.null(args$ylim)) args$ylim <- c(0.5-d[1], nrow(x)+0.5+d[3])
if (is.null(args$xaxs)) args$xaxs <- 'i'
if (is.null(args$yaxs)) args$yaxs <- 'i'
if (is.null(args$cex)) args$cex <- 1
do.call('plot', args, quote=TRUE) ### do.call
## draw matrix polygons
# determine color
color <- c(na.col, col)
if (matrixtype==1) {
index <- 1+findInterval(x, breaks)
ones <- (index==length(breaks)+1) | is.na(index)
index[ones] <- 1
max <- which(x==max(breaks))
index[max] <- length(color)
}
if (matrixtype==2) index <- 1+match(x, breaks, nomatch=0)
color <- matrix(color[index], ncol=ncol(x))
# build axes
if (!is.null(axis.col)) axis.col <- createAxis(list(side=1), ellipsis[apar], axis.col)
if (!is.null(axis.row)) axis.row <- createAxis(list(side=2), ellipsis[apar], axis.row)
if (!is.null(axis.key)) {
axis.key <- createAxis(list(side=4), ellipsis[apar], axis.key)
} else if(!is.null(key)) {
axis.key <- createAxis(list(side=4), ellipsis[apar], key)
}
# check axes
axes <- rep(0, 4)
if (!is.null(axis.col)) {
if (axes[axis.col$side]) warning("Two axes at the same side")
axes[axis.col$side] <- axes[axis.col$side]+1
}
if (!is.null(axis.row)) {
if (axes[axis.row$side]) warning("Two axes at the same side")
axes[axis.row$side] <- axes[axis.row$side]+1
}
if (!is.null(axis.key)) {
if (axes[axis.key$side]) warning("Two axes at the same side")
axes[axis.key$side] <- axes[axis.key$side]+1
}
# polygons
pcell <- modifyList(list(), ellipsis[ppar])
polygon.cell <- if (is.null(polygon.cell)) pcell else modifyList(pcell, polygon.cell)
colindex <- 1:ncol(x)
rowindex <- 1:nrow(x)
# build text
tcell <- modifyList(list(), ellipsis[tpar])
text.cell <- if (is.null(text.cell)) tcell else modifyList(tcell, text.cell)
#
if (is.null(polygon.cell)) polygon.cell <- list()
for (i in rowindex) {
py <- nrow(x)-i+1
polygon.cell$y <- c(py-0.5, py+0.5, py+0.5, py-0.5)
for (j in colindex) {
px <- j
polygon.cell$x <- c(px-0.5, px-0.5, px+0.5, px+0.5)
polygon.cell$col <- color[i,j]
do.call('polygon', polygon.cell) ### polygon
if (!is.null(fmt.cell)) {
if (matrixtype==1) sij <- x[i, j]
if (matrixtype==2) sij <- if (is.na(digits)) x[i, j] else substr(x[i, j], 1, abs(digits))
text.cell$x <- px
text.cell$y <- py
text.cell$labels <- sprintf(fmt.cell, sij)
do.call('text', text.cell) ## text
}
}
}
# draw axes
if (!is.null(axis.col)) {
if (is.null(axis.col$labels)) {
cn <- dimnames(x)[[2]]
if (is.null(cn)) cn <- as.character(colindex)
axis.col$labels <- cn
}
if (is.null(axis.col$at)) axis.col$at <- colindex
do.call('axis', axis.col)
}
if (!is.null(axis.row)) {
if (is.null(axis.row$labels)) {
rn <- dimnames(x)[[1]]
if (is.null(rn)) rn <- rev(as.character(rowindex))
axis.row$labels <- rn
}
if (is.null(axis.row$at)) axis.row$at <- rowindex
do.call('axis', axis.row)
}
## draw if key necessary
if (!is.null(axis.key)) {
if (matrixtype==1) {
at <- (0:(length(breaks)-1))/(length(breaks)-1)
if (axis.key$side %in% c(2,4)) axis.key$at <- 1+(nrow(x)-1)*at
if (axis.key$side %in% c(1,3)) axis.key$at <- 1+(ncol(x)-1)*at
blocks <- axis.key$at
}
if (matrixtype==2) {
at <- (0:length(breaks))/length(breaks)
if (axis.key$side %in% c(2,4)) blocks <- 1+(nrow(x)-1)*at
if (axis.key$side %in% c(1,3)) blocks <- 1+(ncol(x)-1)*at
axis.key$at <- (blocks[-1]+blocks[-length(blocks)])/2
}
axis.key$labels <- sprintf(fmt.key, breaks)
if (is.null(axis.key$las)) axis.key$las <- 1
do.call('axis', axis.key) ### key axis
pcell <- modifyList(list(), ellipsis[ppar])
polygon.key <- if (is.null(polygon.key)) pcell else modifyList(pcell, polygon.key)
for (i in 1:length(col)) {
if (axis.key$side==1) {
}
if (axis.key$side==2) {
polygon.key$x <- c(-0.5, -0.5, 0, 0)
polygon.key$y <- c(blocks[i], blocks[i+1], blocks[i+1], blocks[i])
}
if (axis.key$side==3) {
polygon.key$x <- c(blocks[i], blocks[i+1], blocks[i+1], blocks[i])
polygon.key$y <- c(nrow(x)+1, nrow(x)+1, nrow(x)+1.5, nrow(x)+1.5)
}
if (axis.key$side==4) {
polygon.key$x <- c(ncol(x)+1, ncol(x)+1, ncol(x)+1.5, ncol(x)+1.5)
polygon.key$y <- c(blocks[i], blocks[i+1], blocks[i+1], blocks[i])
}
polygon.key$col <- col[i]
do.call('polygon', polygon.key) ### polygon
}
}
}
sigbertklinke/plot.matrix documentation built on April 2, 2022, midnight
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' plot.matrix
#'
#' Visualizes a matrix with a colored heatmap and optionally a color key. It distinguishes between numeric and non-numeric matrices.
#' You may need to modify \code{mar} with the \code{\link[graphics]{par}} command from its default \code{c(5.1,4.1,4.1,2.1)}.
#' For further see the vignette \code{vignettes('plot.matrix')}
#'
#' @details
#' A color key is drawn if either \code{key} (defaults to \code{list(cex=1)}) or \code{fmt.key}
#' (defaults to \code{NULL}) is not \code{NULL}.
#'
#' If you want to plot the matrix entries you must set either \code{digits} or \code{fmt}.
#' For a non-numeric matrix \code{digits} gives the length of the string printed, a negative value
#' results in right-justified string. For a numeric matrix \code{digits} determines the number of
#' decimal places, a negative value uses a "exponential" decimal notation. You may set format
#' strings \code{fmt} and \code{fmt.key} directly. Settings \code{digits} leads to the following
#' format strings (\code{n} the absolute value of \code{digits}):
#'
#' \tabular{ll}{
#' \code{x} numeric and \code{digits>0}:\tab \code{"\%+.nf"}\cr
#' \code{x} numeric and \code{digits<0}:\tab \code{"\%+.ne"}\cr
#' \code{x} non-numeric and \code{digits>0}:\tab \code{"\%+ns"}\cr
#' \code{x} non-numeric and \code{digits<0}:\tab \code{"\%-ns"}\cr
#' }
#'
#' If no colors are given then the \code{\link[grDevices]{heat.colors}} will be used. Alternatively you may specify your own color function
#' that delivers a vector with \code{n} colors if called by \code{col(n)}. The final colors and breaks used
#' depend if \code{plot.matrix} gets a numeric or non-numeric matrix.
#'
#' \strong{Numeric matrix:} In general it must hold \code{length(col)+1==length(breaks)}.
#' \describe{
#' \item{1. \code{breaks==NULL} and \code{col==NULL}}{The colors are taken from \code{heat.colors(10)} and the eleven breaks are calculated as an equidistant grid
#' between \code{min(x)} and \code{max(x)}.}
#' \item{2. \code{breaks==NULL} and \code{col} is a color function}{Ten colors are taken from the color function and eleven breaks are calculated as an equidistant grid
#' between \code{min(x)} and \code{max(x)}.}
#' \item{3. \code{breaks==NULL} and \code{col} is a vector of colors}{The \code{length(col)+1} breaks are calculated as an equidistant grid
#' between \code{min(x)} and \code{max(x)}.}
#' \item{4. \code{breaks} are given and \code{col==NULL}}{The colors are taken from \code{heat.colors(length(breaks)-1)}.}
#' \item{5. \code{breaks} are given and \code{col} is a color function}{The \code{length(breaks)-1} colors are taken from the color function.}
#' \item{6. \code{breaks} are given and \code{col} is a vector of colors}{If not \code{length(col)+1==length(breaks)} holds then
#' the \code{length(col)+1} breaks are calculated as an equidistant grid between \code{min(breaks)} and \code{max(breaks)}.}
#' }
#'
#' \strong{Non-numeric matrix:} In general it must hold \code{length(col)==length(breaks)}. At first the number of unique elements in \code{x} is determined: \code{nu}.
#' \describe{
#' \item{1. \code{breaks==NULL} and \code{col==NULL}}{The colors are taken from \code{heat.colors(nu)} and the breaks are set to the unique elements of \code{x}.}
#' \item{2. \code{breaks==NULL} and \code{col} is a color function}{The \code{nu} colors are taken from color function and the breaks are set to the unique elements of \code{x}.}
#' \item{3. \code{breaks==NULL} and \code{col} is a vector of colors}{The \code{length(col)} breaks are calculated as an equidistant grid
#' between \code{min(x)} and \code{max(x)}.}
#' \item{4. \code{breaks} are given and \code{color==NULL}}{The colors are taken from \code{heat.colors(length(breaks))}.}
#' \item{5. \code{breaks} are given and \code{color} is a color function}{The \code{length(breaks)} colors are taken from color function.}
#' \item{6. \code{breaks} are given and \code{color} is a vector of colors}{If not \code{length(colors)==length(breaks)} holds then
#' either \code{breaks} or \code{color} is shorten to the shorter of both.}
#' }
#'
#' @note The use of \code{fmt} or \code{fmt.key} have the same restrictions as the use of \code{fmt} in \code{\link[base]{sprintf}}:
#'
#' \emph{The format string is passed down the OS's sprintf function, and incorrect formats can cause the latter to crash the R process.
#' R does perform sanity checks on the format, but not all possible user errors on all platforms have been tested, and some might
#' be terminal.}
#'
#' @param x matrix
#' @param y unused
#' @param digits number of digits for numeric data or length of string for non-numeric data
#' @param col a vector of colors or a function, e.g. \code{\link[grDevices]{heat.colors}} with one parameter \code{n}
#' @param breaks breaks for numeric values or values for \code{col}
#' @param key list of parameters used for \code{\link[graphics]{axis}}. If set to \code{NULL} then no information will be plotted. Instead of \code{key=list(side=4)} you may use \code{key=4} or \code{key="right"}.
#' @param axis.key as \code{key}
#' @param na.col color for missing value (default: white)
#' @param fmt.cell format string for writring matrix entries, overwrites \code{digits}, defaults to \code{NULL}
#' @param fmt.key format string for writring key entries, overwrites \code{digits}, defaults to \code{fmt}
#' @param polygon.cell list of parameters used for \code{\link[graphics]{polygon}} for heatmap
#' @param polygon.key list of parameters used for \code{\link[graphics]{polygon}} for key
#' @param text.cell list of parameters used for \code{\link[graphics]{text}} for matrix entries
#' @param axis.col list of parameters used for \code{\link[graphics]{axis}} for axis of matrix columns. Instead of \code{axis.col=list(side=1)} you may use \code{axis.col=1} or \code{axis.col="bottom"}.
#' @param axis.row list of parameters used for \code{\link[graphics]{axis}} for axis of matrix rows. Instead of \code{axis.row=list(side=2)} you may use \code{axis.row=2} or \code{axis.col="left"}.
#' @param ... further parameter given to the \code{\link[graphics]{plot}} command
#' @return a plot
#' @importFrom grDevices heat.colors col2rgb
#' @importFrom graphics axis polygon text
#' @importFrom utils modifyList
#' @export
#'
#' @aliases plot
#' @examples
#' par(mar=c(5.1, 4.1, 4.1, 4.1))
#' # numeric matrix
#' x <- matrix(runif(50), nrow=10)
#' plot(x)
#' plot(x, key=NULL)
#' plot(x, key=list(cex.axis=0.5, tick=FALSE))
#' plot(x, digits=3)
#' plot(x, breaks=c(0,1), digits=3, cex=0.6)
#' # logical matrix
#' m <- matrix(runif(50)<0.5, nrow=10)
#' plot(m)
#' plot(m, col=c("red", "blue"))
#' plot(m, key=NULL, digits=1)
#' # character matrix
#' s <- matrix(sample(letters[1:10], 50, replace=TRUE), nrow=10)
#' plot(s)
#' plot(s, col=topo.colors)
#' plot(s, digits=10)
#' plot(s, digits=1, col=heat.colors(5), breaks=letters[1:5])
#' plot(s, digits=1, col=heat.colors(5), breaks=c('a', 'c', 'e', 'g', 'i'))
#' # contingency table
#' tab <- table(round(rnorm(100)), round(rnorm(100)))
#' plot(unclass(tab))
#' # chisquare test residuals
#' cst <- chisq.test(apply(HairEyeColor, 1:2, sum))
#' col <- colorRampPalette(c("blue", "white", "red"))
#' plot(cst$residuals, col=col, breaks=c(-7,7))
plot.matrix <- function(x, y=NULL, breaks=NULL, col=NULL, na.col="white",
#
digits=NA,
fmt.cell=NULL,
fmt.key=NULL,
#
polygon.cell=NULL,
polygon.key=NULL,
#
text.cell=NULL,
#
key=list(side=4, las=1),
axis.col=list(side=1),
axis.row=list(side=2),
axis.key=NULL,
#
...) {
# from https://stackoverflow.com/questions/13289009/check-if-character-string-is-a-valid-color-representation
areColors <- function(x) {
sapply(x, function(X) {
tryCatch(is.matrix(col2rgb(X)),
error = function(e) FALSE)
})
}
#
createAxis <- function(defaults, globals, args) {
if (is.null(defaults)) res <- list()
if (!is.null(globals)) res <- modifyList(defaults, globals)
if (is.numeric(args)) {
if (args %in% 1:4) res$side <- args
}
if (is.character(args)) {
side <- pmatch(axis.col, c("bottom", "left", "top", "right"))
if (!is.na(side)) res$side <- args
}
if (is.list(args)) res <- modifyList(res, args)
res
}
#
main <- paste(deparse(substitute(x)), collapse = "\n")
## determine color type: set of colors (=1) or color function (=2)
coltype <- 0
if (is.null(col)) {
col <- heat.colors
coltype <- 2
} else if (is.function(col)) {
coltype <- 2
} else if (all(areColors(col))) {
coltype <- 1
}
if (!coltype) stop('non convertible color type')
## determine matrix type: numerical (=1) or non-numerical (=2)
matrixtype <- 0
if (('numeric' %in% class(x[1,1])) | (('integer' %in% class(x[1,1])))) {
matrixtype <- 1
#
if (is.null(breaks)) {
if (coltype==1) {
breaks <- seq(from=min(x, na.rm=TRUE), to=max(x, na.rm=TRUE), length.out=length(col)+1)
}
if (coltype==2) {
col <- col(10)
coltype <- 1
breaks <- seq(from=min(x, na.rm=TRUE), to=max(x, na.rm=TRUE), length.out=length(col)+1)
}
} else {
if (coltype==1) {
if (length(col)+1!=length(breaks)) breaks <- seq(from=min(breaks, na.rm=TRUE), to=max(breaks, na.rm=TRUE), length.out=length(col)+1)
}
if (coltype==2) {
if (length(breaks)<3) {
col <- col(10)
coltype <- 1
breaks <- seq(from=min(breaks, na.rm=TRUE), to=max(breaks, na.rm=TRUE), length.out=length(col)+1)
} else {
col <- col(length(breaks)-1)
coltype <- 1
}
}
}
if (length(col)+1!=length(breaks)) stop("colors and breaks do not match")
} else {
matrixtype <- 2
v <- factor(x)
x <- matrix(v, ncol=ncol(x))
if (coltype==1) {
if (is.null(breaks)) breaks <- levels(v)
if (length(col)<length(breaks)) breaks <- breaks[1:length(col)]
if (length(breaks)<length(col)) col <- col[1:length(breaks)]
}
if (coltype==2) {
if (is.null(breaks)) breaks <- levels(v)
col <- col(length(breaks))
}
if (length(col)!=length(breaks)) stop("colors and breaks do not match")
}
if (!matrixtype) stop('non convertible data type')
## prepare formats
if (is.null(fmt.cell)) {
if (!is.na(digits)) {
if (matrixtype==1) fmt.cell <- if (digits<0) sprintf("%%+.%.0fe", -digits) else sprintf("%%+.%.0ff", digits)
if (matrixtype==2) fmt.cell <- if (digits<0) sprintf("%%+.%.0fs", -digits) else sprintf("%%+.%.0fs", digits)
}
}
if (is.null(fmt.key)) {
if (!is.na(digits)) {
if (matrixtype==1) fmt.key <- if (digits<0) sprintf("%%+.%.0fe", -digits) else sprintf("%%+.%.0ff", digits)
if (matrixtype==2) fmt.key <- if (digits<0) sprintf("%%+.%.0fs", -digits) else sprintf("%%+.%.0fs", digits)
}
}
## shall we plot the key?
if (!(is.null(key) && is.null(fmt.key) && is.null(polygon.key) && is.null(axis.key))) {
if (is.null(axis.key)) {
axis.key <- if (is.null(key)) list() else key
if (is.null(axis.key$side)) axis.key$side <- 4
}
if (is.null(fmt.key)) {
if (matrixtype==1) {
digits <- as.integer(2-log10(diff(breaks)[1]))
fmt.key <- if (digits<0) sprintf("%%+.%.0fe", -digits) else sprintf("%%+.%.0ff", digits)
}
if (matrixtype==2) {
fmt.key <- "%s"
}
}
}
## prepare basic plot
args <- ellipsis <- list(...)
apar <- c('cex.axis', 'col.axis', 'col.ticks', 'font', 'font.axis', 'hadj', 'las',
'lwd.ticks', 'line' , 'outer', 'padj', 'tck', 'tcl', 'tick')
ppar <- c('border', 'density', 'angle')
tpar <- c('cex', 'font', 'vfont')
#
args[apar] <- NULL
args[ppar] <- NULL
args$x <- c(0.5, ncol(x)+0.5)
args$y <- c(0.5, nrow(x)+0.5)
args$type <- 'n'
if (is.null(args$main)) args$main <- main
if (is.null(args$axes)) args$axes <- FALSE
dimn <- names(dimnames(x))
if (is.null(args$xlab)) args$xlab <- if (is.null(dimn[2])) 'Column' else dimn[2]
if (is.null(args$ylab)) args$ylab <- if (is.null(dimn[2])) 'Row' else dimn[1]
d <- c(0,0,0,0,0)
if (!is.null(axis.key)) d[axis.key$side] <- 1
if (is.null(args$xlim)) args$xlim <- c(0.5-d[2], ncol(x)+0.5+d[4])
if (is.null(args$ylim)) args$ylim <- c(0.5-d[1], nrow(x)+0.5+d[3])
if (is.null(args$xaxs)) args$xaxs <- 'i'
if (is.null(args$yaxs)) args$yaxs <- 'i'
if (is.null(args$cex)) args$cex <- 1
do.call('plot', args, quote=TRUE) ### do.call
## draw matrix polygons
# determine color
color <- c(na.col, col)
if (matrixtype==1) {
index <- 1+findInterval(x, breaks)
ones <- (index==length(breaks)+1) | is.na(index)
index[ones] <- 1
max <- which(x==max(breaks))
index[max] <- length(color)
}
if (matrixtype==2) index <- 1+match(x, breaks, nomatch=0)
color <- matrix(color[index], ncol=ncol(x))
# build axes
if (!is.null(axis.col)) axis.col <- createAxis(list(side=1), ellipsis[apar], axis.col)
if (!is.null(axis.row)) axis.row <- createAxis(list(side=2), ellipsis[apar], axis.row)
if (!is.null(axis.key)) {
axis.key <- createAxis(list(side=4), ellipsis[apar], axis.key)
} else if(!is.null(key)) {
axis.key <- createAxis(list(side=4), ellipsis[apar], key)
}
# check axes
axes <- rep(0, 4)
if (!is.null(axis.col)) {
if (axes[axis.col$side]) warning("Two axes at the same side")
axes[axis.col$side] <- axes[axis.col$side]+1
}
if (!is.null(axis.row)) {
if (axes[axis.row$side]) warning("Two axes at the same side")
axes[axis.row$side] <- axes[axis.row$side]+1
}
if (!is.null(axis.key)) {
if (axes[axis.key$side]) warning("Two axes at the same side")
axes[axis.key$side] <- axes[axis.key$side]+1
}
# polygons
pcell <- modifyList(list(), ellipsis[ppar])
polygon.cell <- if (is.null(polygon.cell)) pcell else modifyList(pcell, polygon.cell)
colindex <- 1:ncol(x)
rowindex <- 1:nrow(x)
# build text
tcell <- modifyList(list(), ellipsis[tpar])
text.cell <- if (is.null(text.cell)) tcell else modifyList(tcell, text.cell)
#
if (is.null(polygon.cell)) polygon.cell <- list()
for (i in rowindex) {
py <- nrow(x)-i+1
polygon.cell$y <- c(py-0.5, py+0.5, py+0.5, py-0.5)
for (j in colindex) {
px <- j
polygon.cell$x <- c(px-0.5, px-0.5, px+0.5, px+0.5)
polygon.cell$col <- color[i,j]
do.call('polygon', polygon.cell) ### polygon
if (!is.null(fmt.cell)) {
if (matrixtype==1) sij <- x[i, j]
if (matrixtype==2) sij <- if (is.na(digits)) x[i, j] else substr(x[i, j], 1, abs(digits))
text.cell$x <- px
text.cell$y <- py
text.cell$labels <- sprintf(fmt.cell, sij)
do.call('text', text.cell) ## text
}
}
}
# draw axes
if (!is.null(axis.col)) {
if (is.null(axis.col$labels)) {
cn <- dimnames(x)[[2]]
if (is.null(cn)) cn <- as.character(colindex)
axis.col$labels <- cn
}
if (is.null(axis.col$at)) axis.col$at <- colindex
do.call('axis', axis.col)
}
if (!is.null(axis.row)) {
if (is.null(axis.row$labels)) {
rn <- dimnames(x)[[1]]
if (is.null(rn)) rn <- rev(as.character(rowindex))
axis.row$labels <- rn
}
if (is.null(axis.row$at)) axis.row$at <- rowindex
do.call('axis', axis.row)
}
## draw if key necessary
if (!is.null(axis.key)) {
if (matrixtype==1) {
at <- (0:(length(breaks)-1))/(length(breaks)-1)
if (axis.key$side %in% c(2,4)) axis.key$at <- 1+(nrow(x)-1)*at
if (axis.key$side %in% c(1,3)) axis.key$at <- 1+(ncol(x)-1)*at
blocks <- axis.key$at
}
if (matrixtype==2) {
at <- (0:length(breaks))/length(breaks)
if (axis.key$side %in% c(2,4)) blocks <- 1+(nrow(x)-1)*at
if (axis.key$side %in% c(1,3)) blocks <- 1+(ncol(x)-1)*at
axis.key$at <- (blocks[-1]+blocks[-length(blocks)])/2
}
axis.key$labels <- sprintf(fmt.key, breaks)
if (is.null(axis.key$las)) axis.key$las <- 1
do.call('axis', axis.key) ### key axis
pcell <- modifyList(list(), ellipsis[ppar])
polygon.key <- if (is.null(polygon.key)) pcell else modifyList(pcell, polygon.key)
for (i in 1:length(col)) {
if (axis.key$side==1) {
}
if (axis.key$side==2) {
polygon.key$x <- c(-0.5, -0.5, 0, 0)
polygon.key$y <- c(blocks[i], blocks[i+1], blocks[i+1], blocks[i])
}
if (axis.key$side==3) {
polygon.key$x <- c(blocks[i], blocks[i+1], blocks[i+1], blocks[i])
polygon.key$y <- c(nrow(x)+1, nrow(x)+1, nrow(x)+1.5, nrow(x)+1.5)
}
if (axis.key$side==4) {
polygon.key$x <- c(ncol(x)+1, ncol(x)+1, ncol(x)+1.5, ncol(x)+1.5)
polygon.key$y <- c(blocks[i], blocks[i+1], blocks[i+1], blocks[i])
}
polygon.key$col <- col[i]
do.call('polygon', polygon.key) ### polygon
}
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.