4

这是与从此答案修改的自定义几何相关的问题。给定的 geom 分组失败，所以我包含coord_munch在 中draw_panel，深受GeomLine和的启发GeomPath。它实际上在很多情况下都有效，但我觉得它经常同样失败。

特别是，它似乎在两人一组时失败（见下面的例子），并且在使用拼凑而成的某些地块上奇怪地失败了。我打开了一个issue，但还没有得到回复，对此我并不感到惊讶，我同意并认为这实际上是一个写得不好的geom的问题，而不是拼凑的问题。

我相信用于 GeomPath 的分组（在代码## Work out grouping variables for grobs中用 标记）对于这个 grob 失败，但我不知道如何检查在两者之间创建的 munch 对象。

我的主要问题是，我如何检查这个对象？

如果有人看到并理解我的 geom 问题，我会更加感激。干杯

例子：

library(tidyverse)

## this is not an arrange problem, as shown by the correct plot using geom_path
testdf <- testdf %>% arrange(id, group, x)

与 geom_path 一起使用

ggplot(testdf, aes(x, y)) +
  geom_path(aes(group = id))

geom_trail 失败

ggplot(testdf, aes(x, y)) +
  geom_trail(aes(group = id))

使用颜色时更糟

ggplot(testdf, aes(x, y)) +
  geom_trail(aes(group = id, color = group))

由reprex 包（v0.3.0）于 2020-07-02 创建

几何轨迹

geom_trail <-
  function (mapping = NULL, data = NULL, stat = "identity", position = "identity",
            na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...) {
    layer(data = data, mapping = mapping, stat = stat, geom = GeomTrail,
          position = position, show.legend = show.legend, inherit.aes = inherit.aes,
          params = list(na.rm = na.rm, ...))
  }

GeomTrail <- ggplot2::ggproto(
  "GeomTrail", ggplot2::GeomPoint,
  
  default_aes = ggplot2::aes(
    shape = 19, colour = "black", size = 1.5, fill = NA, alpha = NA, stroke = 0.5,
    linesize = 0.5, linetype = 1, gap = .9,
  ),
  
  ## tjebo: 
  ## here is a function handle_na(), which does have no effect on the problem
  
  draw_panel = function(data, panel_params, coord, arrow = NULL,
                        lineend = "butt", linejoin = "round", linemitre = 10,
                        na.rm = FALSE) {
    if (!anyDuplicated(data$group)) {
      message_wrap("geom_path: Each group consists of only one observation. ",
                   "Do you need to adjust the group aesthetic?")
    }
    
    
    # ggplot: 
    ##must be sorted on group
    data <- data[order(data$group), , drop = FALSE]
    munched <- coord_munch(coord, data, panel_params)
    
    # ggplot: 
    ##Default geom point behaviour
    if (is.character(data$shape)) {
      data$shape <- translate_shape_string(data$shape)
    }
    coords <- coord$transform(data, panel_params)
    
    if (unique(coords$size == 0)) {
      my_points <- NULL
    } else {
      my_points <- grid::pointsGrob(
        coords$x,
        coords$y,
        pch = coords$shape,
        gp = grid::gpar(
          col = alpha(coords$colour, coords$alpha),
          fill = alpha(coords$fill, coords$alpha),
          fontsize = coords$size * .pt + coords$stroke * .stroke / 2,
          lwd = coords$stroke * .stroke / 2
        )
      )
    }
    
    # ggplot: 
    ##Silently drop lines with less than two points, preserving order
    rows <- stats::ave(seq_len(nrow(munched)), munched$group, FUN = length)
    munched <- munched[rows >= 2, ]
    if (nrow(munched) < 2) {
      return(zeroGrob())
    }
    
    ## tjebo: 
    ## here, ggplot2:::dapply() checks which grob to use (segment or lines), 
    ## but it also does not seem to have an effect, or at least I don't know 
    ## to change the grob in this case
    
    # teunbrand: 
    # New behaviour
    ## Convert x and y to units
    x <- unit(munched$x, "npc")
    y <- unit(munched$y, "npc")
    
    ## Work out grouping variables for grobs 
    n <- nrow(munched)
    group_diff <- munched$group[-1] != munched$group[-n]
    start <- c(TRUE, group_diff)
    end <- c(group_diff, TRUE)
    
    ## teunbrand: Custom grob class
    my_path <- grid::grob(
      x = x, y = y,
      mult = munched$gap * .pt,
      name = "trail",
      gp = grid::gpar(
        col = alpha(munched$colour, munched$alpha)[!end], # this could also be [start]
        fill = alpha(munched$colour, munched$alpha)[!end],
        lwd = munched$linesize * .pt,
        lty = munched$linetype,
        lineend = "butt",
        linejoin = "round",
        linemitre = 10
      ),
      vp = NULL,
      cl = "trail"
    )

    ggplot2:::ggname(
      "geom_trail",
      grid::grobTree(my_path, my_points)
    )
  }
)

