R/jamba-imagebycolors.R
In jmw86069/jamba: Jam Base Methods
#' Display color raster image using a matrix of colors
#'
#' Display color raster image using a matrix of colors
#'
#' This function is similar to \code{\link[graphics]{image}} except that
#' it takes a matrix which already has colors defined for each cell.
#' This function calls \code{\link{imageDefault}} which enables updated
#' use of the \code{useRaster} functionality.
#'
#' Additionally, if \code{cellnote} is supplied, which contains a matrix
#' of labels for the image cells, those labels will also be displayed.
#' By default, labels are grouped, so that only one label is displayed
#' whenever two or more labels appear in consecutive cells. This behavior
#' can be disabled with groupCellnotes=FALSE.
#'
#' The `groupCellnotes` behavior uses `breaksByVector()` to
#' determine where to place consecutive labels, and it applies this logic
#' starting with rows, then columns. Note that labels are only grouped when
#' both the cell color and the cell label are identical for consecutive
#' cells.
#'
#' In general, if a large rectangular set of cells contains the same label,
#' and cell colors, the resulting label will be positioned in the
#' center. However, when the square is not symmetric, the label will be
#' grouped only where consecutive columns contain the same groups of
#' consecutive rows for a given label. In theory one could use polygon
#' functions from the \code{sp} or \code{rgeos} package to detect contiguous
#' polygons, and position the label in the center of those polygons.
#'
#' It is helpful to rotate labels partially to prevent overlaps, e.g.
#' srtCellnote=10 or srtCellnote=80.
#'
#' To do:
#' \itemize{
#' \item{Detect the size of the area being labeled and determine whether
#' to rotate the label sideways.}
#' \item{Detect the size of the label, compared to its bounding box,
#' and resize the label to fit the available space.}
#' \item{Optionally draw border around contiguous colored and labeled
#' polygons. Whether to draw border based only upon color, or color
#' and label, or just label... it may get confusing.}
#' \item{Label proper contiguous polygons based upon color and label,
#' especially when color and label are present on multiple rows and
#' columns, but not always the same columns per row.}
#' }
#'
#' @family jam plot functions
#'
#' @param x matrix or data.frame containing colors
#' @param useRaster logical sent to \code{\link{imageDefault}} to enable
#' raster rendering, as opposed to polygon rendering. This parameter is
#' highly recommended when the matrix is large (>50 columns or rows).
#' @param fixRasterRatio logical sent to \code{\link{imageDefault}}.
#' @param maxRatioFix numeric sent to \code{\link{imageDefault}}.
#' @param xaxt,yaxt character values compatible with \code{\link[graphics]{par}} to
#' determine whether x- and y-axes are plotted. Set both to "n" to
#' suppress display of axes.
#' @param doPlot logical whether to create a plot, or simply return data which
#' would have been used to create the plot.
#' @param cellnote matrix or data.frame of labels to be displayed on the
#' image. If groupCellnotes==TRUE labels will be placed in the center
#' of consecutive cells with the same label and identical color.
#' Currently, cell text is colored using \code{\link{setTextContrastColor}}
#' which uses either white or black depending upon the brightness of
#' the background color.
#' @param cexCellnote,srtCellnote,fontCellnote numeric vectors, with values
#' applied to cellnote text to be compatible with par("cex"), par("srt"),
#' and par("font"), respectively. If supplied a matrix or data.frame with
#' it is used as-is or expanded to equivalent dimensions of \code{x}.
#' If the vector is named by colnames(x) then it is applied
#' by column in order, otherwise it is applied by row, with values recycled
#' to the number of columns or rows, respectively. Note \code{cexCellnote}
#' can also be a list, with the list elements being applied to individual
#' cells in order. If the list is named by colnames(x), each list element
#' is applied to values in each column, in order. In future this parameter
#' may also accept a matrix of cex values as input. Final note: values are
#' applied to each cell, but when cell labels are combined with
#' groupCellnotes==TRUE, the value for the first matching cell is used.
#' Remember that values are placed by coordinate, bottom-to-top on the
#' y-axis, and left-to-right on the x-axis.
#' @param groupCellnotes logical whether to group labels where consecutive
#' cells contain the same label and identical cell colors, thus only
#' displaying one label in the center of these groups.
#' @param groupBy character value indicating the direction to group
#' cellnotes, when `groupCellnotes=TRUE`: `"row"` will group cellnote
#' values by row; `"column"` will group cellnote values by column.
#' By default, it will first group cellnotes by `"row"` then
#' by `"column"`.
#' @param groupByColors logical indicating whether the cellnote grouping
#' should also include the cell color. When `groupByColors=FALSE`,
#' cellnote values will be grouped together regardless whether the
#' underlying colors change, which may be preferred when applying
#' text label to topographical data.
#' @param adjBy character value indicating how to apply adjustments for
#' cexCellnote, srtCellnote, and fontCellnote, as described above.
#' @param adjustMargins logical indicating whether to adjust the axis
#' label margins to ensure enough room to draw the text rownames
#' and colnames.
#' @param interpolate logical whether to implement image interpolation,
#' by default TRUE when useRaster=TRUE.
#' @param verbose logical whether to print verbose output.
#' @param xpd NULLL or logical used for \code{par("xpd")} to define whether
#' to crop displayed output to the plot area. If xpd=NULL then par("xpd")
#' will not be modified, otherwise par("xpd"=xpd) will be defined while
#' adding any cell notes, then reverted to its previous value afterward.
#' This parameter is mainly useful when cellnote labels may overhang the
#' plot space, and would be cropped and not visible if
#' \code{par("xpd"=TRUE)}.
#' @param doTest logical whether to run a test showing basic features of
#' \code{imageByColors}.
#' @param keepTextAlpha logical passed to \code{\link{setTextContrastColor}}
#' indicating whether the text label color should inherit the alpha
#' transparency from the background color. If TRUE then fully transparent
#' background colors will not have a visible label.
#'
#' @examples
#' a1 <- c("red4","blue")[c(1,1,2)];
#' b1 <- c("yellow","orange")[c(1,2,2)];
#' c1 <- c("purple","orange")[c(1,2,2)];
#' d1 <- c("purple","green4")[c(1,2,2)];
#' df1 <- data.frame(a=a1, b=b1, c=c1, d=d1);
#'
#' # default using polygons
#' imageByColors(df1, cellnote=df1);
#'
#' # useRaster=TRUE, edges are slightly blurred with small tables
#' imageByColors(df1, cellnote=df1, useRaster=TRUE);
#'
#' # some text features, rotation, font size, etc
#' imageByColors(df1, cellnote=df1, useRaster=TRUE, adjBy="column",
#' cexCellnote=list(c(1.5,1.5,1), c(1,1.5), c(1.6,1.2), c(1.6,1.5)),
#' srtCellnote=list(c(90,0,0), c(0,45), c(0,0,0), c(0,90,0)));
#' @export
imageByColors <- function
(x,
useRaster=FALSE,
fixRasterRatio=TRUE,
maxRatioFix=100,
xaxt="s",
yaxt="s",
doPlot=TRUE,
cellnote=NULL,
cexCellnote=1,
srtCellnote=0,
fontCellnote=1,
groupCellnotes=TRUE,
groupBy=c("column", "row"),
groupByColors=TRUE,
adjBy=c("column","row"),
adjustMargins=FALSE,
interpolate=getOption("interpolate", TRUE),
verbose=FALSE,
xpd=NULL,
bty=par("bty"),
flip=c("none","y","x","xy"),
keepTextAlpha=FALSE,
doTest=FALSE,
add=FALSE,
...)
{
## Purpose is to take as input a matrix with color names
## and convert it for use by the image() function, which otherwise
## expects numerical values and an associated color ramp.
##
## if cellnote is provided, the text will be centered in each cell
##
## groupCellnotes=TRUE will label only one entry per group, if a
## series of cells have the same label. Currently only supported for
## columns, not rows
##
## if xpd=NULL then par("xpd") will not be modified,
## otherwise par("xpd"=xpd) will be defined while
## adding any cell notes, then reverted to its previous value afterward.
## if xpd=FALSE then par("xpd") will be modified to par("xpd"=FALSE) while
## adding any cell notes, then reverted to its previous value afterward.
## The intent
##
## adjBy allows adjusting the cellnote using srtCellnote, cexCellnote, fontCellnote
## either by row or by column, helpful when using the colors beside a heatmap.
adjBy <- match.arg(adjBy);
flip <- match.arg(flip);
## Optionally run a test demonstrating imageByColors()
if (doTest) {
a1 <- c("red4","blue")[c(1,1,2)];
b1 <- c("yellow","orange")[c(1,2,2)];
c1 <- c("purple","orange")[c(1,2,2)];
d1 <- c("purple","green4")[c(1,2,2)];
df1 <- data.frame(a=a1, b=b1, c=c1, d=d1);
rownames(df1) <- 1:3;
imageByColors(df1, cellnote=df1, adjBy="column", doRaster=TRUE,
srtCellnote=list(c(90,0,0), c(0,0), c(0,0), c(0,90)),
cexCellnote=list(c(1.5,1.5,1), c(1,1.5), c(1.6,1.2), c(1.6,1.5)),
fontCellnote=list(c(1,1,2), c(1,2), c(1,2), c(2,2)),
maxRatioFix=maxRatioFix,
verbose=verbose, ...);
return(invisible(list(
x=df1,
cexCellnote=cexCellnote,
srtCellnote=srtCellnote,
fontCellnote=fontCellnote
)));
}
##
cellnoteX <- NULL;
srtCellnoteDF <- NULL;
if ("data.frame" %in% class(x)) {
x <- as.matrix(x);
}
xNcolSeq <- 1:ncol(x);
xNrowSeq <- 1:nrow(x);
## Fix blank colors, sent in various forms, all of which we convert to
## "transparent"
blankMatch <- c(NA, "NA", "...", "", "blank", "empty", "-");
if (any(x %in% blankMatch)) {
if (verbose) {
printDebug("Blank values changed to transparent:",
formatInt(sum(x %in% blankMatch)));
}
x[x %in% c(NA, "NA", "...", "", "blank", "empty", "-")] <- "transparent";
}
xFac <- as.factor(x);
xFacM <- matrix(data=as.numeric(xFac),
ncol=ncol(x),
dimnames=dimnames(x));
if (doPlot) {
if (adjustMargins && (!xaxt %in% "n" || !yaxt %in% "n")) {
parmar <- par("mar");
#on.exit(par("mar"=parmar));
if (!xaxt %in% "n") {
adjustAxisLabelMargins(x=colnames(x),
margin=1,
...);
}
if (!yaxt %in% "n") {
adjustAxisLabelMargins(x=rownames(x),
margin=2,
...);
}
}
imageDefault(x=xNcolSeq,
y=xNrowSeq,
z=t(xFacM),
col=levels(xFac),
xaxt="n",
yaxt="n",
oldstyle=TRUE,
useRaster=useRaster,
xlab="",
ylab="",
axes=FALSE,
flip=flip,
fixRasterRatio=fixRasterRatio,
maxRatioFix=maxRatioFix,
bty=bty,
interpolate=interpolate,
verbose=verbose,
...);
}
## Optionally add labels to the cells
if (!is.null(cellnote)) {
if ("data.frame" %in% class(cellnote)) {
cellnote <- as.matrix(cellnote);
} else if (is.atomic(cellnote)) {
cellnote <- matrix(data=cellnote,
ncol=ncol(x),
nrow=nrow(x),
dimnames=dimnames(x));
}
cellnoteY <- matrix(ncol=ncol(cellnote), nrow=nrow(cellnote),
dimnames=dimnames(cellnote), rep(1:nrow(cellnote), ncol(cellnote)));
cellnoteX <- matrix(ncol=ncol(cellnote), nrow=nrow(cellnote),
dimnames=dimnames(cellnote), rep(1:ncol(cellnote), each=nrow(cellnote)));
cellnote1 <- cellnote;
xrow <- 1;
xcol <- 1;
xrowfac <- 1;
xcolfac <- 1;
if (verbose) {
printDebug("dim(cellnote):", dim(cellnote));
}
## apply cellnote grouping
if (groupCellnotes) {
if (nrow(x) > 1) {
xrow <- rep(1:nrow(cellnote), each=2);
xrowfac <- 2;
}
if (ncol(x) > 1) {
xcol <- rep(1:ncol(cellnote), each=2);
xcolfac <- 2;
}
if (verbose) {
printDebug(" xrow:", xrow);
printDebug(" xcol:", xcol);
}
cellnote <- cellnote[xrow,xcol,drop=FALSE];
cellnote_fac <- cellnote;
if (groupByColors) {
cellnote_fac[] <- paste(cellnote, xFacM[xrow,xcol,drop=FALSE]);
}
cellnote_fac_n <- unique(as.vector(cellnote_fac));
cellnote_fac_v <- nameVector(
as.vector(cellnote)[match(cellnote_fac_n, cellnote_fac)],
cellnote_fac_n);
x1 <- x[xrow,xcol,drop=FALSE];
if (nrow(cellnote) > 1) {
cellnoteL <- apply(cellnote_fac, 2, function(i){
i1 <- rmNA(i, naValue="")
cellnoteXi <- 1:nrow(cellnote);
if (!"column" %in% groupBy) {
i1seq <- seq_len(nrow(cellnote)/2) * 2 - 1;
i1 <- rep(i1seq, each=2);
bbv1 <- breaksByVector(i1, returnFractions=TRUE);
cellnoteXi[trunc(bbv1$labelPoints)] <- bbv1$labelPoints;
cellnoteVi <- rmNA(naValue="", i[as.numeric(bbv1$newLabels)]);
} else if (length(unique(i1)) == 1) {
cellnoteXi[trunc(nrow(cellnote)/2+0.5)] <- nrow(cellnote)/2+0.5;
cellnoteVi <- rep("",nrow(cellnote));
cellnoteVi[trunc(nrow(cellnote)/2+0.5)] <- unique(i1);
} else {
bbv1 <- breaksByVector(i1, returnFractions=TRUE);
cellnoteXi[trunc(bbv1$labelPoints)] <- bbv1$labelPoints;
cellnoteVi <- bbv1$newLabels;
}
list(cellnoteXi=cellnoteXi, cellnoteVi=cellnoteVi);
});
cellnoteY <- do.call(cbind, lapply(cellnoteL, function(i){
i$cellnoteXi;
}));
cellnote_fac <- do.call(cbind, lapply(cellnoteL, function(i){
i$cellnoteVi;
}));
} else {
cellnoteY <- matrix(ncol=ncol(cellnote), nrow=nrow(cellnote),
dimnames=dimnames(cellnote), rep(1:nrow(cellnote), ncol(cellnote)));
}
if (ncol(cellnote) > 1) {
cellnoteL <- apply(cellnote_fac, 1, function(i){
i1 <- rmNA(i, naValue="")
cellnoteXi <- 1:ncol(cellnote);
if (!"row" %in% groupBy) {
i1seq <- seq_len(ncol(cellnote)/2) * 2 - 1;
i1 <- rep(i1seq, each=2);
bbv1 <- breaksByVector(i1, returnFractions=TRUE);
cellnoteXi[trunc(bbv1$labelPoints)] <- bbv1$labelPoints;
cellnoteVi <- rmNA(naValue="", i[as.numeric(bbv1$newLabels)]);
} else if (length(unique(i1)) == 1) {
cellnoteXi[trunc(ncol(cellnote)/2+0.5)] <- ncol(cellnote)/2+0.5;
cellnoteVi <- rep("",ncol(cellnote));
cellnoteVi[trunc(ncol(cellnote)/2+0.5)] <- unique(i1);
} else {
bbv1 <- breaksByVector(i1, returnFractions=TRUE);
cellnoteXi[trunc(bbv1$labelPoints)] <- bbv1$labelPoints;
cellnoteVi <- bbv1$newLabels;
}
list(cellnoteXi=cellnoteXi, cellnoteVi=cellnoteVi);
});
cellnoteX <- rbindList(lapply(cellnoteL, function(i){
i$cellnoteXi;
}));
cellnote_fac <- rbindList(lapply(cellnoteL, function(i){
i$cellnoteVi;
}));
} else {
cellnoteX <- matrix(ncol=ncol(cellnote), nrow=nrow(cellnote),
dimnames=dimnames(cellnote),
rep(1:ncol(cellnote), each=nrow(cellnote)));
if (verbose) {
printDebug("cellnoteX:");
print(head(cellnoteX));
}
}
cellnote[] <- cellnote_fac_v[as.vector(cellnote_fac)];
} else {
x1 <- x;
}
cellWhich <- which(!cellnote %in% c(NA, ""));
if (xcolfac > 1) {
cellX <- (as.vector(cellnoteX)[cellWhich]+0.5)/xcolfac;
} else {
cellX <- as.vector(cellnoteX)[cellWhich];
}
if (verbose) {
printDebug("xcolfac:", xcolfac,
",\ncellX:", cellX,
",\nas.vector(cellnoteX):", as.vector(cellnoteX),
",\ncellWhich:", cellWhich,
",\nclass(cellnote):", class(cellnote));
print(cellnote);
}
if (xrowfac > 1) {
cellY <- (as.vector(cellnoteY)[cellWhich]+0.5)/xrowfac;
} else {
cellY <- as.vector(cellnoteY)[cellWhich];
}
celltext <- as.vector(cellnote)[cellWhich];
cellColor <- as.vector(x1)[cellWhich];
prepMatrixParam <- function(x, param, ...) {
## Purpose is to take a vector or list as input, and
## return a vector sufficient to cover the matrix x.
##
## If given a vector, with length=ncol(x)*nrow(x),
## its values are returned as-is, to be applied to the matrix
## by column.
## Otherwise if given a vector, its values are extended to ncol(x)
## then repeated within each column.
## If given a list, the list is repeated to ncol(x), then
## each list element is repeated to nrow(x) as needed.
##
if (igrepHas("matrix|data.frame", class(param))) {
paramX <- rep(seq_len(ncol(param)), length.out=ncol(x));
paramY <- rep(seq_len(nrow(param)), length.out=nrow(x));
param <- param[paramY,paramX,drop=FALSE];
dimnames(param) <- dimnames(x);
return(param);
}
if (length(param) != prod(ncol(x), nrow(x))) {
param <- rep(param, length.out=ncol(x));
if (!igrepHas("list", class(param))) {
param <- as.list(param);
}
if (!all(lengths(param) == nrow(x))) {
param <- lapply(param, function(i){
rep(i, length.out=nrow(x));
});
}
}
param <- matrix(ncol=ncol(x), nrow=nrow(x), unlist(param),
dimnames=dimnames(x));
return(param);
}
if (!is.null(names(cexCellnote)) &&
all(names(cexCellnote) %in% colnames(x))) {
adjBy <- "column";
} else if (!is.null(names(cexCellnote)) &&
all(names(cexCellnote) %in% rownames(x))) {
adjBy <- "row";
}
if (adjBy %in% "column") {
cexCellnote <- prepMatrixParam(x, cexCellnote);
fontCellnote <- prepMatrixParam(x, fontCellnote);
srtCellnote <- prepMatrixParam(x, srtCellnote);
} else {
cexCellnote <- t(prepMatrixParam(t(x), cexCellnote));
fontCellnote <- t(prepMatrixParam(t(x), fontCellnote));
srtCellnote <- t(prepMatrixParam(t(x), srtCellnote));
}
if (verbose) {
printDebug("head(cexCellnote):");
print(head(cexCellnote, 10));
}
## paramCell is the cell for which the parameter is applied, by column,
## then by row.
## Note that for labels spanning two rows or columns, it simply takes
## the first parameter.
paramCell <- floor(cellX)*nrow(x)-(nrow(x)) + floor(cellY);
if (verbose) {
printDebug("head(cellX):");print(head(cellX));
printDebug("head(paramCell):");print(head(paramCell));
}
srtCellnoteDF <- data.frame(cellX=cellX,
cellY=cellY,
celltext=celltext,
cexCellnote=cexCellnote[paramCell],
srtCellnote=srtCellnote[paramCell],
fontCellnote=fontCellnote[paramCell],
paramCell=paramCell,
cellColor=cellColor);
if (verbose) {
printDebug("srtCellnoteDF:");
print(head(srtCellnoteDF));
}
if (!is.null(xpd)) {
parXpd <- par("xpd");
par("xpd"=xpd);
}
## srt can be set only once per text() call, so we must loop through
## each srtCellnote value
## Text can only be customized once per text() call, so for every combination of
## srt, font, and cex, we must run this function again
srtCellnoteDF[,"textKey"] <- pasteByRow(srtCellnoteDF[,c("cexCellnote",
"srtCellnote", "fontCellnote")], sep="_");
if (doPlot) {
text1 <- tapply(seq_len(nrow(srtCellnoteDF)),
srtCellnoteDF[,"textKey"], function(iRow){
if (verbose) {
printDebug("textKey:", head(srtCellnoteDF[iRow,"textKey"], 1),
", iRow:", head(iRow));
}
text(x=srtCellnoteDF[iRow,"cellX"],
y=srtCellnoteDF[iRow,"cellY"],
labels=srtCellnoteDF[iRow,"celltext"],
pos=NULL,
cex=head(srtCellnoteDF[iRow,"cexCellnote"],1),
srt=head(srtCellnoteDF[iRow,"srtCellnote"],1),
font=head(srtCellnoteDF[iRow,"fontCellnote"],1),
col=setTextContrastColor(srtCellnoteDF[iRow,"cellColor"],
keepAlpha=keepTextAlpha,
useGrey=18,
...),
adj=c(0.5,0.5));
});
}
if (!is.null(xpd)) {
par("xpd"=parXpd);
}
}
## Print column and row labels if defined
if (doPlot) {
if (!xaxt %in% "n" && !is.null(colnames(x))) {
axis(1, las=2, at=1:ncol(x), labels=colnames(x), ...);
}
if (!yaxt %in% "n" && !is.null(rownames(x))) {
axis(2, las=2, at=1:nrow(x), labels=rownames(x), ...);
}
graphics::box(bty=bty,
...);
}
invisible(list(x=xNcolSeq,
y=xNrowSeq,
z=t(xFacM),
col=levels(xFac),
cellnoteX=cellnoteX,
srtCellnoteDF=srtCellnoteDF,
cexCellnote=cexCellnote));
}
jmw86069/jamba documentation built on March 26, 2024, 5:26 a.m.
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.
#' Display color raster image using a matrix of colors
#'
#' Display color raster image using a matrix of colors
#'
#' This function is similar to \code{\link[graphics]{image}} except that
#' it takes a matrix which already has colors defined for each cell.
#' This function calls \code{\link{imageDefault}} which enables updated
#' use of the \code{useRaster} functionality.
#'
#' Additionally, if \code{cellnote} is supplied, which contains a matrix
#' of labels for the image cells, those labels will also be displayed.
#' By default, labels are grouped, so that only one label is displayed
#' whenever two or more labels appear in consecutive cells. This behavior
#' can be disabled with groupCellnotes=FALSE.
#'
#' The `groupCellnotes` behavior uses `breaksByVector()` to
#' determine where to place consecutive labels, and it applies this logic
#' starting with rows, then columns. Note that labels are only grouped when
#' both the cell color and the cell label are identical for consecutive
#' cells.
#'
#' In general, if a large rectangular set of cells contains the same label,
#' and cell colors, the resulting label will be positioned in the
#' center. However, when the square is not symmetric, the label will be
#' grouped only where consecutive columns contain the same groups of
#' consecutive rows for a given label. In theory one could use polygon
#' functions from the \code{sp} or \code{rgeos} package to detect contiguous
#' polygons, and position the label in the center of those polygons.
#'
#' It is helpful to rotate labels partially to prevent overlaps, e.g.
#' srtCellnote=10 or srtCellnote=80.
#'
#' To do:
#' \itemize{
#' \item{Detect the size of the area being labeled and determine whether
#' to rotate the label sideways.}
#' \item{Detect the size of the label, compared to its bounding box,
#' and resize the label to fit the available space.}
#' \item{Optionally draw border around contiguous colored and labeled
#' polygons. Whether to draw border based only upon color, or color
#' and label, or just label... it may get confusing.}
#' \item{Label proper contiguous polygons based upon color and label,
#' especially when color and label are present on multiple rows and
#' columns, but not always the same columns per row.}
#' }
#'
#' @family jam plot functions
#'
#' @param x matrix or data.frame containing colors
#' @param useRaster logical sent to \code{\link{imageDefault}} to enable
#' raster rendering, as opposed to polygon rendering. This parameter is
#' highly recommended when the matrix is large (>50 columns or rows).
#' @param fixRasterRatio logical sent to \code{\link{imageDefault}}.
#' @param maxRatioFix numeric sent to \code{\link{imageDefault}}.
#' @param xaxt,yaxt character values compatible with \code{\link[graphics]{par}} to
#' determine whether x- and y-axes are plotted. Set both to "n" to
#' suppress display of axes.
#' @param doPlot logical whether to create a plot, or simply return data which
#' would have been used to create the plot.
#' @param cellnote matrix or data.frame of labels to be displayed on the
#' image. If groupCellnotes==TRUE labels will be placed in the center
#' of consecutive cells with the same label and identical color.
#' Currently, cell text is colored using \code{\link{setTextContrastColor}}
#' which uses either white or black depending upon the brightness of
#' the background color.
#' @param cexCellnote,srtCellnote,fontCellnote numeric vectors, with values
#' applied to cellnote text to be compatible with par("cex"), par("srt"),
#' and par("font"), respectively. If supplied a matrix or data.frame with
#' it is used as-is or expanded to equivalent dimensions of \code{x}.
#' If the vector is named by colnames(x) then it is applied
#' by column in order, otherwise it is applied by row, with values recycled
#' to the number of columns or rows, respectively. Note \code{cexCellnote}
#' can also be a list, with the list elements being applied to individual
#' cells in order. If the list is named by colnames(x), each list element
#' is applied to values in each column, in order. In future this parameter
#' may also accept a matrix of cex values as input. Final note: values are
#' applied to each cell, but when cell labels are combined with
#' groupCellnotes==TRUE, the value for the first matching cell is used.
#' Remember that values are placed by coordinate, bottom-to-top on the
#' y-axis, and left-to-right on the x-axis.
#' @param groupCellnotes logical whether to group labels where consecutive
#' cells contain the same label and identical cell colors, thus only
#' displaying one label in the center of these groups.
#' @param groupBy character value indicating the direction to group
#' cellnotes, when `groupCellnotes=TRUE`: `"row"` will group cellnote
#' values by row; `"column"` will group cellnote values by column.
#' By default, it will first group cellnotes by `"row"` then
#' by `"column"`.
#' @param groupByColors logical indicating whether the cellnote grouping
#' should also include the cell color. When `groupByColors=FALSE`,
#' cellnote values will be grouped together regardless whether the
#' underlying colors change, which may be preferred when applying
#' text label to topographical data.
#' @param adjBy character value indicating how to apply adjustments for
#' cexCellnote, srtCellnote, and fontCellnote, as described above.
#' @param adjustMargins logical indicating whether to adjust the axis
#' label margins to ensure enough room to draw the text rownames
#' and colnames.
#' @param interpolate logical whether to implement image interpolation,
#' by default TRUE when useRaster=TRUE.
#' @param verbose logical whether to print verbose output.
#' @param xpd NULLL or logical used for \code{par("xpd")} to define whether
#' to crop displayed output to the plot area. If xpd=NULL then par("xpd")
#' will not be modified, otherwise par("xpd"=xpd) will be defined while
#' adding any cell notes, then reverted to its previous value afterward.
#' This parameter is mainly useful when cellnote labels may overhang the
#' plot space, and would be cropped and not visible if
#' \code{par("xpd"=TRUE)}.
#' @param doTest logical whether to run a test showing basic features of
#' \code{imageByColors}.
#' @param keepTextAlpha logical passed to \code{\link{setTextContrastColor}}
#' indicating whether the text label color should inherit the alpha
#' transparency from the background color. If TRUE then fully transparent
#' background colors will not have a visible label.
#'
#' @examples
#' a1 <- c("red4","blue")[c(1,1,2)];
#' b1 <- c("yellow","orange")[c(1,2,2)];
#' c1 <- c("purple","orange")[c(1,2,2)];
#' d1 <- c("purple","green4")[c(1,2,2)];
#' df1 <- data.frame(a=a1, b=b1, c=c1, d=d1);
#'
#' # default using polygons
#' imageByColors(df1, cellnote=df1);
#'
#' # useRaster=TRUE, edges are slightly blurred with small tables
#' imageByColors(df1, cellnote=df1, useRaster=TRUE);
#'
#' # some text features, rotation, font size, etc
#' imageByColors(df1, cellnote=df1, useRaster=TRUE, adjBy="column",
#' cexCellnote=list(c(1.5,1.5,1), c(1,1.5), c(1.6,1.2), c(1.6,1.5)),
#' srtCellnote=list(c(90,0,0), c(0,45), c(0,0,0), c(0,90,0)));
#' @export
imageByColors <- function
(x,
useRaster=FALSE,
fixRasterRatio=TRUE,
maxRatioFix=100,
xaxt="s",
yaxt="s",
doPlot=TRUE,
cellnote=NULL,
cexCellnote=1,
srtCellnote=0,
fontCellnote=1,
groupCellnotes=TRUE,
groupBy=c("column", "row"),
groupByColors=TRUE,
adjBy=c("column","row"),
adjustMargins=FALSE,
interpolate=getOption("interpolate", TRUE),
verbose=FALSE,
xpd=NULL,
bty=par("bty"),
flip=c("none","y","x","xy"),
keepTextAlpha=FALSE,
doTest=FALSE,
add=FALSE,
...)
{
## Purpose is to take as input a matrix with color names
## and convert it for use by the image() function, which otherwise
## expects numerical values and an associated color ramp.
##
## if cellnote is provided, the text will be centered in each cell
##
## groupCellnotes=TRUE will label only one entry per group, if a
## series of cells have the same label. Currently only supported for
## columns, not rows
##
## if xpd=NULL then par("xpd") will not be modified,
## otherwise par("xpd"=xpd) will be defined while
## adding any cell notes, then reverted to its previous value afterward.
## if xpd=FALSE then par("xpd") will be modified to par("xpd"=FALSE) while
## adding any cell notes, then reverted to its previous value afterward.
## The intent
##
## adjBy allows adjusting the cellnote using srtCellnote, cexCellnote, fontCellnote
## either by row or by column, helpful when using the colors beside a heatmap.
adjBy <- match.arg(adjBy);
flip <- match.arg(flip);
## Optionally run a test demonstrating imageByColors()
if (doTest) {
a1 <- c("red4","blue")[c(1,1,2)];
b1 <- c("yellow","orange")[c(1,2,2)];
c1 <- c("purple","orange")[c(1,2,2)];
d1 <- c("purple","green4")[c(1,2,2)];
df1 <- data.frame(a=a1, b=b1, c=c1, d=d1);
rownames(df1) <- 1:3;
imageByColors(df1, cellnote=df1, adjBy="column", doRaster=TRUE,
srtCellnote=list(c(90,0,0), c(0,0), c(0,0), c(0,90)),
cexCellnote=list(c(1.5,1.5,1), c(1,1.5), c(1.6,1.2), c(1.6,1.5)),
fontCellnote=list(c(1,1,2), c(1,2), c(1,2), c(2,2)),
maxRatioFix=maxRatioFix,
verbose=verbose, ...);
return(invisible(list(
x=df1,
cexCellnote=cexCellnote,
srtCellnote=srtCellnote,
fontCellnote=fontCellnote
)));
}
##
cellnoteX <- NULL;
srtCellnoteDF <- NULL;
if ("data.frame" %in% class(x)) {
x <- as.matrix(x);
}
xNcolSeq <- 1:ncol(x);
xNrowSeq <- 1:nrow(x);
## Fix blank colors, sent in various forms, all of which we convert to
## "transparent"
blankMatch <- c(NA, "NA", "...", "", "blank", "empty", "-");
if (any(x %in% blankMatch)) {
if (verbose) {
printDebug("Blank values changed to transparent:",
formatInt(sum(x %in% blankMatch)));
}
x[x %in% c(NA, "NA", "...", "", "blank", "empty", "-")] <- "transparent";
}
xFac <- as.factor(x);
xFacM <- matrix(data=as.numeric(xFac),
ncol=ncol(x),
dimnames=dimnames(x));
if (doPlot) {
if (adjustMargins && (!xaxt %in% "n" || !yaxt %in% "n")) {
parmar <- par("mar");
#on.exit(par("mar"=parmar));
if (!xaxt %in% "n") {
adjustAxisLabelMargins(x=colnames(x),
margin=1,
...);
}
if (!yaxt %in% "n") {
adjustAxisLabelMargins(x=rownames(x),
margin=2,
...);
}
}
imageDefault(x=xNcolSeq,
y=xNrowSeq,
z=t(xFacM),
col=levels(xFac),
xaxt="n",
yaxt="n",
oldstyle=TRUE,
useRaster=useRaster,
xlab="",
ylab="",
axes=FALSE,
flip=flip,
fixRasterRatio=fixRasterRatio,
maxRatioFix=maxRatioFix,
bty=bty,
interpolate=interpolate,
verbose=verbose,
...);
}
## Optionally add labels to the cells
if (!is.null(cellnote)) {
if ("data.frame" %in% class(cellnote)) {
cellnote <- as.matrix(cellnote);
} else if (is.atomic(cellnote)) {
cellnote <- matrix(data=cellnote,
ncol=ncol(x),
nrow=nrow(x),
dimnames=dimnames(x));
}
cellnoteY <- matrix(ncol=ncol(cellnote), nrow=nrow(cellnote),
dimnames=dimnames(cellnote), rep(1:nrow(cellnote), ncol(cellnote)));
cellnoteX <- matrix(ncol=ncol(cellnote), nrow=nrow(cellnote),
dimnames=dimnames(cellnote), rep(1:ncol(cellnote), each=nrow(cellnote)));
cellnote1 <- cellnote;
xrow <- 1;
xcol <- 1;
xrowfac <- 1;
xcolfac <- 1;
if (verbose) {
printDebug("dim(cellnote):", dim(cellnote));
}
## apply cellnote grouping
if (groupCellnotes) {
if (nrow(x) > 1) {
xrow <- rep(1:nrow(cellnote), each=2);
xrowfac <- 2;
}
if (ncol(x) > 1) {
xcol <- rep(1:ncol(cellnote), each=2);
xcolfac <- 2;
}
if (verbose) {
printDebug(" xrow:", xrow);
printDebug(" xcol:", xcol);
}
cellnote <- cellnote[xrow,xcol,drop=FALSE];
cellnote_fac <- cellnote;
if (groupByColors) {
cellnote_fac[] <- paste(cellnote, xFacM[xrow,xcol,drop=FALSE]);
}
cellnote_fac_n <- unique(as.vector(cellnote_fac));
cellnote_fac_v <- nameVector(
as.vector(cellnote)[match(cellnote_fac_n, cellnote_fac)],
cellnote_fac_n);
x1 <- x[xrow,xcol,drop=FALSE];
if (nrow(cellnote) > 1) {
cellnoteL <- apply(cellnote_fac, 2, function(i){
i1 <- rmNA(i, naValue="")
cellnoteXi <- 1:nrow(cellnote);
if (!"column" %in% groupBy) {
i1seq <- seq_len(nrow(cellnote)/2) * 2 - 1;
i1 <- rep(i1seq, each=2);
bbv1 <- breaksByVector(i1, returnFractions=TRUE);
cellnoteXi[trunc(bbv1$labelPoints)] <- bbv1$labelPoints;
cellnoteVi <- rmNA(naValue="", i[as.numeric(bbv1$newLabels)]);
} else if (length(unique(i1)) == 1) {
cellnoteXi[trunc(nrow(cellnote)/2+0.5)] <- nrow(cellnote)/2+0.5;
cellnoteVi <- rep("",nrow(cellnote));
cellnoteVi[trunc(nrow(cellnote)/2+0.5)] <- unique(i1);
} else {
bbv1 <- breaksByVector(i1, returnFractions=TRUE);
cellnoteXi[trunc(bbv1$labelPoints)] <- bbv1$labelPoints;
cellnoteVi <- bbv1$newLabels;
}
list(cellnoteXi=cellnoteXi, cellnoteVi=cellnoteVi);
});
cellnoteY <- do.call(cbind, lapply(cellnoteL, function(i){
i$cellnoteXi;
}));
cellnote_fac <- do.call(cbind, lapply(cellnoteL, function(i){
i$cellnoteVi;
}));
} else {
cellnoteY <- matrix(ncol=ncol(cellnote), nrow=nrow(cellnote),
dimnames=dimnames(cellnote), rep(1:nrow(cellnote), ncol(cellnote)));
}
if (ncol(cellnote) > 1) {
cellnoteL <- apply(cellnote_fac, 1, function(i){
i1 <- rmNA(i, naValue="")
cellnoteXi <- 1:ncol(cellnote);
if (!"row" %in% groupBy) {
i1seq <- seq_len(ncol(cellnote)/2) * 2 - 1;
i1 <- rep(i1seq, each=2);
bbv1 <- breaksByVector(i1, returnFractions=TRUE);
cellnoteXi[trunc(bbv1$labelPoints)] <- bbv1$labelPoints;
cellnoteVi <- rmNA(naValue="", i[as.numeric(bbv1$newLabels)]);
} else if (length(unique(i1)) == 1) {
cellnoteXi[trunc(ncol(cellnote)/2+0.5)] <- ncol(cellnote)/2+0.5;
cellnoteVi <- rep("",ncol(cellnote));
cellnoteVi[trunc(ncol(cellnote)/2+0.5)] <- unique(i1);
} else {
bbv1 <- breaksByVector(i1, returnFractions=TRUE);
cellnoteXi[trunc(bbv1$labelPoints)] <- bbv1$labelPoints;
cellnoteVi <- bbv1$newLabels;
}
list(cellnoteXi=cellnoteXi, cellnoteVi=cellnoteVi);
});
cellnoteX <- rbindList(lapply(cellnoteL, function(i){
i$cellnoteXi;
}));
cellnote_fac <- rbindList(lapply(cellnoteL, function(i){
i$cellnoteVi;
}));
} else {
cellnoteX <- matrix(ncol=ncol(cellnote), nrow=nrow(cellnote),
dimnames=dimnames(cellnote),
rep(1:ncol(cellnote), each=nrow(cellnote)));
if (verbose) {
printDebug("cellnoteX:");
print(head(cellnoteX));
}
}
cellnote[] <- cellnote_fac_v[as.vector(cellnote_fac)];
} else {
x1 <- x;
}
cellWhich <- which(!cellnote %in% c(NA, ""));
if (xcolfac > 1) {
cellX <- (as.vector(cellnoteX)[cellWhich]+0.5)/xcolfac;
} else {
cellX <- as.vector(cellnoteX)[cellWhich];
}
if (verbose) {
printDebug("xcolfac:", xcolfac,
",\ncellX:", cellX,
",\nas.vector(cellnoteX):", as.vector(cellnoteX),
",\ncellWhich:", cellWhich,
",\nclass(cellnote):", class(cellnote));
print(cellnote);
}
if (xrowfac > 1) {
cellY <- (as.vector(cellnoteY)[cellWhich]+0.5)/xrowfac;
} else {
cellY <- as.vector(cellnoteY)[cellWhich];
}
celltext <- as.vector(cellnote)[cellWhich];
cellColor <- as.vector(x1)[cellWhich];
prepMatrixParam <- function(x, param, ...) {
## Purpose is to take a vector or list as input, and
## return a vector sufficient to cover the matrix x.
##
## If given a vector, with length=ncol(x)*nrow(x),
## its values are returned as-is, to be applied to the matrix
## by column.
## Otherwise if given a vector, its values are extended to ncol(x)
## then repeated within each column.
## If given a list, the list is repeated to ncol(x), then
## each list element is repeated to nrow(x) as needed.
##
if (igrepHas("matrix|data.frame", class(param))) {
paramX <- rep(seq_len(ncol(param)), length.out=ncol(x));
paramY <- rep(seq_len(nrow(param)), length.out=nrow(x));
param <- param[paramY,paramX,drop=FALSE];
dimnames(param) <- dimnames(x);
return(param);
}
if (length(param) != prod(ncol(x), nrow(x))) {
param <- rep(param, length.out=ncol(x));
if (!igrepHas("list", class(param))) {
param <- as.list(param);
}
if (!all(lengths(param) == nrow(x))) {
param <- lapply(param, function(i){
rep(i, length.out=nrow(x));
});
}
}
param <- matrix(ncol=ncol(x), nrow=nrow(x), unlist(param),
dimnames=dimnames(x));
return(param);
}
if (!is.null(names(cexCellnote)) &&
all(names(cexCellnote) %in% colnames(x))) {
adjBy <- "column";
} else if (!is.null(names(cexCellnote)) &&
all(names(cexCellnote) %in% rownames(x))) {
adjBy <- "row";
}
if (adjBy %in% "column") {
cexCellnote <- prepMatrixParam(x, cexCellnote);
fontCellnote <- prepMatrixParam(x, fontCellnote);
srtCellnote <- prepMatrixParam(x, srtCellnote);
} else {
cexCellnote <- t(prepMatrixParam(t(x), cexCellnote));
fontCellnote <- t(prepMatrixParam(t(x), fontCellnote));
srtCellnote <- t(prepMatrixParam(t(x), srtCellnote));
}
if (verbose) {
printDebug("head(cexCellnote):");
print(head(cexCellnote, 10));
}
## paramCell is the cell for which the parameter is applied, by column,
## then by row.
## Note that for labels spanning two rows or columns, it simply takes
## the first parameter.
paramCell <- floor(cellX)*nrow(x)-(nrow(x)) + floor(cellY);
if (verbose) {
printDebug("head(cellX):");print(head(cellX));
printDebug("head(paramCell):");print(head(paramCell));
}
srtCellnoteDF <- data.frame(cellX=cellX,
cellY=cellY,
celltext=celltext,
cexCellnote=cexCellnote[paramCell],
srtCellnote=srtCellnote[paramCell],
fontCellnote=fontCellnote[paramCell],
paramCell=paramCell,
cellColor=cellColor);
if (verbose) {
printDebug("srtCellnoteDF:");
print(head(srtCellnoteDF));
}
if (!is.null(xpd)) {
parXpd <- par("xpd");
par("xpd"=xpd);
}
## srt can be set only once per text() call, so we must loop through
## each srtCellnote value
## Text can only be customized once per text() call, so for every combination of
## srt, font, and cex, we must run this function again
srtCellnoteDF[,"textKey"] <- pasteByRow(srtCellnoteDF[,c("cexCellnote",
"srtCellnote", "fontCellnote")], sep="_");
if (doPlot) {
text1 <- tapply(seq_len(nrow(srtCellnoteDF)),
srtCellnoteDF[,"textKey"], function(iRow){
if (verbose) {
printDebug("textKey:", head(srtCellnoteDF[iRow,"textKey"], 1),
", iRow:", head(iRow));
}
text(x=srtCellnoteDF[iRow,"cellX"],
y=srtCellnoteDF[iRow,"cellY"],
labels=srtCellnoteDF[iRow,"celltext"],
pos=NULL,
cex=head(srtCellnoteDF[iRow,"cexCellnote"],1),
srt=head(srtCellnoteDF[iRow,"srtCellnote"],1),
font=head(srtCellnoteDF[iRow,"fontCellnote"],1),
col=setTextContrastColor(srtCellnoteDF[iRow,"cellColor"],
keepAlpha=keepTextAlpha,
useGrey=18,
...),
adj=c(0.5,0.5));
});
}
if (!is.null(xpd)) {
par("xpd"=parXpd);
}
}
## Print column and row labels if defined
if (doPlot) {
if (!xaxt %in% "n" && !is.null(colnames(x))) {
axis(1, las=2, at=1:ncol(x), labels=colnames(x), ...);
}
if (!yaxt %in% "n" && !is.null(rownames(x))) {
axis(2, las=2, at=1:nrow(x), labels=rownames(x), ...);
}
graphics::box(bty=bty,
...);
}
invisible(list(x=xNcolSeq,
y=xNrowSeq,
z=t(xFacM),
col=levels(xFac),
cellnoteX=cellnoteX,
srtCellnoteDF=srtCellnoteDF,
cexCellnote=cexCellnote));
}
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.