Travis Heeter Travis Heeter - 6 days ago 8
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:
enter image description here

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?

Answer

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),
              add.expr,
              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())
    op <- par(no.readonly = TRUE)
    on.exit(par(op), add = TRUE)
    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)
    if (!missing(add.expr)) 
        eval.parent(substitute(add.expr))
    # 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: enter image description here

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: enter image description here

Comments