盒装geom_text与ggplot2

我正在开发与ggplot2的图形，其中我需要在其他图形元素上叠加文本。根据文本底层元素的颜色，可能难以阅读文本。有没有办法在半透明背景的边界框中绘制geom_text？盒装geom_text与ggplot2

我可以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重叠的位置。

来源

2011-10-05 isDotR

尝试此的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()

enter image description here

来源

2011-10-05 14:01:48 kohske

这真是太好了，正是我在找的东西！我要指出的一件事情是，它似乎不与hjust/vjust一起工作......但这是一个很小的挑剔与一个优秀的解决方案。 – isDotR

而不是添加一个边框的，我建议改变文字颜色为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)

enter image description here

来源

2011-10-05 12:30:17 Ramnath

这是一个潜在的解决方案的具体问题，我上面的说明，这是在黑色背景上的黑色文本，所以谢谢你。然而，我仍然对更一般的解决方案感兴趣，该解决方案允许绘制任何颜色的文本而非潜在的异构背景。 – isDotR

哦 - 更新非常有用;谢谢。 – isDotR

一种选择是添加对应于文本层的另一层。由于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)

enter image description here

来源

2011-10-05 12:34:24 Chase

这是一个相当不错的通用解决方案，尽管各个标签中字符数量差异很大时，该解决方案并非最佳选择。如果其中一个轴是离散的，它也不起作用（没有一些解决方法）。谢谢你的帮助！ – isDotR

更新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")

来源

2012-03-22 00:20:39 baptiste

谢谢baptiste！ – momeara

请注意，此版本不适合plotmath尺寸，并且不能控制矩形外观;这只是一个概念验证。 – baptiste

以下巴蒂斯特V0.9答案，这里是一个更新基本控制o f盒外观（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()

来源

2014-12-15 17:12:10 julou

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, ...) 
}

来源

2015-08-04 15:03:29 Alan

在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)

来源

2015-11-08 11:12:47

盒装geom_text与ggplot2

回答

相关问题