r - 使用雷达坐标将线段添加到ggplot2中的直方图中

Question

我正在尝试在 ggplot2 中制作极坐标直方图，其注释线不是径向线。

使用coord_polar的简单方法给出了曲线:

library(ggplot2)

d = data.frame(x=rep(seq(0, 350, 10), times=1:36))
lines = data.frame(x = c(40, 90, 150, 220, 270), 
y = c(20, 20, 20, 20, 20), 
xend = c(115, 165, 225, 295, 345), 
yend = c(5, 5, 5, 5, 5))

ggplot(d, aes(x)) + 
  geom_histogram(binwidth = 10) + 
  geom_segment(data = lines, 
               aes(x, y, xend = xend, yend = yend), 
               color = 'red') + 
  coord_polar() + 
  scale_x_continuous(limits=c(0, 360))

第二次尝试使用 coord_radar，来自 StackOverflow 和邮件列表上的各种来源:

coord_radar <- function (theta = "x", start = 0, direction = 1) 
{
 theta <- match.arg(theta, c("x", "y"))
 r <- if (theta == "x") 
        "y"
      else "x"
 ggproto("CoordRadar", CoordPolar, theta = theta, r = r, start = start, 
      direction = sign(direction),
      is_linear = function(coord) TRUE)
}

ggplot(d, aes(x)) + 
  geom_histogram(binwidth = 10) + 
  geom_segment(data = lines, 
               aes(x, y, xend = xend, yend = yend), 
               color = 'red') + 
  coord_radar()

这完全失败了:

如果我使用分组线而不是线段，我可以绘制线:

lines2 = data.frame(x = c(40, 115, 90, 165, 150, 225, 220, 295, 270, 345, 330, 45), 
y = c(20, 5, 20, 5, 20, 5, 20, 5, 20, 5, 20, 5), 
group = c(1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6))

ggplot(lines2, aes(x, y, group = group)) + 
  geom_line(color = 'red') + 
  coord_radar() + 
  scale_y_continuous(limits = c(0, 36)) + 
  scale_x_continuous(limits = c(0, 360))

但我仍然需要直方图...

有什么想法吗？

Answer 1

我刚刚回答了similar question在 geom_segment 部分。简而言之:geom_segment/geom_histogram后面的ggproto Geom对象的draw_panel函数有两种不同的方法来绘制各自的geoms，取决于 ggplot 对象的坐标系是线性还是非线性。

coord_polar 是非线性的(我们可以运行 CoordPolar$is_linear() 来确认这一点)，因此可以使用与非线性相关的方法正确绘制几何图形坐标系。 coord_radar 是线性的，因此改用线性方法，并造成严重破坏。

我们可以通过定义相关 Geoms 的调整版本来解决这个问题，这些版本仅包含非线性方法，以及调用它们而不是原始 Geoms 的 geom_* 函数。

geom_segment2:

GeomSegment2 <- ggproto("GeomSegment2",
                        GeomSegment,
                        draw_panel = function (data, panel_params, coord, arrow = NULL,
                                               arrow.fill = NULL, lineend = "butt", 
                                               linejoin = "round", na.rm = FALSE) {
                          data <- remove_missing(data, na.rm = na.rm, 
                                                 c("x", "y", "xend", "yend", "linetype", 
                                                   "size", "shape"), 
                                                 name = "geom_segment")                          
                          if (ggplot2:::empty(data)) 
                            return(zeroGrob())
                          # remove option for linear coordinate system
                          data$group <- 1:nrow(data)
                          starts <- subset(data, select = c(-xend, -yend))
                          ends <- plyr::rename(subset(data, select = c(-x, -y)), 
                                               c(xend = "x", yend = "y"), 
                                               warn_missing = FALSE)
                          pieces <- rbind(starts, ends)
                          pieces <- pieces[order(pieces$group), ]
                          GeomPath$draw_panel(pieces, panel_params, coord, arrow = arrow, 
                                              lineend = lineend)
                        })

geom_segment2 <- function (mapping = NULL, data = NULL, stat = "identity", 
                           position = "identity", ..., arrow = NULL, arrow.fill = NULL, 
                           lineend = "butt", linejoin = "round", na.rm = FALSE, 
                           show.legend = NA, inherit.aes = TRUE) {
  layer(data = data, mapping = mapping, stat = stat, 
        geom = GeomSegment2, # instead of GeomSegment
        position = position, show.legend = show.legend, inherit.aes = inherit.aes, 
        params = list(arrow = arrow, arrow.fill = arrow.fill, 
                      lineend = lineend, linejoin = linejoin, na.rm = na.rm, 
                      ...))
}

geom_histogram2:

library(grid)

GeomBar2 <- ggproto("GeomBar2",
                    GeomBar,
                    draw_panel = function (self, data, panel_params, coord, 
                                           width = NULL) {
                      # copy over GeomRect's draw_panel function for the non-linear portion
                      aesthetics <- setdiff(names(data), 
                                            c("x", "y", "xmin", "xmax", "ymin", "ymax"))
                      polys <- plyr::alply(data, 1, function(row) {
                        poly <- ggplot2:::rect_to_poly(row$xmin, row$xmax, row$ymin, row$ymax)
                        aes <- as.data.frame(row[aesthetics], 
                                             stringsAsFactors = FALSE)[rep(1, 5), ]
                        GeomPolygon$draw_panel(cbind(poly, aes), panel_params, coord)
                      })
                      ggplot2:::ggname("bar", do.call("grobTree", polys))
                    })

geom_histogram2 <- function (mapping = NULL, data = NULL, stat = "bin", 
                             position = "stack", ..., binwidth = NULL, 
                             bins = NULL, na.rm = FALSE, show.legend = NA, 
                             inherit.aes = TRUE) {
  layer(data = data, mapping = mapping, stat = stat, 
        geom = GeomBar2, # instead of GeomBar
        position = position, show.legend = show.legend, inherit.aes = inherit.aes, 
        params = list(binwidth = binwidth, bins = bins, na.rm = na.rm, 
                      pad = FALSE, ...))
}

用法:

ggplot(d, aes(x)) + 
  geom_histogram2(binwidth = 10) + 
  geom_segment2(data = lines, 
                aes(x, y, xend = xend, yend = yend), 
                color = 'red') + 
  coord_radar() +
  scale_x_continuous(limits = c(0, 360))