grid 进阶: 构建自己的 grob 对象

1引言

当你熟练使用 grid 的基础函数绘制一些简单的图形以后,也许你可能需要创建一些稍微高级一些的复杂图形方便像 grid.(rect/point) 类似的来调用。最简单的方式就是将这些 grid.rect/rectGrob 等函数打包成一个函数来使用就好。目前我就是这样干的,确实直接方便快捷,但是如果你想让别人使用你的函数,并且能够像 grid 那样的操作来修改你函数的输出时,更严谨的来说,你需要构建一个 grob 对象,并且拥有一些相关的属性。后面我们可以使用 grid.edit 等函数对其中的元素进行修改。我们看看如何自己重新构建一个 grob 对象。

参考链接:

Writing grid Extensions

• https://www.stat.auckland.ac.nz/~paul/Reports/CustomGrobs/custom-grob.html)

2简单函数包装

我们使用 grid.roundrect, grid.text 两个函数,打包起来绘制一个带有边框的文字:

library(grid)

textbox <- function(label) {
  grid.roundrect(width=1.5*stringWidth(label),
                 height=1.5*stringHeight(label),
                 name="box")
  grid.text(label, name="text")
}

grid.newpage()
textbox("test")

该图形含有两个 grobs,但是这两个 grobs 并没有任何联系:

grid.ls(fullNames=TRUE)
# roundrect[box]
# text[text]

比如我们修改标签,可以看到文字超出了边框的范围:

grid.edit("text", label="hello world")

这时候我们可以构建一个 gTree 来包含它们:

textbox <- function(label) {
  rr <- roundrectGrob(
    width=1.5*stringWidth(label),
    height=1.5*stringHeight(label),
    name="box")
  tg <- textGrob(label, name="text")
  grid.draw(gTree(children=gList(rr,tg),
                  name="tb"))
}

grid.newpage()
textbox("test")

这时候我们查看元素组成时,可以看到有一个 gTree 包含了两个 grob:

grid.ls(fullNames=TRUE)
# gTree[tb]
#   roundrect[box]
#   text[text]

但是当我们修改文字时,边框依然不变:

grid.edit("tb::text", label="hello world")

3drawDetails 方法

我们可以延迟画图的行为,在图形生成之前就计算好边框的大小,我们首先构建一个 grob 对象:

textbox <- function(label,
                    name=NULL, gp=NULL, vp=NULL) {
  grid.draw(grob(label=label,
                 name=name, gp=gp, vp=vp,
                 cl="textbox"))
}

然后我们为 textbox 这个 grob 类定义 drawDetails 方法,来说明如果绘制图形:

drawDetails.textbox <- function(x, ...) {
  grid.roundrect(
    width=1.5*stringWidth(x$label),
    height=1.5*stringHeight(x$label),
    name="box")
  grid.text(x$label, name="text")
}

画图:grid.newpage()
textbox("test", name="tb")

现在只含有一个 textbox, 其中包含的 grob 不再可见:grid.ls(fullNames=TRUE)
# textbox[tb]

这时候修改标签,边框也变大了:grid.edit("tb", label="hello world")

修改元素:grid.edit("tb", gp=gpar(col="grey"))

你可以看到,标签和文本的颜色都改变了。

4makeContent 方法

makeContent 是另外一种开发自定义 grob 的办法,与 drawDetails 不同的是, 它是调用 grid 的函数来生成 grob,而不是直接画出来,下面我们举例说明:

构建 grob 还是一样的代码:

textbox <- function(label,
                    name=NULL, gp=NULL, vp=NULL) {
  grid.draw(gTree(label=label,
                  name=name, gp=gp, vp=vp,
                  cl="textboxtree"))
}

添加 makeContent 方法:

makeContent.textboxtree  <- function(x) {
  t <- textGrob(x$label,
                name="text")
  rr <- roundrectGrob(width=1.5*grobWidth(t),
                      height=1.5*grobHeight(t),
                      name="box")

  setChildren(x, gList(rr,t))
}

grid.newpage()
textbox("test", name="tbt")

查看元素组成:

grid.ls(fullNames=TRUE)
# textboxtree[tbt]

修改标签:

grid.edit("tbt", label="hello world")

grid.force 可以展示所有包含的 grobs:

grid.force()
grid.ls(fullNames=TRUE)
# forcedgrob[tbt]
#   forcedgrob[box]
#   text[text]

5makeContext 方法

makeContext 可以在绘图时产生一个或多个视图 viewport,grid 会自动负责 push 视图并之后进行清理。

textbox <- function(label,
                    name=NULL, gp=NULL, vp=NULL) {
  grid.draw(gTree(label=label,
                  name=name, gp=gp, vp=vp,
                  cl="textboxtree"))
}


makeContext.textboxtree <- function(x) {
  tbvp <-
    viewport(width=1.5*stringWidth(x$label),
             height=1.5*stringHeight(x$label))

  if (is.null(x$vp))
    x$vp <- tbvp
  else
    x$vp <- vpStack(x$vp, tbvp)
  x
}

makeContent.textboxtree <- function(x) {
  t <- textGrob(x$label, name="text")
  rr <- roundrectGrob(name="box")
  setChildren(x, gList(rr,t))
}

这里我们使用 makeContext 方法来给图形添加一个 viewport 视图,大小和边框一样大。所以我们后面makeContent 方法绘制矩形边框时就不需要再指定大小了。

