Travis Heeter - 1 year ago 94
R Question

# How to use graphical parameters (par/mtext) in the stats heatmap?

Here's the data I want to show in a heatmap:

``````structure(c(0.275131583482786, 0.313534037727115, 0.962898063173055, 0.370113551736794, 1.14085845291068, 1.02395544767755, 0.610512768755584, 0.992090676567594, 1.01157287717658, 0.679398973271326, 1.28114204694855, 0.963474557283888, 0.963249806395876, 0.952350396411827, 0.917066806607197, 0.721011695495292, 0.621362668286169, 0.905890374647831, 1.2375342589893, 0.80959426908998, 0.89503844823737, 1.33699982243824, 1.00649486312353, 0.897702695054227, 1.47859465133637, 1.00649486312353, 0.896753478691479), .Dim = c(3L, 9L), .Dimnames = list(c("Connectivity", "Dunn", "Silhouette"), c("2", "3", "4", "5", "6", "7", "8", "9", "10")), "`scaled:scale`" = structure(c(19.2058175118873, 0.0166116998686644, 0.748614066120069), .Names = c("Connectivity", "Dunn", "Silhouette")))
``````

Here's my heatmap function:

``````par(mar=c(5,5,5,5), cex=.4)
vhm<-heatmap(vkm,Rowv = NA,Colv = NA,
main="Ionospheric Reflection Variance")
mtext("K-Means Cluster Size Analysis: 2-10")
``````

And here's what it looks like:

I'd like to change:

1. Margins: How do I get an equal amount of space between the top and bottom of the plot? Right now the main title is right up against the top of the window, and the bottom has too much space.

2. Text Size: The row names are way too big.

3. Subtitle: I'd like to position it below the main title.

4. Text position: I'd like the row names to be on the left and the column names to be on the right.

I'm not sure why nothing seems to be working as expected, my guess is it's because this plot is from the stats package, but the doc says it's building the plot with the graphics package.

How can I get par and mtext working with the heatmap?

There is a dirty but not quick solution by tuning the source code of `heatmap`. Not flexible but works with a little effort:

1. see comment a in the following code;
2. `cexRow` and `cexCol`;
3. tuning `line`;
4. change the side of row axis to right (see comment b in the following code);

the is the modified function:

``````heatmap <- function (x,
Rowv = NULL,
Colv = if (symm) "Rowv" else NULL,
distfun = dist,
hclustfun = hclust,
reorderfun = function(d, w) reorder(d, w),
symm = FALSE,
revC = identical(Colv, "Rowv"),
scale = c("row", "column", "none"),
na.rm = TRUE,
margins = c(5, 5),
ColSideColors,
RowSideColors,
cexRow = 0.2 +
1 / log10(nr),
cexCol = 0.2 + 1 / log10(nc),
labRow = NULL,
labCol = NULL,
main = NULL,
xlab = NULL,
ylab = NULL,
keep.dendro = FALSE,
verbose = getOption("verbose"),
...)

