R/plotcorr.R

In biostatUZH: Misc Tools of the Department of Biostatistics, EBPI, University of Zurich

################################################################################
### Part of the R package "biostatUZH".
### Free software under the terms of the GNU General Public License (version 2
### or later) a copy of which is available at http://www.R-project.org/Licenses
###
### A fork of ellipse::plotcorr() by Duncan Murdoch
###
### Copyright (C) 2015 Sebastian Meyer
################################################################################

"plotcorr" <-
  function (corr, outline = TRUE, col = TRUE,
            lower.panel = "ellipse", upper.panel = "number", diag.panel = NULL,
            bty = "n", axes = FALSE, xlab = "", ylab = "", asp = 1,
            cex.lab = par("cex.lab"), cex = 0.75*par("cex"), mar = 0.1 + c(2,2,4,2), ...)
{
    savepar <- par(pty = "s", mar = mar)
    on.exit(par(savepar))

    if (is.null(corr)) return(invisible())
    if ((!is.matrix(corr)) || (round(min(corr, na.rm = TRUE), 6) < -1) 
			   || (round(max(corr, na.rm = TRUE), 6) > 1)) 
	stop("Need a correlation matrix")

    plot.new()
    par(new = TRUE)

    rowdim <- dim(corr)[1]
    coldim <- dim(corr)[2]

    rowlabs <- dimnames(corr)[[1]]
    collabs <- dimnames(corr)[[2]]
    if (is.null(rowlabs)) rowlabs <- 1:rowdim
    if (is.null(collabs)) collabs <- 1:coldim
    rowlabs <- as.character(rowlabs)
    collabs <- as.character(collabs)

    col <- if (isTRUE(col)) {
        colorRampPalette(c("blue", "white", "red"))(11)[5*corr + 6]
    } else {
        rep(col, length.out = length(corr))
    }
    dim(col) <- dim(corr)

    if (!is.null(lower.panel)) {
        lower.panel <- match.arg(lower.panel, choices = c("ellipse", "number"))
    }
    if (!is.null(upper.panel)) {
        upper.panel <- match.arg(upper.panel, choices = c("ellipse", "number"))
    }
    if (!is.null(diag.panel)) {
        diag.panel <- match.arg(diag.panel, choices = c("ellipse", "number"))
    }
    
    cols <- 1:coldim
    rows <- 1:rowdim
    
    maxdim <- max(length(rows), length(cols))

    plt <- par('plt')
    xlabwidth <- max(strwidth(rowlabs[rows],units='figure',cex=cex.lab))/(plt[2]-plt[1])
    xlabwidth <- xlabwidth*maxdim/(1-xlabwidth)
    ylabwidth <- max(strwidth(collabs[cols],units='figure',cex=cex.lab))/(plt[4]-plt[3])
    ylabwidth <- ylabwidth*maxdim/(1-ylabwidth)

    plot(c(-xlabwidth-0.5, maxdim + 0.5), c(0.5, maxdim + 1 + ylabwidth), 
	 type = "n", bty = bty, axes = axes, xlab = "", ylab = "", asp = asp, 
	 cex.lab = cex.lab, ...)
    text(rep(0, length(rows)), length(rows):1, labels = rowlabs[rows], adj = 1, cex = cex.lab)
    text(cols, rep(length(rows) + 1, length(cols)), labels = collabs[cols], 
	 srt = 90, adj = 0, cex = cex.lab)
    mtext(xlab,1,0)
    mtext(ylab,2,0) 
    mat <- diag(c(1, 1))
    plotcorrInternal <- function()
    {
      panel <- if (i == j) diag.panel else if (i > j) lower.panel else upper.panel
      if (is.null(panel)) return()
      if (panel == "ellipse") {
        mat[1, 2] <- corr[i, j]
        mat[2, 1] <- mat[1, 2]
        ell <- ellipse::ellipse(mat, t = 0.43)
        ell[, 1] <- ell[, 1] + j
        ell[, 2] <- ell[, 2] + length(rows) + 1 - i
        polygon(ell, col = col[i, j])
        if (outline) lines(ell)
      } else {
        text(j + 0.3, length(rows) + 1 - i, round(10 * corr[i, j], 0),
             adj = 1, cex = cex)
      }
    }
    for (i in 1:dim(corr)[1]) {
      for (j in 1:dim(corr)[2]) {
          plotcorrInternal()
      }
    }
    invisible()
}