[英]How to place grobs with annotation_custom() at precise areas of the plot region?
我试图用ggplot2重现以下[base R]图
我已经完成了大部分工作,但目前困扰我的是线段的位置,这些线段以相应的标签连接到位于图右侧的边缘地毯图。 标签是通过anotation_custom()
绘制的(在下面的第二张图中),我使用了anotation_custom()
的技巧,即关闭裁剪以允许在绘图边距中绘制。
尽管进行了许多尝试,但我仍无法将segmentGrobs()
放置在设备中的所需位置,以使它们加入正确的地毯滴答声和标签。
一个可重现的例子是
y <- data.frame(matrix(runif(30*10), ncol = 10))
names(y) <- paste0("spp", 1:10)
treat <- gl(3, 10)
time <- factor(rep(1:10, 3))
require(vegan); require(grid); require(reshape2); require(ggplot2)
mod <- prc(y, treat, time)
如果您没有安装素食主义者 ,则在Question的末尾附加要强化对象的dput
和要使用ggplot()
进行方便绘图的fortify()
方法(如果您希望运行示例和fortify()
ggplot()
。 我还包括一个有点冗长的函数myPlt()
,它说明了我到目前为止的工作,如果您已加载软件包并可以创建mod
,则可以在示例数据集上使用mod
。
我已经尝试了很多选择,但是在正确放置线段时,我似乎陷入了困境。
我不是在寻找为示例数据集绘制标签/段的特定问题的解决方案,而是可以通过编程方式放置段和标签的通用解决方案,因为这将构成autoplot()
方法的基础class(mod)
对象。 我已经解决了标签问题,但不是线段。 因此,对于以下问题:
x0
, y0
到x1
, y1
的行的段grob时,如何使用xmin
, xmax
, ymin
, ymax
参数? annotation_custom()
在已知数据坐标x0
, y0
到x1
, y1
之间的绘图区域之外绘制段? 我很高兴收到答案,该答案只是在绘图区域中有任何旧绘图,但展示了如何在绘图边缘的已知坐标之间添加线段。
我不愿意使用annotation_custom()
所以如果有更好的解决方案,我也会考虑。 我确实想避免在绘图区域中放置标签; 我想我可以通过使用annotate()
并通过expand
参数扩展x轴限制来实现这一点。
fortify()
方法 fortify.prc <- function(model, data, scaling = 3, axis = 1,
...) {
s <- summary(model, scaling = scaling, axis = axis)
b <- t(coef(s))
rs <- rownames(b)
cs <- colnames(b)
res <- melt(b)
names(res) <- c("Time", "Treatment", "Response")
n <- length(s$sp)
sampLab <- paste(res$Treatment, res$Time, sep = "-")
res <- rbind(res, cbind(Time = rep(NA, n),
Treatment = rep(NA, n),
Response = s$sp))
res$Score <- factor(c(rep("Sample", prod(dim(b))),
rep("Species", n)))
res$Label <- c(sampLab, names(s$sp))
res
}
dput()
这是fortify.prc(mod)
的输出:
structure(list(Time = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 1, 2,
3, 4, 5, 6, 7, 8, 9, 10, NA, NA, NA, NA, NA, NA, NA, NA, NA,
NA), Treatment = c(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3,
3, 3, 3, 3, 3, 3, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), Response = c(0.775222658013234,
-0.0374860102875694, 0.100620532505619, 0.17475403767196, -0.736181209242918,
1.18581913245908, -0.235457236665258, -0.494834646295896, -0.22096700738071,
-0.00852429328460645, 0.102286976108412, -0.116035743892094,
0.01054849999509, 0.429857364190398, -0.29619258318138, 0.394303081010858,
-0.456401545475929, 0.391960511587087, -0.218177702859661, -0.174814586471715,
0.424769871360028, -0.0771395073436865, 0.698662414019584, 0.695676522106077,
-0.31659375422071, -0.584947748238806, -0.523065304477453, -0.19259357510277,
-0.0786143714402391, -0.313283220381509), Score = structure(c(1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), .Label = c("Sample",
"Species"), class = "factor"), Label = c("2-1", "2-2", "2-3",
"2-4", "2-5", "2-6", "2-7", "2-8", "2-9", "2-10", "3-1", "3-2",
"3-3", "3-4", "3-5", "3-6", "3-7", "3-8", "3-9", "3-10", "spp1",
"spp2", "spp3", "spp4", "spp5", "spp6", "spp7", "spp8", "spp9",
"spp10")), .Names = c("Time", "Treatment", "Response", "Score",
"Label"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8",
"9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19",
"20", "spp1", "spp2", "spp3", "spp4", "spp5", "spp6", "spp7",
"spp8", "spp9", "spp10"), class = "data.frame")
myPlt <- function(x, air = 1.1) {
## fortify PRC model
fx <- fortify(x)
## samples and species scores
sampScr <- fx[fx$Score == "Sample", ]
sppScr <- fx[fx$Score != "Sample", ]
ord <- order(sppScr$Response)
sppScr <- sppScr[ord, ]
## base plot
plt <- ggplot(data = sampScr,
aes(x = Time, y = Response,
colour = Treatment, group = Treatment),
subset = Score == "Sample")
plt <- plt + geom_line() + # add lines
geom_rug(sides = "r", data = sppScr) ## add rug
## species labels
sppLab <- sppScr[, "Label"]
## label grobs
tg <- lapply(sppLab, textGrob, just = "left")
## label grob widths
wd <- sapply(tg, function(x) convertWidth(grobWidth(x), "cm",
valueOnly = TRUE))
mwd <- max(wd) ## largest label
## add some space to the margin, move legend etc
plt <- plt +
theme(plot.margin = unit(c(0, mwd + 1, 0, 0), "cm"),
legend.position = "top",
legend.direction = "horizontal",
legend.key.width = unit(0.1, "npc"))
## annotate locations
## - Xloc = new x coord for label
## - Xloc2 = location at edge of plot region where rug ticks met plot box
Xloc <- max(fx$Time, na.rm = TRUE) +
(2 * (0.04 * diff(range(fx$Time, na.rm = TRUE))))
Xloc2 <- max(fx$Time, na.rm = TRUE) +
(0.04 * diff(range(fx$Time, na.rm = TRUE)))
## Yloc - where to position the labels in y coordinates
yran <- max(sampScr$Response, na.rm = TRUE) -
min(sampScr$Response, na.rm = TRUE)
## This is taken from vegan:::linestack
## attempting to space the labels out in the y-axis direction
ht <- 2 * (air * (sapply(sppLab,
function(x) convertHeight(stringHeight(x),
"npc", valueOnly = TRUE)) *
yran))
n <- length(sppLab)
pos <- numeric(n)
mid <- (n + 1) %/% 2
pos[mid] <- sppScr$Response[mid]
if (n > 1) {
for (i in (mid + 1):n) {
pos[i] <- max(sppScr$Response[i], pos[i - 1] + ht[i])
}
}
if (n > 2) {
for (i in (mid - 1):1) {
pos[i] <- min(sppScr$Response[i], pos[i + 1] - ht[i])
}
}
## pos now contains the y-axis locations for the labels, spread out
## Loop over label and add textGrob and segmentsGrob for each one
for (i in seq_along(wd)) {
plt <- plt + annotation_custom(tg[[i]],
xmin = Xloc,
xmax = Xloc,
ymin = pos[i],
ymax = pos[i])
seg <- segmentsGrob(Xloc2, pos[i], Xloc, pos[i])
## here is problem - what to use for ymin, ymax, xmin, xmax??
plt <- plt + annotation_custom(seg,
## xmin = Xloc2,
## xmax = Xloc,
## ymin = pos[i],
## ymax = pos[i])
xmin = Xloc2,
xmax = Xloc,
ymin = min(pos[i], sppScr$Response[i]),
ymax = max(pos[i], sppScr$Response[i]))
}
## Build the plot
p2 <- ggplot_gtable(ggplot_build(plt))
## turn off clipping
p2$layout$clip[p2$layout$name=="panel"] <- "off"
## draw plot
grid.draw(p2)
}
myPlt()
尝试过的图 这是我从上面用myPlt()
。 请注意通过标签绘制的水平小刻度线-这些应该是上方第一张图中的斜线段。
这就是我的处理方法,
library(gtable)
library(ggplot2)
library(plyr)
set.seed(1)
d <- data.frame(x=rep(1:10, 5),
y=rnorm(50),
g = gl(5,10))
# example plot
p <- ggplot(d, aes(x,y,colour=g)) +
geom_line() +
scale_x_continuous(expand=c(0,0))+
theme(legend.position="top",
plot.margin=unit(c(1,0,0,0),"line"))
# dummy data for the legend plot
# built with the same y axis (same limits, same expand factor)
d2 <- ddply(d, "g", summarise, x=0, y=y[length(y)])
d2$lab <- paste0("line #", seq_len(nrow(d2)))
plegend <- ggplot(d, aes(x,y, colour=g)) +
geom_blank() +
geom_segment(data=d2, aes(x=2, xend=0, y=y, yend=y),
arrow=arrow(length=unit(2,"mm"), type="closed")) +
geom_text(data=d2, aes(x=2.5,label=lab), hjust=0) +
scale_x_continuous(expand=c(0,0)) +
guides(colour="none")+
theme_minimal() + theme(line=element_blank(),
text=element_blank(),
panel.background=element_rect(fill="grey95", linetype=2))
# extract the panel only, we don't need the rest
gl <- gtable_filter(ggplotGrob(plegend), "panel")
# add a cell next to the main plot panel, and insert gl there
g <- ggplotGrob(p)
index <- subset(g$layout, name == "panel")
g <- gtable_add_cols(g, unit(1, "strwidth", "line # 1") + unit(1, "cm"))
g <- gtable_add_grob(g, gl, t = index$t, l=ncol(g),
b=index$b, r=ncol(g))
grid.newpage()
grid.draw(g)
用特定的标签和位置修改“传奇”图应该很简单(留给感兴趣的读者练习)。
也许这可以说明annotation_custom
,
myGrob <- grobTree(rectGrob(gp=gpar(fill="red", alpha=0.5)),
segmentsGrob(x0=0, x1=1, y0=0, y1=1, default.units="npc"))
myGrob2 <- grobTree(rectGrob(gp=gpar(fill="blue", alpha=0.5)),
segmentsGrob(x0=0, x1=1, y0=0, y1=1, default.units="npc"))
p <- qplot(1:10, 1:10) + theme(plot.margin=unit(c(0, 3, 0, 0), "cm")) +
annotation_custom(myGrob, xmin=5, xmax=6, ymin=3.5, ymax=5.5) +
annotate("segment", x=5, xend=6, y=3, yend=5, colour="red") +
annotation_custom(myGrob2, xmin=8, xmax=12, ymin=3.5, ymax=5.5)
p
g <- ggplotGrob(p)
g$layout$clip[g$layout$name=="panel"] <- "off"
grid.draw(g)
显然有一个奇怪的错误,即如果我重用myGrob
而不是myGrob2
,它将第二次忽略放置坐标,并将其与第一层堆叠在一起。 此功能确实有问题。
这看起来像是使用ggrepel更好的解决方案: https ://stackoverflow.com/a/45631834/4927395
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.