Customized corrgram function

corrgram_plot.R

# Pairs points panel ------------------------------------------------------

panel_points <- function(x, y, corr = NULL, fit.line = F, ...) {
  if(!is.null(corr)) {
    return()
  }
  plot.xy(xy.coords(x, y), type = "p", ...)
  box(col = "lightgray")
  
  if(fit.line) {
    abline(lm(y ~ x), col = "red", lwd = 1.2)
  }
  
}


# Pairs histogram diag panel ----------------------------------------------

panel_hist <- function (x, corr = NULL, breaks, binwidth, ...) {
  
  if (!is.null(corr)) {
    return()
  }
  
#   if(missing(binwidth)) {
#     binwidth <- diff(range(x, na.rm = TRUE)) * (1/10)
#   }
  
#   x.hist <- ggplot2:::bin(x, binwidth = binwidth)
#   x.hist$xmin <- x.hist$x - x.hist$width[1]
#   x.hist$xmax <- x.hist$x + x.hist$width[1]
  
  hist.out <- hist(x, plot = F)
  x.hist <- data.frame(count = hist.out$counts, 
    x = head(hist.out$breaks, -1),
    xmax = tail(hist.out$breaks, -1))
  
  yr <- range(x.hist$count, na.rm = TRUE)
  
  par(usr = c(par("usr")[1:2], min(yr), max(yr) * 1.1))
  
  plot.xy(xy.coords(x.hist$x, x.hist$count), type = "n", ...)
  rect(xleft = x.hist$x, ybottom = 0, xright = x.hist$xmax, ytop = x.hist$count,
    col = "grey75", border = "white")

  box(col = "lightgray")
}


# Combines panel.conf and panel.shade -------------------------------------

shaded_conf <- function (x, y, corr = NULL, digits = 2, cex.cor, ...) {
  auto <- missing(cex.cor)
  old.usr <- par("usr")
  on.exit(par(old.usr))
  par(usr = c(0, 1, 0, 1))
  usr <- par("usr")
  
  # Establish color palette
  ncol <- 14
  pal <- col.corrgram(ncol)
  
  # Maximize text contrast
  txt_col <- function(r) {
    ifelse(abs(r) > 0.3, "white", "black")
  }
  
  
  if (!is.null(corr)) {
    est <- corr
    est <- formatC(est, digits = digits, format = "f")
    
    if (auto) {
      cex.cor <- 0.7/strwidth(est)
    }
    
    col.ind <- as.numeric(cut(corr, 
      breaks = seq(from = -1, to = 1, length = ncol + 1), 
      include.lowest = TRUE))
    
    rect(usr[1], usr[3], usr[2], usr[4], col = pal[col.ind], border = NA)
    
    text(0.5, 0.6, est, cex = cex.cor, col = txt_col(corr))
  } else {
    results <- cor.test(x, y, alternative = "two.sided")
    est <- results$estimate
    est <- formatC(est, digits = digits, format = "f")
    
    if (auto) {
      cex.cor <- 0.7/strwidth(est)
    }
    
    col.ind <- as.numeric(cut(results$estimate, 
                              breaks = seq(from = -1, to = 1, length = ncol + 1), 
                              include.lowest = TRUE))
    
    rect(usr[1], usr[3], usr[2], usr[4], col = pal[col.ind], border = NA)
    
    text(0.5, 0.6, est, cex = cex.cor, col = txt_col(results$estimate))
    
    ci <- results$conf.int
    ci <- formatC(ci, digits = 2, format = "f")
    ci <- paste("(", ci[1], ",", ci[2], ")", sep = "")
    
    if (auto) {
      cex.cor <- 0.8/strwidth(ci)
    }
    
    text(0.5, 0.3, ci, cex = cex.cor, col = txt_col(results$estimate))
  }
  
  box(col = "lightgrey")
}

# Customized corrgram plot ------------------------------------------------

corrgram_plot <- function(df, pt.col = rgb(0, 0, 0, .4), pt.cex = 1, ...) {
  corrgram(df, order = TRUE,
    upper.panel = shaded_conf,
    lower.panel = function(...) 
      panel_points(..., fit.line = T, pch = 16, col = pt.col, cex = pt.cex),
    diag.panel = panel_hist, ...)
}