Добавьте стрелку с закрашенной головой в ggplot, автор geom_label_repel

Я хочу добавить стрелку с заполненной головкой к объекту ggplot с помощью функции geom_label_repel. Я думал, что могу использовать: arrow.fill = 'black', как я делаю с geom_segment, но это не работает в geom_label_repel. Это еще один способ получить закрашенную стрелку?

Причина, по которой я использую geom_label_repel, заключается в том, что это был единственный способ начать стрелку на границе метки. Если эту координату можно найти другим способом, я мог бы использовать вместо нее geom_segment.

library(tidyverse)
library(ggrepel)

dmax <- iris %>%
  filter(Sepal.Length == max(Sepal.Length))

ggplot(data = iris, aes(x=Sepal.Width, y=Sepal.Length)) +
  geom_point() +
  geom_label_repel(data=dmax, aes(label = 'max'), 
                   box.padding = unit(.25, 'lines'), 
                   point.padding = unit(1.5, 'lines'), 
                   arrow = arrow(length = unit(0.25, 'cm'), type = 'closed')) +
  geom_segment(aes(x=3, xend=max(Sepal.Width), y=0, yend=max(Sepal.Width)), 
               arrow=arrow(length = unit(0.25, 'cm'), type = 'closed'), 
               arrow.fill = 'black')

person gentiana    schedule 06.04.2020    source источник
comment
Параметр стрелки ggrepel::geom_label_repel предоставляется пакетом grid. В grid::arrow нет опции arrow.fill, поэтому я не думаю, что вы можете заполнить стрелку из ggrepel::geom_label_repel.   -  person markhogue    schedule 06.04.2020
comment
также geom_segment использует arrow из grid, но может заполнить острие стрелки. Вам, вероятно, придется покопаться в таблицах grob и тому подобном. Я пытаюсь выяснить, как geom_segment это делает   -  person GGamba    schedule 06.04.2020
comment
@GGamba может помочь в вашем расследовании. как-то связано stackoverflow.com/questions/60446727/ мне кажется, что ggrepel должен изменить функцию рисования сетки, как рисовать стрелку - кажется, что это действительно так ' заполнить стрелку ...   -  person tjebo    schedule 06.04.2020


Ответы (1)


Из GeomSegment$draw_panel видно, что значение arrow.fill в geom_segment передается в параметр fill в grid::segmentsGrob. Такая же модификация может быть применена к ggrepel::geom_label_repel:

ggplot(data = iris, 
       aes(x=Sepal.Width, y=Sepal.Length)) +
  geom_point() +
  geom_label_repel2(data=. %>% 
                      filter(Sepal.Length == max(Sepal.Length)), 
                    aes(label = 'max'), 
                    box.padding = unit(.25, 'lines'), 
                    point.padding = unit(1.5, 'lines'), 
                    arrow = arrow(length = unit(0.25, 'cm'), type = 'closed'),
                    arrow.fill = "green") +
  geom_segment(aes(x=3, xend=max(Sepal.Width), y=0, yend=max(Sepal.Width)), 
               arrow = arrow(length = unit(0.25, 'cm'), type = 'closed'), 
               arrow.fill = 'red')

результат

Код для модифицированного объекта ggproto и функции geom:

