r - 在格子图中使用额外/而不是背景颜色的模式

Question

我正在使用 R lattice 包中的水平图。我生成的图如下所示。

我现在的问题是我需要生成一个黑白版本来打印。

有没有办法将颜色更改为灰度并为矩形提供背景图案，以便将红色与蓝色区分开来？例如，我会想到点或对角线。

谢谢！

Answer 1

点会更容易添加，只需panel.points在顶部添加即可。向图例添加点可能会有点困难。以下函数在网格图形中执行此操作。

grid.colorbar(runif(10, -2, 5))

require(RColorBrewer)
require(scales)

diverging_palette <- function(d = NULL, centered = FALSE, midpoint = 0,
                              colors = RColorBrewer::brewer.pal(7,"PRGn")){

  half <- length(colors)/2

  if(!length(colors)%%2)
    stop("requires odd number of colors")
  if( !centered && !(midpoint <=  max(d) && midpoint >= min(d)))
    warning("Midpoint is outside the data range!")

  values <-  if(!centered) {
    low <- seq(min(d), midpoint, length=half)
    high <- seq(midpoint, max(d), length=half)
    c(low[-length(low)], midpoint, high[-1])
  } else {
    mabs <- max(abs(d - midpoint))
    seq(midpoint-mabs, midpoint + mabs, length=length(colors))
  }

  scales::gradient_n_pal(colors, values = values)

}

colorbarGrob <- function(d, x = unit(0.5, "npc"), 
                         y = unit(0.1,"npc"),
                         height=unit(0.8,"npc"),
                         width=unit(0.5, "cm"), size=0.7,
                         margin=unit(1,"mm"), tick.length=0.2*width,
                         pretty.breaks = grid.pretty(range(d)),
                         digits = 2, show.extrema=TRUE,
                         palette = diverging_palette(d), n = 1e2,
                         point.negative=TRUE,   gap =5,
                         interpolate=TRUE,
                         ...){

  ## includes extreme limits of the data
  legend.vals <- unique(round(sort(c(pretty.breaks, min(d), max(d))), digits)) 

  legend.labs <- if(show.extrema)
    legend.vals else unique(round(sort(pretty.breaks), digits)) 

  ## interpolate the colors
  colors <- palette(seq(min(d), max(d), length=n))
  ## 1D strip of colors, from bottom <-> min(d) to top <-> max(d)
  lg <- rasterGrob(rev(colors), # rasterGrob draws from top to bottom
                   y=y, interpolate=interpolate,
                   x=x, just=c("left", "bottom"),
                   width=width, height=height)


  ## box around color strip
  bg <- rectGrob(x=x, y=y, just=c("left", "bottom"),
                 width=width, height=height, gp=gpar(fill="transparent"))

  ## positions of the tick marks
  pos.y <- y + height * rescale(legend.vals)
  if(!show.extrema) pos.y <-  pos.y[-c(1, length(pos.y))]

  ## tick labels
  ltg <- textGrob(legend.labs, x = x + width + margin, y=pos.y,
                          just=c("left", "center"))
  ## right tick marks
  rticks <- segmentsGrob(y0=pos.y, y1=pos.y,
                         x0 = x + width,
                         x1 = x + width - tick.length,
                         gp=gpar())
  ## left tick marks
 lticks <- segmentsGrob(y0=pos.y, y1=pos.y,
                        x0 = x ,
                        x1 = x + tick.length,
                        gp=gpar())

  ## position of the dots
  if(any( d < 0 )){
  yneg <- diff(range(c(0, d[d<0])))/diff(range(d))  * height
  clipvp <- viewport(clip=TRUE, x=x, y=y, width=width, height=yneg,
                     just=c("left", "bottom"))
  h <- convertUnit(yneg, "mm", "y", valueOnly=TRUE)

  pos <- seq(0, to=h, by=gap)
  }
  ## coloured dots
  cg <- if(!point.negative || !any( d < 0 )) nullGrob() else
  pointsGrob(x=unit(rep(0.5, length(pos)), "npc"), y = y + unit(pos, "mm") ,
          pch=21, gp=gpar(col="white", fill="black"),size=unit(size*gap, "mm"), vp=clipvp)
  ## for more general pattern use the following
  ## gridExtra::patternGrob(x=unit(0.5, "npc"), y = unit(0.5, "npc") , height=unit(h,"mm"), 
  ##   pattern=1,granularity=unit(2,"mm"), gp=gpar(col="black"), vp=clipvp)

  gTree(children=gList(lg,  lticks, rticks, ltg, bg, cg),
        width = width + margin + max(stringWidth(legend.vals)), ... , cl="colorbar")
}

grid.colorbar <- function(...){
  g <- colorbarGrob(...)
  grid.draw(g)
  invisible(g)
}

widthDetails.colorbar <- function(x){
 x$width 
}

编辑：对于图案填充，您可以替换pointsGrob为gridExtra::patternGrob（您也可以为矩阵的图块执行此操作）。

Answer 2

IMO 使用两种以上的图案（例如，具有不同密度的 45° 和 135° 定向线）会令人困惑。（尽管我不知道我们如何使用 lattice 来做到这一点。）您可以通过使用灰度来实现可读模式，请col.regions参阅levelplot().

library(RColorBrewer)
cols <- colorRampPalette(brewer.pal(8, "RdBu"))
p <- levelplot(Harman23.cor$cov, scales=list(x=list(rot=45)), 
               xlab="", ylab="", col.regions=cols)
# versus all greys
p <- levelplot(Harman23.cor$cov, scales=list(x=list(rot=45)), 
               xlab="", ylab="", col.regions=gray.colors)
p <- levelplot(Harman23.cor$cov, scales=list(x=list(rot=45)), 
               xlab="", ylab="", col.regions=gray.colors(6), cuts=6)

Answer 3

我找到了一种手动绘制到 levelplot 面板并在值大于 0.5 的所有单元格上绘制对角线填充图案的方法

但是，我无法在颜色键图例中绘制相同的图案。经过几个小时的阅读论坛并试图理解 lattice 源代码，我无法获得任何线索。也许其他人可以解决这个问题。这是我得到的：

library(lattice)
library(RColorBrewer)
cols <- colorRampPalette(brewer.pal(8, "RdBu"))

data <- Harman23.cor$cov    

fx <- fy <- c()
for (r in seq(nrow(data)))
  for (c in seq(ncol(data)))
  {
    if (data[r, c] > 0.5)
    {
      fx <- c(fx, r);
      fy <- c(fy, c);
    }
  }

diag_pattern <- function(...)
{
  panel.levelplot(...)
  for (i in seq(length(fx)))
  {
    panel.linejoin(x = c(fx[i],fx[i]+.5), y= c(fy[i]+.5,fy[i]), col="black")
    panel.linejoin(x = c(fx[i]-.5,fx[i]+.5), y= c(fy[i]+.5,fy[i]-.5), col="black")
    panel.linejoin(x = c(fx[i]-.5,fx[i]), y= c(fy[i],fy[i]-.5), col="black")   
  }
}      

p <- levelplot(data, scales=list(x=list(rot=45)), 
               xlab="", ylab="", col.regions=cols, panel=diag_pattern)
print(p)