r - 如何绘制具有精确起点和终点的弯曲箭头？

Question

我想绘制弯曲的箭头，不幸的是，函数中没有实现曲率参数arrows(., curve=)。

我的解决方案是对省略号进行子集化。由于 plotrix::draw.ellipse() 画线并且我需要点子集，我写了一个函数 arrow_curved() 从 this great answer fork 代码这给出了一个令人满意的结果。

arrow_curved <- function(xc, yc, a, b, .xlim, .ylim, .srt, .lwd=1.25, .col=1) {
  phi <- pi/3
  t <- seq(0, 2*pi, 0.001) 
  x <- xc + a*cos(t)*cos(phi) - b*sin(t)*sin(phi)
  y <- yc + a*cos(t)*cos(phi) + b*sin(t)*cos(phi)
  w <- which(x > .xlim[1] & x < .xlim[2] & y < .ylim[2] & y > .ylim[1])
  x <- x[w]; y <- y[w]
  segments(x, y, x, y, lwd=.lwd, col=.col)
  text(x[which.max(x)], y[which.max(x)], labels='>', srt=.srt, col=.col)
}


plot(c(0, 10), c(0, 10), type="n")

## red arrows
arrow_curved(xc=3, yc=8, a=10, b=6.5, .xlim=c(3.25, 8.15), 
             .ylim=c(2, 4.5), .srt=20, .lwd=1.25, .col=2)
arrows(3.25, 2, 8.15, 4.5, length=.075, col=2, lty=2)  ## straight arrow

## green arrow
arrow_curved(xc=2, yc=4, a=6, b=10, .xlim=c(1, 5), 
             .ylim=c(1, 10), .srt=-20, .lwd=1.25, .col=3)

但是，您需要一点运气来指定参数。理想情况下，该函数的工作方式类似于 arrows()，除了 x0, y0, x1, y1 之外，我们还可以指定曲率 curve= 参数>。此外，目前起点和终点仅与 .xlim= 和 .ylim= 参数中指定的值大致匹配(将弯曲的红色箭头与直线引用箭头进行比较)。

谁能看到改进这方面功能的方法？也许可以借助数学以某种方式轻松调整坐标，这超出了我的知识范围。

Answer 1

你的问题让我很好奇如何做到这一点，所以我又试了一次。这涉及到相当多的几何学，但这是一个有趣的挑战。

基本上，我意识到，如果要使圆弧保持圆形，两点之间的行进距离将取决于您为圆弧指定的度数。小的度数意味着几乎是一条直线，而大的度数意味着到第二点的非常迂回的方式。在大多数情况下，我关于使用样条曲线的评论可能更有意义，但如果保持箭头的圆形形式很重要，那么以下内容似乎可以做到这一点。

所需功能:

# helper functions to convert between radians and degrees
deg2rad <- function (deg){
  stopifnot(is.numeric(deg))
  (rad <- (pi/180) * deg)
}

rad2deg <- function (rad){
  stopifnot(is.numeric(rad))
  (deg <- rad/(pi/180))
}

# function to calculate the points on an arc between two points
# position 1: x0, y0
# position 2: x1, y1
# number of points in resulting arc line: n
# degrees of the arc connecting the points (positive is counter-clockwise, 
# negative is clockwise): arcdeg
calcArc <- function(x0 = 1, y0 = 1, x1 = 4, y1 = 6, arcdeg = 30, n = 50){
  
  if(abs(arcdeg)>-359.9 & abs(arcdeg)>359.9){stop("angle of arc (arcdeg) must be between -359.9 and 359.9")}
  
  anglerad <- atan2(y = y1-y0, x = x1-x0) # angle between points
  midpt <- list(x = mean(c(x0,x1)), y = mean(c(y0,y1))) # midpoint coordinates of chord
  arcrad <- deg2rad(deg = arcdeg) # angle of arc in radians
  chordlength <- sqrt((x1-x0)^2 + (y1-y0)^2) # length between points
  r <- abs((chordlength/2) / sin(arcrad/2)) # radius of circle
  
  # angle from midpoint to circle center
  lut <- data.frame(
    lessthan180 = c(TRUE, TRUE, FALSE, FALSE), 
    sign = c(1, -1, 1, -1), 
    rotation = c(90, -90, -90, 90))
  hit <- which(lut$lessthan180 == (abs(arcdeg) < 180) & lut$sign == sign(arcdeg))
  anglecen <- anglerad + deg2rad(lut$rotation[hit])
  
  # length of midpoint to circle center
  midpt2cenpt <- sqrt(r^2 - (chordlength/2)^2) 
  
  # calculate center point
  cenpt <- list(x = midpt$x + midpt2cenpt*cos(anglecen), 
    y = midpt$y + midpt2cenpt*sin(anglecen))
  
  # angle from circle center to arc
  anglecen2arc <- anglecen + ifelse(abs(arcdeg)<180, deg2rad(180), 0)

  # produce vector of arc with n points
  arc <- data.frame(
    rad = seq(
      from = anglecen2arc - arcrad/2,
      to = anglecen2arc + arcrad/2, 
      length.out = n
    )
  )
  arc$x <- cenpt$x + r*cos(arc$rad)
  arc$y <- cenpt$y + r*sin(arc$rad)
  
  return(arc)
}