# not modified hook
makeContent.trail <- function(x){ 
  # Convert npcs to absolute units
  x_new <- grid::convertX(x$x, "mm", TRUE)
  y_new <- grid::convertY(x$y, "mm", TRUE)
  
  # Do trigonometry stuff
  hyp <- sqrt(diff(x_new)^2 + diff(y_new)^2)
  sin_plot <- diff(y_new) / hyp
  cos_plot <- diff(x_new) / hyp
  
  diff_x0_seg <- head(x$mult, -1) * cos_plot
  diff_x1_seg <- (hyp - head(x$mult, -1)) * cos_plot
  diff_y0_seg <- head(x$mult, -1) * sin_plot
  diff_y1_seg <- (hyp - head(x$mult, -1)) * sin_plot
  
  x0 = head(x_new, -1) + diff_x0_seg
  x1 = head(x_new, -1) + diff_x1_seg
  y0 = head(y_new, -1) + diff_y0_seg
  y1 = head(y_new, -1) + diff_y1_seg
  keep <- unclass(x0) < unclass(x1)
  
  # Remove old xy coordinates
  x$x <- NULL
  x$y <- NULL
  
  # Supply new xy coordinates
  x$x0 <- unit(x0, "mm")[keep]
  x$x1 <- unit(x1, "mm")[keep]
  x$y0 <- unit(y0, "mm")[keep]
  x$y1 <- unit(y1, "mm")[keep]
  
  # Set to segments class
  class(x)[1] <- 'segments'
  x
}

数据

