带有ggplot2的盒装geom_text答案

【问题标题】：Boxed geom_text with ggplot2带有ggplot2的盒装geom_text
【发布时间】：2011-12-01 10:22:42
【问题描述】：

我正在使用 ggplot2 开发一个图形，其中我需要将文本叠加在其他图形元素上。根据文本下方元素的颜色，可能难以阅读文本。有没有办法在具有半透明背景的边界框中绘制 geom_text？

我可以用 plotrix 做到这一点：

library(plotrix)
Labels <- c("Alabama", "Alaska", "Arizona", "Arkansas")
SampleFrame <- data.frame(X = 1:10, Y = 1:10)
TextFrame <- data.frame(X = 4:7, Y = 4:7, LAB = Labels)
### plotrix ###
plot(SampleFrame, pch = 20, cex = 20)
boxed.labels(TextFrame$X, TextFrame$Y, TextFrame$LAB,
 bg = "#ffffff99", border = FALSE,
 xpad = 3/2, ypad = 3/2)

但我不知道用 ggplot2 实现类似结果的方法：

### ggplot2 ###
library(ggplot2)
Plot <- ggplot(data = SampleFrame,
 aes(x = X, y = Y)) + geom_point(size = 20)
Plot <- Plot + geom_text(data = TextFrame,
 aes(x = X, y = Y, label = LAB))
print(Plot)

如您所见，黑色文本标签无法感知它们与背景中黑色 geom_points 重叠的位置。

【问题讨论】：

标签： r text ggplot2

【解决方案1】：

在development version of ggplot2 包中有一个名为geom_label() 的新geom，它直接实现了这一点。可以通过alpha=参数实现透明度。

ggplot(data = SampleFrame,
       aes(x = X, y = Y)) + geom_point(size = 20)+ 
        geom_label(data = TextFrame,
                         aes(x = X, y = Y, label = LAB),alpha=0.5)

【讨论】：

【解决方案2】：

ggplot2 1.0.1 更新

GeomText2 <- proto(ggplot2:::GeomText, {
  objname <- "text2"

  draw <- function(., data, scales, coordinates, ..., parse = FALSE, na.rm = FALSE
                    ,hjust = 0.5, vjust = 0.5
                    ,expand = c(1.1,1.2), bgcol = "black", bgfill = "white", bgalpha = 1) {
    data <- remove_missing(data, na.rm, c("x", "y", "label"), name = "geom_text")

    lab <- data$label
    if (parse) {
      lab <- parse(text = lab)
    }

    with(coord_transform(coordinates, data, scales),{
        sizes <- llply(1:nrow(data),
            function(i) with(data[i, ], {
                grobs <- textGrob(lab[i], default.units="native", rot=angle, gp=gpar(fontsize=size * .pt))
                list(w = grobWidth(grobs), h = grobHeight(grobs))
            })
        )
        w <- do.call(unit.c, lapply(sizes, "[[", "w"))
        h <- do.call(unit.c, lapply(sizes, "[[", "h"))
        gList(rectGrob(x, y,
                     width = w * expand[1], 
                     height = h * expand[length(expand)],
                     just = c(hjust,vjust),
                     gp = gpar(col = alpha(bgcol, bgalpha), fill = alpha(bgfill, bgalpha))),
            .super$draw(., data, scales, coordinates, ..., parse))
    })
  }
})

geom_text2 <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",parse = FALSE, ...) {
  GeomText2$new(mapping = mapping, data = data, stat = stat, position = position, parse = parse, ...)
}

【讨论】：

【解决方案3】：

根据 baptiste v0.9 的回答，这里有一个对盒子外观（bgfill、bgalpha、bgcol、expand_w、expand_h）的基本控制的更新：

btextGrob <- function (label,x = unit(0.5, "npc"), y = unit(0.5, "npc"), 
                       just = "centre", hjust = NULL, vjust = NULL, rot = 0, check.overlap = FALSE, 
                       default.units = "npc", name = NULL, gp = gpar(), vp = NULL, expand_w, expand_h, box_gp = gpar()) {
  if (!is.unit(x)) 
    x <- unit(x, default.units)
  if (!is.unit(y)) 
    y <- unit(y, default.units)
  grob(label = label, x = x, y = y, just = just, hjust = hjust, 
       vjust = vjust, rot = rot, check.overlap = check.overlap, 
       name = name, gp = gp, vp = vp, cl = "text")
  tg <- textGrob(label = label, x = x, y = y, just = just, hjust = hjust, 
                 vjust = vjust, rot = rot, check.overlap = check.overlap)
  w <- unit(rep(1, length(label)), "strwidth", as.list(label))
  h <- unit(rep(1, length(label)), "strheight", as.list(label))
  rg <- rectGrob(x=x, y=y, width=expand_w*w, height=expand_h*h,
                 gp=box_gp)

  gTree(children=gList(rg, tg), vp=vp, gp=gp, name=name)
}