# function drawing the results of calcArc as a line or arrow.
# makes a conversion in plotting region units in order to maintain a circular arc
addArc <- function(x0 = 1, y0 = 1, x1 = 4, y1 = 6, arcdeg = 30, n = 50, 
  t = "l", col = 1, lty = 1, lwd = 1, 
  arrowlength = NULL, arrowangle = 30, arrowcode = 2,
  result = FALSE,
  ...){
  
  # calculate arc
  arc <- calcArc(x0 = x0, y0 = y0, x1 = x1, y1 = y1, arcdeg = arcdeg, n = n)

  # calculate arc in device units
  FROM = "user"
  TO = "chars"
  
  x0 <- grconvertX(x0, from = FROM, to = TO)
  x1 <- grconvertX(x1, from = FROM, to = TO)
  y0 <- grconvertY(y0, from = FROM, to = TO)
  y1 <- grconvertY(y1, from = FROM, to = TO)
  arc2 <- calcArc(x0 = x0, y0 = y0, x1 = x1, y1 = y1, arcdeg = arcdeg, n = n)
  names(arc2) <- c("rad", "xusr", "yusr")
  
  arc <- cbind(arc, arc2[,c("xusr", "yusr")])
  
  # convert back to user coordinates
  arc$xusr <- grconvertX(arc$xusr, from = TO, to = FROM)
  arc$yusr <- grconvertY(arc$yusr, from = TO, to = FROM)
  
  lines(yusr ~ xusr, data = arc, t = t, 
    col = col, lty = lty, lwd = lwd, ...)
  if(!is.null(arrowlength)){
    arrows(x0 = arc$xusr[n-1], x1 = arc$xusr[n], y0 = arc$yusr[n-1], y1 = arc$yusr[n], 
      length = arrowlength, code = arrowcode, angle = arrowangle, 
      col = col, lty = lty, lwd = lwd, ...)
  }
  
  if(result){return(arc)}
}

示例1——在2点之间添加多个不同度数的箭头弧

plot(1, t = "n", xlim = c(-4, 6), ylim = c(0,10), xlab = "", ylab = "")
points(x = c(0,1), y = c(4,6), pch = 16, cex = 1)
addArc(x0 = 0, x1 = 1, y0 = 4, y1 = 6, arcdeg = 90, col = 4, arrowlength = 0.1, lwd = 2)
addArc(x0 = 0, x1 = 1, y0 = 4, y1 = 6, arcdeg = -90, col = 4, arrowlength = 0.1, lwd = 2)
addArc(x0 = 0, x1 = 1, y0 = 4, y1 = 6, arcdeg = -180, col = 4, arrowlength = 0.1, lwd = 2)
addArc(x0 = 0, x1 = 1, y0 = 4, y1 = 6, arcdeg = -300, col = 4, arrowlength = 0.1, lwd = 2)

示例 2 - 连接框周围点的箭头

df <- data.frame(x = c(0,1,1,0.5,0.5,0, 0), y = c(0,0,1,1,0.5,0.5,0))
dfmid <- data.frame(x = df$x[-nrow(df)] + diff(df$x)/2,
  y = df$y[-nrow(df)] + diff(df$y)/2)
dfmid$arcdeg <- c(270, -90, 270, -270, 270, 270)
dfmid$col <- rainbow(nrow(dfmid))
plot(y ~ x, df, t = "n", xlim = c(-1,2), ylim = c(-1,2))
polygon(x = df$x, y = df$y, col = "grey70", border = NA)
points(y ~ x, dfmid)
for(i in seq(nrow(dfmid)-1)){
  addArc(x0 = dfmid$x[i], y0 = dfmid$y[i], x1 = dfmid$x[i+1], y1 = dfmid$y[i+1], 
    arcdeg = dfmid$arcdeg[i], arrowlength = 0.1, col = dfmid$col[i], 
    lwd = 3, lty = 1, n = 500, t = "l")
}