在成对函数调用中设置面板的背景颜色

Question

问题看起来很简单，但我不知道如何管理R中的基本图形设备。

我有一个下面给出的代码，我想根据相关系数的值设置非对角线单元格的背景颜色。

panel.cor <- function(x, y, digits = 2, cex.cor, ...)
{
  usr <- par("usr"); 
  on.exit(par(usr))
  par(usr = c(0, 1, 0, 1))

  r <- cor(x, y)
  txt <- format(c(r, 0.123456789), digits = digits)[1]
  txt <- paste("r = ", txt, sep = "")

  # try to set background here, but it doesn't affect the output
  if (r > 0.5) 
    par(bg = "red")

  text(0.5, 0.6, txt)

  p <- cor.test(x, y)$p.value
  txt2 <- format(c(p, 0.123456789), digits = digits)[1]
  txt2 <- paste("p = ", txt2, sep = "")
  if (p < 0.01) txt2 <- "p < 0.01"
  text(0.5, 0.4, txt2)
}

pairs(iris[, 1:4], upper.panel = panel.cor)

问题是如何在上面板和底面板上正确设置背景，但最少在上面板上。颜色可以是红色到蓝色，或者它们可以是离散的：r为红色。 -0.8，蓝色表示r> 0.8。

Answer 1

要在pairs图中设置背景色，请使用下面的更新代码：

# install.packages("RColorBrewer") 
# Needed to get color gradient
library(RColorBrewer)


cols = brewer.pal(11, "RdBu")   # goes from red to white to blue
pal = colorRampPalette(cols)
cor_colors = data.frame(correlation = seq(-1,1,0.01), 
correlation_color = pal(201)[1:201])  # assigns a color for each r correlation value
cor_colors$correlation_color = as.character(cor_colors$correlation_color)

panel.cor <- function(x, y, digits=2, cex.cor)
{
par(usr = c(0, 1, 0, 1))
u <- par('usr') 
names(u) <- c("xleft", "xright", "ybottom", "ytop")
r <- cor(x, y,method="spearman",use="complete.obs")
test <- cor.test(x,y)
bgcolor = cor_colors[2+(-r+1)*100,2]    # converts correlation into a specific color
do.call(rect, c(col = bgcolor, as.list(u))) # colors the correlation box

if (test$p.value> 0.05){
text(0.5,0.5,"Insignificant",cex=1.5)
} else{
text(0.5, 0.75, paste("r=",round(r,2)),cex=2.5) # prints correlatoin coefficient
text(.5, .25, paste("p=",formatC(test$p.value, format = "e", digits = 1)),cex=2)  
abline(h = 0.5, lty = 2) # draws a line between correlatoin coefficient and p value
}

}

panel.smooth<-function (x, y, col = "black", bg = NA, pch = 19, cex = 1.2, 
col.smooth = "blue", span = 2/3, iter = 3, ...) {
points(x, y, pch = pch, col = col, bg = bg, cex = cex)
ok <- is.finite(x) & is.finite(y)
if (any(ok)) 
lines(stats::lowess(x[ok], y[ok], f = span, iter = iter), lwd=2.5, col = col.smooth, ...)
}
panel.hist <- function(x, ...)
{
 usr <- par("usr"); on.exit(par(usr))
par(usr = c(usr[1:2], 0, 1.5) )
h <- hist(x, plot = FALSE)
breaks <- h$breaks; nB <- length(breaks)
y <- h$counts; y <- y/max(y)
rect(breaks[-nB], 0, breaks[-1], y, col="cyan", ...)
}
pairs(iris[1:4],lower.panel=panel.smooth, upper.panel=panel.cor,diag.panel=panel.hist,cex.labels=2)

图片：