#r #text #ggplot2
#r #текст #ggplot2
Вопрос:
Я разрабатываю графику с помощью 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 на заднем плане.
Ответ №1:
Попробуйте этот 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()
Комментарии:
1. Это здорово, и именно то, что я искал! Одна вещь, которую я хотел бы отметить, это то, что, похоже, она не работает с hjust / vjust… но это небольшая придирка с отличным решением.
Ответ №2:
В версии для разработки пакета ggplot2 есть новый geom, geom_label() который напрямую реализует это. Прозрачность может быть достигнута с 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)
Ответ №3:
Вместо добавления ограничивающей рамки я бы предложил изменить цвет текста white , который можно выполнить, выполнив
Plot <- Plot
geom_text(data = TextFrame, aes(x = X, y = Y, label = LAB), colour = 'white')
Другим подходом было бы добавить alpha to geom_point , чтобы сделать его более прозрачным
Plot <- Plot geom_point(size = 20, alpha = 0.5)
Редактировать. Вот способ обобщить решение Чейза для автоматического вычисления ограничивающей рамки. Хитрость заключается в добавлении 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)
Комментарии:
1. Это потенциальное решение конкретной проблемы, которую я проиллюстрировал выше, которая представляет собой черный текст на черном фоне, так что спасибо. Тем не менее, я все равно был бы заинтересован в более общем решении, которое позволяет отображать текст любого цвета на потенциально разнородном фоне.
Ответ №4:
Обновление для версии 0.9 ggplot2
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")
Комментарии:
1. обратите внимание, что эта версия плохо работает с размерами plotmath и не контролирует внешний вид прямоугольника; это просто проверка концепции.
Ответ №5:
Один из вариантов — добавить еще один слой, соответствующий текстовому слою. Поскольку ggplot добавляет слои последовательно, поместите a geom_rect под вызовом to geom_text , и это создаст иллюзию, которую вы ищете. По общему признанию, это немного ручной процесс, пытающийся определить подходящий размер для поля, но это лучшее, что я могу придумать на данный момент.
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)
Комментарии:
1. Это довольно хорошее общее решение, хотя и неоптимальное, когда количество символов сильно варьируется в разных метках. Это также не работает (без каких-либо обходных путей), если одна из ваших осей дискретна. Спасибо за вашу помощь!
Ответ №6:
следуя ответу baptiste версии 0.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()
Ответ №7:
Обновление для 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, ...)
}