grid.newpage()
textbox("test", name="tbt")

6实战

前面为了弥补 grid 默认 grid.xaxis/grid.yaxis 的不足,我自己重新写了这两个函数 听说你要手搓一个 grid.xaxis2/grid.yaxis2? ,所用的方法也就是简单函数包装一下, 这次我们使用学到的知识,对其重新构建一个 grob 对象,我们举例拿 grid.xaxis2 举例。

原函数:

grid.xaxis2 <- function(at = NULL,
                        breaks = 5,
                        labels = NULL,
                        tick.len = 0.5,
                        label.space = 0.5,
                        side = c("bottom","top"),
                        rot = 0,
                        label.size = 12){
  # labels and ticks
  if(is.null(at) || is.null(labels)){
    at <- grid.pretty(current.viewport()$xscale,n = 5)
    labels <- as.character(at)
  }else{
    at <- at
    labels <- as.character(labels)
  }

  # axis position
  side <- match.arg(side,c("bottom","top"))
  if(side == "bottom"){
    tck.y0 = unit(0, "npc")
    tck.y1 = unit(-tick.len, "lines")
    text.y = unit(-tick.len - label.space,"lines")
  }else{
    tck.y0 = unit(1, "npc")
    tck.y1 = unit(1, "npc") + unit(tick.len, "lines")
    text.y = unit(abs(tick.len) + abs(label.space),"lines") + unit(1, "npc")
  }

  grid.segments(x0 = 0,x1 = 1,y0 = 0,y1 = 0)
  grid.segments(x0 = unit(at, "native"),
                x1 = unit(at, "native"),
                y0 = tck.y0,
                y1 = tck.y1)

  grid.text(label = labels,
            x = unit(at, "native"),
            y = text.y,
            rot = rot,
            gp = gpar(fontsize = label.size))
}

构建 grob 对象

grid.xaxis2 <- function(at = NULL,
                        breaks = 5,
                        labels = NULL,
                        tick.len = 0.5,
                        label.space = 0.5,
                        side = c("bottom","top"),
                        rot = 0,
                        ticks.gp = NULL,
                        text.gp = NULL,
                        hjust = NULL,
                        vjust = NULL,
                        name = NULL, gp = NULL, vp = NULL) {
  gTree(at = NULL,
        breaks = 5,
        labels = NULL,
        tick.len = 0.5,
        label.space = 0.5,
        side = c("bottom","top"),
        rot = 0,
        ticks.gp = NULL,
        text.gp = NULL,
        hjust = NULL,
        vjust = NULL,
        name = name, gp = gp, vp = vp,
        cl = "xaxis2")
}

添加 makeContent.xaxis2 方法

具体如何绘制坐标轴:

makeContent.xaxis2 <- function(x) {
  # labels and ticks
  if(is.null(x$at) || is.null(x$labels)){
    if(is.null(x$vp)){
      at <- grid.pretty(current.viewport()$xscale,n = x$breaks)
    }else{
      at <- grid.pretty(x$vp$xscale,n = x$breaks)
    }
    labels <- as.character(at)
  }else{
    at <- x$at
    labels <- as.character(x$labels)
  }

  # axis position
  side <- match.arg(x$side,c("bottom","top"))
  if(side == "bottom"){
    tck.y0 = unit(0, "npc")
    tck.y1 = unit(-x$tick.len, "lines")
    text.y = unit(-x$tick.len - x$label.space,"lines")
  }else{
    tck.y0 = unit(1, "npc")
    tck.y1 = unit(1, "npc") + unit(x$tick.len, "lines")
    text.y = unit(abs(x$tick.len) + abs(x$label.space),"lines") + unit(1, "npc")
  }

  seg.main <- segmentsGrob(x0 = 0,x1 = 1,y0 = 0,y1 = 0,name = "main")

  ticks <- segmentsGrob(x0 = unit(at, "native"),x1 = unit(at, "native"),
                        y0 = tck.y0,y1 = tck.y1,
                        gp = x$ticks.gp,name = "ticks")

  text <- textGrob(label = labels,
                   x = unit(at, "native"),y = text.y,
                   rot = x$rot,
                   hjust = x$hjust,vjust = x$vjust,
                   gp = x$text.gp,name = "labels")

  setChildren(x, gList(seg.main,ticks,text))
}

测试

既然已经构建好了,我们下面来测试工作效果如何:

grid.newpage()
pushViewport(viewport(width = 0.5,height = 0.5,xscale = c(0,10)))
grid.rect()
grid.draw(grid.xaxis2())

grid.newpage()
grid.draw(grid.xaxis2(vp = viewport(xscale = c(0,10),width = 0.5,height = 0.5)))

查看组成:

grid.ls()
# GRID.xaxis2.8850
grid.force()
grid.ls()
# GRID.xaxis2.8823
#   main
#   ticks
#   labels

编辑元素:

grid.edit("main", gp = gpar(lwd = 5,col = "red"))
grid.edit("ticks", gp = gpar(col = "blue"))
grid.edit("labels", gp = gpar(fontface = "bold.italic",rot = 45))

7结尾

路漫漫其修远兮,吾将上下而求索。

欢迎加入生信交流群。加我微信我也拉你进 微信群聊 老俊俊生信交流群 (微信交流群需收取 20 元入群费用,一旦交费,拒不退还!(防止骗子和便于管理)) 。QQ 群可免费加入, 记得进群按格式修改备注哦。