Как поместить грыбы с annotation_custom() в точные области участка участка?

Я пытаюсь воспроизвести следующий график [base R] с ggplot2

Я справился с этим, но в настоящее время меня озадачивает размещение сегментов линии, которые присоединяются к графику маргинального ковра справа от графика с соответствующей меткой. Ярлыки были нарисованы (на втором рисунке ниже) через anotation_custom(), и я использовал трюк @baptiste для отключения обрезки, чтобы рисовать на графике.

Несмотря на множество попыток, я не могу разместить 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)

Если у вас нет установленного vegan, я добавлю dput укрепленного объекта в конце Вопроса и fortify(), если вы хотите запустить пример и fortify() для удобного построения с ggplot(). Я также включаю в себя несколько длительную функцию myPlt(), которая иллюстрирует то, что я работал до сих пор, которое может быть использовано в наборе данных примера, если у вас загружены пакеты и может создать mod.

Я попробовал несколько вариантов, но теперь, похоже, сейчас в темном порядке возникают проблемы с правильной настройкой сегментов линии.

Я не ищу решение конкретной проблемы построения меток/сегментов для набора данных примера, но общее решение, которое я могу использовать для размещения сегментов и меток программно, поскольку это будет составлять основу autoplot() для объектов class(mod). У меня есть ярлыки, разработанные ОК, а не сегменты линий. Итак, на вопросы:

Как используются аргументы xmin, xmax, ymin, ymax, когда я хочу поместить сегментную грань, содержащую строку, идущую от координат данных x0, y0 до x1, y1?
Возможно, задан другой способ: как вы используете annotation_custom() для выделения сегментов вне области графика между известными координатами данных x0, y0 до x1, y1?

Я был бы рад получить ответы, которые просто имели какой-либо старый сюжет в области сюжета, но показали, как добавить сегменты линии между известными координатами на краю сюжета.

Я не согласен с использованием annotation_custom(), поэтому, если доступно лучшее решение, я бы тоже подумал об этом. Однако я хочу избежать ярлыков в области сюжета; Я думаю, что я могу достичь этого, используя annotate() и расширяя пределы оси x в шкале через аргумент expand.

Метод `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() сверху. Обратите внимание на небольшие горизонтальные тики, прочерченные через метки - это должны быть сегменты наклонной линии на первом рисунке выше.

Ответ 1

Возможно, это может проиллюстрировать 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, она игнорирует координаты места размещения во второй раз и складывает ее с первым слоем. Эта функция действительно глючит.

Ответ 2

Вот как я бы это сделал,

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)

Нужно прямо адаптировать сюжет "легенды" с конкретными тегами и местоположениями (оставленный как упражнение для заинтересованного читателя).

Ответ 3

Это выглядит как лучшее решение с ggrepel: https://stackoverflow.com/a/45631834/4927395

Метод fortify()

dput()