GeomTextbox <- proto(ggplot2:::GeomText, {
  objname <- "textbox"

  draw <- function(., data, scales, coordinates, ..., parse = FALSE, na.rm = FALSE,
                   expand_w = 1.2, expand_h = 2, bgcol = "grey50", bgfill = "white", bgalpha = 1) {
    data <- remove_missing(data, na.rm, 
                           c("x", "y", "label"), name = "geom_textbox")
    lab <- data$label
    if (parse) {
      lab <- parse(text = lab)
    }

    with(coord_transform(coordinates, data, scales),
         btextGrob(lab, x, y, default.units="native", 
                   hjust=hjust, vjust=vjust, rot=angle, 
                   gp = gpar(col = alpha(colour, alpha), fontsize = size * .pt,
                             fontfamily = family, fontface = fontface, lineheight = lineheight),
                   box_gp = gpar(fill = bgfill, alpha = bgalpha, col = bgcol),
                   expand_w = expand_w, expand_h = expand_h)
    )
  }

})

geom_textbox <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", 
                        parse = FALSE,  ...) { 
  GeomTextbox$new(mapping = mapping, data = data, stat = stat,position = position, 
                parse = parse, ...)
}


qplot(wt, mpg, data = mtcars, label = rownames(mtcars), size = wt) +
  theme_bw() +
  geom_textbox()

【讨论】：

【解决方案4】：

ggplot2 v0.9 更新

library(ggplot2)
library(proto)

btextGrob <- function (label,x = unit(0.5, "npc"), y = unit(0.5, "npc"), 
    just = "centre", hjust = NULL, vjust = NULL, rot = 0, check.overlap = FALSE, 
    default.units = "npc", name = NULL, gp = gpar(), vp = NULL,  f=1.5) {
    if (!is.unit(x)) 
      x <- unit(x, default.units)
    if (!is.unit(y)) 
      y <- unit(y, default.units)
    grob(label = label, x = x, y = y, just = just, hjust = hjust, 
         vjust = vjust, rot = rot, check.overlap = check.overlap, 
         name = name, gp = gp, vp = vp, cl = "text")
    tg <- textGrob(label = label, x = x, y = y, just = just, hjust = hjust, 
                   vjust = vjust, rot = rot, check.overlap = check.overlap)
    w <- unit(rep(1, length(label)), "strwidth", as.list(label))
    h <- unit(rep(1, length(label)), "strheight", as.list(label))
    rg <- rectGrob(x=x, y=y, width=f*w, height=f*h,
                   gp=gpar(fill="white", alpha=0.3,  col=NA))

    gTree(children=gList(rg, tg), vp=vp, gp=gp, name=name)
  }

GeomText2 <- proto(ggplot2:::GeomText, {
  objname <- "text2"

  draw <- function(., data, scales, coordinates, ..., parse = FALSE, na.rm = FALSE) {
    data <- remove_missing(data, na.rm, 
      c("x", "y", "label"), name = "geom_text2")

    lab <- data$label
    if (parse) {
      lab <- parse(text = lab)
    }

    with(coord_transform(coordinates, data, scales),
      btextGrob(lab, x, y, default.units="native", 
        hjust=hjust, vjust=vjust, rot=angle, 
        gp = gpar(col = alpha(colour, alpha), fontsize = size * .pt,
          fontfamily = family, fontface = fontface, lineheight = lineheight))
    )
  }

})

geom_text2 <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", 
parse = FALSE,  ...) { 
  GeomText2$new(mapping = mapping, data = data, stat = stat,position = position, 
  parse = parse, ...)
}


qplot(wt, mpg, data = mtcars, label = rownames(mtcars), size = wt) +
   geom_text2(colour = "red")

【讨论】：

请注意，此版本不适用于绘图大小，并且无法控制矩形外观；这只是一个概念验证。

【解决方案5】：

试试这个 geom，它是从 GeomText 稍微修改的。

GeomText2 <- proto(GeomText, {
  objname <- "text2"
  draw <- function(., data, scales, coordinates, ..., parse = FALSE,
                   expand = 1.2, bgcol = "grey50", bgfill = NA, bgalpha = 1) {
    lab <- data$label
    if (parse) {
      lab <- parse(text = lab)
    }

    with(coordinates$transform(data, scales), {
      tg <- do.call("mapply",
        c(function(...) {
            tg <- with(list(...), textGrob(lab, default.units="native", rot=angle, gp=gpar(fontsize=size * .pt)))
            list(w = grobWidth(tg), h = grobHeight(tg))
          }, data))
      gList(rectGrob(x, y,
                     width = do.call(unit.c, tg["w",]) * expand,
                     height = do.call(unit.c, tg["h",]) * expand,
                     gp = gpar(col = alpha(bgcol, bgalpha), fill = alpha(bgfill, bgalpha))),
            .super$draw(., data, scales, coordinates, ..., parse))
    })
  }
})

