跟着 Nature 学作图 | 相关性热图（显示相关性散点图）

setwd(dir = 'F:/MZBJ/Corrplot')
df = read.csv('sample_data.csv', row.names = 1)
df = log(df+1)
library(corrgram)
pairs(df)

panel.fill<- function(x, y, digits = 2, prefix = "",col = "red", cex.cor, ...)
{
  par(usr = c(0, 1, 0, 1))#设置panel大小
  r <- abs(cor(x, y))#计算相关性，此处使用的绝对值
  txt <- format(r, digits = digits)[1]#相关性洗漱保留两位小数
  col <- colorRampPalette(c("grey",'grey','grey', 'red'))(100)#生成一组色阶用于相关性系数映射
  rect(0, 0, 1, 1, col = col[ceiling(r * 100)])#按相关性系数值从色阶中提取颜色
  text(0.5, 0.5, txt, cex = 1.5,col = '#77787b', font = 2 )#设置文本格式
}
pairs(df,
      lower.panel = panel.fill,
      gap = 0)

panel.point <- function(x, y, ...){       
  r <- abs(cor(x, y))
  col <- colorRampPalette(c("grey",'grey','grey', 'red'))(100)  
  rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], #将panel范围填充为对应颜色
       col = col[ceiling(r * 100)],lwd = 2)
  plot.xy(xy.coords(x, y), type = "p", #绘制散点图
          pch = 20, 
          cex = .2,
          ...)
}
pairs(df,
      upper.panel = panel.point,
      lower.panel = panel.fill,
      gap = 0)

text.panel <- function(x, y, txt, cex, ...)
{ text(x, y, txt, cex = cex, font = 2)
  box(lwd = 1)
}
pairs(df,
      upper.panel = panel.point,
      lower.panel = panel.fill,
      text.panel = text.panel,
      gap = 0)

library(GGally)
library(ggplot2)
ggpairs(df,1:4)

GGup <- function(data, mapping, ..., 
                 method = "pearson") {
  x <- GGally::eval_data_col(data, mapping$x)#提取x,y值
  y <- GGally::eval_data_col(data, mapping$y)
  cor <- cor(x, y, method = method, use="pairwise.complete.obs")#计算相关系数
  df <- data.frame(x = x, y = y)
  df <- na.omit(df)
  col <- colorRampPalette(c("grey",'grey','grey', 'red'))(100) #生成色阶以便后面映射提取
  cor_col = col[ceiling(cor * 100)]#按照相关系数来提取色阶中的颜色
  pp <- ggplot(df) +
    geom_text(data = data.frame(
      xlabel = min(x,na.rm = T),
      ylabel = min(y,na.rm = T), 
      labs = round(cor,2)),
      aes(x = xlabel, y = ylabel, label = labs),
      size = 10,
      fontface = "bold",
      inherit.aes = FALSE
    )+
    theme_bw()+
    theme(panel.background = element_rect(fill =  cor_col))
  return(pp)
}
ggpairs(df, 1:4, upper = list(continuous = wrap(GGup)))

GGdown <- function(data, mapping, ..., 
                   method = "pearson") {
  x <- GGally::eval_data_col(data, mapping$x)
  y <- GGally::eval_data_col(data, mapping$y)
  col <- colorRampPalette(c("grey",'grey','grey', 'red'))(100)  
  cor <- cor(x, y, method = method, use="pairwise.complete.obs")
  cor_col = col[ceiling(cor * 100)]
  df <- data.frame(x = x, y = y)
  df <- na.omit(df)
  pp <- ggplot(df, aes(x=x, y=y)) +
    ggplot2::geom_point( show.legend = FALSE, size = 1) +
    theme_bw()+
    theme(panel.background = element_rect(fill =  cor_col))
  return(pp)
}
ggpairs(df, 1:4,
        upper = list(continuous = wrap(GGup)),
        lower = list(continuous = wrap(GGdown)))

GGdiag = function(data, mapping, ...){
  name= deparse(substitute(mapping))#提取出映射变量名（并非变量名本身，可用性尝试一下不进行下一步）
  name = str_extract(name, "x = ~(.*?)\\)", 1)#对变量名进行处理提取出变量名
  ggplot(data = data) +
    geom_text(aes(x = 0.5, y = 0.5, label = name), size = 5)+
    theme_bw()+
    theme(panel.background = element_blank())#将变量名绘制于图中央
}
ggpairs(df, 1:4,
        upper = list(continuous = wrap(GGup)),
        lower = list(continuous = wrap(GGdown)),
        diag = list(continuous = wrap(GGdiag)))

ggpairs(df,
        upper = list(continuous = wrap(GGup)),
        lower = list(continuous = wrap(GGdown)),
        diag = list(continuous = wrap(GGdiag)))+
  theme(panel.grid = element_blank(),
        axis.text =  element_blank(),
        strip.background = element_blank(),
        strip.text = element_blank())