diff --git a/R/plot.R b/R/plot.R index 1421f7e5e08..47fec471a77 100644 --- a/R/plot.R +++ b/R/plot.R @@ -127,8 +127,8 @@ plot.igraph <- function( edge.label.color <- params("edge", "label.color") elab.x <- params("edge", "label.x") elab.y <- params("edge", "label.y") - arrow.size <- params("edge", "arrow.size")[1] - arrow.width <- params("edge", "arrow.width")[1] + arrow.size <- params("edge", "arrow.size") + arrow.width <- params("edge", "arrow.width") curved <- params("edge", "curved") if (is.function(curved)) { curved <- curved(graph) @@ -1611,204 +1611,163 @@ rglplot.igraph <- function(x, ...) { # slightly modified: code argument added #' @importFrom graphics par xyinch segments xspline lines polygon -igraph.Arrows <- - function( - x1, - y1, - x2, - y2, - code = 2, - size = 1, - width = 1.2 / 4 / cin, - open = TRUE, - sh.adj = 0.1, - sh.lwd = 1, - sh.col = par("fg"), - sh.lty = 1, - h.col = sh.col, - h.col.bo = sh.col, - h.lwd = sh.lwd, - h.lty = sh.lty, - curved = FALSE - ) { - ## Author: Andreas Ruckstuhl, refined by Rene Locher - ## Version: 2005-10-17 - cin <- size * par("cin")[2] - width <- width * (1.2 / 4 / cin) - uin <- 1 / xyinch() +# Vectorized and modular igraph.Arrows refactor +igraph.Arrows <- function( + x1, + y1, + x2, + y2, + code = 2, + size = 1, + width = 1.2 / 4 / par("cin")[2], + open = TRUE, + sh.adj = 0.1, + sh.lwd = 1, + sh.col = par("fg"), + sh.lty = 1, + h.col = sh.col, + h.col.bo = sh.col, + h.lwd = sh.lwd, + h.lty = sh.lty, + curved = FALSE +) { + n <- length(x1) + + recycle <- function(x) rep(x, length.out = n) + + x1 <- recycle(x1) + y1 <- recycle(y1) + x2 <- recycle(x2) + y2 <- recycle(y2) + size <- recycle(size) + width <- recycle(width) + curved <- recycle(curved) + sh.lwd <- recycle(sh.lwd) + sh.col <- recycle(sh.col) + sh.lty <- recycle(sh.lty) + h.col <- recycle(h.col) + h.col.bo <- recycle(h.col.bo) + h.lwd <- recycle(h.lwd) + h.lty <- recycle(h.lty) + + uin <- 1 / xyinch() + + label_x <- numeric(n) + label_y <- numeric(n) + + for (i in seq_len(n)) { + cin <- size[i] * par("cin")[2] + w <- width[i] * (1.2 / 4 / cin) + delta <- sqrt(h.lwd[i]) * par("cin")[2] * 0.005 + + # Arrowhead shape x <- sqrt(seq(0, cin^2, length.out = floor(35 * cin) + 2)) - delta <- sqrt(h.lwd) * par("cin")[2] * 0.005 ## has been 0.05 x.arr <- c(-rev(x), -x) - wx2 <- width * x^2 + wx2 <- w * x^2 y.arr <- c(-rev(wx2 + delta), wx2 + delta) deg.arr <- c(atan2(y.arr, x.arr), NA) r.arr <- c(sqrt(x.arr^2 + y.arr^2), NA) - ## backup - bx1 <- x1 - bx2 <- x2 - by1 <- y1 - by2 <- y2 - - ## shaft - lx <- length(x1) - r.seg <- rep(cin * sh.adj, lx) - theta1 <- atan2((y1 - y2) * uin[2], (x1 - x2) * uin[1]) - th.seg1 <- theta1 + rep(atan2(0, -cin), lx) - theta2 <- atan2((y2 - y1) * uin[2], (x2 - x1) * uin[1]) - th.seg2 <- theta2 + rep(atan2(0, -cin), lx) + theta1 <- atan2((y1[i] - y2[i]) * uin[2], (x1[i] - x2[i]) * uin[1]) + theta2 <- atan2((y2[i] - y1[i]) * uin[2], (x2[i] - x1[i]) * uin[1]) + r.seg <- cin * sh.adj + x1d <- y1d <- x2d <- y2d <- 0 if (code %in% c(1, 3)) { - x2d <- r.seg * cos(th.seg2) / uin[1] - y2d <- r.seg * sin(th.seg2) / uin[2] + x2d <- r.seg * cos(theta2) / uin[1] + y2d <- r.seg * sin(theta2) / uin[2] } if (code %in% c(2, 3)) { - x1d <- r.seg * cos(th.seg1) / uin[1] - y1d <- r.seg * sin(th.seg1) / uin[2] + x1d <- r.seg * cos(theta1) / uin[1] + y1d <- r.seg * sin(theta1) / uin[2] } - if ( - is.logical(curved) && all(!curved) || is.numeric(curved) && all(!curved) - ) { + + sx1 <- x1[i] + x1d + sy1 <- y1[i] + y1d + sx2 <- x2[i] + x2d + sy2 <- y2[i] + y2d + + if (!curved[i]) { segments( - x1 + x1d, - y1 + y1d, - x2 + x2d, - y2 + y2d, - lwd = sh.lwd, - col = sh.col, - lty = sh.lty + sx1, + sy1, + sx2, + sy2, + lwd = sh.lwd[i], + col = sh.col[i], + lty = sh.lty[i] ) - phi <- atan2(y1 - y2, x1 - x2) - r <- sqrt((x1 - x2)^2 + (y1 - y2)^2) - lc.x <- x2 + 2 / 3 * r * cos(phi) - lc.y <- y2 + 2 / 3 * r * sin(phi) + phi <- atan2(y1[i] - y2[i], x1[i] - x2[i]) + r <- sqrt((x1[i] - x2[i])^2 + (y1[i] - y2[i])^2) + label_x[i] <- x2[i] + 2 / 3 * r * cos(phi) + label_y[i] <- y2[i] + 2 / 3 * r * sin(phi) } else { - if (is.numeric(curved)) { - lambda <- curved - } else { - lambda <- as.logical(curved) * 0.5 + lambda <- if (is.numeric(curved)) curved[i] else 0.5 + midx <- (x1[i] + x2[i]) / 2 + midy <- (y1[i] + y2[i]) / 2 + spx <- midx - lambda * 1 / 2 * (sy2 - sy1) + spy <- midy + lambda * 1 / 2 * (sx2 - sx1) + + spl <- xspline( + x = c(sx1, spx, sx2), + y = c(sy1, spy, sy2), + shape = 1, + draw = FALSE + ) + lines(spl, lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i]) + label_x[i] <- spl$x[round(2 / 3 * length(spl$x))] + label_y[i] <- spl$y[round(2 / 3 * length(spl$y))] + + if (code %in% c(2, 3)) { + x1[i] <- spl$x[round(3 / 4 * length(spl$x))] + y1[i] <- spl$y[round(3 / 4 * length(spl$y))] } - lambda <- rep(lambda, length.out = length(x1)) - c.x1 <- x1 + x1d - c.y1 <- y1 + y1d - c.x2 <- x2 + x2d - c.y2 <- y2 + y2d - - midx <- (x1 + x2) / 2 - midy <- (y1 + y2) / 2 - spx <- midx - lambda * 1 / 2 * (c.y2 - c.y1) - spy <- midy + lambda * 1 / 2 * (c.x2 - c.x1) - sh.col <- rep(sh.col, length.out = length(c.x1)) - sh.lty <- rep(sh.lty, length.out = length(c.x1)) - sh.lwd <- rep(sh.lwd, length.out = length(c.x1)) - lc.x <- lc.y <- numeric(length(c.x1)) - - for (i in seq_len(length(c.x1))) { - ## Straight line? - if (lambda[i] == 0) { - segments( - c.x1[i], - c.y1[i], - c.x2[i], - c.y2[i], - lwd = sh.lwd[i], - col = sh.col[i], - lty = sh.lty[i] - ) - phi <- atan2(y1[i] - y2[i], x1[i] - x2[i]) - r <- sqrt((x1[i] - x2[i])^2 + (y1[i] - y2[i])^2) - lc.x[i] <- x2[i] + 2 / 3 * r * cos(phi) - lc.y[i] <- y2[i] + 2 / 3 * r * sin(phi) - } else { - spl <- xspline( - x = c(c.x1[i], spx[i], c.x2[i]), - y = c(c.y1[i], spy[i], c.y2[i]), - shape = 1, - draw = FALSE - ) - lines(spl, lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i]) - if (code %in% c(2, 3)) { - x1[i] <- spl$x[3 * length(spl$x) / 4] - y1[i] <- spl$y[3 * length(spl$y) / 4] - } - if (code %in% c(1, 3)) { - x2[i] <- spl$x[length(spl$x) / 4] - y2[i] <- spl$y[length(spl$y) / 4] - } - lc.x[i] <- spl$x[2 / 3 * length(spl$x)] - lc.y[i] <- spl$y[2 / 3 * length(spl$y)] - } + if (code %in% c(1, 3)) { + x2[i] <- spl$x[round(1 / 4 * length(spl$x))] + y2[i] <- spl$y[round(1 / 4 * length(spl$y))] } } - ## forward arrowhead - if (code %in% c(2, 3)) { - theta <- atan2((by2 - y1) * uin[2], (bx2 - x1) * uin[1]) - Rep <- rep(length(deg.arr), lx) - p.x2 <- rep(bx2, Rep) - p.y2 <- rep(by2, Rep) - ttheta <- rep(theta, Rep) + rep(deg.arr, lx) - r.arr.rep <- rep(r.arr, lx) + draw_arrowhead <- function(px, py, theta) { + px2 <- rep(px, length(deg.arr)) + py2 <- rep(py, length(deg.arr)) + ttheta <- rep(theta, length(deg.arr)) + deg.arr + + xhead <- px2 + r.arr * cos(ttheta) / uin[1] + yhead <- py2 + r.arr * sin(ttheta) / uin[2] + if (open) { - lines( - (p.x2 + r.arr.rep * cos(ttheta) / uin[1]), - (p.y2 + r.arr.rep * sin(ttheta) / uin[2]), - lwd = h.lwd, - col = h.col.bo, - lty = h.lty - ) + lines(xhead, yhead, lwd = h.lwd[i], col = h.col.bo[i], lty = h.lty[i]) } else { polygon( - p.x2 + r.arr.rep * cos(ttheta) / uin[1], - p.y2 + r.arr * sin(ttheta) / uin[2], - col = h.col, - lwd = h.lwd, - border = h.col.bo, - lty = h.lty + xhead, + yhead, + col = h.col[i], + lwd = h.lwd[i], + border = h.col.bo[i], + lty = h.lty[i] ) } } - ## backward arrow head + if (code %in% c(2, 3)) { + draw_arrowhead( + x2[i], + y2[i], + atan2((y2[i] - y1[i]) * uin[2], (x2[i] - x1[i]) * uin[1]) + ) + } if (code %in% c(1, 3)) { - x1 <- bx1 - y1 <- by1 - tmp <- x1 - x1 <- x2 - x2 <- tmp - tmp <- y1 - y1 <- y2 - y2 <- tmp - theta <- atan2((y2 - y1) * uin[2], (x2 - x1) * uin[1]) - lx <- length(x1) - Rep <- rep(length(deg.arr), lx) - p.x2 <- rep(x2, Rep) - p.y2 <- rep(y2, Rep) - ttheta <- rep(theta, Rep) + rep(deg.arr, lx) - r.arr.rep <- rep(r.arr, lx) - - if (open) { - lines( - (p.x2 + r.arr.rep * cos(ttheta) / uin[1]), - (p.y2 + r.arr.rep * sin(ttheta) / uin[2]), - lwd = h.lwd, - col = h.col.bo, - lty = h.lty - ) - } else { - polygon( - p.x2 + r.arr.rep * cos(ttheta) / uin[1], - p.y2 + r.arr.rep * sin(ttheta) / uin[2], - col = h.col, - lwd = h.lwd, - border = h.col.bo, - lty = h.lty - ) - } + draw_arrowhead( + x1[i], + y1[i], + atan2((y1[i] - y2[i]) * uin[2], (x1[i] - x2[i]) * uin[1]) + ) } + } - list(lab.x = lc.x, lab.y = lc.y) - } # Arrows + list(lab.x = label_x, lab.y = label_y) +} #' @importFrom graphics xspline igraph.polygon <- function( diff --git a/R/plot.common.R b/R/plot.common.R index 06a3327b9b9..6350f1a683f 100644 --- a/R/plot.common.R +++ b/R/plot.common.R @@ -252,24 +252,10 @@ #' The width of the edges. The default value is 1. #' } #' \item{arrow.size}{ -#' The size of the arrows. Currently this is a constant, so it is the same for every edge. -#' If a vector is submitted then only the first element is used, -#' ie. if this is taken from an edge attribute -#' then only the attribute of the first edge is used for all arrows. -#' This will likely change in the future. -#' -#' The default value is 1. +#' The size of the arrows. The default value is 1. #' } #' \item{arrow.width}{ -#' The width of the arrows. Currently this is a constant, so it is the same for every edge. -#' If a vector is submitted then only the first element is used, -#' ie. if this is taken from an edge attribute -#' then only the attribute of the first edge is used for all arrows. -#' This will likely change in the future. -#' -#' This argument is currently only used by [plot.igraph()]. -#' -#' The default value is 1, which gives the same width as before this option appeared in igraph. +#' The width of the arrows. The default value is 1. #' } #' \item{lty}{ #' The line type for the edges. Almost the diff --git a/man/plot.common.Rd b/man/plot.common.Rd index 99c01689b73..b9b4fb750d9 100644 --- a/man/plot.common.Rd +++ b/man/plot.common.Rd @@ -261,24 +261,10 @@ By default this parameter is \code{darkgrey}. The width of the edges. The default value is 1. } \item{arrow.size}{ -The size of the arrows. Currently this is a constant, so it is the same for every edge. -If a vector is submitted then only the first element is used, -ie. if this is taken from an edge attribute -then only the attribute of the first edge is used for all arrows. -This will likely change in the future. - -The default value is 1. +The size of the arrows. The default value is 1. } \item{arrow.width}{ -The width of the arrows. Currently this is a constant, so it is the same for every edge. -If a vector is submitted then only the first element is used, -ie. if this is taken from an edge attribute -then only the attribute of the first edge is used for all arrows. -This will likely change in the future. - -This argument is currently only used by \code{\link[=plot.igraph]{plot.igraph()}}. - -The default value is 1, which gives the same width as before this option appeared in igraph. +The width of the arrows. The default value is 1. } \item{lty}{ The line type for the edges. Almost the diff --git a/tests/testthat/_snaps/plot/rectangle-edges.svg b/tests/testthat/_snaps/plot/rectangle-edges.svg index b28a9769dd4..011a8cf4221 100644 --- a/tests/testthat/_snaps/plot/rectangle-edges.svg +++ b/tests/testthat/_snaps/plot/rectangle-edges.svg @@ -25,21 +25,21 @@ - - - - - - - - + + + + + + + + diff --git a/tests/testthat/_snaps/plot/standard-arrow-modes.svg b/tests/testthat/_snaps/plot/standard-arrow-modes.svg new file mode 100644 index 00000000000..8ccc1656b5e --- /dev/null +++ b/tests/testthat/_snaps/plot/standard-arrow-modes.svg @@ -0,0 +1,46 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 + + diff --git a/tests/testthat/_snaps/plot/standard-arrow-sizes.svg b/tests/testthat/_snaps/plot/standard-arrow-sizes.svg new file mode 100644 index 00000000000..b99add14423 --- /dev/null +++ b/tests/testthat/_snaps/plot/standard-arrow-sizes.svg @@ -0,0 +1,45 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 + + diff --git a/tests/testthat/_snaps/plot/standard-arrow.svg b/tests/testthat/_snaps/plot/standard-arrow.svg new file mode 100644 index 00000000000..6025f506d67 --- /dev/null +++ b/tests/testthat/_snaps/plot/standard-arrow.svg @@ -0,0 +1,45 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 + + diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index d444050058f..171f6bb7568 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -131,3 +131,26 @@ test_that("Edges stop at outside of rectangle node", { vdiffr::expect_doppelganger("rectangle-edges", rectangle_edges) }) + +test_that("Arrow drawing works correctly", { + standard_arrow <- function() { + g <- make_graph(c(1, 2, 1, 3, 2, 4), directed = TRUE) + g$layout <- cbind(1:4, rep(0, 4)) + plot(g) + } + vdiffr::expect_doppelganger("standard-arrow", standard_arrow) + + standard_arrow_modes <- function() { + g <- make_graph(c(1, 2, 2, 3, 3, 4), directed = TRUE) + g$layout <- cbind(1:4, rep(0, 4)) + plot(g, edge.arrow.mode = c(1,2,3)) + } + vdiffr::expect_doppelganger("standard-arrow-modes", standard_arrow_modes) + + standard_arrow_sizes <- function() { + g <- make_graph(c(1, 2, 2, 3, 3, 4), directed = TRUE) + g$layout <- cbind(1:4, rep(0, 4)) + plot(g, edge.arrow.size = c(1,2,3)) + } + vdiffr::expect_doppelganger("standard-arrow-sizes", standard_arrow_sizes) +})