geom_text2 <- GeomText2$build_accessor()

Labels <- c("Alabama", "Alaska", "Arizona", "Arkansas")
SampleFrame <- data.frame(X = 1:10, Y = 1:10)
TextFrame <- data.frame(X = 4:7, Y = 4:7, LAB = Labels)

Plot <- ggplot(data = SampleFrame, aes(x = X, y = Y)) + geom_point(size = 20)
Plot <- Plot + geom_text2(data = TextFrame, aes(x = X, y = Y, label = LAB),
                          size = 5, expand = 1.5, bgcol = "green", bgfill = "skyblue", bgalpha = 0.8)
print(Plot)

错误修复和代码改进

GeomText2 <- proto(GeomText, {
  objname <- "text2"
  draw <- function(., data, scales, coordinates, ..., parse = FALSE,
                   expand = 1.2, bgcol = "grey50", bgfill = NA, bgalpha = 1) {
    lab <- data$label
    if (parse) {
      lab <- parse(text = lab)
    }
    with(coordinates$transform(data, scales), {
      sizes <- llply(1:nrow(data),
        function(i) with(data[i, ], {
          grobs <- textGrob(lab[i], default.units="native", rot=angle, gp=gpar(fontsize=size * .pt))
          list(w = grobWidth(grobs), h = grobHeight(grobs))
        }))

      gList(rectGrob(x, y,
                     width = do.call(unit.c, lapply(sizes, "[[", "w")) * expand,
                     height = do.call(unit.c, lapply(sizes, "[[", "h")) * expand,
                     gp = gpar(col = alpha(bgcol, bgalpha), fill = alpha(bgfill, bgalpha))),
            .super$draw(., data, scales, coordinates, ..., parse))
    })
  }
})

geom_text2 <- GeomText2$build_accessor()

【讨论】：

这很棒，正是我想要的！我要注意的一件事是，它似乎不适用于 hjust/vjust... 但这是一个具有出色解决方案的小问题。

【解决方案6】：

我建议不要添加边界框，而是将文本颜色更改为white，这可以通过这样做来完成

Plot <- Plot + 
  geom_text(data = TextFrame, aes(x = X, y = Y, label = LAB), colour = 'white')

另一种方法是将alpha 添加到geom_point 以使其更加透明

Plot <- Plot + geom_point(size = 20, alpha = 0.5)

编辑。这是一种推广 Chase 自动计算边界框的解决方案的方法。诀窍是将文本的width 和height 直接添加到文本数据框中。这是一个例子

Labels <- c("Alabama", "Alaska", "Arizona", "Arkansas", 
    "Pennsylvania + California")
TextFrame <- data.frame(X = 4:8, Y = 4:8, LAB = Labels)
TextFrame <- transform(TextFrame,
    w = strwidth(LAB, 'inches') + 0.25,
    h = strheight(LAB, 'inches') + 0.25
)

ggplot(data = SampleFrame,aes(x = X, y = Y)) + 
  geom_point(size = 20) +
  geom_rect(data = TextFrame, aes(xmin = X - w/2, xmax = X + w/2, 
    ymin = Y - h/2, ymax = Y + h/2), fill = "grey80") +
  geom_text(data = TextFrame,aes(x = X, y = Y, label = LAB), size = 4)

【讨论】：

这是我上面说明的特定问题的潜在解决方案，即黑色背景上的黑色文本，所以谢谢。但是，我仍然对更通用的解决方案感兴趣，该解决方案允许在潜在的异构背景上绘制任何颜色的文本。

【解决方案7】：

一个选项是添加对应于文本层的另一个层。由于 ggplot 按顺序添加图层，因此在对 geom_text 的调用下方放置一个 geom_rect，它会产生您所追求的错觉。诚然，这有点像试图找出合适的盒子尺寸的手动过程，但这是我目前能想到的最好的。

library(ggplot2)
ggplot(data = SampleFrame,aes(x = X, y = Y)) + 
  geom_point(size = 20) +
  geom_rect(data = TextFrame, aes(xmin = X -.4, xmax = X + .4, ymin = Y - .4, ymax = Y + .4), fill = "grey80") +
  geom_text(data = TextFrame,aes(x = X, y = Y, label = LAB), size = 4)

【讨论】：

这是一个非常好的通用解决方案，尽管当标签之间的字符数差异很大时不是最佳解决方案。如果您的轴之一是离散的，它也不起作用（没有一些解决方法）。感谢您的帮助！