GeomLabelRepel2 <- ggproto(
  "GeomLabelRepel2",
  GeomLabelRepel,
  draw_panel = function (self, data, panel_scales, coord, parse = FALSE, na.rm = FALSE, 
                         box.padding = 0.25, label.padding = 0.25, point.padding = 1e-06, 
                         label.r = 0.15, label.size = 0.25, segment.colour = NULL, 
                         segment.size = 0.5, segment.alpha = NULL, min.segment.length = 0.5, 
                         arrow = NULL, arrow.fill = NULL, # add arrow.fill parameter
                         force = 1, nudge_x = 0, nudge_y = 0, xlim = c(NA, NA), 
                         ylim = c(NA, NA), max.iter = 2000, direction = "both", seed = NA) 
  {
    lab <- data$label
    if (parse) {
      lab <- parse(text = as.character(lab))
    }
    if (!length(which(ggrepel:::not_empty(lab)))) {
      return()
    }
    nudges <- data.frame(x = data$x + nudge_x, y = data$y + nudge_y)
    nudges <- coord$transform(nudges, panel_scales)
    data <- coord$transform(data, panel_scales)
    nudges$x <- nudges$x - data$x
    nudges$y <- nudges$y - data$y
    limits <- data.frame(x = xlim, y = ylim)
    limits <- coord$transform(limits, panel_scales)
    limits$x[is.na(limits$x)] <- c(0, 1)[is.na(limits$x)]
    limits$y[is.na(limits$y)] <- c(0, 1)[is.na(limits$y)]
    if (is.character(data$vjust)) {
      data$vjust <- compute_just(data$vjust, data$y)
    }
    if (is.character(data$hjust)) {
      data$hjust <- compute_just(data$hjust, data$x)
    }
    if(is.null(arrow.fill)) { # define fill if arrow.fill is specified
      arrow.fill.gp <- grid::gpar()
    } else {
      arrow.fill.gp <- grid::gpar(fill = arrow.fill)
    }
    ggplot2:::ggname("geom_label_repel", 
                     grid::gTree(limits = limits, 
                                 data = data, 
                                 lab = lab, 
                                 nudges = nudges, 
                                 box.padding = ggrepel:::to_unit(box.padding), 
                                 label.padding = ggrepel:::to_unit(label.padding), 
                                 point.padding = ggrepel:::to_unit(point.padding), 
                                 label.r = ggrepel:::to_unit(label.r), 
                                 label.size = label.size, 
                                 segment.colour = segment.colour,
                                 segment.size = segment.size, 
                                 segment.alpha = segment.alpha, 
                                 min.segment.length = ggrepel:::to_unit(min.segment.length), 
                                 arrow = arrow, 
                                 gp = arrow.fill.gp, # add gp
                                 force = force, 
                                 max.iter = max.iter, 
                                 direction = direction, 
                                 seed = seed, 
                                 cl = "labelrepeltree"))
  }
)

geom_label_repel2 <- function (mapping = NULL, data = NULL, stat = "identity", 
                               position = "identity", parse = FALSE, ..., box.padding = 0.25, 
                               label.padding = 0.25, point.padding = 1e-06, label.r = 0.15, 
                               label.size = 0.25, segment.colour = NULL, segment.color = NULL, 
                               segment.size = 0.5, segment.alpha = NULL, min.segment.length = 0.5, 
                               arrow = NULL, arrow.fill = NULL, # add arrow.fill parameter
                               force = 1, max.iter = 2000, nudge_x = 0, nudge_y = 0, 
                               xlim = c(NA, NA), ylim = c(NA, NA), na.rm = FALSE, show.legend = NA, 
                               direction = c("both", "y", "x"), seed = NA, 
                               inherit.aes = TRUE) {
  if (!missing(nudge_x) || !missing(nudge_y)) {
    if (!missing(position)) {
      stop("Specify either `position` or `nudge_x`/`nudge_y`", 
           call. = FALSE)
    }
  }
  layer(data = data, mapping = mapping, stat = stat, geom = GeomLabelRepel2, # change geom
        position = position, show.legend = show.legend, inherit.aes = inherit.aes, 
        params = list(parse = parse, box.padding = ggrepel:::to_unit(box.padding), 
                      label.padding = ggrepel:::to_unit(label.padding), point.padding = ggrepel:::to_unit(point.padding), 
                      label.r = ggrepel:::to_unit(label.r), label.size = label.size, 
                      segment.colour = segment.color %||% segment.colour, 
                      segment.size = segment.size, segment.alpha = segment.alpha, 
                      min.segment.length = ggrepel:::to_unit(min.segment.length), 
                      arrow = arrow, arrow.fill = arrow.fill, # add arrow.fill parameter
                      na.rm = na.rm, force = force, max.iter = max.iter, 
                      nudge_x = nudge_x, nudge_y = nudge_y, xlim = xlim, 
                      ylim = ylim, direction = match.arg(direction), seed = seed, 
                      ...))
}
person Z.Lin    schedule 15.02.2021
comment
кажется, почти стоит запрос на перенос;) - person tjebo; 15.02.2021
comment
@ Z.Lin есть ли у вас какие-нибудь учебники по созданию этих сложных функций? - person PesKchan; 15.04.2021