{
scale <- if (symm && missing(scale))
"none"
else match.arg(scale)
if (length(di <- dim(x)) != 2 || !is.numeric(x))
stop("'x' must be a numeric matrix")
nr <- di[1L]
nc <- di[2L]
if (nr <= 1 || nc <= 1)
stop("'x' must have at least 2 rows and 2 columns")
if (!is.numeric(margins) || length(margins) != 2L)
stop("'margins' must be a numeric vector of length 2")
doRdend <- !identical(Rowv, NA)
doCdend <- !identical(Colv, NA)
if (!doRdend && identical(Colv, "Rowv"))
doCdend <- FALSE
if (is.null(Rowv))
Rowv <- rowMeans(x, na.rm = na.rm)
if (is.null(Colv))
Colv <- colMeans(x, na.rm = na.rm)
if (doRdend) {
if (inherits(Rowv, "dendrogram"))
ddr <- Rowv
else {
hcr <- hclustfun(distfun(x))
ddr <- as.dendrogram(hcr)
if (!is.logical(Rowv) || Rowv)
ddr <- reorderfun(ddr, Rowv)
}
if (nr != length(rowInd <- order.dendrogram(ddr)))
stop("row dendrogram ordering gave index of wrong length")
}
else rowInd <- 1L:nr
if (doCdend) {
if (inherits(Colv, "dendrogram"))
ddc <- Colv
else if (identical(Colv, "Rowv")) {
if (nr != nc)
stop("Colv = \"Rowv\" but nrow(x) != ncol(x)")
ddc <- ddr
}
else {
hcc <- hclustfun(distfun(if (symm)
x
else t(x)))
ddc <- as.dendrogram(hcc)
if (!is.logical(Colv) || Colv)
ddc <- reorderfun(ddc, Colv)
}
if (nc != length(colInd <- order.dendrogram(ddc)))
stop("column dendrogram ordering gave index of wrong length")
}
else colInd <- 1L:nc
x <- x[rowInd, colInd]
labRow <- if (is.null(labRow))
if (is.null(rownames(x)))
(1L:nr)[rowInd]
else rownames(x)
else labRow[rowInd]
labCol <- if (is.null(labCol))
if (is.null(colnames(x)))
(1L:nc)[colInd]
else colnames(x)
else labCol[colInd]
if (scale == "row") {
x <- sweep(x, 1L, rowMeans(x, na.rm = na.rm), check.margin = FALSE)
sx <- apply(x, 1L, sd, na.rm = na.rm)
x <- sweep(x, 1L, sx, "/", check.margin = FALSE)
}
else if (scale == "column") {
x <- sweep(x, 2L, colMeans(x, na.rm = na.rm), check.margin = FALSE)
sx <- apply(x, 2L, sd, na.rm = na.rm)
x <- sweep(x, 2L, sx, "/", check.margin = FALSE)
}
lmat <- rbind(c(NA, 3), 2:1)
lwid <- c(if (doRdend) 1 else 0.05, 4)
lhei <- c((if (doCdend) 1 else 0.05) + if (!is.null(main)) 0.2 else 0,
4)
if (!missing(ColSideColors)) {
if (!is.character(ColSideColors) || length(ColSideColors) !=
nc)
stop("'ColSideColors' must be a character vector of length ncol(x)")
lmat <- rbind(lmat[1, ] + 1, c(NA, 1), lmat[2, ] + 1)
lhei <- c(lhei[1L], 0.2, lhei[2L])
}
if (!missing(RowSideColors)) {
if (!is.character(RowSideColors) || length(RowSideColors) !=
nr)
stop("'RowSideColors' must be a character vector of length nrow(x)")
lmat <- cbind(lmat[, 1] + 1, c(rep(NA, nrow(lmat) - 1),
1), lmat[, 2] + 1)
lwid <- c(lwid[1L], 0.2, lwid[2L])
}
lmat[is.na(lmat)] <- 0
if (verbose) {
cat("layout: widths = ", lwid, ", heights = ", lhei,
"; lmat=\n")
print(lmat)
}
dev.hold()
on.exit(dev.flush())
layout(lmat, widths = lwid, heights = lhei, respect = TRUE)
if (!missing(RowSideColors)) {
par(mar = c(margins[1L], 0, 0, 0.5))
image(rbind(if (revC)
nr:1L
else 1L:nr), col = RowSideColors[rowInd], axes = FALSE)
}
if (!missing(ColSideColors)) {
par(mar = c(0.5, 0, 0, margins[2L]))
image(cbind(1L:nc), col = ColSideColors[colInd], axes = FALSE)
}
# -------------------------- a -----------------------
# plot main figure
# the following line controls margins around
par(mar = c(margins[1L], 5, 5, margins[2L]))
if (!symm || scale != "none")
x <- t(x)
if (revC) {
iy <- nr:1
if (doRdend)
ddr <- rev(ddr)
x <- x[, iy]
}
else iy <- 1L:nr
image(1L:nc, 1L:nr, x, xlim = 0.5 + c(0, nc), ylim = 0.5 +
c(0, nr), axes = FALSE, xlab = "", ylab = "", ...)
axis(1, 1L:nc, labels = labCol, las = 2, line = -0.5, tick = 0,
cex.axis = cexCol)
if (!is.null(xlab))
mtext(xlab, side = 1, line = margins[1L] - 1.25)
# ----------------------- b --------------------------------
# which side to plot rownames: right = 2
axis(2, iy, labels = labRow, las = 2, line = -0.5, tick = 0,
cex.axis = cexRow)
if (!is.null(ylab))
# remember to change this to 2 as well
mtext(ylab, side = 2, line = margins[2L] - 1.25)
# plot row dendro
par(mar = c(margins[1L], 0, 0, 0))
if (doRdend)
plot(ddr, horiz = TRUE, axes = FALSE, yaxs = "i", leaflab = "none")
else frame()
# plot col dendro
par(mar = c(0, 0, if (!is.null(main)) 1 else 0, margins[2L]))
if (doCdend)
plot(ddc, axes = FALSE, xaxs = "i", leaflab = "none")
else if (!is.null(main))
frame()
# title
if (!is.null(main)) {
par(xpd = NA, mar = c(0, 0, 1, 0))
title(main, cex.main = 1.5 * op[["cex.main"]])
}
invisible(list(rowInd = rowInd, colInd = colInd,
Rowv = if (keep.dendro && doRdend) ddr,
Colv = if (keep.dendro && doCdend) ddc))
}
``````

draw the heatmap:

``````heatmap(
vkm,
Rowv = NA,
Colv = NA,
cexRow = 1,
cexCol = 1,
margins = c(3, 5),
main = "Ionospheric Reflection Variance"
)
mtext("K-Means Cluster Size Analysis: 2-10", line = 0)
``````

This is how the figure looks like:

However, this could be done more flexibly with `ggplot2::geom_raster`:

``````library(ggplot2)
df <- expand.grid(
vars = rownames(vkm),
cols = colnames(vkm)
)
df\$value <- c(vkm)

ggplot(df, aes(x = cols, y = vars)) +
geom_raster(aes(fill = value)) +
scale_fill_gradient(low = 'red', high = 'yellow') +
ggtitle(bquote(
atop("Ionospheric Reflection Variance",
atop("K-Means Cluster Size Analysis: 2-10")))) +
theme(
axis.title.x = element_blank(),
axis.title.y = element_blank()
)
``````

The result is:

Recommended from our users: Dynamic Network Monitoring from WhatsUp Gold from IPSwitch. Free Download