R语言：改造corrgram包画复合型相关性热图

corrgram用来画相关性热图很不错，因为此包可以使上下半个三角用于显示不同的图和信息，从而让热图信息比较充实。

此函数内置了很多参数，比如可以通过lowe.pancel或者upper.panel的自带方法在上下半区显示：颜色热图，相关性系数，散点图，bar图等等。

corrgram(data,

        diag=panel.density,

        lower.panel=panel.fill, #相关系数显示颜色

        upper.panel=panel.cor,  #显示相关系数

        col.regions = colorRampPalette(c("navy","white","red")),

        main="相关系数图")


#对应参数可以参考文档
#https://cran.r-project.org/web/packages/corrgram/corrgram.pdf

#The off-diagonal panels are specified with panel.pts, panel.pie, 
#panel.shade, panel.fill,‘panel.bar, panel.ellipse, panel.conf. panel.cor.
#Diagonal panels are specified with panel.txt, panel.minmax, panel.density.

关于基础的函数教学不再赘述，其他教程也有很多，这里主要来讲讲如何改写内置函数，使一张相关性热图显示对应颜色，相关系数，显著性，散点图，拟合线，如下所示。

首先，我们此处输入的数据是普通格式的，corrgram可以输入普通普通格式，也可以输入已经计算好的相关系数矩阵形式，所以不要弄混。也只有普通格式的数据才能画出散点图，这里以corrgram函数中自带的三个数据集auto，baseball，vote中的auto汽车数据为例子，展示下普通格式数据。

如果仅仅使用自带参数，只能画出类似如下形式的图。

library(corrgram)

raw_data <- auto
raw_data <- na.omit(auto)

corrgram(raw_data[,-c(1,2)], 
         #diag=panel.density, 
         lower.panel=panel.cor, #panel.fill, 
         upper.panel=panel.pts,  #panel.pie,
         col.regions =colorRampPalette(rev(brewer.pal(11,"RdYlGn"))),
         main="相关系数图"
)

这可不行啊，我明明在别的文献里看过更复合型的图，看来只能自己动手改造了，源代码在此 corrgram source: R/corrgram.R 大家也可以参考自己的需要进行改写。

library(corrgram)

raw_data <- auto
raw_data <- na.omit(auto)


panel.newupper <- function (x, y, corr = NULL, col.regions, cor.method, digits=2, 
                            cex.cor, ...) {
  if(is.null(corr)) { 
  #这里是用于辨认数据是普通型还是相关性矩阵，注意我这里只能使用普通型数据
    if(sum(complete.cases(x,y)) < 2) {
      warning("Need at least 2 complete cases for cor()")
      return()
    } else {
      corr <- cor(x, y, use='pair', method=cor.method)
    }
  }
  
  ncol <- 14
  pal <- col.regions(ncol)
  col.ind <- as.numeric(cut(corr, breaks=seq(from=-1, to=1, length.out=ncol+1),
                            include.lowest=TRUE))
  
  
  plot.xy(xy.coords(x, y), type = "p", col = pal[col.ind], ...) #散点图
  abline(lm(y ~ x)) #拟合线
  box(col = "lightgray")
}

panel.newlower <- function(x, y, corr=NULL, col.regions, cor.method, digits=2, 
                           cex.cor, ...){
  
  # If corr not given, try to calculate it
  if(is.null(corr)) {
    if(sum(complete.cases(x,y)) < 2) {
      warning("Need at least 2 complete cases for cor()")
      return()
    } else {
      corr <- cor(x, y, use='pair', method=cor.method)
    }
  }
  
  ncol <- 14
  pal <- col.regions(ncol)
  col.ind <- as.numeric(cut(corr, breaks=seq(from=-1, to=1, length.out=ncol+1),
                            include.lowest=TRUE))
  usr <- par("usr")
  # Solid fill
  rect(usr[1], usr[3], usr[2], usr[4], col=pal[col.ind], border=NA)
  
  ####cor
  auto <- missing(cex.cor)
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(0, 1, 0, 1))
  # determine string width using absolute values so that
  # negative numbers are not wider than positive numbers
  abscorr <- formatC(abs(corr), digits=digits, format='f')
  corr <- formatC(corr, digits=digits, format='f')
  if(auto) cex.cor <- 0.7/strwidth(abscorr)
  text(0.5, 0.6, corr, cex=cex.cor, col="black")
  
  ####pval
  pval <- cor.test(x, y, alternative = "two.sided", method=cor.method)$p.value
  stars <- ifelse(pval < 0.001, "***", ifelse(pval < 0.01, "**", ifelse(pval < 0.05, "*", "")))
  text(x = 0.5, y = 0.3, labels = stars, cex = cex.cor, col = "black")
  
  # Boounding box needs to plot on top of the shading, so do it last.
  box(col='lightgray')
  
  #######https://rdrr.io/cran/corrgram/src/R/corrgram.R
}


corrgram(raw_data[,-c(1,2)], 
         #diag=panel.density, 
         lower.panel=panel.newlower, 
         upper.panel=panel.newupper,
         col.regions =colorRampPalette(rev(brewer.pal(11,"RdYlGn"))),
         main="相关系数图"
)

这样就可以得到一个漂亮的图图啦！！！

​