testdf <- tibble(
  id = c("A", "B", "B", "C", "D", "A", "E", "E", "F", "F", "G", "H", "I", "J", "I", "J", "K", "L", "M", "N", "M", "O", "P", "Q", "R", "R", "S", "T", "S", "T"),
  group = c("a", "a", "a", "a", "a", "a", "b", "b", "b", "b", "b", "b", "c", "c", "c", "c", "c", "c", "d", "d", "d", "d", "d", "d", "e", "e", "e", "e", "e", "e"),
  x = c(41, 43, 45, 45, 45, 46, 41, 46, 53, 54, 54, 56, 35, 35, 37, 37, 44, 44, 43, 44, 45, 45, 46, 46, 44, 48, 50, 52, 53, 54),
  y = structure(c(2.2, 1.8, 1.8, 2.3, 2.2, 2.2, 5.3, 2.3, 4.6, 4.6, 4.8, 4.8, 3.9, 4.1, 3.9, 4.1, 3.6, 3.7, 2.8, 2.6, 2.8, 3.1, 3.1, 2.9, 0.7, 0.7, 1, 0.8, 1, 0.8), .Names = c("", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", ""))
)
4

2 回答 2

8

这里有几点需要注意

调试 ggproto 方法

以下是我最喜欢的三种调试方法：

如果您自己编写 ggproto，您可以使用 RStudio 的浏览器，或从代码中超级分配对象。奖励：您可以从调试屏幕进行超级分配。

GeomDummy <- ggproto(
  "GeomDummy", Geom,
  draw_panel = function(...) { # Doesn't really matter

   # If in RStudio, put this somewhere in the beginning
   browser()

   {...} # Useful code here

   # Superassign data to be debugged to global environment
   debugdata <<- problemdata
  }
)

如果调试不可变的代码（比如 ggplot 自己的代码，除非你 fork ），你仍然可以用浏览器调试它，但是要遵循正确的路径才能找到有问题的代码需要一些努力：

debugonce(ggplot2:::ggplot_build.ggplot)
# The above is triggered whenever a plot is build before drawing
ggplot(mtcars, aes(wt, mpg)) + geom_point()

你也可以debug(ggplot2:::ggplot_build.ggplot)，但完成后你必须undebug()这样做。

发现改进

在以下位中：

if (!anyDuplicated(data$group)) {
    message_wrap("geom_path: Each group consists of only one observation. ",
                 "Do you need to adjust the group aesthetic?")
}
{...}
if (nrow(munched) < 2) {
  return(zeroGrob())
}

这根本不会绘制任何内容，即使要绘制 1 个不需要段来连接自身的点。

在下面的代码中：

if (unique(coords$size == 0)) {
  my_points <- NULL
}

通常人们会使用shape = NA省略绘图点，但我不能决定如何编写自己的几何图形。另外，我以前从未见过这种if(unique(x == y))模式，但是如果同时存在TRUE案例和FALSE案例，这不会引发警告吗？将其替换为if (all(coords$size == 0)).

也就是说，整个条件点绘制可以简化为以下结构：

GeomTrail <- ggproto(
  "GeomTrail", GeomPoint,
  draw_panel = function(self, ...usual_arguments...) { # Important to include self
    # Default geom point behaviour
    my_points <- ggproto_parent(GeomPoint, self)$draw_panel(
      data, panel_params, coord, na.rm = na.rm
    )

  {..rest of code goes here..}

  },
  non_missing_aes = c("size", "colour") # Omit shape here
)

改进的 ggproto / 网格代码

我做的主要事情是将 (x,y) 参数化更改为 ([x0,x1],[y0,y1]) 使用的参数化geom_segments()，这使得网格代码中的其他计算也更容易遵循。

我也从 切换makeContent()到makeContext()，因为由于我无法理解的原因，颜色不会更新。

GeomTrail <- ggplot2::ggproto(
  "GeomTrail", ggplot2::GeomPoint,
  
  default_aes = ggplot2::aes(
    shape = 19, colour = "black", size = 1.5, fill = NA, alpha = NA, stroke = 0.5,
    linesize = 0.5, linetype = 1, gap = .9,
  ),
  
  ## tjebo: 
  ## here is a function handle_na(), which does have no effect on the problem
  
  draw_panel = function(data, panel_params, coord, arrow = NULL,
                        lineend = "butt", linejoin = "round", linemitre = 10,
                        na.rm = FALSE) {
    if (!anyDuplicated(data$group)) {
      message_wrap("geom_path: Each group consists of only one observation. ",
                   "Do you need to adjust the group aesthetic?")
    }
    
    
    # ggplot: 
    ##must be sorted on group
    data <- data[order(data$group), , drop = FALSE]
    
    # ggplot: 
    ##Default geom point behaviour
    if (is.character(data$shape)) {
      data$shape <- translate_shape_string(data$shape)
    }
    coords <- coord$transform(data, panel_params)
    
    if (unique(coords$size == 0)) {
      my_points <- NULL
    } else {
      my_points <- grid::pointsGrob(
        coords$x,
        coords$y,
        pch = coords$shape,
        gp = grid::gpar(
          col = alpha(coords$colour, coords$alpha),
          fill = alpha(coords$fill, coords$alpha),
          fontsize = coords$size * .pt + coords$stroke * .stroke / 2,
          lwd = coords$stroke * .stroke / 2
        )
      )
    }
    
    data <- coord_munch(coord, data, panel_params)
    
    data <- transform(data,
                      xend = c(tail(x, -1), NA),
                      yend = c(tail(y, -1), NA),
                      keep = c(group[-1] == head(group, -1), FALSE))
    data <- data[data$keep, ]
    
    ## Make custom grob class
    my_path <- grid::grob(
      x0 = unit(data$x, "npc"), x1 = unit(data$xend, "npc"),
      y0 = unit(data$y, "npc"), y1 = unit(data$yend, "npc"),
      mult = data$gap * .pt,
      name = "pointpath",
      gp = grid::gpar(
        col = alpha(data$colour, data$alpha),
        lwd = (data$linesize * .pt),
        lty = data$linetype,
        lineend = "butt",
        linejoin = "round", linemitre = 10
      ),
      vp = NULL,
      ### Now this is the important bit:
      cl = "trail"
    )
    
    ggplot2:::ggname(
      "geom_trail",
      grid::grobTree(my_path, my_points)
    )
  }
)

makeContext.trail <- function(x) {
  # Convert npcs to absolute units
  x0 <- grid::convertX(x$x0, "mm", TRUE)
  y0 <- grid::convertY(x$y0, "mm", TRUE)
  x1 <- grid::convertX(x$x1, "mm", TRUE)
  y1 <- grid::convertY(x$y1, "mm", TRUE)
  
  # Do trigonometry stuff
  dx <- x1 - x0
  dy <- y1 - y0
  hyp <- sqrt(dx ^ 2 + dy ^ 2)
  nudge_y <- (dy / hyp) * x$mult
  nudge_x <- (dx / hyp) * x$mult
  
  # Calculate new positions
  x0 <- x0 + nudge_x
  x1 <- x1 - nudge_x
  y0 <- y0 + nudge_y
  y1 <- y1 - nudge_y
  
  # Filter overshoot
  keep <- (sign(dx) == sign(x1 - x0)) & (sign(dy) == sign(y1 - y0))
  x$gp[] <- lapply(x$gp, function(x) {
    if (length(x) == 1L) return(x) else x[keep]
  })
  
  # Supply new xy coordinates
  x$x0 <- unit(x0[keep], "mm")
  x$x1 <- unit(x1[keep], "mm")
  x$y0 <- unit(y0[keep], "mm")
  x$y1 <- unit(y1[keep], "mm")
  
  # Set to segments class
  x$mult <- NULL
  x$id <- NULL
  class(x)[1] <- "segments"
  x
}

最终结果

它现在绘制如下：

ggplot(testdf, aes(x, y)) +
    geom_trail(aes(group = id, color = group))

在此处输入图像描述

笔记：

我实际上并没有想出这个来回答一个 SO 问题，我最近不得不用我自己的这个 geom版本处理非常相似的问题。

于 2020-07-02T18:14:53.770 回答
1

一年后，我发现了一种调试 ggplot2 ggproto 方法的新方法，我认为由于它的简单性，它值得一个不同的答案。

我们可以声明两个辅助函数：

ggdebug <- function(x, once = TRUE) {
  fun <- if (once) debugonce else debug
  fun(environment(x)$f)
}

ggundebug <- function(x) {
  undebug(environment(x)$f)
}

接下来，我们可以标记一个ggproto方法进行调试

ggdebug(GeomPoint$draw_panel)

执行一些使用该方法的代码，我们就有了！

ggplot(mpg, aes(displ, hwy)) +
  geom_point()
于 2021-08-24T12:56:27.473 回答