如何让geom_curve的箭头在使用alpha时保持透明度一致

问题说明 #

我需要在地图上绘制带单侧箭头的半透明曲线来连接点，用ggplot2的geom_curve实现，但设置alpha参数后箭头出现透明度不均的问题，希望让箭头和曲线保持统一的透明度。示例代码如下：

library(tidyverse)
library(ggplot2)
data <- data.frame(x = 4, y = 20, xend = 7, yend = 15)

ggplot(data) + geom_curve(aes(x = x, y = y, xend = xend, yend = yend),
    arrow = arrow(length = unit(0.17, "npc"), type="closed", angle=20),
    colour = "red",
    linewidth = 5,
    angle = 90, 
    alpha=.2,
    lineend = "butt",
    curvature = -0.4,
) 

解决方案 #

1. 修改自定义几何对象适配geom_curve #

原针对geom_segment的自定义几何对象可以修改为支持曲线的版本，核心是把曲线和箭头作为一个整体图形元素绘制，避免透明度分层。修改后的代码如下：

library(ggplot2)
library(grid)

GeomCurveArrow <- ggproto(
  "GeomCurveArrow", Geom,
  required_aes = c("x", "y", "xend", "yend"),
  default_aes = aes(
    colour = "black", linewidth = 1, linetype = 1, alpha = 1,
    curvature = 0.5, angle = 90, ncp = 5, arrow = NULL, lineend = "butt"
  ),
  draw_panel = function(data, panel_params, coord, na.rm = FALSE) {
    coords <- coord$transform(data, panel_params)
    
    # 生成曲线路径
    curve_grobs <- lapply(1:nrow(coords), function(i) {
      curveGrob(
        x0 = coords$x[i], y0 = coords$y[i],
        x1 = coords$xend[i], y1 = coords$yend[i],
        curvature = coords$curvature[i], angle = coords$angle[i],
        ncp = coords$ncp[i], gp = gpar(
          col = alpha(coords$colour[i], coords$alpha[i]),
          lwd = coords$linewidth[i] * .pt,
          lty = coords$linetype[i],
          lineend = coords$lineend[i]
        )
      )
    })
    
    # 添加箭头（如果设置了箭头参数）
    if (!is.null(coords$arrow[[1]])) {
      arrow_grobs <- lapply(1:nrow(coords), function(i) {
        # 计算曲线末端的角度
        curve_path <- curvePoints(
          x0 = coords$x[i], y0 = coords$y[i],
          x1 = coords$xend[i], y1 = coords$yend[i],
          curvature = coords$curvature[i], angle = coords$angle[i],
          ncp = coords$ncp[i]
        )
        end_point <- tail(curve_path, 1)
        prev_point <- tail(curve_path, 2)[1,]
        angle <- atan2(end_point$y - prev_point$y, end_point$x - prev_point$x) * 180 / pi
        
        # 生成箭头多边形
        arrow_spec <- coords$arrow[[i]]
        arrow_x <- arrow_spec$x * arrow_spec$length$value
        arrow_angles <- c(angle + arrow_spec$angle, angle, angle - arrow_spec$angle)
        arrow_points <- data.frame(
          x = coords$xend[i] + arrow_x * cos(arrow_angles * pi / 180),
          y = coords$yend[i] + arrow_x * sin(arrow_angles * pi / 180)
        )
        # 闭合箭头多边形
        arrow_points <- rbind(arrow_points, arrow_points[1,])
        
        polygonGrob(
          x = arrow_points$x, y = arrow_points$y,
          gp = gpar(
            fill = alpha(coords$colour[i], coords$alpha[i]),
            col = alpha(coords$colour[i], coords$alpha[i])
          )
        )
      })
      grobs <- mapply(function(c, a) grobTree(c, a), curve_grobs, arrow_grobs, SIMPLIFY = FALSE)
    } else {
      grobs <- curve_grobs
    }
    
    do.call(grobTree, grobs)
  },
  draw_key = draw_key_path
)

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

使用方式和原geom_curve完全一致：

ggplot(data) + 
  geom_curve_arrow(aes(x = x, y = y, xend = xend, yend = yend),
    arrow = arrow(length = unit(0.17, "npc"), type="closed", angle=20),
    colour = "red",
    linewidth = 5,
    angle = 90, 
    alpha=.2,
    lineend = "butt",
    curvature = -0.4
  )

2. 用grid包手动绘制（简单场景） #

如果只是少量曲线，也可以直接用grid工具组合绘制，确保箭头和曲线使用相同的透明度：

library(grid)
library(ggplot2)

data <- data.frame(x = 4, y = 20, xend = 7, yend = 15)

# 先创建基础画布
p <- ggplot(data) + geom_blank() + coord_cartesian(xlim = c(3,8), ylim = c(14,21))

# 转换数据到画布坐标
coords <- layer_data(p)[1,]

# 生成曲线grob
curve_grob <- curveGrob(
  x0 = coords$x, y0 = coords$y,
  x1 = coords$xend, y1 = coords$yend,
  curvature = -0.4, angle = 90,
  gp = gpar(col = alpha("red", 0.2), lwd = 5*.pt, lineend = "butt")
)

# 计算箭头角度并生成箭头grob
curve_path <- curvePoints(x0 = coords$x, y0 = coords$y, x1 = coords$xend, y1 = coords$yend, curvature = -0.4, angle = 90)
end_point <- tail(curve_path, 1)
prev_point <- tail(curve_path, 2)[1,]
angle <- atan2(end_point$y - prev_point$y, end_point$x - prev_point$x) * 180 / pi

arrow_spec <- arrow(length = unit(0.17, "npc"), type="closed", angle=20)
arrow_x <- arrow_spec$x * arrow_spec$length$value
arrow_angles <- c(angle + arrow_spec$angle, angle, angle - arrow_spec$angle)
arrow_points <- data.frame(
  x = coords$xend + arrow_x * cos(arrow_angles * pi / 180),
  y = coords$yend + arrow_x * sin(arrow_angles * pi / 180)
)
arrow_points <- rbind(arrow_points, arrow_points[1,])

arrow_grob <- polygonGrob(
  x = arrow_points$x, y = arrow_points$y,
  gp = gpar(fill = alpha("red", 0.2), col = alpha("red", 0.2))
)

# 将曲线和箭头添加到画布
p + annotation_custom(grobTree(curve_grob, arrow_grob))

3. 关于geom_gene_arrow #

geom_gene_arrow属于gggenes包，主要用于绘制基因结构的矩形箭头，无法生成自定义曲率的曲线，因此不适合用来绘制地图中点与点之间的曲线连接，不推荐使用。

内容的提问来源于stack exchange，提问作者bill999