¿Cómo colocar grobs con annotation_custom () en áreas precisas de la región de trazado?

Estoy tratando de reproducir el siguiente argumento [base R] con ggplot2

enter image description here

Logré la mayor parte de esto, pero lo que actualmente me desconcierta es la ubicación de los segmentos de línea que unen la plot de alfombra marginal a la derecha de la plot con la etiqueta respectiva. Las tags han sido dibujadas (en la segunda figura a continuación) a través de anotation_custom() y he usado el truco de @ baptiste para desactivar el recorte para permitir el dibujo en el margen de la ttwig.

A pesar de muchos bashs, no puedo ubicar segmentGrobs() en las ubicaciones deseadas del dispositivo, de modo que se unan a la marca y etiqueta de alfombra correcta.

Un ejemplo reproducible es

 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) 

Si no tiene instalado vegan , dput un dput del objeto fortificado al final de la Pregunta y un método ggplot() si desea ejecutar el ejemplo y fortify() para un trazado práctico con ggplot() . También myPlt() una función algo larga, myPlt() , que ilustra lo que he estado trabajando hasta ahora, que puede usarse en el conjunto de datos de ejemplo si tiene los paquetes cargados y puede crear mod .

He intentado bastantes opciones, pero ahora parece que estoy dando tumbos en la oscuridad para conseguir que los segmentos de línea se coloquen correctamente.

No estoy buscando una solución al problema específico de trazar las tags / segmentos para el conjunto de datos de ejemplo, sino una solución genérica que puedo usar para colocar segmentos y tags de manera programática ya que esto formará la base de un método autoplot() para objetos de class(mod) . Tengo las tags resueltas, pero no los segmentos de línea. Entonces a las preguntas:

  1. ¿Cómo se xmin los xmin , xmax , xmin , xmin cuando quiero colocar un segmento grob que contiene una línea que se ejecuta desde coordenadas de datos x0 , y0 a x1 , y1 ?
  2. Tal vez preguntado de otra manera, ¿cómo se usa annotation_custom() para dibujar segmentos fuera de la región de trazado entre coords de datos conocidos x0 , y0 a x1 , y1 ?

Me gustaría recibir Respuestas que simplemente tienen una ttwig anterior en la región de la ttwig, pero que muestran cómo agregar segmentos de línea entre las coordenadas conocidas en el margen de la ttwig .

No estoy casado con el uso de annotation_custom() así que si hay una mejor solución disponible, lo consideraría también. Sin embargo, quiero evitar tener las tags en la región de la ttwig; Creo que puedo lograr eso usando annotate() y extender los límites del eje x en la escala a través del argumento expand .

El método 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 } 

El dput()

Esta es la salida de 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") 

Lo que he intentado:

 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]  1) { for (i in (mid + 1):n) { pos[i]  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) } 

Figura basada en lo que he probado en myPlt()

Esto es tan lejos como lo he hecho con myPlt() desde arriba. Tenga en cuenta las pequeñas marcas horizontales dibujadas a través de las tags: estos deben ser los segmentos de línea en ángulo en la primera figura de arriba.

enter image description here

Tal vez esto puede ilustrar 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) 

enter image description here

Parece que hay un error extraño, por lo que si reutilizo myGrob lugar de myGrob2 , ignora las coordenadas de ubicación la segunda vez y lo acumula con la primera capa. Esta función es realmente defectuosa.

Así es como me acercaría a esto,

 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) 

enter image description here

Debería ser sencillo adaptar la ttwig "leyenda" con tags y ubicaciones específicas (se deja como ejercicio para el lector interesado).