From dd4e21c2f5db58ec46c26ea13377b62c5344beb0 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Tue, 23 Jun 2026 21:31:30 +0200 Subject: [PATCH 01/30] test: extend plotting test coverage ahead of refactor Add a behavior-locking safety net for the plotting subsystem before the planned refactor of parameter resolution and edge subsetting. - New test-plot-params.R: unit tests for i.parse.plot.params() precedence, recycling, and NA handling, plus the getter helpers (i.get.arrow.mode, i.get.labels, i.get.main/xlab, igraph.check.shapes, curve_multiple, i.rescale.vertex). - test-plot.shapes.R: clip-math tests for non-circle shapes, including the per-endpoint vertex.size vector selection. - test-plot.R: integration snapshots for vector edge params across loops and non-loops, auto-curved multi-edges, NA-attribute warning, multi-group mark.groups, label.dist/degree, add=TRUE overlay, and palette indexing. Co-Authored-By: Claude Opus 4.8 (1M context) --- tests/testthat/_snaps/plot-params.md | 8 + tests/testthat/_snaps/plot/add-overlay.svg | 53 +++++ .../_snaps/plot/label-dist-degree.svg | 43 ++++ .../_snaps/plot/mark-groups-multi.svg | 53 +++++ .../testthat/_snaps/plot/multi-edge-curve.svg | 45 ++++ tests/testthat/_snaps/plot/palette-index.svg | 43 ++++ .../_snaps/plot/vector-edge-params-loops.svg | 56 +++++ tests/testthat/test-plot-params.R | 206 ++++++++++++++++++ tests/testthat/test-plot.R | 112 ++++++++++ tests/testthat/test-plot.shapes.R | 66 +++++- 10 files changed, 684 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/_snaps/plot-params.md create mode 100644 tests/testthat/_snaps/plot/add-overlay.svg create mode 100644 tests/testthat/_snaps/plot/label-dist-degree.svg create mode 100644 tests/testthat/_snaps/plot/mark-groups-multi.svg create mode 100644 tests/testthat/_snaps/plot/multi-edge-curve.svg create mode 100644 tests/testthat/_snaps/plot/palette-index.svg create mode 100644 tests/testthat/_snaps/plot/vector-edge-params-loops.svg create mode 100644 tests/testthat/test-plot-params.R diff --git a/tests/testthat/_snaps/plot-params.md b/tests/testthat/_snaps/plot-params.md new file mode 100644 index 00000000000..9b9d0b0e294 --- /dev/null +++ b/tests/testthat/_snaps/plot-params.md @@ -0,0 +1,8 @@ +# igraph.check.shapes() aborts on unknown shapes + + Code + igraph.check.shapes(c("circle", "not_a_shape")) + Condition + Error in `igraph.check.shapes()`: + ! Bad vertex shapes: not_a_shape. + diff --git a/tests/testthat/_snaps/plot/add-overlay.svg b/tests/testthat/_snaps/plot/add-overlay.svg new file mode 100644 index 00000000000..389bb1a98ef --- /dev/null +++ b/tests/testthat/_snaps/plot/add-overlay.svg @@ -0,0 +1,53 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 + + + + + + + + + + +1 +2 +3 + + diff --git a/tests/testthat/_snaps/plot/label-dist-degree.svg b/tests/testthat/_snaps/plot/label-dist-degree.svg new file mode 100644 index 00000000000..1c33fe0c387 --- /dev/null +++ b/tests/testthat/_snaps/plot/label-dist-degree.svg @@ -0,0 +1,43 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +N +E +S +W + + diff --git a/tests/testthat/_snaps/plot/mark-groups-multi.svg b/tests/testthat/_snaps/plot/mark-groups-multi.svg new file mode 100644 index 00000000000..b5c25f1a881 --- /dev/null +++ b/tests/testthat/_snaps/plot/mark-groups-multi.svg @@ -0,0 +1,53 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 + + diff --git a/tests/testthat/_snaps/plot/multi-edge-curve.svg b/tests/testthat/_snaps/plot/multi-edge-curve.svg new file mode 100644 index 00000000000..1e66f8f19ba --- /dev/null +++ b/tests/testthat/_snaps/plot/multi-edge-curve.svg @@ -0,0 +1,45 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 + + diff --git a/tests/testthat/_snaps/plot/palette-index.svg b/tests/testthat/_snaps/plot/palette-index.svg new file mode 100644 index 00000000000..5cbdd07ea80 --- /dev/null +++ b/tests/testthat/_snaps/plot/palette-index.svg @@ -0,0 +1,43 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 + + diff --git a/tests/testthat/_snaps/plot/vector-edge-params-loops.svg b/tests/testthat/_snaps/plot/vector-edge-params-loops.svg new file mode 100644 index 00000000000..b395f738243 --- /dev/null +++ b/tests/testthat/_snaps/plot/vector-edge-params-loops.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + +c + + + +d + + + + + + +a +b +e + + + + + +1 +2 +3 + + diff --git a/tests/testthat/test-plot-params.R b/tests/testthat/test-plot-params.R new file mode 100644 index 00000000000..63e313b9fe5 --- /dev/null +++ b/tests/testthat/test-plot-params.R @@ -0,0 +1,206 @@ +# Unit tests for the (non-exported) plotting parameter-resolution machinery and +# getter helpers in R/plot.common.R. These are fast, mostly device-free tests +# that pin down behavior before the planned plotting refactor. + +# --------------------------------------------------------------------------- +# i.parse.plot.params(): precedence, routing, recycling, NA handling +# --------------------------------------------------------------------------- + +test_that("i.parse.plot.params() resolves arg > attr > option > default", { + g <- make_ring(3) + + # default: nothing set anywhere -> hard-coded default (vertex color = 1) + p_default <- i.parse.plot.params(g, list()) + expect_equal(p_default("vertex", "color"), 1) + + # option beats default + withr::local_options(igraph_verbose = FALSE) + local_igraph_options(vertex.color = "green") + p_opt <- i.parse.plot.params(g, list()) + expect_equal(p_opt("vertex", "color"), "green") + + # graph attribute beats option + ga <- set_vertex_attr(g, "color", value = rep("red", 3)) + p_attr <- i.parse.plot.params(ga, list()) + expect_equal(p_attr("vertex", "color"), rep("red", 3)) + + # explicit argument beats everything + p_arg <- i.parse.plot.params(ga, list(vertex.color = "blue")) + expect_equal(p_arg("vertex", "color"), "blue") +}) + +test_that("i.parse.plot.params() routes vertex./edge./plain prefixes", { + g <- make_ring(3) + p <- i.parse.plot.params( + g, + list(vertex.size = 99, edge.width = 7, margin = 0.5) + ) + expect_equal(p("vertex", "size"), 99) + expect_equal(p("edge", "width"), 7) + expect_equal(p("plot", "margin"), 0.5) +}) + +test_that("i.parse.plot.params() calls function-valued defaults with the graph", { + g <- make_ring(3) + g <- set_vertex_attr(g, "name", value = c("a", "b", "c")) + p <- i.parse.plot.params(g, list()) + + # vertex label default is i.get.labels(), which returns the name attribute + expect_equal(p("vertex", "label"), c("a", "b", "c")) + + # dontcall = TRUE returns the function itself rather than calling it + expect_true(is.function(p("vertex", "label", dontcall = TRUE))) +}) + +test_that("i.parse.plot.params() selects a single recycled element via range", { + g <- make_ring(3) + + # scalar value: returned as-is for a scalar range + p_scalar <- i.parse.plot.params(g, list(vertex.size = 5)) + expect_equal(p_scalar("vertex", "size", range = 2), 5) + + # vector value: 0-based index into rep(v, length.out = range + 1) + p_vec <- i.parse.plot.params(g, list(vertex.size = c(10, 20))) + expect_equal(p_vec("vertex", "size", range = 0), 10) + expect_equal(p_vec("vertex", "size", range = 1), 20) + expect_equal(p_vec("vertex", "size", range = 2), 10) # recycles +}) + +test_that("i.parse.plot.params() warns and replaces NA in non-label attributes", { + g <- make_ring(3) + g <- set_vertex_attr(g, "color", value = c("red", NA, "blue")) + p <- i.parse.plot.params(g, list()) + + expect_warning(res <- p("vertex", "color"), "contains NAs") + # NA replaced with the default vertex color (1), coerced into the vector + expect_false(anyNA(res)) + expect_equal(res[c(1, 3)], c("red", "blue")) +}) + +test_that("i.parse.plot.params() silently replaces NA labels with empty string", { + g <- make_ring(3) + g <- set_vertex_attr(g, "label", value = c("a", NA, "c")) + p <- i.parse.plot.params(g, list()) + + expect_no_warning(res <- p("vertex", "label")) + expect_equal(res, c("a", "", "c")) +}) + +# --------------------------------------------------------------------------- +# i.get.arrow.mode() +# --------------------------------------------------------------------------- + +test_that("i.get.arrow.mode() maps character arrow specs to numeric codes", { + g <- make_ring(3, directed = TRUE) + expect_equal( + i.get.arrow.mode(g, c("<", "<-", ">", "->", "<>", "<->", "x")), + c(1, 1, 2, 2, 3, 3, 0) + ) +}) + +test_that("i.get.arrow.mode() reads a vertex attribute via the 'a:' prefix", { + g <- make_ring(2, directed = TRUE) + g <- set_vertex_attr(g, "am", value = c("->", "<-")) + expect_equal(i.get.arrow.mode(g, "a:am"), c(2, 1)) +}) + +test_that("i.get.arrow.mode() defaults by graph directedness when NULL", { + expect_equal(i.get.arrow.mode(make_ring(3, directed = TRUE), NULL), 2) + expect_equal(i.get.arrow.mode(make_ring(3, directed = FALSE), NULL), 0) +}) + +# --------------------------------------------------------------------------- +# label getters +# --------------------------------------------------------------------------- + +test_that("i.get.labels() uses the name attribute, else vertex indices", { + g_named <- set_vertex_attr(make_ring(3), "name", value = c("x", "y", "z")) + expect_equal(i.get.labels(g_named), c("x", "y", "z")) + + expect_equal(i.get.labels(make_ring(3)), 1:3) +}) + +test_that("i.get.edge.labels() defaults to an NA vector of edge length", { + g <- make_ring(4) + res <- i.get.edge.labels(g) + expect_length(res, ecount(g)) + expect_true(all(is.na(res))) +}) + +# --------------------------------------------------------------------------- +# i.get.main() / i.get.xlab() and annotate.plot +# --------------------------------------------------------------------------- + +test_that("i.get.main()/i.get.xlab() respect the annotate.plot option", { + g <- make_ring(3) + g$name <- "my graph" + + # default: no annotation + expect_identical(i.get.main(g), "") + expect_identical(i.get.xlab(g), "") + + # with annotate.plot = TRUE, return graph metadata + local_igraph_options(annotate.plot = TRUE) + expect_identical(i.get.main(g), "my graph") + expect_match(i.get.xlab(g), "3 vertices") + expect_match(i.get.xlab(g), "3 edges") +}) + +# --------------------------------------------------------------------------- +# igraph.check.shapes() +# --------------------------------------------------------------------------- + +test_that("igraph.check.shapes() passes valid shapes through", { + expect_equal( + igraph.check.shapes(c("circle", "square")), + c("circle", "square") + ) +}) + +test_that("igraph.check.shapes() aborts on unknown shapes", { + expect_snapshot_igraph_error({ + igraph.check.shapes(c("circle", "not_a_shape")) + }) +}) + +# --------------------------------------------------------------------------- +# curve_multiple() +# --------------------------------------------------------------------------- + +test_that("curve_multiple() returns zero curvature for a simple graph", { + g <- make_ring(4) + expect_equal(curve_multiple(g), rep(0, ecount(g))) +}) + +test_that("curve_multiple() spreads symmetric curvature across multi-edges", { + # two parallel edges in the same direction share an edgelist key + g <- make_graph(c(1, 2, 1, 2), directed = TRUE) + expect_equal(curve_multiple(g), c(-0.5, 0.5)) + + # reciprocal edges (1->2, 2->1) are distinct keys, so each stays 0 + g2 <- make_graph(c(1, 2, 2, 1), directed = TRUE) + expect_equal(curve_multiple(g2), c(0, 0)) +}) + +# --------------------------------------------------------------------------- +# i.rescale.vertex() -- needs an open device for par("usr") +# --------------------------------------------------------------------------- + +test_that("i.rescale.vertex() clamps sizes to the relative-size range", { + grDevices::pdf(NULL) + withr::defer(grDevices::dev.off()) + plot(0, 0, type = "n", xlim = c(-1, 1), ylim = c(-1, 1)) + + minmax <- c(0.01, 0.025) + res <- i.rescale.vertex(c(10, 20, 30), minmax.relative.size = minmax) + + usr <- par("usr")[1:2] + scal <- (usr[2] - usr[1]) * minmax + + expect_length(res, 3) + # smallest input maps to the lower bound, largest to the upper bound + expect_equal(res[1], scal[1]) + expect_equal(res[3], scal[2]) + # monotonic increasing in between + expect_true(all(diff(res) > 0)) +}) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index bbc29010ab8..3e17443c05b 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -234,6 +234,118 @@ test_that("mark border linewidth", { vdiffr::expect_doppelganger("mark-border-lwd", mark_border_lwd) }) +test_that("vector edge params are subset correctly across loops and non-loops", { + # Guards the per-edge subsetting of loop vs non-loop edges in plot.igraph(). + skip_if_not_installed("vdiffr") + + vector_edge_params <- function() { + # edges: 1->2, 2->3, 1->1 (loop), 3->3 (loop), 2->1 + g <- make_graph(c(1, 2, 2, 3, 1, 1, 3, 3, 2, 1), directed = TRUE) + V(g)$x <- c(0, 1, 2) + V(g)$y <- c(0, 1, 0) + ne <- ecount(g) + plot( + g, + edge.color = c("red", "green", "blue", "orange", "purple"), + edge.width = c(1, 2, 3, 4, 5), + edge.lty = c(1, 2, 1, 2, 1), + edge.arrow.mode = c(1, 2, 3, 2, 1), + edge.arrow.size = c(1, 1.5, 2, 1.5, 1), + edge.label = letters[seq_len(ne)], + edge.label.color = c("red", "green", "blue", "orange", "purple"), + margin = 0.3 + ) + } + vdiffr::expect_doppelganger("vector-edge-params-loops", vector_edge_params) +}) + +test_that("multi-edges are auto-curved", { + skip_if_not_installed("vdiffr") + + multi_edge_curve <- function() { + g <- make_graph(c(1, 2, 1, 2, 1, 2, 2, 3), directed = TRUE) + V(g)$x <- c(0, 2, 4) + V(g)$y <- c(0, 0, 0) + plot(g, edge.curved = TRUE, margin = 0.3) + } + vdiffr::expect_doppelganger("multi-edge-curve", multi_edge_curve) +}) + +test_that("NA in a vertex attribute warns and still plots", { + g <- make_ring(3) + V(g)$color <- c("red", NA, "blue") + g$layout <- cbind(1:3, rep(0, 3)) + + grDevices::pdf(NULL) + withr::defer(grDevices::dev.off()) + expect_warning(plot(g), "contains NAs") +}) + +test_that("mark.groups draws multiple overlapping groups", { + skip_if_not_installed("vdiffr") + + mark_groups_multi <- function() { + g <- make_full_graph(5) + V(g)$x <- c(0, 1, 2, 1, 0) + V(g)$y <- c(0, 0, 1, 2, 2) + plot( + g, + mark.groups = list(c(1, 2, 3), c(3, 4, 5)), + mark.col = c("#ffcccc", "#ccccff"), + mark.border = c("red", "blue"), + margin = 0.5 + ) + } + vdiffr::expect_doppelganger("mark-groups-multi", mark_groups_multi) +}) + +test_that("label.dist and label.degree position labels", { + skip_if_not_installed("vdiffr") + + label_dist_degree <- function() { + g <- make_ring(4) + g$layout <- layout_in_circle(g) + plot( + g, + vertex.label = c("N", "E", "S", "W"), + vertex.label.dist = 2, + vertex.label.degree = c(pi / 2, 0, -pi / 2, pi), + margin = 0.4 + ) + } + vdiffr::expect_doppelganger("label-dist-degree", label_dist_degree) +}) + +test_that("add = TRUE overlays a second graph on the same device", { + skip_if_not_installed("vdiffr") + + overlay <- function() { + g1 <- make_ring(3) + g1$layout <- cbind(c(0, 1, 2), c(0, 0, 0)) + g2 <- make_ring(3) + g2$layout <- cbind(c(0, 1, 2), c(1, 1, 1)) + plot(g1, rescale = FALSE, xlim = c(-1, 3), ylim = c(-1, 2), vertex.color = "red") + plot(g2, rescale = FALSE, add = TRUE, vertex.color = "blue") + } + vdiffr::expect_doppelganger("add-overlay", overlay) +}) + +test_that("numeric vertex.color indexes into a custom palette", { + skip_if_not_installed("vdiffr") + + palette_index <- function() { + g <- make_ring(4) + g$layout <- layout_in_circle(g) + plot( + g, + vertex.color = c(1, 2, 3, 4), + palette = categorical_pal(4), + vertex.size = 30 + ) + } + vdiffr::expect_doppelganger("palette-index", palette_index) +}) + test_that("plot rescales correctly", { skip_if_not_installed("vdiffr") rescale_coords <- function() { diff --git a/tests/testthat/test-plot.shapes.R b/tests/testthat/test-plot.shapes.R index 37ea9ae1f13..b71e1205b7c 100644 --- a/tests/testthat/test-plot.shapes.R +++ b/tests/testthat/test-plot.shapes.R @@ -119,13 +119,77 @@ test_that("clipping handles empty coordinates", { el <- matrix(numeric(0), nrow = 0, ncol = 2) params <- function(type, param) 1 - for (shape_name in c("circle", "square", "rectangle")) { + built_in <- c( + "circle", "square", "csquare", "rectangle", "crectangle", + "vrectangle", "pie" + ) + for (shape_name in built_in) { clip_func <- shapes(shape_name)$clip result <- clip_func(empty_coords, el, params, "both") expect_equal(nrow(result), 0) } }) +test_that("non-circle clip functions return the right column structure", { + # diagonal edge from (0,0) to (10,10) + coords <- matrix(c(0, 0, 10, 10), nrow = 1) + el <- matrix(c(1, 2), nrow = 1) + params <- function(type, param) { + switch(param, "size" = 2, "size2" = 2, 1) + } + + all_clip <- c("square", "csquare", "rectangle", "crectangle", "vrectangle", "pie") + for (shape_name in all_clip) { + clip_func <- shapes(shape_name)$clip + expect_equal(ncol(clip_func(coords, el, params, "from")), 2, info = shape_name) + expect_equal(ncol(clip_func(coords, el, params, "to")), 2, info = shape_name) + expect_equal(ncol(clip_func(coords, el, params, "both")), 4, info = shape_name) + } +}) + +test_that("non-centered clip functions clip endpoints inward", { + # diagonal edge from (0,0) to (10,10) + coords <- matrix(c(0, 0, 10, 10), nrow = 1) + el <- matrix(c(1, 2), nrow = 1) + params <- function(type, param) { + switch(param, "size" = 2, "size2" = 2, 1) + } + + # csquare/crectangle clip to a face-center (can sit on an axis for a 45 deg + # edge), so the inward check applies only to the non-centered shapes. + for (shape_name in c("square", "rectangle", "vrectangle", "pie")) { + clip_func <- shapes(shape_name)$clip + expect_true(clip_func(coords, el, params, "from")[1, 1] > 0, info = shape_name) + expect_true(clip_func(coords, el, params, "to")[1, 1] < 10, info = shape_name) + } +}) + +test_that("clip functions select vertex.size per endpoint from a vector", { + # Two identical diagonal edges, distinct from/to vertex indices, so that a + # per-vertex size vector must be indexed by el[, 1] (from) and el[, 2] (to). + # This pins the exact per-endpoint selection that the planned refactor + # deduplicates across shapes. + coords <- rbind(c(0, 0, 10, 10), c(0, 0, 10, 10)) + el <- rbind(c(1, 2), c(3, 4)) + sizes <- c(2, 2, 8, 8) # vertices 3 and 4 are larger + params <- function(type, param) { + if (param == "size") return(sizes) + 1 + } + + clip_func <- shapes("circle")$clip + + # "from" uses size[el[, 1]] = c(2, 8): the larger from-vertex (row 2) is + # clipped further along the edge, so its x is greater. + res_from <- clip_func(coords, el, params, "from") + expect_gt(res_from[2, 1], res_from[1, 1]) + + # "to" uses size[el[, 2]] = c(2, 8): the larger to-vertex (row 2) clips the + # endpoint back more, so its x is smaller. + res_to <- clip_func(coords, el, params, "to") + expect_lt(res_to[2, 1], res_to[1, 1]) +}) + test_that("all built-in shapes render correctly", { skip_if_not_installed("vdiffr") From 292fa71a45aa1c88d3ddd64be5a6eee1401630a4 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Tue, 23 Jun 2026 22:07:44 +0200 Subject: [PATCH 02/30] refactor(plot): remove duplicate default tables, name magic constants P1.4: drop the redundant second i.default.values[["edge"/"plot"]] assignments in plot.common.R (exact duplicates). P1.5: introduce VERTEX_SIZE_SCALE (1/200 size->user-coord factor) and ARROW_WIDTH_FACTOR (1.2/4 arrowhead scaling) in plot.R, applied across plot.igraph() and igraph.Arrows(). Behaviour-preserving; rglplot() occurrences left untouched (no snapshot coverage here). Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot.R | 31 +++++++++++++++++++++++-------- R/plot.common.R | 3 --- 2 files changed, 23 insertions(+), 11 deletions(-) diff --git a/R/plot.R b/R/plot.R index 1b0f390e6c7..ce849382a5c 100644 --- a/R/plot.R +++ b/R/plot.R @@ -19,6 +19,15 @@ # ################################################################### +# Vertex sizes and edge widths are specified on a 0-200 scale (a `vertex.size` +# of 15 is the default); this factor converts them to user coordinates, where +# the plotting region spans [-1, 1] after rescaling. +VERTEX_SIZE_SCALE <- 1 / 200 + +# Arrowhead width scaling factor used by igraph.Arrows(); combined with the +# character size from par("cin") to size arrowheads relative to the device. +ARROW_WIDTH_FACTOR <- 1.2 / 4 + #' Plotting of graphs #' #' `plot.igraph()` is able to plot graphs to any R device. It is the @@ -178,7 +187,7 @@ plot.igraph <- function( } layout <- norm_coords(layout, -1, 1, -1, 1) fact <- (1 - vertex.size.scaling) - maxv <- 1 / 200 * max(vertex.size) + maxv <- VERTEX_SIZE_SCALE * max(vertex.size) xlim <- c( xlim[1] - margin[2] - fact * maxv, @@ -257,12 +266,12 @@ plot.igraph <- function( params <- i.parse.plot.params( graph, list( - vertex.size = 1 / 200 * vertex.size, - vertex.size2 = 1 / 200 * params("vertex", "size2"), + vertex.size = VERTEX_SIZE_SCALE * vertex.size, + vertex.size2 = VERTEX_SIZE_SCALE * params("vertex", "size2"), ... ) ) - vertex.size <- 1 / 200 * vertex.size + vertex.size <- VERTEX_SIZE_SCALE * vertex.size } ################################################################ ## Mark vertex groups @@ -826,9 +835,15 @@ plot.igraph <- function( old_xpd <- par(xpd = TRUE) on.exit(par(old_xpd), add = TRUE) x <- layout[, 1] + - label.dist * cos(-label.degree) * (vertex.size + 6 * 8 * log10(2)) / 200 + label.dist * + cos(-label.degree) * + (vertex.size + 6 * 8 * log10(2)) * + VERTEX_SIZE_SCALE y <- layout[, 2] + - label.dist * sin(-label.degree) * (vertex.size + 6 * 8 * log10(2)) / 200 + label.dist * + sin(-label.degree) * + (vertex.size + 6 * 8 * log10(2)) * + VERTEX_SIZE_SCALE if (vc > 0) { label.col <- rep(label.color, length.out = vc) label.fam <- rep(label.family, length.out = vc) @@ -1734,7 +1749,7 @@ igraph.Arrows <- function( y2, code = 2, size = 1, - width = 1.2 / 4 / par("cin")[2], + width = ARROW_WIDTH_FACTOR / par("cin")[2], open = TRUE, sh.adj = 0.1, sh.lwd = 1, @@ -1772,7 +1787,7 @@ igraph.Arrows <- function( for (i in seq_len(n)) { cin <- size[i] * par("cin")[2] - w <- width[i] * (1.2 / 4 / cin) + w <- width[i] * (ARROW_WIDTH_FACTOR / cin) delta <- sqrt(h.lwd[i]) * par("cin")[2] * 0.005 # Arrowhead shape diff --git a/R/plot.common.R b/R/plot.common.R index d5beec08456..79e5d317ed4 100644 --- a/R/plot.common.R +++ b/R/plot.common.R @@ -4946,9 +4946,6 @@ i.rescale.vertex <- function( return(size) } -i.default.values[["edge"]] <- i.edge.default -i.default.values[["plot"]] <- i.plot.default - #' Using pie charts as vertices in graph plots #' #' More complex vertex images can be used to express addtional information From 4dbfcd27d7eb5afd3f9d228d58119ca39bde4f02 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Tue, 23 Jun 2026 22:13:36 +0200 Subject: [PATCH 03/30] refactor(plot): introduce Stage 1 edge aesthetic table (vctrs) Add R/plot-aes.R with i.aes_table()/i.edge_aes_table(), which package resolved per-edge plotting parameters into a vctrs data frame that can be sliced by edge index. Use it in plot.igraph() to replace the 11x repeated `if (length(x) > 1) x[loops.e]` block for loop edges with a single table build + vec_slice(). Behaviour-preserving: recycling keeps the historical rep(length.out=) semantics (downstream mapply/igraph.Arrows recycle anyway), so the strict-recycling change flagged in the plan is intentionally NOT adopted here (it needs a revdep check). The non-loop block's entangled per-arrow-code curved handling is left for the P2.4 consolidation step. Also document the resolution precedence on i.parse.plot.params() and add unit tests for the new table helpers. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-aes.R | 63 ++++++++++++++++++++++++++++++ R/plot.R | 64 ++++++++++++++----------------- R/plot.common.R | 11 ++++++ tests/testthat/test-plot-params.R | 35 +++++++++++++++++ 4 files changed, 137 insertions(+), 36 deletions(-) create mode 100644 R/plot-aes.R diff --git a/R/plot-aes.R b/R/plot-aes.R new file mode 100644 index 00000000000..16d77650fb6 --- /dev/null +++ b/R/plot-aes.R @@ -0,0 +1,63 @@ +# IGraph R package +# Copyright (C) 2003-2012 Gabor Csardi +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +################################################################### + +# Stage 1 of the plotting pipeline: turn resolved plotting parameters into a +# typed, rectangular aesthetic table so that downstream code can slice it by +# vertex/edge index instead of re-implementing the +# `if (length(x) > 1) x[idx]` idiom for every parameter. +# +# Aesthetic resolution itself (the precedence chain +# argument > graph attribute > igraph option > default) still lives in +# `i.parse.plot.params()`; this layer only packages the already-resolved values. + +# Build an aesthetic table from a named list of columns, each recycled to `n` +# rows. Recycling uses `rep(length.out = n)` to match the historical (lenient) +# plotting behavior; downstream consumers (`mapply()`, `igraph.Arrows()`) recycle +# their arguments anyway, so a length-1 column behaves identically whether it is +# kept scalar or expanded here. +# +# Returns a vctrs data frame, which is type-stable (no factor coercion) and can +# be subset with `vctrs::vec_slice()`. +i.aes_table <- function(cols, n) { + cols <- lapply(cols, function(x) rep(x, length.out = n)) + vctrs::new_data_frame(cols, n = as.integer(n)) +} + +# Edge aesthetic table for the per-edge visual properties that are subset by +# edge index when drawing loop vs. non-loop edges. `loop.angle` (nullable) and +# vertex-scoped properties are handled separately by the caller. +i.edge_aes_table <- function( + color, + width, + lty, + arrow.mode, + arrow.size, + curved, + label.color, + label.family, + label.font, + label.cex, + n +) { + i.aes_table( + list( + color = color, + width = width, + lty = lty, + arrow.mode = arrow.mode, + arrow.size = arrow.size, + curved = curved, + label.color = label.color, + label.family = label.family, + label.font = label.font, + label.cex = label.cex + ), + n = n + ) +} diff --git a/R/plot.R b/R/plot.R index ce849382a5c..4e7c7e3bba2 100644 --- a/R/plot.R +++ b/R/plot.R @@ -528,50 +528,42 @@ plot.igraph <- function( } } - ec <- edge.color - if (length(ec) > 1) { - ec <- ec[loops.e] - } + # vertex.size is vertex-scoped (indexed by the loop's vertex) and loop.angle + # is nullable, so both are handled outside the edge aesthetic table. vs <- vertex.size if (length(vertex.size) > 1) { vs <- vs[loops.v] } - ew <- edge.width - if (length(edge.width) > 1) { - ew <- ew[loops.e] - } la <- loop.angle if (length(loop.angle) > 1) { la <- la[loops.e] } - lty <- edge.lty - if (length(edge.lty) > 1) { - lty <- lty[loops.e] - } - arr <- arrow.mode - if (length(arrow.mode) > 1) { - arr <- arrow.mode[loops.e] - } - asize <- arrow.size - if (length(arrow.size) > 1) { - asize <- arrow.size[loops.e] - } - lcol <- edge.label.color - if (length(lcol) > 1) { - lcol <- lcol[loops.e] - } - lfam <- edge.label.family - if (length(lfam) > 1) { - lfam <- lfam[loops.e] - } - lfon <- edge.label.font - if (length(lfon) > 1) { - lfon <- lfon[loops.e] - } - lcex <- edge.label.cex - if (length(lcex) > 1) { - lcex <- lcex[loops.e] - } + + # Stage 1: resolve the per-edge aesthetics into a table once, then slice it + # by loop-edge index instead of repeating `if (length(x) > 1) x[loops.e]`. + edge_aes <- i.edge_aes_table( + color = edge.color, + width = edge.width, + lty = edge.lty, + arrow.mode = arrow.mode, + arrow.size = arrow.size, + curved = curved, + label.color = edge.label.color, + label.family = edge.label.family, + label.font = edge.label.font, + label.cex = edge.label.cex, + n = ecount(graph) + ) + loop_aes <- vctrs::vec_slice(edge_aes, loops.e) + ec <- loop_aes$color + ew <- loop_aes$width + lty <- loop_aes$lty + arr <- loop_aes$arrow.mode + asize <- loop_aes$arrow.size + lcol <- loop_aes$label.color + lfam <- loop_aes$label.family + lfon <- loop_aes$label.font + lcex <- loop_aes$label.cex # For each loop, assign unique angle within largest gap (flower petal style) # depending on the number of loops and the available angular space diff --git a/R/plot.common.R b/R/plot.common.R index 79e5d317ed4..ad0e6cde57a 100644 --- a/R/plot.common.R +++ b/R/plot.common.R @@ -527,6 +527,17 @@ autocurve.edges <- function(graph, start = 0.5) { # Common functions for plot and tkplot ################################################################### +# Resolve plotting parameters on demand. The returned closure `func(type, name)` +# looks a parameter up with the following precedence, highest first: +# 1. an explicit argument passed to plot() (vertex./edge./plain prefix) +# 2. a matching graph attribute (vertex_attr / edge_attr / graph_attr) +# 3. the corresponding igraph option (igraph_opt(".")) +# 4. the hard-coded default in i.default.values +# Function-valued defaults are evaluated with the graph; NAs in a resolved +# attribute are replaced with the default (or "" for labels). +# +# This closure is part of the public contract: user shapes registered via +# add_shape() receive it as their `params` argument and call params("vertex", .). i.parse.plot.params <- function(graph, params) { ## store the arguments p <- list(vertex = list(), edge = list(), plot = list()) diff --git a/tests/testthat/test-plot-params.R b/tests/testthat/test-plot-params.R index 63e313b9fe5..f9555c5b527 100644 --- a/tests/testthat/test-plot-params.R +++ b/tests/testthat/test-plot-params.R @@ -86,6 +86,41 @@ test_that("i.parse.plot.params() silently replaces NA labels with empty string", expect_equal(res, c("a", "", "c")) }) +# --------------------------------------------------------------------------- +# Stage 1 aesthetic tables (i.aes_table / i.edge_aes_table) +# --------------------------------------------------------------------------- + +test_that("i.aes_table recycles columns to n rows", { + tbl <- i.aes_table(list(a = 1, b = c("x", "y")), n = 4) + expect_s3_class(tbl, "data.frame") + expect_equal(nrow(tbl), 4) + expect_equal(tbl$a, rep(1, 4)) + expect_equal(tbl$b, c("x", "y", "x", "y")) +}) + +test_that("i.edge_aes_table expands scalars and is sliceable by edge index", { + tbl <- i.edge_aes_table( + color = "red", + width = c(1, 2, 3), + lty = 1, + arrow.mode = 2, + arrow.size = 1, + curved = 0, + label.color = "blue", + label.family = "serif", + label.font = 1, + label.cex = 1, + n = 3 + ) + expect_equal(nrow(tbl), 3) + expect_equal(tbl$color, rep("red", 3)) # scalar expanded + expect_equal(tbl$width, c(1, 2, 3)) # vector preserved + + sliced <- vctrs::vec_slice(tbl, c(1, 3)) + expect_equal(nrow(sliced), 2) + expect_equal(sliced$width, c(1, 3)) +}) + # --------------------------------------------------------------------------- # i.get.arrow.mode() # --------------------------------------------------------------------------- From 5b36a33a0f63902da7057469a73dc083dc4be24f Mon Sep 17 00:00:00 2001 From: David Schoch Date: Tue, 23 Jun 2026 22:15:46 +0200 Subject: [PATCH 04/30] refactor(plot): extract pure arrowhead geometry from igraph.Arrows (S2) Pull the arrowhead-outline computation out of the igraph.Arrows() drawing loop into i.arrowhead_shape(cin, w, delta), a pure function returning the head outline in polar form. Adds a device-free unit test for it (previously the geometry was only exercised indirectly via the standard-arrow* snapshots). Scoped to the arrowhead geometry; the shaft-endpoint and curved-path math remain inline (more entangled with drawing/mutation) and can follow in the P2.4 consolidation. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot.R | 28 +++++++++++++++++++++------- tests/testthat/test-plot.R | 15 +++++++++++++++ 2 files changed, 36 insertions(+), 7 deletions(-) diff --git a/R/plot.R b/R/plot.R index 4e7c7e3bba2..5c35fcef905 100644 --- a/R/plot.R +++ b/R/plot.R @@ -1732,6 +1732,23 @@ rglplot.igraph <- function(x, ...) { # This is taken from the IDPmisc package, # slightly modified: code argument added +# Pure geometry (Stage 2): the outline of an arrowhead in polar coordinates +# (angle + radius from the tip), used by igraph.Arrows() to draw or outline the +# head. Depends only on scalar inputs, so it is testable without a device. +# cin arrow length, already scaled by the character size (par("cin")) +# w arrow width factor +# delta line-width-dependent padding +i.arrowhead_shape <- function(cin, w, delta) { + x <- sqrt(seq(0, cin^2, length.out = floor(35 * cin) + 2)) + x.arr <- c(-rev(x), -x) + wx2 <- w * x^2 + y.arr <- c(-rev(wx2 + delta), wx2 + delta) + list( + deg.arr = c(atan2(y.arr, x.arr), NA), + r.arr = c(sqrt(x.arr^2 + y.arr^2), NA) + ) +} + #' @importFrom graphics par xyinch segments xspline lines polygon # Vectorized and modular igraph.Arrows refactor igraph.Arrows <- function( @@ -1782,13 +1799,10 @@ igraph.Arrows <- function( w <- width[i] * (ARROW_WIDTH_FACTOR / 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)) - x.arr <- c(-rev(x), -x) - 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) + # Arrowhead shape (pure geometry, see i.arrowhead_shape) + head <- i.arrowhead_shape(cin, w, delta) + deg.arr <- head$deg.arr + r.arr <- head$r.arr 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]) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 3e17443c05b..e5597558fca 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -234,6 +234,21 @@ test_that("mark border linewidth", { vdiffr::expect_doppelganger("mark-border-lwd", mark_border_lwd) }) +test_that("i.arrowhead_shape returns matched polar arrays ending in NA", { + # Pure geometry helper extracted from igraph.Arrows (Stage 2); device-free. + head <- i.arrowhead_shape(cin = 0.2, w = 1.5, delta = 0.01) + expect_named(head, c("deg.arr", "r.arr")) + expect_equal(length(head$deg.arr), length(head$r.arr)) + # both arrays terminate in NA (the pen-up marker for the outline) + expect_true(is.na(tail(head$deg.arr, 1))) + expect_true(is.na(tail(head$r.arr, 1))) + # radii are non-negative where defined + expect_true(all(head$r.arr >= 0, na.rm = TRUE)) + # larger arrows (bigger cin) produce more outline points + bigger <- i.arrowhead_shape(cin = 0.4, w = 1.5, delta = 0.01) + expect_gt(length(bigger$r.arr), length(head$r.arr)) +}) + test_that("vector edge params are subset correctly across loops and non-loops", { # Guards the per-edge subsetting of loop vs non-loop edges in plot.igraph(). skip_if_not_installed("vdiffr") From 8bc22b543f8dde7138e144e2e2356dc10884a3fc Mon Sep 17 00:00:00 2001 From: David Schoch Date: Tue, 23 Jun 2026 22:20:43 +0200 Subject: [PATCH 05/30] refactor(plot): hoist self-loop Bezier helpers out of plot.igraph (P2.1) Move the four nested functions (point.on.cubic.bezier, compute.bezier, plot.bezier, loop) from inside plot.igraph()'s body to file-level internal functions, renamed with an i. prefix. i.plot.bezier in particular avoids being mistaken for an S3 plot() method for class "bezier". This removes ~155 lines from the plot.igraph() body and makes the helpers independently reusable. The functions capture no enclosing state; loop's self-referential arg defaults (always supplied by the mapply call site) become harmless literals. Also drops a dead duplicate `ec <- edge.color` extraction left over from the Stage 1 change. Behaviour-preserving (loop-graph / multi-loops snapshots unchanged). The larger phase-helper extraction (plot_vertices/plot_labels) is deferred: threading the 40+ locals is higher risk than snapshot-only verification covers. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot.R | 321 ++++++++++++++++++++++++++++--------------------------- 1 file changed, 164 insertions(+), 157 deletions(-) diff --git a/R/plot.R b/R/plot.R index 5c35fcef905..b046c8200d6 100644 --- a/R/plot.R +++ b/R/plot.R @@ -28,6 +28,169 @@ VERTEX_SIZE_SCALE <- 1 / 200 # character size from par("cin") to size arrowheads relative to the device. ARROW_WIDTH_FACTOR <- 1.2 / 4 +# --- Self-loop / Bézier drawing helpers -------------------------------------- +# Hoisted out of plot.igraph()'s body (they capture no enclosing state). Named +# with an `i.` prefix; `i.plot.bezier` in particular must NOT be called +# `plot.bezier`, which R would treat as an S3 plot() method for class "bezier". + +# A single point on a cubic Bézier curve defined by control points `cp` (a 4x2 +# matrix) at parameter `t` in [0, 1]. +i.point.on.cubic.bezier <- function(cp, t) { + c <- 3 * (cp[2, ] - cp[1, ]) + b <- 3 * (cp[3, ] - cp[2, ]) - c + a <- cp[4, ] - cp[1, ] - c - b + + t2 <- t * t + t3 <- t * t * t + + a * t3 + b * t2 + c * t + cp[1, ] +} + +# `points` evenly spaced points along the cubic Bézier curve `cp`. +i.compute.bezier <- function(cp, points) { + dt <- seq(0, 1, by = 1 / (points - 1)) + sapply(dt, function(t) i.point.on.cubic.bezier(cp, t)) +} + +# Draw a Bézier curve with optional arrowheads at its ends. +i.plot.bezier <- function( + cp, + points, + color, + width, + arr, + lty, + arrow.size, + arr.w +) { + p <- i.compute.bezier(cp, points) + polygon(p[1, ], p[2, ], border = color, lwd = width, lty = lty) + if (arr == 1 || arr == 3) { + igraph.Arrows( + p[1, ncol(p) - 1], + p[2, ncol(p) - 1], + p[1, ncol(p)], + p[2, ncol(p)], + sh.col = color, + h.col = color, + size = arrow.size, + sh.lwd = width, + h.lwd = width, + open = FALSE, + code = 2, + width = arr.w + ) + } + if (arr == 2 || arr == 3) { + igraph.Arrows( + p[1, 2], + p[2, 2], + p[1, 1], + p[2, 1], + sh.col = color, + h.col = color, + size = arrow.size, + sh.lwd = width, + h.lwd = width, + open = FALSE, + code = 2, + width = arr.w + ) + } +} + +# Draw one self-loop as a rotated Bézier curve, plus its optional label. +# arrow.size/arr.w/loopSize defaults are placeholders only: every call site +# (the mapply() in plot.igraph) supplies them explicitly. +i.draw.loop <- function( + x0, + y0, + cx = x0, + cy = y0, + color, + angle = 0, + label = NA, + label.color, + label.font, + label.family, + label.cex, + width = 1, + arr = 2, + lty = 1, + arrow.size = 1, + arr.w = 1, + lab.x, + lab.y, + loopSize = 1, + narrowing = 1 +) { + rad <- angle + center <- c(cx, cy) + cp <- matrix( + c( + x0, + y0, + x0 + 0.4 * loopSize, + y0 + narrowing * 0.2 * loopSize, + x0 + 0.4 * loopSize, + y0 - narrowing * 0.2 * loopSize, + x0, + y0 + ), + ncol = 2, + byrow = TRUE + ) + cp_centered <- cp - + matrix(rep(center, each = nrow(cp)), ncol = 2, byrow = FALSE) + + rotation_matrix <- matrix(c(cos(rad), -sin(rad), sin(rad), cos(rad)), ncol = 2) + cp_rotated <- t(rotation_matrix %*% t(cp_centered)) + + cp <- cp_rotated + + matrix(rep(center, each = nrow(cp_rotated)), ncol = 2, byrow = FALSE) + + if (is.na(width)) { + width <- 1 + } + + i.plot.bezier( + cp, + 50, + color, + width, + arr = arr, + lty = lty, + arrow.size = arrow.size, + arr.w = arr.w + ) + + if (is.language(label) || !is.na(label)) { + # Get midpoint of the Bezier curve for label placement + p <- i.compute.bezier(cp, 50) + mid_index <- floor(ncol(p) / 2) + lx <- p[1, mid_index] + ly <- p[2, mid_index] + + # Override if label position explicitly given + if (!is.na(lab.x)) { + lx <- lab.x + } + if (!is.na(lab.y)) { + ly <- lab.y + } + + text( + lx, + ly, + label, + col = label.color, + font = label.font, + family = label.family, + cex = label.cex + ) + } +} + #' Plotting of graphs #' #' `plot.igraph()` is able to plot graphs to any R device. It is the @@ -372,162 +535,6 @@ plot.igraph <- function( ################################################################ ## add the loop edges if (length(loops.e) > 0) { - ec <- edge.color - if (length(ec) > 1) { - ec <- ec[loops.e] - } - - point.on.cubic.bezier <- function(cp, t) { - c <- 3 * (cp[2, ] - cp[1, ]) - b <- 3 * (cp[3, ] - cp[2, ]) - c - a <- cp[4, ] - cp[1, ] - c - b - - t2 <- t * t - t3 <- t * t * t - - a * t3 + b * t2 + c * t + cp[1, ] - } - - compute.bezier <- function(cp, points) { - dt <- seq(0, 1, by = 1 / (points - 1)) - sapply(dt, function(t) point.on.cubic.bezier(cp, t)) - } - - plot.bezier <- function( - cp, - points, - color, - width, - arr, - lty, - arrow.size, - arr.w - ) { - p <- compute.bezier(cp, points) - polygon(p[1, ], p[2, ], border = color, lwd = width, lty = lty) - if (arr == 1 || arr == 3) { - igraph.Arrows( - p[1, ncol(p) - 1], - p[2, ncol(p) - 1], - p[1, ncol(p)], - p[2, ncol(p)], - sh.col = color, - h.col = color, - size = arrow.size, - sh.lwd = width, - h.lwd = width, - open = FALSE, - code = 2, - width = arr.w - ) - } - if (arr == 2 || arr == 3) { - igraph.Arrows( - p[1, 2], - p[2, 2], - p[1, 1], - p[2, 1], - sh.col = color, - h.col = color, - size = arrow.size, - sh.lwd = width, - h.lwd = width, - open = FALSE, - code = 2, - width = arr.w - ) - } - } - - loop <- function( - x0, - y0, - cx = x0, - cy = y0, - color, - angle = 0, - label = NA, - label.color, - label.font, - label.family, - label.cex, - width = 1, - arr = 2, - lty = 1, - arrow.size = arrow.size, - arr.w = arr.w, - lab.x, - lab.y, - loopSize = loop.size, - narrowing = 1 - ) { - rad <- angle - center <- c(cx, cy) - cp <- matrix( - c( - x0, - y0, - x0 + 0.4 * loopSize, - y0 + narrowing * 0.2 * loopSize, - x0 + 0.4 * loopSize, - y0 - narrowing * 0.2 * loopSize, - x0, - y0 - ), - ncol = 2, - byrow = TRUE - ) - cp_centered <- cp - - matrix(rep(center, each = nrow(cp)), ncol = 2, byrow = FALSE) - - rotation_matrix <- matrix(c(cos(rad), -sin(rad), sin(rad), cos(rad)), ncol = 2) - cp_rotated <- t(rotation_matrix %*% t(cp_centered)) - - cp <- cp_rotated + - matrix(rep(center, each = nrow(cp_rotated)), ncol = 2, byrow = FALSE) - - if (is.na(width)) { - width <- 1 - } - - plot.bezier( - cp, - 50, - color, - width, - arr = arr, - lty = lty, - arrow.size = arrow.size, - arr.w = arr.w - ) - - if (is.language(label) || !is.na(label)) { - # Get midpoint of the Bezier curve for label placement - p <- compute.bezier(cp, 50) - mid_index <- floor(ncol(p) / 2) - lx <- p[1, mid_index] - ly <- p[2, mid_index] - - # Override if label position explicitly given - if (!is.na(lab.x)) { - lx <- lab.x - } - if (!is.na(lab.y)) { - ly <- lab.y - } - - text( - lx, - ly, - label, - col = label.color, - font = label.font, - family = label.family, - cex = label.cex - ) - } - } - # vertex.size is vertex-scoped (indexed by the loop's vertex) and loop.angle # is nullable, so both are handled outside the edge aesthetic table. vs <- vertex.size @@ -646,7 +653,7 @@ plot.igraph <- function( yy0 <- layout[loops.v, 2] + sin(la) * r_offset mapply( - loop, + i.draw.loop, xx0, yy0, color = ec, From 931ddb5fc05356697bee2b141d8916a379583087 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Tue, 23 Jun 2026 22:23:03 +0200 Subject: [PATCH 06/30] refactor(plot): thin the base-graphics render path (S4) Two behaviour-preserving render-path cleanups: - Extract i.hide_zero_frame() for the "frame.width <= 0 hides the border" rule that was copy-pasted into the circle/square/rectangle plot functions. - Extract i.init_plot_canvas() for the empty-canvas plot() setup, so plot.igraph() reads as setup -> edges -> vertices -> labels. Snapshots unchanged. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot.R | 54 +++++++++++++++++++++++++++++++++++++------------ R/plot.shapes.R | 28 ++++++++++++++++--------- 2 files changed, 60 insertions(+), 22 deletions(-) diff --git a/R/plot.R b/R/plot.R index b046c8200d6..b4efa1247b5 100644 --- a/R/plot.R +++ b/R/plot.R @@ -191,6 +191,37 @@ i.draw.loop <- function( } } +# Initialize the plotting canvas (Stage 4 device setup): an empty plot region +# with the requested limits, axes, aspect ratio and titles. Isolated from the +# drawing orchestration in plot.igraph() so the latter reads as +# setup -> edges -> vertices -> labels. +i.init_plot_canvas <- function( + xlim, + ylim, + xlab, + ylab, + axes, + frame.plot, + asp, + main, + sub +) { + plot( + 0, + 0, + type = "n", + xlab = xlab, + ylab = ylab, + xlim = xlim, + ylim = ylim, + axes = axes, + frame.plot = ifelse(is.null(frame.plot), axes, frame.plot), + asp = asp, + main = main, + sub = sub + ) +} + #' Plotting of graphs #' #' `plot.igraph()` is able to plot graphs to any R device. It is the @@ -369,19 +400,16 @@ plot.igraph <- function( } } if (!add) { - plot( - 0, - 0, - type = "n", - xlab = xlab, - ylab = ylab, - xlim = xlim, - ylim = ylim, - axes = axes, - frame.plot = ifelse(is.null(frame.plot), axes, frame.plot), - asp = asp, - main = main, - sub = sub + i.init_plot_canvas( + xlim, + ylim, + xlab, + ylab, + axes, + frame.plot, + asp, + main, + sub ) } diff --git a/R/plot.shapes.R b/R/plot.shapes.R index a5b5e06529e..ef47eb7f186 100644 --- a/R/plot.shapes.R +++ b/R/plot.shapes.R @@ -414,6 +414,16 @@ add_shape <- function( ## These are the predefined shapes #nocov start + +# A non-positive frame width means "draw no border": blank the frame colour and +# reset the width to a drawable value. Shared by the vertex shape plot functions +# so the rule lives in one place. +i.hide_zero_frame <- function(color, width) { + color[width <= 0] <- NA + width[width <= 0] <- 1 + list(color = color, width = width) +} + .igraph.shape.circle.clip <- function( coords, el, @@ -495,9 +505,9 @@ add_shape <- function( } vertex.size <- rep(vertex.size, length.out = nrow(coords)) - # Handle vertex.frame.width <= 0 by hiding the border - vertex.frame.color[vertex.frame.width <= 0] <- NA - vertex.frame.width[vertex.frame.width <= 0] <- 1 + frame <- i.hide_zero_frame(vertex.frame.color, vertex.frame.width) + vertex.frame.color <- frame$color + vertex.frame.width <- frame$width if (length(vertex.frame.width) == 1) { symbols( @@ -650,9 +660,9 @@ add_shape <- function( } vertex.size <- rep(vertex.size, length.out = nrow(coords)) - # Handle vertex.frame.width <= 0 by hiding the border - vertex.frame.color[vertex.frame.width <= 0] <- NA - vertex.frame.width[vertex.frame.width <= 0] <- 1 + frame <- i.hide_zero_frame(vertex.frame.color, vertex.frame.width) + vertex.frame.color <- frame$color + vertex.frame.width <- frame$width if (length(vertex.frame.width) == 1) { symbols( @@ -899,9 +909,9 @@ add_shape <- function( } vertex.size <- cbind(vertex.size, vertex.size2) - # Handle vertex.frame.width <= 0 by hiding the border - vertex.frame.color[vertex.frame.width <= 0] <- NA - vertex.frame.width[vertex.frame.width <= 0] <- 1 + frame <- i.hide_zero_frame(vertex.frame.color, vertex.frame.width) + vertex.frame.color <- frame$color + vertex.frame.width <- frame$width if (length(vertex.frame.width) == 1) { symbols( From f4a6ecd585c91bcfde4ecb3f4980e454fe227912 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 08:14:42 +0200 Subject: [PATCH 07/30] feat(plot)!: strict recycling for plotting aesthetics (B1) BREAKING CHANGE (igraph 3.0.0): a per-element plotting aesthetic must now be length 1 or exactly vcount()/ecount(). Previously a wrong-length vector (e.g. 3 colors for 5 vertices) was silently recycled, masking user mistakes; it is now a clear error via i.check_aes_lengths(). Applied to the unambiguous per-element vertex/edge aesthetics. Intentionally excluded: arrow.mode (its "a:" form reads a vertex attribute, so it can be vcount-long), and label.adj / pie / raster, which have non-per-element length semantics. Adds unit tests for i.check_aes_lengths plus plot()-level error/valid-length tests and error snapshots. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-aes.R | 31 ++++++++++++++++ R/plot.R | 35 ++++++++++++++++++ tests/testthat/_snaps/plot-params.md | 22 ++++++++++++ tests/testthat/test-plot-params.R | 53 ++++++++++++++++++++++++++++ 4 files changed, 141 insertions(+) diff --git a/R/plot-aes.R b/R/plot-aes.R index 16d77650fb6..975565a3464 100644 --- a/R/plot-aes.R +++ b/R/plot-aes.R @@ -29,6 +29,37 @@ i.aes_table <- function(cols, n) { vctrs::new_data_frame(cols, n = as.integer(n)) } +# igraph 3.0.0 breaking change: a per-element plotting aesthetic must have +# length 1 or exactly the number of vertices/edges. Previously a wrong-length +# vector (e.g. 3 colors for 5 vertices) was silently recycled, masking user +# mistakes; now it is an error. +# +# `vertex` and `edge` are named lists of resolved aesthetic vectors to check +# against `vc` / `ec`. Only unambiguous per-element aesthetics should be passed: +# aesthetics with special length semantics (vertex `label.adj`, list-valued +# `pie`/`raster`, the vertex-attribute `arrow.mode` "a:" form) are intentionally +# excluded by the caller. +i.check_aes_lengths <- function(vertex, edge, vc, ec, call = rlang::caller_env()) { + one_scope <- function(lst, n, scope, plural) { + for (nm in names(lst)) { + len <- length(lst[[nm]]) + if (len != 1L && len != n) { + cli::cli_abort( + c( + "Invalid length for {scope} aesthetic {.field {nm}}.", + "x" = "It has length {len}, but must be length 1 or {n}.", + "i" = "The graph has {n} {plural}." + ), + call = call + ) + } + } + } + one_scope(vertex, vc, "vertex", "vertices") + one_scope(edge, ec, "edge", "edges") + invisible(NULL) +} + # Edge aesthetic table for the per-edge visual properties that are subset by # edge index when drawing loop vs. non-loop edges. `loop.angle` (nullable) and # vertex-scoped properties are handled separately by the caller. diff --git a/R/plot.R b/R/plot.R index b4efa1247b5..3169a7fd62e 100644 --- a/R/plot.R +++ b/R/plot.R @@ -370,6 +370,41 @@ plot.igraph <- function( # the new style parameters can't do this yet arrow.mode <- i.get.arrow.mode(graph, arrow.mode) + # igraph 3.0.0: per-element aesthetics must be length 1 or vcount()/ecount(). + # arrow.mode is excluded (its "a:" form reads a vertex attribute, so it can be + # vcount-long); label.adj / pie / raster have non-per-element length semantics. + i.check_aes_lengths( + vertex = list( + size = vertex.size, + color = params("vertex", "color"), + frame.color = params("vertex", "frame.color"), + frame.width = params("vertex", "frame.width"), + shape = shape, + label = labels, + label.color = label.color, + label.cex = label.cex, + label.dist = label.dist, + label.degree = label.degree, + label.angle = label.angle, + label.font = label.font, + label.family = label.family + ), + edge = list( + color = edge.color, + width = edge.width, + lty = edge.lty, + arrow.size = arrow.size, + arrow.width = arrow.width, + label = edge.labels, + label.color = edge.label.color, + label.cex = edge.label.cex, + label.font = edge.label.font, + label.family = edge.label.family + ), + vc = vc, + ec = ecount(graph) + ) + ################################################################ ## create the plot if (rescale) { diff --git a/tests/testthat/_snaps/plot-params.md b/tests/testthat/_snaps/plot-params.md index 9b9d0b0e294..05d7429192d 100644 --- a/tests/testthat/_snaps/plot-params.md +++ b/tests/testthat/_snaps/plot-params.md @@ -1,3 +1,25 @@ +# i.check_aes_lengths rejects mismatched vertex lengths + + Code + i.check_aes_lengths(vertex = list(color = c("red", "green")), edge = list(), + vc = 5, ec = 4) + Condition + Error: + ! Invalid length for vertex aesthetic color. + x It has length 2, but must be length 1 or 5. + i The graph has 5 vertices. + +# i.check_aes_lengths rejects mismatched edge lengths + + Code + i.check_aes_lengths(vertex = list(), edge = list(width = c(1, 2, 3)), vc = 5, + ec = 5) + Condition + Error: + ! Invalid length for edge aesthetic width. + x It has length 3, but must be length 1 or 5. + i The graph has 5 edges. + # igraph.check.shapes() aborts on unknown shapes Code diff --git a/tests/testthat/test-plot-params.R b/tests/testthat/test-plot-params.R index f9555c5b527..ebdf7cee00d 100644 --- a/tests/testthat/test-plot-params.R +++ b/tests/testthat/test-plot-params.R @@ -121,6 +121,59 @@ test_that("i.edge_aes_table expands scalars and is sliceable by edge index", { expect_equal(sliced$width, c(1, 3)) }) +# --------------------------------------------------------------------------- +# i.check_aes_lengths() — strict recycling (igraph 3.0.0) +# --------------------------------------------------------------------------- + +test_that("i.check_aes_lengths accepts length 1 and length n", { + expect_silent( + i.check_aes_lengths( + vertex = list(color = "red", size = c(1, 2, 3)), + edge = list(width = 1), + vc = 3, + ec = 2 + ) + ) +}) + +test_that("i.check_aes_lengths rejects mismatched vertex lengths", { + expect_snapshot_igraph_error( + i.check_aes_lengths( + vertex = list(color = c("red", "green")), + edge = list(), + vc = 5, + ec = 4 + ) + ) +}) + +test_that("i.check_aes_lengths rejects mismatched edge lengths", { + expect_snapshot_igraph_error( + i.check_aes_lengths( + vertex = list(), + edge = list(width = c(1, 2, 3)), + vc = 5, + ec = 5 + ) + ) +}) + +test_that("plot() errors on a wrong-length vertex aesthetic (strict recycling)", { + g <- make_ring(5) + grDevices::pdf(NULL) + withr::defer(grDevices::dev.off()) + # 3 colors for 5 vertices: previously silently recycled, now an error + expect_error(plot(g, vertex.color = c("red", "green", "blue")), "length 3") +}) + +test_that("plot() still accepts length-1 and length-n aesthetics", { + g <- make_ring(5) + grDevices::pdf(NULL) + withr::defer(grDevices::dev.off()) + expect_no_error(plot(g, vertex.color = "red")) + expect_no_error(plot(g, vertex.color = rep("red", 5))) +}) + # --------------------------------------------------------------------------- # i.get.arrow.mode() # --------------------------------------------------------------------------- From 483b17fcdc8c3f649d07cba46ea118184b36ac61 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 08:21:47 +0200 Subject: [PATCH 08/30] fix(plot)!: route non-loop edges through the aesthetic table (B2) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Build the edge aesthetic table once (now including arrow.width) before both the loop and non-loop edge blocks, and slice it per block with vec_slice(). This replaces the remaining per-parameter `if (length(x) > 1) x[idx]` subsetting and fixes two latent bugs in the mixed-arrow-mode path: - `curved` was sliced to non-loop edges and then re-expanded with `rep(curved, length.out = ecount)[nonloops.e]`, double-indexing and scrambling curvature values. - `arrow.size` / `arrow.width` were not subset by the per-arrow-code `valid` mask, so igraph.Arrows() received the leading elements rather than the matching ones. Both now index consistently by `valid`. BREAKING: plots that combined mixed arrow modes with per-edge curved/arrow.size/arrow.width render differently (now correctly) — the vector-edge-params-loops snapshot is updated accordingly, and a new mixed-modes-curved regression snapshot covers the path. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-aes.R | 2 + R/plot.R | 124 +++++++----------- .../_snaps/plot/mixed-modes-curved.svg | 50 +++++++ .../_snaps/plot/vector-edge-params-loops.svg | 8 +- tests/testthat/test-plot-params.R | 1 + tests/testthat/test-plot.R | 25 ++++ 6 files changed, 129 insertions(+), 81 deletions(-) create mode 100644 tests/testthat/_snaps/plot/mixed-modes-curved.svg diff --git a/R/plot-aes.R b/R/plot-aes.R index 975565a3464..e02ce474fe2 100644 --- a/R/plot-aes.R +++ b/R/plot-aes.R @@ -69,6 +69,7 @@ i.edge_aes_table <- function( lty, arrow.mode, arrow.size, + arrow.width, curved, label.color, label.family, @@ -83,6 +84,7 @@ i.edge_aes_table <- function( lty = lty, arrow.mode = arrow.mode, arrow.size = arrow.size, + arrow.width = arrow.width, curved = curved, label.color = label.color, label.family = label.family, diff --git a/R/plot.R b/R/plot.R index 3169a7fd62e..07c45f90b33 100644 --- a/R/plot.R +++ b/R/plot.R @@ -595,6 +595,24 @@ plot.igraph <- function( x1 <- ec[, 3] y1 <- ec[, 4] + # Stage 1: resolve the per-edge aesthetics into one table (length ecount), + # then slice it by loop-edge / non-loop-edge index instead of repeating the + # `if (length(x) > 1) x[idx]` idiom for every parameter. + edge_aes <- i.edge_aes_table( + color = edge.color, + width = edge.width, + lty = edge.lty, + arrow.mode = arrow.mode, + arrow.size = arrow.size, + arrow.width = arrow.width, + curved = curved, + label.color = edge.label.color, + label.family = edge.label.family, + label.font = edge.label.font, + label.cex = edge.label.cex, + n = ecount(graph) + ) + ################################################################ ## add the loop edges if (length(loops.e) > 0) { @@ -609,27 +627,13 @@ plot.igraph <- function( la <- la[loops.e] } - # Stage 1: resolve the per-edge aesthetics into a table once, then slice it - # by loop-edge index instead of repeating `if (length(x) > 1) x[loops.e]`. - edge_aes <- i.edge_aes_table( - color = edge.color, - width = edge.width, - lty = edge.lty, - arrow.mode = arrow.mode, - arrow.size = arrow.size, - curved = curved, - label.color = edge.label.color, - label.family = edge.label.family, - label.font = edge.label.font, - label.cex = edge.label.cex, - n = ecount(graph) - ) loop_aes <- vctrs::vec_slice(edge_aes, loops.e) ec <- loop_aes$color ew <- loop_aes$width lty <- loop_aes$lty arr <- loop_aes$arrow.mode asize <- loop_aes$arrow.size + aw <- loop_aes$arrow.width lcol <- loop_aes$label.color lfam <- loop_aes$label.family lfon <- loop_aes$label.font @@ -730,7 +734,7 @@ plot.igraph <- function( width = ew, arr = arr, arrow.size = asize, - arr.w = arrow.width, + arr.w = aw, lab.x = loop.labx, lab.y = loop.laby, loopSize = adjusted_loop_size, @@ -741,24 +745,18 @@ plot.igraph <- function( ################################################################ ## non-loop edges if (length(x0) != 0) { - if (length(edge.color) > 1) { - edge.color <- edge.color[nonloops.e] - } - if (length(edge.width) > 1) { - edge.width <- edge.width[nonloops.e] - } - if (length(edge.lty) > 1) { - edge.lty <- edge.lty[nonloops.e] - } - if (length(arrow.mode) > 1) { - arrow.mode <- arrow.mode[nonloops.e] - } - if (length(arrow.size) > 1) { - arrow.size <- arrow.size[nonloops.e] - } - if (length(curved) > 1) { - curved <- curved[nonloops.e] - } + # Slice the edge aesthetic table to the non-loop edges; every column is now + # length(nonloops.e), so the per-arrow-code branch can index by `valid` + # directly. (This also fixes a former double-slice of `curved`.) + nl_aes <- vctrs::vec_slice(edge_aes, nonloops.e) + edge.color <- nl_aes$color + edge.width <- nl_aes$width + edge.lty <- nl_aes$lty + arrow.mode <- nl_aes$arrow.mode + arrow.size <- nl_aes$arrow.size + arrow.width <- nl_aes$arrow.width + curved <- nl_aes$curved + if (length(unique(arrow.mode)) == 1) { lc <- igraph.Arrows( x0, @@ -781,41 +779,29 @@ plot.igraph <- function( lc.y <- lc$lab.y } else { ## different kinds of arrows drawn separately as 'arrows' cannot - ## handle a vector as the 'code' argument - curved <- rep(curved, length.out = ecount(graph))[nonloops.e] - lc.x <- lc.y <- numeric(length(curved)) + ## handle a vector as the 'code' argument. Every aesthetic is already + ## length(nonloops.e), so subset each by `valid` consistently. + lc.x <- lc.y <- numeric(length(nonloops.e)) for (code in 0:3) { valid <- arrow.mode == code if (!any(valid)) { next } - ec <- edge.color - if (length(ec) > 1) { - ec <- ec[valid] - } - ew <- edge.width - if (length(ew) > 1) { - ew <- ew[valid] - } - el <- edge.lty - if (length(el) > 1) { - el <- el[valid] - } lc <- igraph.Arrows( x0[valid], y0[valid], x1[valid], y1[valid], code = code, - sh.col = ec, - h.col = ec, - sh.lwd = ew, + sh.col = edge.color[valid], + h.col = edge.color[valid], + sh.lwd = edge.width[valid], h.lwd = 1, h.lty = 1, - sh.lty = el, + sh.lty = edge.lty[valid], open = FALSE, - size = arrow.size, - width = arrow.width, + size = arrow.size[valid], + width = arrow.width[valid], curved = curved[valid] ) lc.x[valid] <- lc$lab.x @@ -829,28 +815,12 @@ plot.igraph <- function( lc.y <- ifelse(is.na(elab.y), lc.y, elab.y) } - ecol <- edge.label.color - if (length(ecol) > 1) { - ecol <- ecol[nonloops.e] - } - efam <- edge.label.family - if (length(efam) > 1) { - efam <- efam[nonloops.e] - } - - efon <- edge.label.font - if (length(efon) > 1) { - efon <- efon[nonloops.e] - } - ecex <- edge.label.cex - if (length(ecex) > 1) { - ecex <- ecex[nonloops.e] - } - en <- length(nonloops.e) - ecol <- rep(ecol, length.out = en) - efam <- rep(efam, length.out = en) - efon <- rep(efon, length.out = en) - ecex <- rep(ecex, length.out = en) + # Edge-label aesthetics come from the same non-loop slice (already recycled + # to length(nonloops.e)). + ecol <- nl_aes$label.color + efam <- nl_aes$label.family + efon <- nl_aes$label.font + ecex <- nl_aes$label.cex invisible(mapply( function(x, y, label, col, family, font, cex) { diff --git a/tests/testthat/_snaps/plot/mixed-modes-curved.svg b/tests/testthat/_snaps/plot/mixed-modes-curved.svg new file mode 100644 index 00000000000..59d8a0a2282 --- /dev/null +++ b/tests/testthat/_snaps/plot/mixed-modes-curved.svg @@ -0,0 +1,50 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 + + diff --git a/tests/testthat/_snaps/plot/vector-edge-params-loops.svg b/tests/testthat/_snaps/plot/vector-edge-params-loops.svg index b395f738243..0857150f5d5 100644 --- a/tests/testthat/_snaps/plot/vector-edge-params-loops.svg +++ b/tests/testthat/_snaps/plot/vector-edge-params-loops.svg @@ -37,10 +37,10 @@ d - - - - + + + + a b e diff --git a/tests/testthat/test-plot-params.R b/tests/testthat/test-plot-params.R index ebdf7cee00d..ce32a5e6e6d 100644 --- a/tests/testthat/test-plot-params.R +++ b/tests/testthat/test-plot-params.R @@ -105,6 +105,7 @@ test_that("i.edge_aes_table expands scalars and is sliceable by edge index", { lty = 1, arrow.mode = 2, arrow.size = 1, + arrow.width = 1, curved = 0, label.color = "blue", label.family = "serif", diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index e5597558fca..acd32378b3d 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -274,6 +274,31 @@ test_that("vector edge params are subset correctly across loops and non-loops", vdiffr::expect_doppelganger("vector-edge-params-loops", vector_edge_params) }) +test_that("mixed arrow modes with per-edge curved/size and loops render correctly", { + # Regression guard for B2: the per-arrow-code branch used to double-slice + # `curved` and ignored per-edge arrow.size/width. Exercise that path with a + # graph that has loops, non-loop edges, mixed arrow modes, and per-edge + # curved + arrow.size vectors. + skip_if_not_installed("vdiffr") + + mixed_modes_curved <- function() { + # edges: 1->2, 2->3, 3->1, 1->1 (loop), 2->2 (loop) + g <- make_graph(c(1, 2, 2, 3, 3, 1, 1, 1, 2, 2), directed = TRUE) + V(g)$x <- c(0, 2, 1) + V(g)$y <- c(0, 0, 2) + ne <- ecount(g) + plot( + g, + edge.arrow.mode = c(0, 1, 2, 2, 3), + edge.curved = c(0.3, -0.3, 0.5, 0, 0), + edge.arrow.size = c(0.5, 1, 1.5, 1, 1), + edge.width = c(1, 2, 3, 1, 2), + margin = 0.3 + ) + } + vdiffr::expect_doppelganger("mixed-modes-curved", mixed_modes_curved) +}) + test_that("multi-edges are auto-curved", { skip_if_not_installed("vdiffr") From 53dcdd3b03af2e4eb160cc15dcc7cc855eb60112 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 08:24:53 +0200 Subject: [PATCH 09/30] refactor(plot): extract loop-angle and vertex-label phase helpers (B3) Pull two self-contained phases out of plot.igraph()'s body: - i.loop_angles(graph, layout, loops.v): the "flower-petal" distribution of self-loops into the largest angular gap at each vertex, returning aligned angle/narrowing vectors. Drops two dead locals (loop_table, loop_idx). Now unit-testable. - i.draw_vertex_labels(...): the vertex-label placement + drawing block, with xpd scoped to the helper. Behaviour-preserving (loop / label snapshots unchanged); adds a unit test for i.loop_angles. The loop/non-loop edge-drawing blocks remain inline for now. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot.R | 267 +++++++++++++++++++++---------------- tests/testthat/test-plot.R | 16 +++ 2 files changed, 171 insertions(+), 112 deletions(-) diff --git a/R/plot.R b/R/plot.R index 07c45f90b33..d4a5e4b7ae6 100644 --- a/R/plot.R +++ b/R/plot.R @@ -222,6 +222,144 @@ i.init_plot_canvas <- function( ) } +# Distribute self-loops around each vertex (Stage 2 geometry). For a vertex with +# k loops, place them evenly inside the largest angular gap between its incident +# (non-loop) edges, and compute a narrowing factor that compresses the loops +# when that gap is tight. Returns per-loop `angles` and `narrowing` vectors +# aligned to `loops.v`. +i.loop_angles <- function(graph, layout, loops.v) { + la_dyn <- numeric(length(loops.v)) + narrowing <- numeric(length(loops.v)) + + for (v in unique(loops.v)) { + idx <- which(loops.v == v) + n_loops <- length(idx) + + incident_edges <- incident(graph, v, mode = "all") + incident_edges <- incident_edges[!which_loop(graph)[incident_edges]] + + if (length(incident_edges) == 0) { + # Full circle available if no edges + loop_angles <- seq(0, 2 * pi, length.out = n_loops + 1)[-1] + gap_span <- 2 * pi + } else { + angles <- sapply(incident_edges, function(e) { + ends_e <- ends(graph, e, names = FALSE) + other <- if (as.numeric(ends_e[1]) == v) { + as.numeric(ends_e[2]) + } else { + as.numeric(ends_e[1]) + } + dx <- layout[other, 1] - layout[v, 1] + dy <- layout[other, 2] - layout[v, 2] + atan2(dy, dx) + }) + + angles <- (angles + 2 * pi) %% (2 * pi) + angles <- sort(angles) + gaps <- diff(c(angles, angles[1] + 2 * pi)) + max_gap_index <- which.max(gaps) + + gap_start <- angles[max_gap_index] + gap_span <- gaps[max_gap_index] + gap_end <- (gap_start + gap_span) %% (2 * pi) + + # Generate loop angles spaced inside the gap + if (gap_end > gap_start) { + loop_angles <- seq(gap_start, gap_end, length.out = n_loops + 2)[ + -c(1, n_loops + 2) + ] + } else { + # wrap around + gap_end <- gap_end + 2 * pi + loop_angles <- seq(gap_start, gap_end, length.out = n_loops + 2)[ + -c(1, n_loops + 2) + ] %% + (2 * pi) + } + } + + la_dyn[idx] <- loop_angles + + # Compute narrowing factor based on angular space + angle_per_loop <- gap_span / n_loops + # Scale narrowing between 1 (wide) and ~0.2 (tight) + narrowing_factor <- pmin(1, pmax(0.2, angle_per_loop / (pi / 4))) # full width if ≥45°, compress below + narrowing[idx] <- narrowing_factor + } + + list(angles = la_dyn, narrowing = narrowing) +} + +# Draw vertex labels (Stage 4), offset from each vertex by label.dist along +# label.degree. xpd = TRUE is scoped to this call so labels may spill outside +# the plot region. No-op for an empty graph. +i.draw_vertex_labels <- function( + layout, + labels, + vertex.size, + label.dist, + label.degree, + label.color, + label.family, + label.font, + label.cex, + label.angle, + label.adj +) { + vc <- nrow(layout) + if (vc == 0) { + return(invisible(NULL)) + } + + old_xpd <- par(xpd = TRUE) + on.exit(par(old_xpd), add = TRUE) + + x <- layout[, 1] + + label.dist * + cos(-label.degree) * + (vertex.size + 6 * 8 * log10(2)) * + VERTEX_SIZE_SCALE + y <- layout[, 2] + + label.dist * + sin(-label.degree) * + (vertex.size + 6 * 8 * log10(2)) * + VERTEX_SIZE_SCALE + + label.col <- rep(label.color, length.out = vc) + label.fam <- rep(label.family, length.out = vc) + label.fnt <- rep(label.font, length.out = vc) + label.cex <- rep(label.cex, length.out = vc) + label.ang <- rep(label.angle, length.out = vc) + label.adj <- rep(list(label.adj), length.out = vc) + label.text <- rep(labels, length.out = vc) + + invisible(mapply( + function(x0, y0, lbl, col, fam, fnt, cex, srt, adj) { + text( + x0, + y0, + labels = lbl, + col = col, + family = fam, + font = fnt, + cex = cex, + srt = srt, + adj = adj + ) + }, + x, + y, + label.text, + label.col, + label.fam, + label.fnt, + label.cex, + label.ang, + label.adj + )) +} + #' Plotting of graphs #' #' `plot.igraph()` is able to plot graphs to any R device. It is the @@ -639,70 +777,10 @@ plot.igraph <- function( lfon <- loop_aes$label.font lcex <- loop_aes$label.cex - # For each loop, assign unique angle within largest gap (flower petal style) - # depending on the number of loops and the available angular space - la_dyn <- numeric(length(loops.v)) - narrowing <- numeric(length(loops.v)) - - loop_table <- table(loops.v) - loop_idx <- ave(seq_along(loops.v), loops.v, FUN = seq_along) - - for (v in unique(loops.v)) { - idx <- which(loops.v == v) - n_loops <- length(idx) - - incident_edges <- incident(graph, v, mode = "all") - incident_edges <- incident_edges[!which_loop(graph)[incident_edges]] - - if (length(incident_edges) == 0) { - # Full circle available if no edges - loop_angles <- seq(0, 2 * pi, length.out = n_loops + 1)[-1] - gap_span <- 2 * pi - } else { - angles <- sapply(incident_edges, function(e) { - ends_e <- ends(graph, e, names = FALSE) - other <- if (as.numeric(ends_e[1]) == v) { - as.numeric(ends_e[2]) - } else { - as.numeric(ends_e[1]) - } - dx <- layout[other, 1] - layout[v, 1] - dy <- layout[other, 2] - layout[v, 2] - atan2(dy, dx) - }) - - angles <- (angles + 2 * pi) %% (2 * pi) - angles <- sort(angles) - gaps <- diff(c(angles, angles[1] + 2 * pi)) - max_gap_index <- which.max(gaps) - - gap_start <- angles[max_gap_index] - gap_span <- gaps[max_gap_index] - gap_end <- (gap_start + gap_span) %% (2 * pi) - - # Generate loop angles spaced inside the gap - if (gap_end > gap_start) { - loop_angles <- seq(gap_start, gap_end, length.out = n_loops + 2)[ - -c(1, n_loops + 2) - ] - } else { - # wrap around - gap_end <- gap_end + 2 * pi - loop_angles <- seq(gap_start, gap_end, length.out = n_loops + 2)[ - -c(1, n_loops + 2) - ] %% - (2 * pi) - } - } - - la_dyn[idx] <- loop_angles - - # Compute narrowing factor based on angular space - angle_per_loop <- gap_span / n_loops - # Scale narrowing between 1 (wide) and ~0.2 (tight) - narrowing_factor <- pmin(1, pmax(0.2, angle_per_loop / (pi / 4))) # full width if ≥45°, compress below - narrowing[idx] <- narrowing_factor - } + # Place loops in the largest angular gap at each vertex (flower-petal style). + loop_geo <- i.loop_angles(graph, layout, loops.v) + la_dyn <- loop_geo$angles + narrowing <- loop_geo$narrowing if (is.null(la)) { la <- rep(NA, length(loops.v)) } @@ -864,54 +942,19 @@ plot.igraph <- function( ################################################################ # add the labels - old_xpd <- par(xpd = TRUE) - on.exit(par(old_xpd), add = TRUE) - x <- layout[, 1] + - label.dist * - cos(-label.degree) * - (vertex.size + 6 * 8 * log10(2)) * - VERTEX_SIZE_SCALE - y <- layout[, 2] + - label.dist * - sin(-label.degree) * - (vertex.size + 6 * 8 * log10(2)) * - VERTEX_SIZE_SCALE - if (vc > 0) { - label.col <- rep(label.color, length.out = vc) - label.fam <- rep(label.family, length.out = vc) - label.fnt <- rep(label.font, length.out = vc) - label.cex <- rep(label.cex, length.out = vc) - label.ang <- rep(label.angle, length.out = vc) - label.adj <- rep(list(label.adj), length.out = vc) - label.text <- rep(labels, length.out = vc) - - # Draw vertex labels - invisible(mapply( - function(x0, y0, lbl, col, fam, fnt, cex, srt, adj) { - text( - x0, - y0, - labels = lbl, - col = col, - family = fam, - font = fnt, - cex = cex, - srt = srt, - adj = adj - ) - }, - x, - y, - label.text, - label.col, - label.fam, - label.fnt, - label.cex, - label.ang, - label.adj - )) - } - rm(x, y) + i.draw_vertex_labels( + layout, + labels, + vertex.size, + label.dist, + label.degree, + label.color, + label.family, + label.font, + label.cex, + label.angle, + label.adj + ) invisible(NULL) } diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index acd32378b3d..f3add7c8ef5 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -234,6 +234,22 @@ test_that("mark border linewidth", { vdiffr::expect_doppelganger("mark-border-lwd", mark_border_lwd) }) +test_that("i.loop_angles distributes loops and returns aligned vectors", { + # Two vertices, vertex 1 has 2 loops, plus a 1-2 edge. + g <- make_graph(c(1, 2, 1, 1, 1, 1), directed = FALSE) + layout <- cbind(c(0, 1), c(0, 0)) + loops.v <- c(1, 1) # the two loop edges are both at vertex 1 + + res <- i.loop_angles(g, layout, loops.v) + expect_named(res, c("angles", "narrowing")) + expect_length(res$angles, 2) + expect_length(res$narrowing, 2) + # narrowing is bounded to [0.2, 1] + expect_true(all(res$narrowing >= 0.2 & res$narrowing <= 1)) + # the two loops get distinct angles + expect_false(res$angles[1] == res$angles[2]) +}) + test_that("i.arrowhead_shape returns matched polar arrays ending in NA", { # Pure geometry helper extracted from igraph.Arrows (Stage 2); device-free. head <- i.arrowhead_shape(cin = 0.2, w = 1.5, delta = 0.01) From 9a40ac24b4dbd4262c240950149996df36aed730 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 08:27:34 +0200 Subject: [PATCH 10/30] refactor(plot): finish igraph.Arrows geometry decomposition (B4) Extract the remaining per-edge geometry from the igraph.Arrows() drawing loop into pure helpers: - i.arrow_shaft_endpoints(): shaft segment endpoints, pulled back at the arrowed end(s) per `code`. - i.edge_label_pos(): straight-edge label anchor (2/3 along the edge). - i.curved_spline(): the X-spline control points + curve for a curved edge. igraph.Arrows() now computes geometry via these helpers and only draws. Adds device-free unit tests for the two pure helpers; arrow snapshots unchanged. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot.R | 92 +++++++++++++++++++++++++------------- tests/testthat/test-plot.R | 18 ++++++++ 2 files changed, 79 insertions(+), 31 deletions(-) diff --git a/R/plot.R b/R/plot.R index d4a5e4b7ae6..7a3dfcd9a8e 100644 --- a/R/plot.R +++ b/R/plot.R @@ -1832,6 +1832,49 @@ i.arrowhead_shape <- function(cin, w, delta) { ) } +# Pure geometry (Stage 2): shaft segment endpoints for a single edge, pulled +# back from the vertices by `r.seg` at whichever end carries an arrowhead (per +# `code`) so the shaft does not poke through the head. `uin` is the +# inches-per-user-unit scale from 1/xyinch(). Returns sx1/sy1/sx2/sy2. +i.arrow_shaft_endpoints <- function(x1, y1, x2, y2, code, r.seg, uin) { + theta1 <- atan2((y1 - y2) * uin[2], (x1 - x2) * uin[1]) + theta2 <- atan2((y2 - y1) * uin[2], (x2 - x1) * uin[1]) + x1d <- y1d <- x2d <- y2d <- 0 + if (code %in% c(1, 3)) { + x2d <- r.seg * cos(theta2) / uin[1] + y2d <- r.seg * sin(theta2) / uin[2] + } + if (code %in% c(2, 3)) { + x1d <- r.seg * cos(theta1) / uin[1] + y1d <- r.seg * sin(theta1) / uin[2] + } + list(sx1 = x1 + x1d, sy1 = y1 + y1d, sx2 = x2 + x2d, sy2 = y2 + y2d) +} + +# Pure geometry (Stage 2): label anchor two thirds of the way along a straight +# edge from (x2, y2) toward (x1, y1). +i.edge_label_pos <- function(x1, y1, x2, y2) { + phi <- atan2(y1 - y2, x1 - x2) + r <- sqrt((x1 - x2)^2 + (y1 - y2)^2) + c(x = x2 + 2 / 3 * r * cos(phi), y = y2 + 2 / 3 * r * sin(phi)) +} + +# Geometry (Stage 2): the X-spline of a curved edge. The control point is offset +# from the edge midpoint perpendicular to the shaft by `lambda`. Returns the +# xspline() coordinate list (draw = FALSE; needs an active device). +i.curved_spline <- function(x1, y1, x2, y2, sx1, sy1, sx2, sy2, lambda) { + midx <- (x1 + x2) / 2 + midy <- (y1 + y2) / 2 + spx <- midx - lambda * 1 / 2 * (sy2 - sy1) + spy <- midy + lambda * 1 / 2 * (sx2 - sx1) + xspline( + x = c(sx1, spx, sx2), + y = c(sy1, spy, sy2), + shape = 1, + draw = FALSE + ) +} + #' @importFrom graphics par xyinch segments xspline lines polygon # Vectorized and modular igraph.Arrows refactor igraph.Arrows <- function( @@ -1887,24 +1930,12 @@ igraph.Arrows <- function( deg.arr <- head$deg.arr r.arr <- head$r.arr - 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(theta2) / uin[1] - y2d <- r.seg * sin(theta2) / uin[2] - } - if (code %in% c(2, 3)) { - x1d <- r.seg * cos(theta1) / uin[1] - y1d <- r.seg * sin(theta1) / uin[2] - } - - sx1 <- x1[i] + x1d - sy1 <- y1[i] + y1d - sx2 <- x2[i] + x2d - sy2 <- y2[i] + y2d + sh <- i.arrow_shaft_endpoints(x1[i], y1[i], x2[i], y2[i], code, r.seg, uin) + sx1 <- sh$sx1 + sy1 <- sh$sy1 + sx2 <- sh$sx2 + sy2 <- sh$sy2 if (!curved[i]) { segments( @@ -1916,22 +1947,21 @@ igraph.Arrows <- function( 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) - label_x[i] <- x2[i] + 2 / 3 * r * cos(phi) - label_y[i] <- y2[i] + 2 / 3 * r * sin(phi) + lab <- i.edge_label_pos(x1[i], y1[i], x2[i], y2[i]) + label_x[i] <- lab[["x"]] + label_y[i] <- lab[["y"]] } else { 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 + spl <- i.curved_spline( + x1[i], + y1[i], + x2[i], + y2[i], + sx1, + sy1, + sx2, + sy2, + lambda ) 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))] diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index f3add7c8ef5..058506d90a2 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -265,6 +265,24 @@ test_that("i.arrowhead_shape returns matched polar arrays ending in NA", { expect_gt(length(bigger$r.arr), length(head$r.arr)) }) +test_that("i.arrow_shaft_endpoints adjusts only the arrowed end", { + uin <- c(1, 1) # square device units for a clean check + # horizontal edge (0,0) -> (10,0). code 2 adjusts the from-end (x1d), leaving + # the to-end at 10; the shift is r.seg along theta1 (= -1 here). + s2 <- i.arrow_shaft_endpoints(0, 0, 10, 0, code = 2, r.seg = 1, uin = uin) + expect_equal(s2$sx2, 10) # to-end unchanged for code 2 + expect_equal(s2$sx1, -1) # from-end shifted by r.seg + # code 0 (no arrows): both ends unchanged + s0 <- i.arrow_shaft_endpoints(0, 0, 10, 0, code = 0, r.seg = 1, uin = uin) + expect_equal(c(s0$sx1, s0$sx2), c(0, 10)) +}) + +test_that("i.edge_label_pos is two thirds from the target toward the source", { + pos <- i.edge_label_pos(0, 0, 9, 0) + expect_equal(unname(pos["x"]), 3) # 9 - 2/3*9, i.e. 2/3 from (9,0) toward (0,0) + expect_equal(unname(pos["y"]), 0) +}) + test_that("vector edge params are subset correctly across loops and non-loops", { # Guards the per-edge subsetting of loop vs non-loop edges in plot.igraph(). skip_if_not_installed("vdiffr") From c15792e56ec965c07f753a373a6c32b4dd034e8a Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 08:30:24 +0200 Subject: [PATCH 11/30] feat(plot): validate shape clip/plot signatures in add_shape (B5) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit add_shape() now checks that the clip and plot functions accept the arguments igraph calls them with (clip(coords, el, params=, end=) and plot(coords, v=, params=)), via i.check_shape_fun(). Functions taking `...` are exempt. A malformed custom shape now fails at registration with a clear message instead of cryptically at plot time. Scoped to signature validation; the larger metadata-driven shape registry (per-shape parameter table + plot-time "unknown param" validation) is deferred — it would change what shapes() returns and risks false positives. Adds tests for the new validation, with cleanup so test shapes don't leak into the global registry. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot.shapes.R | 24 +++++++++++++++++++ tests/testthat/test-plot.shapes.R | 38 +++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+) diff --git a/R/plot.shapes.R b/R/plot.shapes.R index ef47eb7f186..a54f2f84631 100644 --- a/R/plot.shapes.R +++ b/R/plot.shapes.R @@ -368,6 +368,23 @@ shape_noplot <- function(coords, v = NULL, params) { invisible(NULL) } +# Check that a shape clip/plot function accepts the arguments igraph calls it +# with. Functions that take `...` are assumed to forward everything and pass. +i.check_shape_fun <- function(fn, arg, required) { + fmls <- names(formals(fn)) + if ("..." %in% fmls) { + return(invisible()) + } + missing <- setdiff(required, fmls) + if (length(missing) > 0) { + cli::cli_abort(c( + "Shape {.arg {arg}} function is missing required argument{?s} {.arg {missing}}.", + i = "It is called as {.code {arg}(coords, {if (arg == 'clip') 'el, ' else ''}...)} with {.arg {required}}; see {.help add_shape}." + )) + } + invisible() +} + #' @rdname shapes #' @export add_shape <- function( @@ -407,6 +424,13 @@ add_shape <- function( )) } + # Validate the clip/plot signatures up front so a malformed shape fails here + # rather than cryptically at plot time. A clip function is called as + # clip(coords, el, params =, end =) and a plot function as + # plot(coords, v =, params =); functions taking `...` are exempt. + i.check_shape_fun(clip, "clip", c("params", "end")) + i.check_shape_fun(plot, "plot", c("params", "v")) + assign(shape, value = list(clip = clip, plot = plot), envir = .igraph.shapes) do.call(igraph_options, parameters) invisible(TRUE) diff --git a/tests/testthat/test-plot.shapes.R b/tests/testthat/test-plot.shapes.R index b71e1205b7c..dc755abe280 100644 --- a/tests/testthat/test-plot.shapes.R +++ b/tests/testthat/test-plot.shapes.R @@ -49,6 +49,44 @@ test_that("add_shape() validates inputs correctly", { ) }) +test_that("add_shape() validates clip/plot signatures", { + # Remove the shapes registered below so they don't leak into other tests + # (e.g. the "render all shapes" snapshot test). + withr::defer({ + for (s in c("dots_shape", "good_shape")) { + if (exists(s, envir = .igraph.shapes)) { + rm(list = s, envir = .igraph.shapes) + } + } + }) + # clip missing `end` + expect_error( + add_shape("bad_clip", clip = function(coords, el, params) coords), + "missing required argument" + ) + # plot missing `params` + expect_error( + add_shape("bad_plot", plot = function(coords, v) invisible()), + "missing required argument" + ) + # functions taking ... are accepted + expect_true( + add_shape( + "dots_shape", + clip = function(...) NULL, + plot = function(...) invisible() + ) + ) + # a correctly-shaped custom shape is accepted + expect_true( + add_shape( + "good_shape", + clip = function(coords, el, params, end) coords, + plot = function(coords, v = NULL, params) invisible() + ) + ) +}) + test_that("add_shape() can override existing shapes", { original_circle <- shapes("circle") dummy_plot <- function(coords, v = NULL, params) invisible(NULL) From 5327c2049ea0ac03e19d1b7b3503a48a648df994 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 08:32:25 +0200 Subject: [PATCH 12/30] refactor(plot): remove dead `frame` default (B7) i.plot.default carried `frame = FALSE`, but plot.igraph() reads `frame.plot` (which falls back to `axes` when unset), so the entry was never used. Remove the misleading dead config and document the actual behaviour. No behaviour change (rescale-coords snapshot with axes = TRUE is unchanged). The file splits in B7 (plot.common.R / layout.R) are deferred: pure code-motion with high merge-conflict cost and no behaviour value, best done once the restructuring churn has settled. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot.common.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/plot.common.R b/R/plot.common.R index ad0e6cde57a..a54526f98b7 100644 --- a/R/plot.common.R +++ b/R/plot.common.R @@ -4909,13 +4909,16 @@ i.edge.default <- list( arrow.width = 1 ) +# Note: there is intentionally no `frame` default. plot.igraph() reads +# `frame.plot`, which falls back to `axes` when unset +# (ifelse(is.null(frame.plot), axes, frame.plot)); a `frame = FALSE` entry here +# was dead config that was never read. i.plot.default <- list( palette = categorical_pal(8), layout = layout_nicely, margin = c(0, 0, 0, 0), rescale = TRUE, asp = 1, - frame = FALSE, main = i.get.main, sub = "", xlab = i.get.xlab, From ab5fc28b5fcd2427a82a854d2317a23800f7c1c3 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 12:22:54 +0200 Subject: [PATCH 13/30] feat(plot): scales + legends for plot.igraph (F1) Add scale_color()/scale_colour() and scale_size(): pass them to vertex/edge colour or size arguments to map a data column to the aesthetic AND draw a matching guide automatically, e.g. plot(g, vertex.color = scale_color(V(g)$group)) plot(g, vertex.size = scale_size(degree(g))) - scale_color(): discrete data -> categorical_pal() + a legend; numeric data -> a sequential colour ramp + a colorbar. - scale_size(): numeric data -> a size range (optional transform) + a size legend. - A new `legend` argument to plot.igraph() controls placement ("topright" default, any corner keyword) or suppression (FALSE). Implemented natively on base graphics (R/plot-scales.R): scales are resolved to plain aesthetic vectors before i.parse.plot.params() (whose recycling strips attributes), with their guides collected and drawn after the vertices/labels. Wrong-length scale data is caught by the existing strict-recycling check. Adds unit tests (test-plot-scales.R) and vdiffr snapshots covering discrete, continuous, size, combined, edge-colour, repositioned, and suppressed guides. NAMESPACE exports are added via @export (regenerated in CI). Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-scales.R | 289 ++++++++++++++++++ R/plot.R | 34 ++- .../_snaps/plot/scale-color-and-size.svg | 71 +++++ .../_snaps/plot/scale-continuous-colorbar.svg | 115 +++++++ .../_snaps/plot/scale-discrete-color.svg | 66 ++++ .../testthat/_snaps/plot/scale-edge-color.svg | 66 ++++ .../_snaps/plot/scale-legend-bottomleft.svg | 66 ++++ .../_snaps/plot/scale-legend-false.svg | 61 ++++ .../_snaps/plot/scale-size-legend.svg | 66 ++++ tests/testthat/test-plot-scales.R | 93 ++++++ tests/testthat/test-plot.R | 60 ++++ 11 files changed, 977 insertions(+), 10 deletions(-) create mode 100644 R/plot-scales.R create mode 100644 tests/testthat/_snaps/plot/scale-color-and-size.svg create mode 100644 tests/testthat/_snaps/plot/scale-continuous-colorbar.svg create mode 100644 tests/testthat/_snaps/plot/scale-discrete-color.svg create mode 100644 tests/testthat/_snaps/plot/scale-edge-color.svg create mode 100644 tests/testthat/_snaps/plot/scale-legend-bottomleft.svg create mode 100644 tests/testthat/_snaps/plot/scale-legend-false.svg create mode 100644 tests/testthat/_snaps/plot/scale-size-legend.svg create mode 100644 tests/testthat/test-plot-scales.R diff --git a/R/plot-scales.R b/R/plot-scales.R new file mode 100644 index 00000000000..8731cbd2825 --- /dev/null +++ b/R/plot-scales.R @@ -0,0 +1,289 @@ +# IGraph R package +# Copyright (C) 2003-2012 Gabor Csardi +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +################################################################### + +# Scales (feature F1): map a data vector to a plotting aesthetic (colour or +# size) AND record a "guide" describing the mapping, so that plot.igraph() can +# draw a matching legend or colorbar. A scale is passed to an existing argument, +# e.g. plot(g, vertex.color = scale_color(V(g)$type)). + +new_igraph_scale <- function(values, guide) { + structure(list(values = values, guide = guide), class = "igraph_scale") +} + +is_igraph_scale <- function(x) inherits(x, "igraph_scale") + +#' Map data to a colour aesthetic with an automatic legend +#' +#' `scale_color()` (alias `scale_colour()`) maps a data vector to vertex or edge +#' colours and records the mapping so that [plot.igraph()] draws a matching +#' guide. Pass it to a colour argument, e.g. +#' `plot(g, vertex.color = scale_color(V(g)$group))`. +#' +#' A non-numeric `x` (factor, character, logical) produces a discrete mapping +#' and a categorical legend; a numeric `x` produces a continuous mapping (a +#' colour ramp) and a colorbar. +#' +#' @param x The data vector to map. Its length must be 1 or the number of +#' vertices/edges of the graph it is used with. +#' @param palette Colours to map to. For discrete `x`, a vector of colours (one +#' per level, recycled); defaults to [categorical_pal()]. For numeric `x`, the +#' anchor colours of the ramp; defaults to [sequential_pal()]. +#' @param na.value Colour used for `NA` entries in `x`. +#' @param name Optional guide title; defaults to the name of the argument the +#' scale is assigned to (e.g. `"vertex.color"`). +#' @return An `igraph_scale` object. +#' @family scales +#' @export +scale_color <- function(x, palette = NULL, na.value = "grey70", name = NULL) { + n <- length(x) + na <- is.na(x) + + if (is.numeric(x)) { + ramp_cols <- if (is.null(palette)) sequential_pal(9) else palette + rng <- range(x, na.rm = TRUE) + norm <- if (diff(rng) == 0) { + rep(0.5, n) + } else { + (x - rng[1]) / (rng[2] - rng[1]) + } + vals <- rep(na.value, n) + if (any(!na)) { + m <- grDevices::colorRamp(ramp_cols)(norm[!na]) + vals[!na] <- grDevices::rgb(m[, 1], m[, 2], m[, 3], maxColorValue = 255) + } + guide <- list( + aesthetic = "color", + type = "continuous", + name = name, + limits = rng, + ramp = ramp_cols + ) + } else { + xc <- as.character(x) + levels <- if (is.factor(x)) { + lv <- levels(x) + lv[lv %in% xc] + } else { + sort(unique(xc[!na])) + } + cols <- if (is.null(palette)) categorical_pal(length(levels)) else palette + cols <- rep(cols, length.out = length(levels)) + map <- stats::setNames(cols, levels) + vals <- unname(map[xc]) + vals[is.na(vals)] <- na.value + guide <- list( + aesthetic = "color", + type = "discrete", + name = name, + labels = levels, + colors = cols + ) + } + + new_igraph_scale(vals, guide) +} + +#' @rdname scale_color +#' @export +scale_colour <- scale_color + +#' Map data to a size aesthetic with an automatic legend +#' +#' `scale_size()` linearly maps a numeric data vector to a size range (suitable +#' for `vertex.size` or `edge.width`) and records the mapping so that +#' [plot.igraph()] draws a matching size legend. Pass it to a size argument, +#' e.g. `plot(g, vertex.size = scale_size(degree(g)))`. +#' +#' @param x A numeric data vector to map. Its length must be 1 or the number of +#' vertices/edges of the graph it is used with. +#' @param range Numeric length-2 vector giving the output size range. +#' @param na.value Size used for `NA` entries in `x`. +#' @param name Optional guide title; defaults to the argument name. +#' @param trans Optional transformation applied to `x` before rescaling, given +#' as a function or its name (e.g. `"sqrt"`, `"log"`). +#' @return An `igraph_scale` object. +#' @family scales +#' @export +scale_size <- function( + x, + range = c(2, 15), + na.value = NA, + name = NULL, + trans = NULL +) { + if (!is.numeric(x)) { + cli::cli_abort("{.arg x} must be numeric for {.fn scale_size}.") + } + n <- length(x) + na <- is.na(x) + tfun <- if (is.null(trans)) identity else match.fun(trans) + xt <- tfun(x) + rng <- range(xt, na.rm = TRUE) + + rescale <- function(v) { + if (diff(rng) == 0) { + rep(mean(range), length(v)) + } else { + (v - rng[1]) / (rng[2] - rng[1]) * (range[2] - range[1]) + range[1] + } + } + + vals <- rescale(xt) + vals[na] <- na.value + + breaks <- pretty(x[!na], n = 3) + breaks <- breaks[breaks >= min(x, na.rm = TRUE) & breaks <= max(x, na.rm = TRUE)] + guide <- list( + aesthetic = "size", + type = "discrete", + name = name, + labels = as.character(breaks), + sizes = rescale(tfun(breaks)) + ) + + new_igraph_scale(vals, guide) +} + +# Replace any igraph_scale arguments in `dots` with their resolved `values`, and +# collect the guides (titling each with the argument name unless the scale set a +# name). Must run before i.parse.plot.params(), whose rep() recycling would strip +# the scale class/attributes. +i.apply_scales <- function(dots) { + guides <- list() + for (nm in names(dots)) { + val <- dots[[nm]] + if (is_igraph_scale(val)) { + guide <- val$guide + if (is.null(guide$name)) { + guide$name <- nm + } + guides[[length(guides) + 1L]] <- guide + dots[[nm]] <- val$values + } + } + list(dots = dots, guides = guides) +} + +# Draw all collected guides, stacking them from a corner. `legend` is TRUE +# (default corner) or a position keyword like "bottomleft". +i.draw_guides <- function(guides, legend) { + pos <- if (is.character(legend)) legend[1] else "topright" + old <- graphics::par(xpd = TRUE) + on.exit(graphics::par(old), add = TRUE) + + anchor <- NULL # NULL => place by keyword; else c(x_left, y_top) + gap <- 0.04 * diff(graphics::par("usr")[3:4]) + for (g in guides) { + rect <- i.draw_one_guide(g, pos, anchor) + anchor <- c(rect$left, rect$top - rect$h - gap) + } + invisible(NULL) +} + +# Draw a single guide and return its bounding rectangle as list(left, top, w, h) +# in user coordinates, so the caller can stack the next one beneath it. +i.draw_one_guide <- function(g, pos, anchor) { + if (g$type == "continuous") { + return(i.draw_colorbar(g, pos, anchor)) + } + + args <- list( + legend = g$labels, + title = g$name, + pch = 21, + bty = "n" + ) + if (g$aesthetic == "color") { + args$pt.bg <- g$colors + args$pt.cex <- 1.8 + } else { + args$pt.bg <- "grey70" + args$pt.cex <- i.size_to_cex(g$sizes) + } + if (is.null(anchor)) { + args <- c(list(x = pos), args) + } else { + args <- c(list(x = anchor[1], y = anchor[2]), args) + } + lg <- do.call(graphics::legend, args) + lg$rect +} + +# Translate plotting sizes (vertex.size / edge.width scale) to a legend point +# cex. Sizes are normalised to a legible cex range; the legend is indicative, +# not a pixel-exact match to the drawn vertices (which use device units). +i.size_to_cex <- function(sizes) { + if (length(sizes) == 0 || all(!is.finite(sizes))) { + return(1.5) + } + mx <- max(sizes, na.rm = TRUE) + if (mx <= 0) { + return(rep(1.5, length(sizes))) + } + 0.8 + 2.2 * (sizes / mx) +} + +# Draw a continuous colour guide (colorbar) anchored at a corner. Returns its +# bounding rectangle for stacking. +i.draw_colorbar <- function(g, pos, anchor) { + usr <- graphics::par("usr") + w <- 0.04 * diff(usr[1:2]) + h <- 0.30 * diff(usr[3:4]) + pad <- 0.03 * diff(usr[1:2]) + gap_lbl <- 0.01 * diff(usr[1:2]) + + # Measure tick labels + title so the whole group can be right-anchored and + # nothing is clipped at the plot edge regardless of device width. + labs <- format(g$limits, digits = 3) + label_w <- max(graphics::strwidth(labs, cex = 0.8)) + gap_lbl + title_w <- if (is.null(g$name)) 0 else graphics::strwidth(g$name) + title_h <- if (is.null(g$name)) 0 else 0.05 * diff(usr[3:4]) + group_w <- max(w + label_w, title_w) + + if (!is.null(anchor)) { + left <- anchor[1] + top <- anchor[2] + } else { + right_side <- grepl("right", pos) + top_side <- !grepl("bottom", pos) + # On the right, set the group's right edge (bar + labels / title) at the + # plot edge so labels and title stay inside. + left <- if (right_side) usr[2] - pad - group_w else usr[1] + pad + top <- if (top_side) usr[4] - pad - title_h else usr[3] + pad + h + } + + nseg <- 50 + ys <- seq(top - h, top, length.out = nseg + 1) + ramp <- grDevices::colorRamp(g$ramp) + cols <- grDevices::rgb( + ramp(seq(0, 1, length.out = nseg)), + maxColorValue = 255 + ) + graphics::rect( + left, + ys[-(nseg + 1)], + left + w, + ys[-1], + col = cols, + border = NA + ) + graphics::rect(left, top - h, left + w, top, border = "grey40") + graphics::text( + left + w + gap_lbl, + c(top - h, top), + labels = labs, + adj = c(0, 0.5), + cex = 0.8 + ) + if (!is.null(g$name)) { + graphics::text(left, top + title_h, labels = g$name, adj = c(0, 0)) + } + + list(left = left, top = top + title_h, w = group_w, h = h + title_h) +} diff --git a/R/plot.R b/R/plot.R index 7a3dfcd9a8e..c8eefeeaa80 100644 --- a/R/plot.R +++ b/R/plot.R @@ -405,6 +405,11 @@ i.draw_vertex_labels <- function( #' @param loop.size A numeric scalar that allows the user to scale the loop edges #' of the network. The default loop size is 1. Larger values will produce larger #' loops. +#' @param legend Controls drawing of legends/colorbars for any aesthetics +#' supplied via [scale_color()] / [scale_size()]. `TRUE` (default) draws them +#' in the top-right corner; a position keyword such as `"bottomleft"` places +#' them elsewhere; `FALSE` suppresses them. Has no effect when no scale is +#' used. #' @param \dots Additional plotting parameters. See [igraph.plotting] for #' the complete list. #' @return Returns `NULL`, invisibly. @@ -439,6 +444,7 @@ plot.igraph <- function( mark.expand = 15, mark.lwd = 1, loop.size = 1, + legend = TRUE, ... ) { graph <- x @@ -448,7 +454,12 @@ plot.igraph <- function( ################################################################ ## Visual parameters - params <- i.parse.plot.params(graph, list(...)) + # Resolve any scale_*() arguments to plain aesthetic vectors and collect their + # guides (legends/colorbars) to draw at the end. Must happen before + # i.parse.plot.params(), whose recycling strips the scale class. + scaled <- i.apply_scales(list(...)) + guides <- scaled$guides + params <- i.parse.plot.params(graph, scaled$dots) vertex.size <- params("vertex", "size") vertex.size.scaling <- params("vertex", "size.scaling") @@ -589,7 +600,7 @@ plot.igraph <- function( ################################################################ ## Rescaling vertices and updating params if (vertex.size.scaling) { - newdots <- list(...) + newdots <- scaled$dots # vertex.size vertex.size <- i.rescale.vertex( @@ -627,14 +638,10 @@ plot.igraph <- function( params <- i.parse.plot.params(graph, newdots) } else { - params <- i.parse.plot.params( - graph, - list( - vertex.size = VERTEX_SIZE_SCALE * vertex.size, - vertex.size2 = VERTEX_SIZE_SCALE * params("vertex", "size2"), - ... - ) - ) + newdots <- scaled$dots + newdots$vertex.size <- VERTEX_SIZE_SCALE * vertex.size + newdots$vertex.size2 <- VERTEX_SIZE_SCALE * params("vertex", "size2") + params <- i.parse.plot.params(graph, newdots) vertex.size <- VERTEX_SIZE_SCALE * vertex.size } ################################################################ @@ -955,6 +962,13 @@ plot.igraph <- function( label.angle, label.adj ) + + ################################################################ + # draw legends / colorbars for any scale_*() aesthetics + if (!isFALSE(legend) && length(guides) > 0) { + i.draw_guides(guides, legend) + } + invisible(NULL) } diff --git a/tests/testthat/_snaps/plot/scale-color-and-size.svg b/tests/testthat/_snaps/plot/scale-color-and-size.svg new file mode 100644 index 00000000000..c21857fa166 --- /dev/null +++ b/tests/testthat/_snaps/plot/scale-color-and-size.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + +vertex.color +alpha +beta + + +vertex.size +5 +10 + + diff --git a/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg b/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg new file mode 100644 index 00000000000..4f04ca5946d --- /dev/null +++ b/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg @@ -0,0 +1,115 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 +10 +vertex.color + + diff --git a/tests/testthat/_snaps/plot/scale-discrete-color.svg b/tests/testthat/_snaps/plot/scale-discrete-color.svg new file mode 100644 index 00000000000..4d14b684cd6 --- /dev/null +++ b/tests/testthat/_snaps/plot/scale-discrete-color.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + +vertex.color +alpha +beta + + diff --git a/tests/testthat/_snaps/plot/scale-edge-color.svg b/tests/testthat/_snaps/plot/scale-edge-color.svg new file mode 100644 index 00000000000..e1537ba0f0c --- /dev/null +++ b/tests/testthat/_snaps/plot/scale-edge-color.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + +edge.color +x +y + + diff --git a/tests/testthat/_snaps/plot/scale-legend-bottomleft.svg b/tests/testthat/_snaps/plot/scale-legend-bottomleft.svg new file mode 100644 index 00000000000..4be8160fd07 --- /dev/null +++ b/tests/testthat/_snaps/plot/scale-legend-bottomleft.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + +vertex.color +alpha +beta + + diff --git a/tests/testthat/_snaps/plot/scale-legend-false.svg b/tests/testthat/_snaps/plot/scale-legend-false.svg new file mode 100644 index 00000000000..28f4cba0f71 --- /dev/null +++ b/tests/testthat/_snaps/plot/scale-legend-false.svg @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + diff --git a/tests/testthat/_snaps/plot/scale-size-legend.svg b/tests/testthat/_snaps/plot/scale-size-legend.svg new file mode 100644 index 00000000000..74f6f74d109 --- /dev/null +++ b/tests/testthat/_snaps/plot/scale-size-legend.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + +vertex.size +5 +10 + + diff --git a/tests/testthat/test-plot-scales.R b/tests/testthat/test-plot-scales.R new file mode 100644 index 00000000000..94d6b644167 --- /dev/null +++ b/tests/testthat/test-plot-scales.R @@ -0,0 +1,93 @@ +# Unit tests for the scale layer (feature F1): scale_color() / scale_size() +# and the internal i.apply_scales() that feeds plot.igraph(). + +test_that("scale_color() maps a discrete vector to categorical colours", { + s <- scale_color(c("a", "b", "a", "c")) + expect_s3_class(s, "igraph_scale") + expect_type(s$values, "character") + + pal <- categorical_pal(3) + # levels are sorted: a, b, c + expect_equal(s$values, pal[c(1, 2, 1, 3)]) + + expect_equal(s$guide$aesthetic, "color") + expect_equal(s$guide$type, "discrete") + expect_equal(s$guide$labels, c("a", "b", "c")) + expect_equal(s$guide$colors, pal) +}) + +test_that("scale_color() respects factor level order and a custom palette", { + x <- factor(c("lo", "hi", "lo"), levels = c("lo", "hi")) + s <- scale_color(x, palette = c("red", "blue")) + expect_equal(s$guide$labels, c("lo", "hi")) # factor order, not sorted + expect_equal(s$values, c("red", "blue", "red")) +}) + +test_that("scale_color() sends NA data to na.value and drops it from the guide", { + s <- scale_color(c("a", NA, "b"), na.value = "grey90") + expect_equal(s$values[2], "grey90") + expect_false("grey90" %in% s$guide$colors) + expect_equal(s$guide$labels, c("a", "b")) +}) + +test_that("scale_color() maps a numeric vector continuously with a colorbar guide", { + s <- scale_color(c(0, 5, 10)) + expect_equal(s$guide$type, "continuous") + expect_equal(s$guide$limits, c(0, 10)) + expect_match(s$values, "^#", all = TRUE) # valid hex + # endpoints differ (low vs high of the ramp) + expect_false(s$values[1] == s$values[3]) +}) + +test_that("scale_size() rescales numeric data to the size range", { + s <- scale_size(c(1, 2, 3), range = c(10, 30)) + expect_s3_class(s, "igraph_scale") + expect_equal(s$values, c(10, 20, 30)) + expect_equal(s$guide$aesthetic, "size") + expect_equal(s$guide$type, "discrete") +}) + +test_that("scale_size() supports a transform and constant input", { + s <- scale_size(c(1, 4, 9), range = c(0, 10), trans = "sqrt") + # sqrt -> 1,2,3 -> linear 0,5,10 + expect_equal(s$values, c(0, 5, 10)) + + flat <- scale_size(rep(5, 4), range = c(2, 8)) + expect_equal(flat$values, rep(5, 4)) # midpoint of range +}) + +test_that("scale_size() rejects non-numeric input", { + expect_error(scale_size(c("a", "b")), "must be numeric") +}) + +test_that("i.apply_scales replaces scale args and collects guides", { + dots <- list( + vertex.color = scale_color(c("a", "b")), + vertex.size = scale_size(c(1, 2)), + edge.width = 3 # plain arg untouched + ) + res <- i.apply_scales(dots) + + expect_type(res$dots$vertex.color, "character") # resolved + expect_equal(res$dots$edge.width, 3) # untouched + expect_length(res$guides, 2) + # title defaults to the argument name + names <- vapply(res$guides, function(g) g$name, character(1)) + expect_setequal(names, c("vertex.color", "vertex.size")) +}) + +test_that("a scale's explicit name overrides the argument-name default", { + res <- i.apply_scales(list(vertex.color = scale_color(c("a", "b"), name = "Group"))) + expect_equal(res$guides[[1]]$name, "Group") +}) + +test_that("a wrong-length scale is rejected by strict recycling at plot time", { + g <- make_ring(5) + grDevices::pdf(NULL) + withr::defer(grDevices::dev.off()) + # 3 colours mapped, but 5 vertices + expect_error( + plot(g, vertex.color = scale_color(c("a", "b", "c"))), + "length 3" + ) +}) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 058506d90a2..99a2627189a 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -283,6 +283,66 @@ test_that("i.edge_label_pos is two thirds from the target toward the source", { expect_equal(unname(pos["y"]), 0) }) +test_that("scales draw matching legends and colorbars", { + skip_if_not_installed("vdiffr") + + ring10 <- function() { + g <- make_ring(10) + g$layout <- layout_in_circle(g) + g + } + + vdiffr::expect_doppelganger("scale-discrete-color", function() { + g <- ring10() + V(g)$grp <- rep(c("alpha", "beta"), 5) + plot(g, vertex.color = scale_color(V(g)$grp), vertex.size = 20) + }) + + vdiffr::expect_doppelganger("scale-continuous-colorbar", function() { + g <- ring10() + plot(g, vertex.color = scale_color(1:10), vertex.size = 20) + }) + + vdiffr::expect_doppelganger("scale-size-legend", function() { + g <- ring10() + plot(g, vertex.size = scale_size(1:10, range = c(5, 25))) + }) + + vdiffr::expect_doppelganger("scale-color-and-size", function() { + g <- ring10() + V(g)$grp <- rep(c("alpha", "beta"), 5) + plot( + g, + vertex.color = scale_color(V(g)$grp), + vertex.size = scale_size(1:10, range = c(5, 25)) + ) + }) + + vdiffr::expect_doppelganger("scale-legend-bottomleft", function() { + g <- ring10() + V(g)$grp <- rep(c("alpha", "beta"), 5) + plot(g, vertex.color = scale_color(V(g)$grp), vertex.size = 20, legend = "bottomleft") + }) + + vdiffr::expect_doppelganger("scale-edge-color", function() { + g <- ring10() + E(g)$type <- rep(c("x", "y"), length.out = ecount(g)) + plot(g, edge.color = scale_color(E(g)$type), edge.width = 2, vertex.size = 15) + }) +}) + +test_that("legend = FALSE suppresses the guide", { + skip_if_not_installed("vdiffr") + # Same graph as scale-discrete-color but with the legend turned off; should + # render identically to a plain coloured plot (no guide box). + vdiffr::expect_doppelganger("scale-legend-false", function() { + g <- make_ring(10) + g$layout <- layout_in_circle(g) + V(g)$grp <- rep(c("alpha", "beta"), 5) + plot(g, vertex.color = scale_color(V(g)$grp), vertex.size = 20, legend = FALSE) + }) +}) + test_that("vector edge params are subset correctly across loops and non-loops", { # Guards the per-edge subsetting of loop vs non-loop edges in plot.igraph(). skip_if_not_installed("vdiffr") From 103a89002f499aac9344a6b01e129c597950720f Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 12:46:55 +0200 Subject: [PATCH 14/30] feat(plot): draw scale legends outside the plot box (F1 follow-up) Legends/colorbars previously sat in a plot corner and overlapped the graph. Now they are drawn in reserved outer-margin space on one side, never over the graph: - New `legend` semantics: TRUE/"right" (default), "left", "top", "bottom" (corner keywords map to the nearest side); FALSE suppresses. - "top"/"bottom" arrange legend entries horizontally and draw a horizontal colorbar; "left"/"right" stack vertically with a vertical colorbar. - plot.igraph() reserves par("mar") on the chosen side before drawing (scaled to label width for left/right) and restores it on exit; guides are drawn with xpd = NA into that margin. - Multiple guides stack (down for left/right, across for top/bottom). Snapshots for the scale cases are regenerated for the new placement; adds horizontal bottom-legend and top-colorbar snapshots. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-scales.R | 219 ++++++++++++------ R/plot.R | 22 +- .../_snaps/plot/scale-color-and-size.svg | 86 +++---- .../plot/scale-continuous-colorbar-top.svg | 115 +++++++++ .../_snaps/plot/scale-continuous-colorbar.svg | 174 +++++++------- .../_snaps/plot/scale-discrete-color.svg | 76 +++--- .../testthat/_snaps/plot/scale-edge-color.svg | 76 +++--- ...svg => scale-legend-bottom-horizontal.svg} | 10 +- .../_snaps/plot/scale-size-legend.svg | 76 +++--- tests/testthat/test-plot.R | 9 +- 10 files changed, 532 insertions(+), 331 deletions(-) create mode 100644 tests/testthat/_snaps/plot/scale-continuous-colorbar-top.svg rename tests/testthat/_snaps/plot/{scale-legend-bottomleft.svg => scale-legend-bottom-horizontal.svg} (90%) diff --git a/R/plot-scales.R b/R/plot-scales.R index 8731cbd2825..98384b0e1c6 100644 --- a/R/plot-scales.R +++ b/R/plot-scales.R @@ -170,34 +170,112 @@ i.apply_scales <- function(dots) { list(dots = dots, guides = guides) } -# Draw all collected guides, stacking them from a corner. `legend` is TRUE -# (default corner) or a position keyword like "bottomleft". -i.draw_guides <- function(guides, legend) { - pos <- if (is.character(legend)) legend[1] else "topright" - old <- graphics::par(xpd = TRUE) + +# Map the `legend` argument to a margin side. TRUE -> "right"; "right"/"left"/ +# "top"/"bottom" are used directly; corner keywords map to the nearest side. +# Returns NULL when there is nothing to draw. +i.legend_side <- function(legend, guides) { + if (isFALSE(legend) || length(guides) == 0) { + return(NULL) + } + if (isTRUE(legend)) { + return("right") + } + pos <- as.character(legend)[1] + if (pos %in% c("right", "left", "top", "bottom")) { + return(pos) + } + if (grepl("left", pos)) { + return("left") + } + if (grepl("right", pos)) { + return("right") + } + if (grepl("top", pos)) { + return("top") + } + if (grepl("bottom", pos)) { + return("bottom") + } + "right" +} + +# Reserve outer-margin space (par("mar"), in text lines) on the legend side, so +# guides are drawn outside the plotting box rather than over the graph. Width +# (left/right) scales with the longest label/title; height (top/bottom) is a +# fixed allowance for one horizontal row plus a title. +i.legend_reserve_mar <- function(mar, side, guides) { + idx <- switch(side, bottom = 1L, left = 2L, top = 3L, right = 4L) + if (side %in% c("right", "left")) { + maxchar <- max(vapply( + guides, + function(g) { + labs <- if (g$type == "continuous") { + format(g$limits, digits = 3) + } else { + g$labels + } + max(nchar(c(labs, if (is.null(g$name)) "" else g$name)), 0L) + }, + numeric(1) + )) + mar[idx] <- max(mar[idx], 3 + 0.65 * maxchar) + } else { + mar[idx] <- max(mar[idx], 5) + } + mar +} + +# Draw all guides in the reserved margin on `side`. left/right stack vertically; +# top/bottom lay each guide's entries out in a row (horiz = TRUE) and stack +# guides left-to-right. +i.draw_guides <- function(guides, side) { + usr <- graphics::par("usr") + old <- graphics::par(xpd = NA) on.exit(graphics::par(old), add = TRUE) - anchor <- NULL # NULL => place by keyword; else c(x_left, y_top) - gap <- 0.04 * diff(graphics::par("usr")[3:4]) + horiz <- side %in% c("top", "bottom") + xr <- diff(usr[1:2]) + yr <- diff(usr[3:4]) + offx <- 0.04 * xr + offy <- 0.06 * yr + + spec <- switch( + side, + right = list(x = usr[2] + offx, y = usr[4], xjust = 0, yjust = 1), + left = list(x = usr[1] - offx, y = usr[4], xjust = 1, yjust = 1), + top = list(x = usr[1], y = usr[4] + offy, xjust = 0, yjust = 0), + bottom = list(x = usr[1], y = usr[3] - offy, xjust = 0, yjust = 1) + ) + gap <- 0.03 * (if (horiz) xr else yr) + for (g in guides) { - rect <- i.draw_one_guide(g, pos, anchor) - anchor <- c(rect$left, rect$top - rect$h - gap) + rect <- i.draw_one_guide(g, spec, horiz) + if (horiz) { + spec$x <- rect$left + rect$w + gap + } else { + spec$y <- rect$top - rect$h - gap + } } invisible(NULL) } -# Draw a single guide and return its bounding rectangle as list(left, top, w, h) -# in user coordinates, so the caller can stack the next one beneath it. -i.draw_one_guide <- function(g, pos, anchor) { +# Draw one guide at the anchor/justification in `spec`; return list(left, top, +# w, h) for stacking. +i.draw_one_guide <- function(g, spec, horiz) { if (g$type == "continuous") { - return(i.draw_colorbar(g, pos, anchor)) + return(i.draw_colorbar(g, spec, horiz)) } - args <- list( + x = spec$x, + y = spec$y, + xjust = spec$xjust, + yjust = spec$yjust, legend = g$labels, title = g$name, pch = 21, - bty = "n" + bty = "n", + horiz = horiz ) if (g$aesthetic == "color") { args$pt.bg <- g$colors @@ -206,13 +284,7 @@ i.draw_one_guide <- function(g, pos, anchor) { args$pt.bg <- "grey70" args$pt.cex <- i.size_to_cex(g$sizes) } - if (is.null(anchor)) { - args <- c(list(x = pos), args) - } else { - args <- c(list(x = anchor[1], y = anchor[2]), args) - } - lg <- do.call(graphics::legend, args) - lg$rect + do.call(graphics::legend, args)$rect } # Translate plotting sizes (vertex.size / edge.width scale) to a legend point @@ -229,61 +301,60 @@ i.size_to_cex <- function(sizes) { 0.8 + 2.2 * (sizes / mx) } -# Draw a continuous colour guide (colorbar) anchored at a corner. Returns its -# bounding rectangle for stacking. -i.draw_colorbar <- function(g, pos, anchor) { +# Continuous colour guide. Vertical bar for left/right, horizontal bar for +# top/bottom. `spec` gives the anchor (x, y) and justification (matching +# graphics::legend); returns the box rect for stacking. +i.draw_colorbar <- function(g, spec, horiz) { usr <- graphics::par("usr") - w <- 0.04 * diff(usr[1:2]) - h <- 0.30 * diff(usr[3:4]) - pad <- 0.03 * diff(usr[1:2]) - gap_lbl <- 0.01 * diff(usr[1:2]) - - # Measure tick labels + title so the whole group can be right-anchored and - # nothing is clipped at the plot edge regardless of device width. + xr <- diff(usr[1:2]) + yr <- diff(usr[3:4]) labs <- format(g$limits, digits = 3) - label_w <- max(graphics::strwidth(labs, cex = 0.8)) + gap_lbl - title_w <- if (is.null(g$name)) 0 else graphics::strwidth(g$name) - title_h <- if (is.null(g$name)) 0 else 0.05 * diff(usr[3:4]) - group_w <- max(w + label_w, title_w) - - if (!is.null(anchor)) { - left <- anchor[1] - top <- anchor[2] - } else { - right_side <- grepl("right", pos) - top_side <- !grepl("bottom", pos) - # On the right, set the group's right edge (bar + labels / title) at the - # plot edge so labels and title stay inside. - left <- if (right_side) usr[2] - pad - group_w else usr[1] + pad - top <- if (top_side) usr[4] - pad - title_h else usr[3] + pad + h - } - - nseg <- 50 - ys <- seq(top - h, top, length.out = nseg + 1) - ramp <- grDevices::colorRamp(g$ramp) - cols <- grDevices::rgb( - ramp(seq(0, 1, length.out = nseg)), + fill <- grDevices::rgb( + grDevices::colorRamp(g$ramp)(seq(0, 1, length.out = 50)), maxColorValue = 255 ) - graphics::rect( - left, - ys[-(nseg + 1)], - left + w, - ys[-1], - col = cols, - border = NA - ) - graphics::rect(left, top - h, left + w, top, border = "grey40") - graphics::text( - left + w + gap_lbl, - c(top - h, top), - labels = labs, - adj = c(0, 0.5), - cex = 0.8 - ) - if (!is.null(g$name)) { - graphics::text(left, top + title_h, labels = g$name, adj = c(0, 0)) - } + line_h <- 1.4 * graphics::strheight("M") + title_h <- if (is.null(g$name)) 0 else line_h - list(left = left, top = top + title_h, w = group_w, h = h + title_h) + if (horiz) { + barw <- 0.25 * xr + barh <- 0.04 * yr + w <- barw + h <- barh + line_h + title_h + left <- spec$x - spec$xjust * w + top <- spec$y + (1 - spec$yjust) * h + bar_top <- top - title_h + xs <- seq(left, left + barw, length.out = 51) + graphics::rect(xs[-51], bar_top - barh, xs[-1], bar_top, col = fill, border = NA) + graphics::rect(left, bar_top - barh, left + barw, bar_top, border = "grey40") + ylab <- bar_top - barh - 0.2 * line_h + graphics::text(left, ylab, labs[1], adj = c(0, 1), cex = 0.8) + graphics::text(left + barw, ylab, labs[2], adj = c(1, 1), cex = 0.8) + if (!is.null(g$name)) { + graphics::text(left, top, labels = g$name, adj = c(0, 1)) + } + } else { + barw <- 0.03 * xr + barh <- 0.25 * yr + label_w <- max(graphics::strwidth(labs, cex = 0.8)) + 0.01 * xr + w <- barw + label_w + h <- barh + title_h + left <- spec$x - spec$xjust * w + top <- spec$y + (1 - spec$yjust) * h + bar_top <- top - title_h + ys <- seq(bar_top - barh, bar_top, length.out = 51) + graphics::rect(left, ys[-51], left + barw, ys[-1], col = fill, border = NA) + graphics::rect(left, bar_top - barh, left + barw, bar_top, border = "grey40") + graphics::text( + left + barw + 0.01 * xr, + c(bar_top - barh, bar_top), + labels = labs, + adj = c(0, 0.5), + cex = 0.8 + ) + if (!is.null(g$name)) { + graphics::text(left, top, labels = g$name, adj = c(0, 1)) + } + } + list(left = left, top = top, w = w, h = h) } diff --git a/R/plot.R b/R/plot.R index c8eefeeaa80..84e9295874b 100644 --- a/R/plot.R +++ b/R/plot.R @@ -406,10 +406,11 @@ i.draw_vertex_labels <- function( #' of the network. The default loop size is 1. Larger values will produce larger #' loops. #' @param legend Controls drawing of legends/colorbars for any aesthetics -#' supplied via [scale_color()] / [scale_size()]. `TRUE` (default) draws them -#' in the top-right corner; a position keyword such as `"bottomleft"` places -#' them elsewhere; `FALSE` suppresses them. Has no effect when no scale is -#' used. +#' supplied via [scale_color()] / [scale_size()]. The guide is drawn in the +#' reserved outer margin on one side of the plot: `TRUE` (default) or +#' `"right"` places it to the right, `"left"`/`"top"`/`"bottom"` on the +#' corresponding side (`"top"`/`"bottom"` arrange entries horizontally); +#' `FALSE` suppresses it. Has no effect when no scale is used. #' @param \dots Additional plotting parameters. See [igraph.plotting] for #' the complete list. #' @return Returns `NULL`, invisibly. @@ -459,6 +460,7 @@ plot.igraph <- function( # i.parse.plot.params(), whose recycling strips the scale class. scaled <- i.apply_scales(list(...)) guides <- scaled$guides + legend_side <- i.legend_side(legend, guides) params <- i.parse.plot.params(graph, scaled$dots) vertex.size <- params("vertex", "size") @@ -583,6 +585,14 @@ plot.igraph <- function( ylim <- range(layout[, 2]) + c(-margin[1], margin[3]) } } + # Reserve outer-margin space for any legends/colorbars so they sit outside the + # plotting box rather than over the graph. Must happen before the canvas is + # set up; restored on exit. + if (!add && !is.null(legend_side)) { + old_mar <- graphics::par("mar") + graphics::par(mar = i.legend_reserve_mar(old_mar, legend_side, guides)) + on.exit(graphics::par(mar = old_mar), add = TRUE) + } if (!add) { i.init_plot_canvas( xlim, @@ -965,8 +975,8 @@ plot.igraph <- function( ################################################################ # draw legends / colorbars for any scale_*() aesthetics - if (!isFALSE(legend) && length(guides) > 0) { - i.draw_guides(guides, legend) + if (!is.null(legend_side)) { + i.draw_guides(guides, legend_side) } invisible(NULL) diff --git a/tests/testthat/_snaps/plot/scale-color-and-size.svg b/tests/testthat/_snaps/plot/scale-color-and-size.svg index c21857fa166..7dcbaf212a1 100644 --- a/tests/testthat/_snaps/plot/scale-color-and-size.svg +++ b/tests/testthat/_snaps/plot/scale-color-and-size.svg @@ -20,52 +20,52 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - -vertex.color -alpha -beta - - -vertex.size -5 -10 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + +vertex.color +alpha +beta + + +vertex.size +5 +10 diff --git a/tests/testthat/_snaps/plot/scale-continuous-colorbar-top.svg b/tests/testthat/_snaps/plot/scale-continuous-colorbar-top.svg new file mode 100644 index 00000000000..0f4fb0e90be --- /dev/null +++ b/tests/testthat/_snaps/plot/scale-continuous-colorbar-top.svg @@ -0,0 +1,115 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 +10 +vertex.color + + diff --git a/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg b/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg index 4f04ca5946d..1c374e484a8 100644 --- a/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg +++ b/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg @@ -20,96 +20,96 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1 -10 -vertex.color +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 +10 +vertex.color diff --git a/tests/testthat/_snaps/plot/scale-discrete-color.svg b/tests/testthat/_snaps/plot/scale-discrete-color.svg index 4d14b684cd6..866cc829cf7 100644 --- a/tests/testthat/_snaps/plot/scale-discrete-color.svg +++ b/tests/testthat/_snaps/plot/scale-discrete-color.svg @@ -20,47 +20,47 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - -vertex.color -alpha -beta +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + +vertex.color +alpha +beta diff --git a/tests/testthat/_snaps/plot/scale-edge-color.svg b/tests/testthat/_snaps/plot/scale-edge-color.svg index e1537ba0f0c..bb51ceac98c 100644 --- a/tests/testthat/_snaps/plot/scale-edge-color.svg +++ b/tests/testthat/_snaps/plot/scale-edge-color.svg @@ -20,47 +20,47 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - -edge.color -x -y +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + +edge.color +x +y diff --git a/tests/testthat/_snaps/plot/scale-legend-bottomleft.svg b/tests/testthat/_snaps/plot/scale-legend-bottom-horizontal.svg similarity index 90% rename from tests/testthat/_snaps/plot/scale-legend-bottomleft.svg rename to tests/testthat/_snaps/plot/scale-legend-bottom-horizontal.svg index 4be8160fd07..17beafc611c 100644 --- a/tests/testthat/_snaps/plot/scale-legend-bottomleft.svg +++ b/tests/testthat/_snaps/plot/scale-legend-bottom-horizontal.svg @@ -57,10 +57,10 @@ 8 9 10 - - -vertex.color -alpha -beta + + +vertex.color +alpha +beta diff --git a/tests/testthat/_snaps/plot/scale-size-legend.svg b/tests/testthat/_snaps/plot/scale-size-legend.svg index 74f6f74d109..72ae4b4cebf 100644 --- a/tests/testthat/_snaps/plot/scale-size-legend.svg +++ b/tests/testthat/_snaps/plot/scale-size-legend.svg @@ -20,47 +20,47 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - -vertex.size -5 -10 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 + + +vertex.size +5 +10 diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 99a2627189a..f7728806d6f 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -318,10 +318,15 @@ test_that("scales draw matching legends and colorbars", { ) }) - vdiffr::expect_doppelganger("scale-legend-bottomleft", function() { + vdiffr::expect_doppelganger("scale-legend-bottom-horizontal", function() { g <- ring10() V(g)$grp <- rep(c("alpha", "beta"), 5) - plot(g, vertex.color = scale_color(V(g)$grp), vertex.size = 20, legend = "bottomleft") + plot(g, vertex.color = scale_color(V(g)$grp), vertex.size = 20, legend = "bottom") + }) + + vdiffr::expect_doppelganger("scale-continuous-colorbar-top", function() { + g <- ring10() + plot(g, vertex.color = scale_color(1:10), vertex.size = 20, legend = "top") }) vdiffr::expect_doppelganger("scale-edge-color", function() { From 4081d0d902aae72cf990b7248e757fc3b4429a58 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 13:13:24 +0200 Subject: [PATCH 15/30] fix(plot): place scale guides in their own resize-stable figure region The previous corner/margin placement positioned guides in data coordinates, which (with asp = 1) drift as the device is resized and could be off-centre or disappear. Switch to the standard two-region approach: split the device with par("fig") into a plot region and a guide region (device-relative NDC, so it is stable across resizes), draw the graph in the plot region, then draw the guides into the guide region via par(new = TRUE). Guides are centred within their region (two-pass measure then layout): stacked vertically for left/right, laid out in a row for top/bottom, with horizontal colorbars for top/bottom and vertical for left/right. Replaces i.draw_guides/i.draw_one_guide/i.draw_colorbar/i.legend_reserve_mar with i.legend_fig + i.draw_guides_region + i.guide_draw + i.colorbar. Legends are only drawn when add = FALSE (a guide region can't be carved out of an existing plot). Scale snapshots regenerated for the new placement. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-scales.R | 193 +++++++++--------- R/plot.R | 21 +- .../_snaps/plot/scale-color-and-size.svg | 95 +++++---- .../plot/scale-continuous-colorbar-top.svg | 183 +++++++++-------- .../_snaps/plot/scale-continuous-colorbar.svg | 183 +++++++++-------- .../_snaps/plot/scale-discrete-color.svg | 85 ++++---- .../testthat/_snaps/plot/scale-edge-color.svg | 85 ++++---- .../plot/scale-legend-bottom-horizontal.svg | 85 ++++---- .../_snaps/plot/scale-size-legend.svg | 85 ++++---- 9 files changed, 537 insertions(+), 478 deletions(-) diff --git a/R/plot-scales.R b/R/plot-scales.R index 98384b0e1c6..6ace752022e 100644 --- a/R/plot-scales.R +++ b/R/plot-scales.R @@ -200,82 +200,75 @@ i.legend_side <- function(legend, guides) { "right" } -# Reserve outer-margin space (par("mar"), in text lines) on the legend side, so -# guides are drawn outside the plotting box rather than over the graph. Width -# (left/right) scales with the longest label/title; height (top/bottom) is a -# fixed allowance for one horizontal row plus a title. -i.legend_reserve_mar <- function(mar, side, guides) { - idx <- switch(side, bottom = 1L, left = 2L, top = 3L, right = 4L) - if (side %in% c("right", "left")) { - maxchar <- max(vapply( - guides, - function(g) { - labs <- if (g$type == "continuous") { - format(g$limits, digits = 3) - } else { - g$labels - } - max(nchar(c(labs, if (is.null(g$name)) "" else g$name)), 0L) - }, - numeric(1) - )) - mar[idx] <- max(mar[idx], 3 + 0.65 * maxchar) - } else { - mar[idx] <- max(mar[idx], 5) - } - mar +# Split the device into a plot region and a guide region, as device-relative +# (NDC) fractions for par("fig"). Using fig regions (rather than data-coordinate +# offsets) keeps the guide put and correctly sized when the device is resized. +i.legend_fig <- function(side) { + frac_v <- 0.22 # width fraction for a left/right guide + frac_h <- 0.18 # height fraction for a top/bottom guide + switch( + side, + right = list(plot = c(0, 1 - frac_v, 0, 1), guide = c(1 - frac_v, 1, 0, 1)), + left = list(plot = c(frac_v, 1, 0, 1), guide = c(0, frac_v, 0, 1)), + top = list(plot = c(0, 1, 0, 1 - frac_h), guide = c(0, 1, 1 - frac_h, 1)), + bottom = list(plot = c(0, 1, frac_h, 1), guide = c(0, 1, 0, frac_h)) + ) } -# Draw all guides in the reserved margin on `side`. left/right stack vertically; -# top/bottom lay each guide's entries out in a row (horiz = TRUE) and stack -# guides left-to-right. -i.draw_guides <- function(guides, side) { - usr <- graphics::par("usr") - old <- graphics::par(xpd = NA) - on.exit(graphics::par(old), add = TRUE) +# Draw the guides in the current figure region (set by the caller via par(fig)). +# A fresh [0, 1] x [0, 1] window is set up and the guides are centred in it: +# stacked vertically for left/right, laid out in a row for top/bottom (with each +# guide's own entries arranged horizontally). +i.draw_guides_region <- function(guides, side) { + graphics::par(mar = c(0.4, 0.4, 0.4, 0.4)) + graphics::plot.new() + graphics::plot.window(xlim = c(0, 1), ylim = c(0, 1)) + graphics::par(xpd = NA) horiz <- side %in% c("top", "bottom") - xr <- diff(usr[1:2]) - yr <- diff(usr[3:4]) - offx <- 0.04 * xr - offy <- 0.06 * yr + # Measure each guide first so the whole stack can be centred. + rects <- lapply(guides, function(g) { + i.guide_draw(g, 0.5, 0.5, 0.5, 0.5, horiz, plot = FALSE) + }) + gap <- 0.04 - spec <- switch( - side, - right = list(x = usr[2] + offx, y = usr[4], xjust = 0, yjust = 1), - left = list(x = usr[1] - offx, y = usr[4], xjust = 1, yjust = 1), - top = list(x = usr[1], y = usr[4] + offy, xjust = 0, yjust = 0), - bottom = list(x = usr[1], y = usr[3] - offy, xjust = 0, yjust = 1) - ) - gap <- 0.03 * (if (horiz) xr else yr) - - for (g in guides) { - rect <- i.draw_one_guide(g, spec, horiz) - if (horiz) { - spec$x <- rect$left + rect$w + gap - } else { - spec$y <- rect$top - rect$h - gap + if (horiz) { + ws <- vapply(rects, function(r) r$w, numeric(1)) + total <- sum(ws) + gap * max(0, length(guides) - 1) + x <- 0.5 - total / 2 + for (i in seq_along(guides)) { + i.guide_draw(guides[[i]], x, 0.5, 0, 0.5, horiz = TRUE, plot = TRUE) + x <- x + ws[i] + gap + } + } else { + hs <- vapply(rects, function(r) r$h, numeric(1)) + total <- sum(hs) + gap * max(0, length(guides) - 1) + y <- 0.5 + total / 2 + for (i in seq_along(guides)) { + i.guide_draw(guides[[i]], 0.5, y, 0.5, 1, horiz = FALSE, plot = TRUE) + y <- y - hs[i] - gap } } invisible(NULL) } -# Draw one guide at the anchor/justification in `spec`; return list(left, top, -# w, h) for stacking. -i.draw_one_guide <- function(g, spec, horiz) { +# Draw (or, with plot = FALSE, just measure) one guide at the given anchor and +# justification. Returns list(left, top, w, h) in the current user coordinates. +i.guide_draw <- function(g, x, y, xjust, yjust, horiz, plot) { if (g$type == "continuous") { - return(i.draw_colorbar(g, spec, horiz)) + return(i.colorbar(g, x, y, xjust, yjust, horiz, plot)) } args <- list( - x = spec$x, - y = spec$y, - xjust = spec$xjust, - yjust = spec$yjust, + x = x, + y = y, + xjust = xjust, + yjust = yjust, legend = g$labels, title = g$name, pch = 21, bty = "n", - horiz = horiz + horiz = horiz, + plot = plot ) if (g$aesthetic == "color") { args$pt.bg <- g$colors @@ -301,59 +294,59 @@ i.size_to_cex <- function(sizes) { 0.8 + 2.2 * (sizes / mx) } -# Continuous colour guide. Vertical bar for left/right, horizontal bar for -# top/bottom. `spec` gives the anchor (x, y) and justification (matching -# graphics::legend); returns the box rect for stacking. -i.draw_colorbar <- function(g, spec, horiz) { - usr <- graphics::par("usr") - xr <- diff(usr[1:2]) - yr <- diff(usr[3:4]) +# Continuous colour guide (colorbar), in the current [0, 1] guide window. +# Vertical bar for left/right, horizontal bar for top/bottom. `plot = FALSE` +# measures only. Returns list(left, top, w, h). +i.colorbar <- function(g, x, y, xjust, yjust, horiz, plot) { labs <- format(g$limits, digits = 3) fill <- grDevices::rgb( grDevices::colorRamp(g$ramp)(seq(0, 1, length.out = 50)), maxColorValue = 255 ) - line_h <- 1.4 * graphics::strheight("M") - title_h <- if (is.null(g$name)) 0 else line_h + lh <- 1.2 * graphics::strheight("M") + title_h <- if (is.null(g$name)) 0 else lh if (horiz) { - barw <- 0.25 * xr - barh <- 0.04 * yr + barw <- 0.5 + barh <- 0.12 w <- barw - h <- barh + line_h + title_h - left <- spec$x - spec$xjust * w - top <- spec$y + (1 - spec$yjust) * h - bar_top <- top - title_h - xs <- seq(left, left + barw, length.out = 51) - graphics::rect(xs[-51], bar_top - barh, xs[-1], bar_top, col = fill, border = NA) - graphics::rect(left, bar_top - barh, left + barw, bar_top, border = "grey40") - ylab <- bar_top - barh - 0.2 * line_h - graphics::text(left, ylab, labs[1], adj = c(0, 1), cex = 0.8) - graphics::text(left + barw, ylab, labs[2], adj = c(1, 1), cex = 0.8) - if (!is.null(g$name)) { - graphics::text(left, top, labels = g$name, adj = c(0, 1)) - } + h <- barh + lh + title_h } else { - barw <- 0.03 * xr - barh <- 0.25 * yr - label_w <- max(graphics::strwidth(labs, cex = 0.8)) + 0.01 * xr + barw <- 0.12 + label_w <- max(graphics::strwidth(labs, cex = 0.8)) + 0.02 + barh <- 0.5 w <- barw + label_w h <- barh + title_h - left <- spec$x - spec$xjust * w - top <- spec$y + (1 - spec$yjust) * h + } + left <- x - xjust * w + top <- y + (1 - yjust) * h + + if (plot) { bar_top <- top - title_h - ys <- seq(bar_top - barh, bar_top, length.out = 51) - graphics::rect(left, ys[-51], left + barw, ys[-1], col = fill, border = NA) - graphics::rect(left, bar_top - barh, left + barw, bar_top, border = "grey40") - graphics::text( - left + barw + 0.01 * xr, - c(bar_top - barh, bar_top), - labels = labs, - adj = c(0, 0.5), - cex = 0.8 - ) - if (!is.null(g$name)) { - graphics::text(left, top, labels = g$name, adj = c(0, 1)) + if (horiz) { + xs <- seq(left, left + barw, length.out = 51) + graphics::rect(xs[-51], bar_top - barh, xs[-1], bar_top, col = fill, border = NA) + graphics::rect(left, bar_top - barh, left + barw, bar_top, border = "grey40") + ylab <- bar_top - barh - 0.2 * lh + graphics::text(left, ylab, labs[1], adj = c(0, 1), cex = 0.8) + graphics::text(left + barw, ylab, labs[2], adj = c(1, 1), cex = 0.8) + if (!is.null(g$name)) { + graphics::text(left + barw / 2, top, g$name, adj = c(0.5, 1)) + } + } else { + ys <- seq(bar_top - barh, bar_top, length.out = 51) + graphics::rect(left, ys[-51], left + barw, ys[-1], col = fill, border = NA) + graphics::rect(left, bar_top - barh, left + barw, bar_top, border = "grey40") + graphics::text( + left + barw + 0.02, + c(bar_top - barh, bar_top), + labels = labs, + adj = c(0, 0.5), + cex = 0.8 + ) + if (!is.null(g$name)) { + graphics::text(left, top, g$name, adj = c(0, 1)) + } } } list(left = left, top = top, w = w, h = h) diff --git a/R/plot.R b/R/plot.R index 84e9295874b..0d5c665db9d 100644 --- a/R/plot.R +++ b/R/plot.R @@ -585,13 +585,15 @@ plot.igraph <- function( ylim <- range(layout[, 2]) + c(-margin[1], margin[3]) } } - # Reserve outer-margin space for any legends/colorbars so they sit outside the - # plotting box rather than over the graph. Must happen before the canvas is - # set up; restored on exit. + # When a scale legend is drawn, split the device into a plot region and a + # guide region (device-relative, so it survives resizing). The graph is drawn + # in the plot region; the guides are drawn into the guide region at the end. + legend_fig <- NULL if (!add && !is.null(legend_side)) { - old_mar <- graphics::par("mar") - graphics::par(mar = i.legend_reserve_mar(old_mar, legend_side, guides)) - on.exit(graphics::par(mar = old_mar), add = TRUE) + legend_fig <- i.legend_fig(legend_side) + old_par <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(old_par), add = TRUE) + graphics::par(fig = legend_fig$plot) } if (!add) { i.init_plot_canvas( @@ -974,9 +976,10 @@ plot.igraph <- function( ) ################################################################ - # draw legends / colorbars for any scale_*() aesthetics - if (!is.null(legend_side)) { - i.draw_guides(guides, legend_side) + # draw legends / colorbars for any scale_*() aesthetics, in the guide region + if (!is.null(legend_fig)) { + graphics::par(fig = legend_fig$guide, new = TRUE) + i.draw_guides_region(guides, legend_side) } invisible(NULL) diff --git a/tests/testthat/_snaps/plot/scale-color-and-size.svg b/tests/testthat/_snaps/plot/scale-color-and-size.svg index 7dcbaf212a1..1152c8404dd 100644 --- a/tests/testthat/_snaps/plot/scale-color-and-size.svg +++ b/tests/testthat/_snaps/plot/scale-color-and-size.svg @@ -20,52 +20,61 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - -vertex.color -alpha -beta - - -vertex.size -5 -10 + + +vertex.color +alpha +beta + + +vertex.size +5 +10 diff --git a/tests/testthat/_snaps/plot/scale-continuous-colorbar-top.svg b/tests/testthat/_snaps/plot/scale-continuous-colorbar-top.svg index 0f4fb0e90be..b0be9dc8a1e 100644 --- a/tests/testthat/_snaps/plot/scale-continuous-colorbar-top.svg +++ b/tests/testthat/_snaps/plot/scale-continuous-colorbar-top.svg @@ -20,96 +20,105 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1 -10 -vertex.color + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 +10 +vertex.color diff --git a/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg b/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg index 1c374e484a8..314120473d0 100644 --- a/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg +++ b/tests/testthat/_snaps/plot/scale-continuous-colorbar.svg @@ -20,96 +20,105 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1 -10 -vertex.color + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 +10 +vertex.color diff --git a/tests/testthat/_snaps/plot/scale-discrete-color.svg b/tests/testthat/_snaps/plot/scale-discrete-color.svg index 866cc829cf7..081510a9400 100644 --- a/tests/testthat/_snaps/plot/scale-discrete-color.svg +++ b/tests/testthat/_snaps/plot/scale-discrete-color.svg @@ -20,47 +20,56 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - -vertex.color -alpha -beta + + +vertex.color +alpha +beta diff --git a/tests/testthat/_snaps/plot/scale-edge-color.svg b/tests/testthat/_snaps/plot/scale-edge-color.svg index bb51ceac98c..eade1e7b68b 100644 --- a/tests/testthat/_snaps/plot/scale-edge-color.svg +++ b/tests/testthat/_snaps/plot/scale-edge-color.svg @@ -20,47 +20,56 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - -edge.color -x -y + + +edge.color +x +y diff --git a/tests/testthat/_snaps/plot/scale-legend-bottom-horizontal.svg b/tests/testthat/_snaps/plot/scale-legend-bottom-horizontal.svg index 17beafc611c..88849b98510 100644 --- a/tests/testthat/_snaps/plot/scale-legend-bottom-horizontal.svg +++ b/tests/testthat/_snaps/plot/scale-legend-bottom-horizontal.svg @@ -20,47 +20,56 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - -vertex.color -alpha -beta + + +vertex.color +alpha +beta diff --git a/tests/testthat/_snaps/plot/scale-size-legend.svg b/tests/testthat/_snaps/plot/scale-size-legend.svg index 72ae4b4cebf..6d2ed01e347 100644 --- a/tests/testthat/_snaps/plot/scale-size-legend.svg +++ b/tests/testthat/_snaps/plot/scale-size-legend.svg @@ -20,47 +20,56 @@ - - + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 - - -vertex.size -5 -10 + + +vertex.size +5 +10 From 7010bd20407c55344a59ebeabb0d511e9505e679 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 14:42:18 +0200 Subject: [PATCH 16/30] feat(plot): non-overlapping vertex labels via vertex.label.repel (F2) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add an opt-in ggrepel/Gephi-style label-adjust: with vertex.label.repel = TRUE, overlapping vertex labels are iteratively nudged apart and a thin leader line connects each moved label to its original anchor. - i.repel_labels(): deterministic force layout — labels repel along the axis of smaller box overlap and are sprung back toward their anchor. Pure (takes label box half-sizes), so it is unit-testable without a device. - i.draw_vertex_labels() gains a `repel` argument: it measures each non-empty label's box (strwidth/strheight), runs the repel, draws leader lines for labels that moved, then draws the text at the adjusted positions. - New `label.repel` vertex default (FALSE) resolved in plot.igraph(); documented in the plotting parameters. Default rendering is unchanged. Adds unit tests for i.repel_labels and a vdiffr snapshot of repelled clustered labels. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot.R | 81 +++++++++++++++++++++- R/plot.common.R | 6 ++ tests/testthat/_snaps/plot/label-repel.svg | 47 +++++++++++++ tests/testthat/test-plot.R | 36 ++++++++++ 4 files changed, 167 insertions(+), 3 deletions(-) create mode 100644 tests/testthat/_snaps/plot/label-repel.svg diff --git a/R/plot.R b/R/plot.R index 0d5c665db9d..6c02d7085b0 100644 --- a/R/plot.R +++ b/R/plot.R @@ -291,9 +291,58 @@ i.loop_angles <- function(graph, layout, loops.v) { list(angles = la_dyn, narrowing = narrowing) } +# Iteratively nudge overlapping text labels apart (ggrepel / Gephi "label +# adjust" style). Each label is repelled by other labels whose boxes overlap and +# gently sprung back toward its original anchor. Pure geometry given the label +# box half-sizes; deterministic (no randomness), so snapshots are stable. +# `hw`/`hh` are per-label half-width/height in user coordinates. +i.repel_labels <- function(x, y, hw, hh, iter = 200, spring = 0.04) { + n <- length(x) + if (n < 2) { + return(list(x = x, y = y)) + } + px <- x + py <- y + for (it in seq_len(iter)) { + fx <- numeric(n) + fy <- numeric(n) + for (i in seq_len(n - 1)) { + for (j in (i + 1):n) { + dx <- px[i] - px[j] + dy <- py[i] - py[j] + ox <- (hw[i] + hw[j]) - abs(dx) # overlap along x + oy <- (hh[i] + hh[j]) - abs(dy) # overlap along y + if (ox > 0 && oy > 0) { + # separate along the axis of smaller overlap (cheaper move) + if (ox <= oy) { + s <- if (dx >= 0) 1 else -1 + fx[i] <- fx[i] + s * ox * 0.5 + fx[j] <- fx[j] - s * ox * 0.5 + } else { + s <- if (dy >= 0) 1 else -1 + fy[i] <- fy[i] + s * oy * 0.5 + fy[j] <- fy[j] - s * oy * 0.5 + } + } + } + } + # spring back toward the original anchor + fx <- fx + (x - px) * spring + fy <- fy + (y - py) * spring + if (max(abs(c(fx, fy))) < 1e-4) { + break + } + px <- px + fx + py <- py + fy + } + list(x = px, y = py) +} + # Draw vertex labels (Stage 4), offset from each vertex by label.dist along # label.degree. xpd = TRUE is scoped to this call so labels may spill outside -# the plot region. No-op for an empty graph. +# the plot region. With `repel = TRUE`, overlapping labels are nudged apart and +# a leader line connects each moved label to its anchor. No-op for an empty +# graph. i.draw_vertex_labels <- function( layout, labels, @@ -305,7 +354,8 @@ i.draw_vertex_labels <- function( label.font, label.cex, label.angle, - label.adj + label.adj, + repel = FALSE ) { vc <- nrow(layout) if (vc == 0) { @@ -334,6 +384,29 @@ i.draw_vertex_labels <- function( label.adj <- rep(list(label.adj), length.out = vc) label.text <- rep(labels, length.out = vc) + if (isTRUE(any(repel)) && vc > 1) { + drawn <- !is.na(label.text) & nzchar(as.character(label.text)) + if (sum(drawn) > 1) { + hw <- rep(0, vc) + hh <- rep(0, vc) + hw[drawn] <- strwidth(label.text[drawn], cex = label.cex[drawn]) / 2 * 1.15 + hh[drawn] <- strheight(label.text[drawn], cex = label.cex[drawn]) / 2 * 1.6 + moved <- i.repel_labels(x[drawn], y[drawn], hw[drawn], hh[drawn]) + nx <- x + ny <- y + nx[drawn] <- moved$x + ny[drawn] <- moved$y + # leader lines from the original anchor to labels that actually moved + shift <- sqrt((nx - x)^2 + (ny - y)^2) + lead <- drawn & shift > pmax(hh, 1e-6) + if (any(lead)) { + segments(x[lead], y[lead], nx[lead], ny[lead], col = "grey60", lwd = 0.5) + } + x <- nx + y <- ny + } + } + invisible(mapply( function(x0, y0, lbl, col, fam, fnt, cex, srt, adj) { text( @@ -473,6 +546,7 @@ plot.igraph <- function( label.dist <- params("vertex", "label.dist") label.angle <- params("vertex", "label.angle") label.adj <- params("vertex", "label.adj") + label.repel <- params("vertex", "label.repel") labels <- params("vertex", "label") shape <- igraph.check.shapes(params("vertex", "shape")) @@ -972,7 +1046,8 @@ plot.igraph <- function( label.font, label.cex, label.angle, - label.adj + label.adj, + repel = label.repel ) ################################################################ diff --git a/R/plot.common.R b/R/plot.common.R index a54526f98b7..fd73a3a447b 100644 --- a/R/plot.common.R +++ b/R/plot.common.R @@ -231,6 +231,11 @@ #' \item{label.adj}{ #' one or two numeric values, giving the horizontal and vertical adjustment of the vertex labels. See also `adj` in [graphics::text()]. #' } +#' \item{label.repel}{ +#' Logical scalar. If `TRUE`, overlapping vertex labels are iteratively nudged +#' apart (in the spirit of \pkg{ggrepel}) and a thin leader line connects each +#' moved label to its original position. The default is `FALSE`. +#' } #' \item{size.scaling}{ #' Switches between absolute vertex sizing (FALSE,default) and relative (TRUE). @@ -4870,6 +4875,7 @@ i.vertex.default <- list( label.cex = 1, label.angle = 0, label.adj = NULL, + label.repel = FALSE, frame.color = "black", frame.width = 1, shape = "circle", diff --git a/tests/testthat/_snaps/plot/label-repel.svg b/tests/testthat/_snaps/plot/label-repel.svg new file mode 100644 index 00000000000..65872883fde --- /dev/null +++ b/tests/testthat/_snaps/plot/label-repel.svg @@ -0,0 +1,47 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Alice +Bob +Carol +Dave +Eve +Frank +Grace +Heidi + + diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index f7728806d6f..c44e39126f3 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -234,6 +234,26 @@ test_that("mark border linewidth", { vdiffr::expect_doppelganger("mark-border-lwd", mark_border_lwd) }) +test_that("i.repel_labels separates overlapping labels and is deterministic", { + # two boxes stacked at the same point should be pushed apart (here along y, + # the smaller-overlap axis) + r <- i.repel_labels(x = c(0, 0), y = c(0, 0), hw = c(0.2, 0.2), hh = c(0.1, 0.1)) + sep <- max(abs(r$x[1] - r$x[2]), abs(r$y[1] - r$y[2])) + expect_gt(sep, 0.15) # was 0; now nearly the box height sum (0.2) + + # deterministic + r2 <- i.repel_labels(x = c(0, 0), y = c(0, 0), hw = c(0.2, 0.2), hh = c(0.1, 0.1)) + expect_equal(r, r2) + + # a single label is returned unchanged + expect_equal(i.repel_labels(5, 7, 1, 1), list(x = 5, y = 7)) + + # non-overlapping labels are left where they are + far <- i.repel_labels(c(0, 10), c(0, 0), c(0.2, 0.2), c(0.1, 0.1)) + expect_equal(far$x, c(0, 10)) + expect_equal(far$y, c(0, 0)) +}) + test_that("i.loop_angles distributes loops and returns aligned vectors", { # Two vertices, vertex 1 has 2 loops, plus a 1-2 edge. g <- make_graph(c(1, 2, 1, 1, 1, 1), directed = FALSE) @@ -336,6 +356,22 @@ test_that("scales draw matching legends and colorbars", { }) }) +test_that("vertex.label.repel separates clustered labels", { + skip_if_not_installed("vdiffr") + + vdiffr::expect_doppelganger("label-repel", function() { + g <- make_empty_graph(8) + layout <- cbind( + c(0, 0.05, 0.1, -0.05, 1, 1.05, 0.95, 1.1), + c(0, 0.05, -0.05, 0.02, 1, 0.95, 1.05, 1.02) + ) + V(g)$label <- c( + "Alice", "Bob", "Carol", "Dave", "Eve", "Frank", "Grace", "Heidi" + ) + plot(g, layout = layout, vertex.size = 12, vertex.label.repel = TRUE) + }) +}) + test_that("legend = FALSE suppresses the guide", { skip_if_not_installed("vdiffr") # Same graph as scale-discrete-color but with the legend turned off; should From 9e142d2275d4acf89603c18d4cebd30eccaf5f33 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 16:23:43 +0200 Subject: [PATCH 17/30] feat(plot): edge.style routing (arc/elbow/diagonal) for plot.igraph (F3) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add a per-edge `edge.style` aesthetic selecting the routing of non-loop edges: "auto" (default; straight, or arc when edge.curved != 0 — unchanged behaviour), "straight", "arc" (curved; strength from edge.curved or a default), "elbow" (two-corner orthogonal connector), and "diagonal" (smooth S-curve with axis-aligned ends). - New pure geometry helpers i.elbow_path() and i.diagonal_path() (the latter reuses the existing Bezier helpers); device-free and unit-tested. - igraph.Arrows() gains a `style` arg and two new draw branches; the existing straight/arc branches are kept byte-identical so no existing snapshot changes. Arrowheads for elbow/diagonal align with the path's end segment. - Wired through i.edge.default, the edge aesthetic table, and the non-loop dispatch; resolved and validated in plot.igraph() (unknown style -> error). Documented in the plotting parameters; ignored for loops and rglplot(). Adds unit tests for the path helpers and vdiffr snapshots for elbow, diagonal, mixed per-edge styles, and forced arcs. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-aes.R | 4 +- R/plot.R | 86 ++++++++++++++++-- R/plot.common.R | 17 +++- .../_snaps/plot/edge-style-arc-single.svg | 51 +++++++++++ .../_snaps/plot/edge-style-diagonal.svg | 89 +++++++++++++++++++ .../testthat/_snaps/plot/edge-style-elbow.svg | 89 +++++++++++++++++++ .../testthat/_snaps/plot/edge-style-mixed.svg | 47 ++++++++++ tests/testthat/test-plot-params.R | 2 + tests/testthat/test-plot.R | 62 +++++++++++++ 9 files changed, 440 insertions(+), 7 deletions(-) create mode 100644 tests/testthat/_snaps/plot/edge-style-arc-single.svg create mode 100644 tests/testthat/_snaps/plot/edge-style-diagonal.svg create mode 100644 tests/testthat/_snaps/plot/edge-style-elbow.svg create mode 100644 tests/testthat/_snaps/plot/edge-style-mixed.svg diff --git a/R/plot-aes.R b/R/plot-aes.R index e02ce474fe2..6f452c3da2f 100644 --- a/R/plot-aes.R +++ b/R/plot-aes.R @@ -75,6 +75,7 @@ i.edge_aes_table <- function( label.family, label.font, label.cex, + style, n ) { i.aes_table( @@ -89,7 +90,8 @@ i.edge_aes_table <- function( label.color = label.color, label.family = label.family, label.font = label.font, - label.cex = label.cex + label.cex = label.cex, + style = style ), n = n ) diff --git a/R/plot.R b/R/plot.R index 6c02d7085b0..111f5033453 100644 --- a/R/plot.R +++ b/R/plot.R @@ -568,6 +568,15 @@ plot.igraph <- function( if (is.function(curved)) { curved <- curved(graph) } + edge.style <- as.character(params("edge", "style")) + i.valid_edge_styles <- c("auto", "straight", "arc", "elbow", "diagonal") + bad.style <- setdiff(unique(edge.style), i.valid_edge_styles) + if (length(bad.style) > 0) { + cli::cli_abort(c( + "Invalid {.arg edge.style} value{?s}: {.val {bad.style}}.", + "i" = "Valid styles are {.val {i.valid_edge_styles}}." + )) + } layout <- i.postprocess.layout(params("plot", "layout")) if (nrow(layout) != vc) { @@ -841,6 +850,7 @@ plot.igraph <- function( label.family = edge.label.family, label.font = edge.label.font, label.cex = edge.label.cex, + style = edge.style, n = ecount(graph) ) @@ -927,6 +937,7 @@ plot.igraph <- function( arrow.size <- nl_aes$arrow.size arrow.width <- nl_aes$arrow.width curved <- nl_aes$curved + edge.style <- nl_aes$style if (length(unique(arrow.mode)) == 1) { lc <- igraph.Arrows( @@ -944,7 +955,8 @@ plot.igraph <- function( h.lty = 1, size = arrow.size, width = arrow.width, - curved = curved + curved = curved, + style = edge.style ) lc.x <- lc$lab.x lc.y <- lc$lab.y @@ -973,7 +985,8 @@ plot.igraph <- function( open = FALSE, size = arrow.size[valid], width = arrow.width[valid], - curved = curved[valid] + curved = curved[valid], + style = edge.style[valid] ) lc.x[valid] <- lc$lab.x lc.y[valid] <- lc$lab.y @@ -1977,6 +1990,35 @@ i.curved_spline <- function(x1, y1, x2, y2, sx1, sy1, sx2, sy2, lambda) { ) } +# Geometry (Stage 2): two-corner orthogonal ("elbow") path between two points. +# Leaves along the dominant axis (larger absolute delta), turns at the midpoint +# of that axis, crosses, then turns into the target. Returns list(x, y) of the +# four polyline vertices. +i.elbow_path <- function(x0, y0, x1, y1) { + if (abs(x1 - x0) >= abs(y1 - y0)) { + mid <- (x0 + x1) / 2 + list(x = c(x0, mid, mid, x1), y = c(y0, y0, y1, y1)) + } else { + mid <- (y0 + y1) / 2 + list(x = c(x0, x0, x1, x1), y = c(y0, mid, mid, y1)) + } +} + +# Geometry (Stage 2): smooth "diagonal" S-curve between two points, a cubic +# Bezier whose control points sit on the dominant axis so the curve leaves and +# enters along that axis. Returns list(x, y) sampled at `n` points. +i.diagonal_path <- function(x0, y0, x1, y1, n = 30) { + if (abs(x1 - x0) >= abs(y1 - y0)) { + mid <- (x0 + x1) / 2 + cp <- rbind(c(x0, y0), c(mid, y0), c(mid, y1), c(x1, y1)) + } else { + mid <- (y0 + y1) / 2 + cp <- rbind(c(x0, y0), c(x0, mid), c(x1, mid), c(x1, y1)) + } + p <- i.compute.bezier(cp, n) + list(x = p[1, ], y = p[2, ]) +} + #' @importFrom graphics par xyinch segments xspline lines polygon # Vectorized and modular igraph.Arrows refactor igraph.Arrows <- function( @@ -1996,7 +2038,8 @@ igraph.Arrows <- function( h.col.bo = sh.col, h.lwd = sh.lwd, h.lty = sh.lty, - curved = FALSE + curved = FALSE, + style = "auto" ) { n <- length(x1) @@ -2009,6 +2052,7 @@ igraph.Arrows <- function( size <- recycle(size) width <- recycle(width) curved <- recycle(curved) + style <- recycle(as.character(style)) sh.lwd <- recycle(sh.lwd) sh.col <- recycle(sh.col) sh.lty <- recycle(sh.lty) @@ -2039,7 +2083,12 @@ igraph.Arrows <- function( sx2 <- sh$sx2 sy2 <- sh$sy2 - if (!curved[i]) { + eff_style <- style[i] + if (eff_style == "auto") { + eff_style <- if (!curved[i]) "straight" else "arc" + } + + if (eff_style == "straight") { segments( sx1, sy1, @@ -2052,8 +2101,12 @@ igraph.Arrows <- function( lab <- i.edge_label_pos(x1[i], y1[i], x2[i], y2[i]) label_x[i] <- lab[["x"]] label_y[i] <- lab[["y"]] - } else { + } else if (eff_style == "arc") { lambda <- if (is.numeric(curved)) curved[i] else 0.5 + if (style[i] == "arc" && lambda == 0) { + # an explicit arc on an otherwise-straight edge needs a strength + lambda <- 0.3 + } spl <- i.curved_spline( x1[i], y1[i], @@ -2077,6 +2130,29 @@ igraph.Arrows <- function( x2[i] <- spl$x[round(1 / 4 * length(spl$x))] y2[i] <- spl$y[round(1 / 4 * length(spl$y))] } + } else { + # elbow or diagonal: a polyline between the shaft endpoints + path <- if (eff_style == "elbow") { + i.elbow_path(sx1, sy1, sx2, sy2) + } else { + i.diagonal_path(sx1, sy1, sx2, sy2) + } + lines(path$x, path$y, lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i]) + np <- length(path$x) + mid <- max(1L, round(np / 2)) + label_x[i] <- path$x[mid] + label_y[i] <- path$y[mid] + + # arrowhead end-tangents: align the head with the path's final/first + # segment (mirrors the arc branch's near-end reassignment) + if (code %in% c(2, 3)) { + x1[i] <- path$x[np - 1] + y1[i] <- path$y[np - 1] + } + if (code %in% c(1, 3)) { + x2[i] <- path$x[2] + y2[i] <- path$y[2] + } } draw_arrowhead <- function(px, py, theta) { diff --git a/R/plot.common.R b/R/plot.common.R index fd73a3a447b..013acf2ae37 100644 --- a/R/plot.common.R +++ b/R/plot.common.R @@ -329,6 +329,20 @@ #' #' This parameter is currently ignored by [rglplot()]. #' } +#' \item{style}{ +#' The routing style for (non-loop) edges, a character scalar or vector, +#' replicated to the number of edges. One of: +#' \describe{ +#' \item{`"auto"`}{(default) straight, unless `curved` is non-zero (in which +#' case an arc), reproducing the historical behaviour.} +#' \item{`"straight"`}{a straight segment.} +#' \item{`"arc"`}{a curved arc; the strength is taken from `curved` if it is +#' non-zero, otherwise a default is used.} +#' \item{`"elbow"`}{a two-corner orthogonal (right-angle) connector.} +#' \item{`"diagonal"`}{a smooth S-curve with axis-aligned ends.} +#' } +#' This parameter is ignored for loop edges and by [rglplot()]. +#' } #' \item{arrow.mode}{ #' This parameter can be used to specify for which edges should arrows be drawn. #' If this parameter is given by the user (in either of the three ways) @@ -4912,7 +4926,8 @@ i.edge.default <- list( arrow.size = 1, arrow.mode = i.get.arrow.mode, curved = curve_multiple, - arrow.width = 1 + arrow.width = 1, + style = "auto" ) # Note: there is intentionally no `frame` default. plot.igraph() reads diff --git a/tests/testthat/_snaps/plot/edge-style-arc-single.svg b/tests/testthat/_snaps/plot/edge-style-arc-single.svg new file mode 100644 index 00000000000..d54a93b2047 --- /dev/null +++ b/tests/testthat/_snaps/plot/edge-style-arc-single.svg @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 + + diff --git a/tests/testthat/_snaps/plot/edge-style-diagonal.svg b/tests/testthat/_snaps/plot/edge-style-diagonal.svg new file mode 100644 index 00000000000..c9c5fbb9cee --- /dev/null +++ b/tests/testthat/_snaps/plot/edge-style-diagonal.svg @@ -0,0 +1,89 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 + + diff --git a/tests/testthat/_snaps/plot/edge-style-elbow.svg b/tests/testthat/_snaps/plot/edge-style-elbow.svg new file mode 100644 index 00000000000..e4d8ee86e9f --- /dev/null +++ b/tests/testthat/_snaps/plot/edge-style-elbow.svg @@ -0,0 +1,89 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 + + diff --git a/tests/testthat/_snaps/plot/edge-style-mixed.svg b/tests/testthat/_snaps/plot/edge-style-mixed.svg new file mode 100644 index 00000000000..17e8d49d91f --- /dev/null +++ b/tests/testthat/_snaps/plot/edge-style-mixed.svg @@ -0,0 +1,47 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 + + diff --git a/tests/testthat/test-plot-params.R b/tests/testthat/test-plot-params.R index ce32a5e6e6d..10c8c1cf610 100644 --- a/tests/testthat/test-plot-params.R +++ b/tests/testthat/test-plot-params.R @@ -111,11 +111,13 @@ test_that("i.edge_aes_table expands scalars and is sliceable by edge index", { label.family = "serif", label.font = 1, label.cex = 1, + style = "auto", n = 3 ) expect_equal(nrow(tbl), 3) expect_equal(tbl$color, rep("red", 3)) # scalar expanded expect_equal(tbl$width, c(1, 2, 3)) # vector preserved + expect_equal(tbl$style, rep("auto", 3)) sliced <- vctrs::vec_slice(tbl, c(1, 3)) expect_equal(nrow(sliced), 2) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index c44e39126f3..d7856d8572f 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -270,6 +270,30 @@ test_that("i.loop_angles distributes loops and returns aligned vectors", { expect_false(res$angles[1] == res$angles[2]) }) +test_that("i.elbow_path is a two-corner route along the dominant axis", { + # horizontal dominant: leave horizontally, turn at mid-x + e <- i.elbow_path(0, 0, 10, 4) + expect_equal(e$x, c(0, 5, 5, 10)) + expect_equal(e$y, c(0, 0, 4, 4)) + # vertical dominant: leave vertically, turn at mid-y + v <- i.elbow_path(0, 0, 4, 10) + expect_equal(v$x, c(0, 0, 4, 4)) + expect_equal(v$y, c(0, 5, 5, 10)) + # endpoints preserved + expect_equal(c(e$x[1], e$y[1]), c(0, 0)) + expect_equal(c(e$x[4], e$y[4]), c(10, 4)) +}) + +test_that("i.diagonal_path is a smooth path between the endpoints", { + d <- i.diagonal_path(0, 0, 10, 4, n = 30) + expect_length(d$x, 30) + expect_equal(c(d$x[1], d$y[1]), c(0, 0)) + expect_equal(c(d$x[30], d$y[30]), c(10, 4)) + expect_true(all(is.finite(d$x)) && all(is.finite(d$y))) + # deterministic + expect_equal(d, i.diagonal_path(0, 0, 10, 4, n = 30)) +}) + test_that("i.arrowhead_shape returns matched polar arrays ending in NA", { # Pure geometry helper extracted from igraph.Arrows (Stage 2); device-free. head <- i.arrowhead_shape(cin = 0.2, w = 1.5, delta = 0.01) @@ -409,6 +433,44 @@ test_that("vector edge params are subset correctly across loops and non-loops", vdiffr::expect_doppelganger("vector-edge-params-loops", vector_edge_params) }) +test_that("edge.style routes edges (elbow / diagonal / mixed / arc)", { + skip_if_not_installed("vdiffr") + + tree <- function() { + g <- make_tree(15, children = 2) + g$layout <- layout_as_tree(g) + g + } + + vdiffr::expect_doppelganger("edge-style-elbow", function() { + plot(tree(), edge.style = "elbow", vertex.size = 12, edge.arrow.size = 0.4) + }) + + vdiffr::expect_doppelganger("edge-style-diagonal", function() { + plot(tree(), edge.style = "diagonal", vertex.size = 12, edge.arrow.size = 0.4) + }) + + vdiffr::expect_doppelganger("edge-style-mixed", function() { + g <- make_graph(c(1, 2, 2, 3, 3, 4, 4, 1), directed = TRUE) + # deliberately non-axis-aligned so elbow/diagonal visibly bend + g$layout <- cbind(c(0, 2, 1.6, 0.3), c(1, 1.4, 0, -0.2)) + plot( + g, + edge.style = c("straight", "arc", "elbow", "diagonal"), + vertex.size = 20, + edge.arrow.size = 0.5, + margin = 0.2 + ) + }) + + vdiffr::expect_doppelganger("edge-style-arc-single", function() { + # "arc" forces a curve on single (otherwise straight) edges + g <- make_ring(5, directed = TRUE) + g$layout <- layout_in_circle(g) + plot(g, edge.style = "arc", vertex.size = 20, edge.arrow.size = 0.5) + }) +}) + test_that("mixed arrow modes with per-edge curved/size and loops render correctly", { # Regression guard for B2: the per-arrow-code branch used to double-slice # `curved` and ignored per-edge arrow.size/width. Exercise that path with a From 791cc3a30e713cf52a6dccfcf71c7cbe0b81fc7e Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 17:26:28 +0200 Subject: [PATCH 18/30] feat(plot): edge colour gradients + alpha transparency (F4) Add two opt-in edge/vertex aesthetics, both no-ops by default: - edge.gradient: when TRUE, an edge is drawn as a colour gradient from its source vertex's colour to its target vertex's colour (a direction cue), with the arrowhead taking the target colour. Implemented via i.draw_gradient_path() (arc-length resample + per-segment colorRamp); igraph.Arrows() gains `gradient`/`col.to` args and a gradient branch per edge style. Source/target colours come from the base vertex fill (resolved lazily, only when a gradient is used). - vertex.alpha / edge.alpha: per-element opacity in [0, 1], folded into the fill colours via i.apply_alpha() (multiplies existing alpha; strict no-op when all 1, so existing plots/snapshots are unchanged). edge.alpha also applies to gradient endpoints; vertex.alpha is injected into vertex.color before the shape draw. Frame colour, pie slices and labels are unaffected. Wired through i.vertex.default/i.edge.default, the edge aesthetic table, and the non-loop dispatch; documented in the plotting parameters. Adds unit tests for i.apply_alpha and vdiffr snapshots for gradients and translucency. Gradients are ignored for self-loops and by rglplot(). Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-aes.R | 6 +- R/plot.R | 151 +++++++++++-- R/plot.common.R | 22 +- .../_snaps/plot/edge-gradient-arc.svg | 157 ++++++++++++++ tests/testthat/_snaps/plot/edge-gradient.svg | 199 ++++++++++++++++++ .../_snaps/plot/vertex-edge-alpha.svg | 58 +++++ tests/testthat/test-plot-params.R | 4 + tests/testthat/test-plot.R | 63 ++++++ 8 files changed, 640 insertions(+), 20 deletions(-) create mode 100644 tests/testthat/_snaps/plot/edge-gradient-arc.svg create mode 100644 tests/testthat/_snaps/plot/edge-gradient.svg create mode 100644 tests/testthat/_snaps/plot/vertex-edge-alpha.svg diff --git a/R/plot-aes.R b/R/plot-aes.R index 6f452c3da2f..b039cca6431 100644 --- a/R/plot-aes.R +++ b/R/plot-aes.R @@ -76,6 +76,8 @@ i.edge_aes_table <- function( label.font, label.cex, style, + alpha, + gradient, n ) { i.aes_table( @@ -91,7 +93,9 @@ i.edge_aes_table <- function( label.family = label.family, label.font = label.font, label.cex = label.cex, - style = style + style = style, + alpha = alpha, + gradient = gradient ), n = n ) diff --git a/R/plot.R b/R/plot.R index 111f5033453..d7ee4c61e6a 100644 --- a/R/plot.R +++ b/R/plot.R @@ -538,6 +538,7 @@ plot.igraph <- function( vertex.size <- params("vertex", "size") vertex.size.scaling <- params("vertex", "size.scaling") + vertex.alpha <- params("vertex", "alpha") label.family <- params("vertex", "label.family") label.font <- params("vertex", "label.font") label.cex <- params("vertex", "label.cex") @@ -551,6 +552,15 @@ plot.igraph <- function( shape <- igraph.check.shapes(params("vertex", "shape")) edge.color <- params("edge", "color") + edge.alpha <- params("edge", "alpha") + edge.color <- i.apply_alpha(edge.color, edge.alpha) + edge.gradient <- as.logical(params("edge", "gradient")) + # Base per-vertex fill colour (before vertex.alpha), only needed for gradients. + vcol_base <- if (any(edge.gradient)) { + rep(params("vertex", "color"), length.out = vc) + } else { + NULL + } edge.width <- params("edge", "width") edge.lty <- params("edge", "lty") arrow.mode <- params("edge", "arrow.mode") @@ -694,6 +704,14 @@ plot.igraph <- function( ################################################################ ## Rescaling vertices and updating params + # Fold vertex.alpha into the vertex fill colour so the shapes pick it up via + # the rebuilt params below (no-op when fully opaque). + if (!all(vertex.alpha == 1)) { + scaled$dots$vertex.color <- i.apply_alpha( + rep(params("vertex", "color"), length.out = vc), + vertex.alpha + ) + } if (vertex.size.scaling) { newdots <- scaled$dots @@ -851,6 +869,8 @@ plot.igraph <- function( label.font = edge.label.font, label.cex = edge.label.cex, style = edge.style, + alpha = edge.alpha, + gradient = edge.gradient, n = ecount(graph) ) @@ -938,6 +958,30 @@ plot.igraph <- function( arrow.width <- nl_aes$arrow.width curved <- nl_aes$curved edge.style <- nl_aes$style + edge.gradient <- as.logical(nl_aes$gradient) + + # Gradient edges: shaft colour runs from the source vertex colour to the + # target vertex colour; the arrowhead uses the target colour. Only touch the + # colour vectors when a gradient is actually requested, so plain plots are + # byte-identical. + sh.col.e <- edge.color + h.col.e <- edge.color + col.to.e <- edge.color + if (any(edge.gradient)) { + to_hex <- function(x) { + grDevices::rgb(t(grDevices::col2rgb(x, alpha = TRUE)), maxColorValue = 255) + } + ealpha <- nl_aes$alpha + grad_from <- i.apply_alpha(to_hex(vcol_base[el[, 1]]), ealpha) + grad_to <- i.apply_alpha(to_hex(vcol_base[el[, 2]]), ealpha) + base_hex <- to_hex(edge.color) + sh.col.e <- base_hex + h.col.e <- base_hex + col.to.e <- base_hex + sh.col.e[edge.gradient] <- grad_from[edge.gradient] + h.col.e[edge.gradient] <- grad_to[edge.gradient] + col.to.e[edge.gradient] <- grad_to[edge.gradient] + } if (length(unique(arrow.mode)) == 1) { lc <- igraph.Arrows( @@ -945,8 +989,8 @@ plot.igraph <- function( y0, x1, y1, - h.col = edge.color, - sh.col = edge.color, + h.col = h.col.e, + sh.col = sh.col.e, sh.lwd = edge.width, h.lwd = 1, open = FALSE, @@ -956,7 +1000,9 @@ plot.igraph <- function( size = arrow.size, width = arrow.width, curved = curved, - style = edge.style + style = edge.style, + gradient = edge.gradient, + col.to = col.to.e ) lc.x <- lc$lab.x lc.y <- lc$lab.y @@ -976,8 +1022,8 @@ plot.igraph <- function( x1[valid], y1[valid], code = code, - sh.col = edge.color[valid], - h.col = edge.color[valid], + sh.col = sh.col.e[valid], + h.col = h.col.e[valid], sh.lwd = edge.width[valid], h.lwd = 1, h.lty = 1, @@ -986,7 +1032,9 @@ plot.igraph <- function( size = arrow.size[valid], width = arrow.width[valid], curved = curved[valid], - style = edge.style[valid] + style = edge.style[valid], + gradient = edge.gradient[valid], + col.to = col.to.e[valid] ) lc.x[valid] <- lc$lab.x lc.y[valid] <- lc$lab.y @@ -2019,6 +2067,36 @@ i.diagonal_path <- function(x0, y0, x1, y1, n = 30) { list(x = p[1, ], y = p[2, ]) } +# Apply a per-element alpha (transparency, in [0, 1]) to a colour vector by +# multiplying any existing alpha. A no-op when every alpha is 1, so the default +# leaves colours — and snapshots — byte-identical. +i.apply_alpha <- function(col, alpha) { + if (length(col) == 0 || all(alpha == 1)) { + return(col) + } + rgba <- grDevices::col2rgb(col, alpha = TRUE) / 255 + a <- rep(alpha, length.out = ncol(rgba)) + grDevices::rgb(rgba[1, ], rgba[2, ], rgba[3, ], alpha = rgba[4, ] * a) +} + +# Draw a polyline (px, py) as a colour gradient from `col_from` to `col_to`: +# resample to `n` points by cumulative arc length, then draw the n-1 pieces with +# interpolated colours. Used for source->target edge gradients. +i.draw_gradient_path <- function(px, py, col_from, col_to, lwd, lty, n = 40) { + d <- c(0, cumsum(sqrt(diff(px)^2 + diff(py)^2))) + if (length(d) < 2 || max(d) == 0) { + return(invisible(NULL)) + } + at <- seq(0, max(d), length.out = n) + rx <- stats::approx(d, px, at)$y + ry <- stats::approx(d, py, at)$y + ramp <- grDevices::colorRamp(c(col_from, col_to), alpha = TRUE) + m <- ramp(seq(0, 1, length.out = n - 1)) # one RGBA row per segment + cols <- grDevices::rgb(m[, 1], m[, 2], m[, 3], alpha = m[, 4], maxColorValue = 255) + segments(rx[-n], ry[-n], rx[-1], ry[-1], col = cols, lwd = lwd, lty = lty) + invisible(NULL) +} + #' @importFrom graphics par xyinch segments xspline lines polygon # Vectorized and modular igraph.Arrows refactor igraph.Arrows <- function( @@ -2039,7 +2117,9 @@ igraph.Arrows <- function( h.lwd = sh.lwd, h.lty = sh.lty, curved = FALSE, - style = "auto" + style = "auto", + gradient = FALSE, + col.to = sh.col ) { n <- length(x1) @@ -2053,6 +2133,8 @@ igraph.Arrows <- function( width <- recycle(width) curved <- recycle(curved) style <- recycle(as.character(style)) + gradient <- recycle(gradient) + col.to <- recycle(col.to) sh.lwd <- recycle(sh.lwd) sh.col <- recycle(sh.col) sh.lty <- recycle(sh.lty) @@ -2089,15 +2171,26 @@ igraph.Arrows <- function( } if (eff_style == "straight") { - segments( - sx1, - sy1, - sx2, - sy2, - lwd = sh.lwd[i], - col = sh.col[i], - lty = sh.lty[i] - ) + if (gradient[i]) { + i.draw_gradient_path( + c(sx1, sx2), + c(sy1, sy2), + sh.col[i], + col.to[i], + sh.lwd[i], + sh.lty[i] + ) + } else { + segments( + sx1, + sy1, + sx2, + sy2, + lwd = sh.lwd[i], + col = sh.col[i], + lty = sh.lty[i] + ) + } lab <- i.edge_label_pos(x1[i], y1[i], x2[i], y2[i]) label_x[i] <- lab[["x"]] label_y[i] <- lab[["y"]] @@ -2118,7 +2211,18 @@ igraph.Arrows <- function( sy2, lambda ) - lines(spl, lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i]) + if (gradient[i]) { + i.draw_gradient_path( + spl$x, + spl$y, + sh.col[i], + col.to[i], + sh.lwd[i], + sh.lty[i] + ) + } else { + 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))] @@ -2137,7 +2241,18 @@ igraph.Arrows <- function( } else { i.diagonal_path(sx1, sy1, sx2, sy2) } - lines(path$x, path$y, lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i]) + if (gradient[i]) { + i.draw_gradient_path( + path$x, + path$y, + sh.col[i], + col.to[i], + sh.lwd[i], + sh.lty[i] + ) + } else { + lines(path$x, path$y, lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i]) + } np <- length(path$x) mid <- max(1L, round(np / 2)) label_x[i] <- path$x[mid] diff --git a/R/plot.common.R b/R/plot.common.R index 013acf2ae37..4c183b34f8a 100644 --- a/R/plot.common.R +++ b/R/plot.common.R @@ -115,6 +115,11 @@ #' #' The default value is \dQuote{\code{SkyBlue2}}. #' } +#' \item{alpha}{ +#' Opacity of the vertex fill, a number (or vector) in `[0, 1]`, multiplied +#' into any alpha already present in `color`. `1` (the default) means fully +#' opaque. Frame colour, pie slices and labels are not affected. +#' } #' \item{frame.color}{ #' The color of the frame of the vertices, the same formats are allowed as for the fill color. #' @@ -343,6 +348,18 @@ #' } #' This parameter is ignored for loop edges and by [rglplot()]. #' } +#' \item{alpha}{ +#' Opacity of the edge, a number (or vector) in `[0, 1]`, multiplied into any +#' alpha already present in `color` (and in the gradient endpoint colours). +#' `1` (the default) means fully opaque. +#' } +#' \item{gradient}{ +#' Logical scalar or vector. If `TRUE`, the edge is drawn as a colour gradient +#' running from its source vertex's colour to its target vertex's colour (a +#' direction cue), and the arrowhead takes the target colour; `color` is then +#' ignored for that edge's shaft. The default is `FALSE`. Ignored for loop +#' edges and by [rglplot()]. +#' } #' \item{arrow.mode}{ #' This parameter can be used to specify for which edges should arrows be drawn. #' If this parameter is given by the user (in either of the three ways) @@ -4890,6 +4907,7 @@ i.vertex.default <- list( label.angle = 0, label.adj = NULL, label.repel = FALSE, + alpha = 1, frame.color = "black", frame.width = 1, shape = "circle", @@ -4927,7 +4945,9 @@ i.edge.default <- list( arrow.mode = i.get.arrow.mode, curved = curve_multiple, arrow.width = 1, - style = "auto" + style = "auto", + alpha = 1, + gradient = FALSE ) # Note: there is intentionally no `frame` default. plot.igraph() reads diff --git a/tests/testthat/_snaps/plot/edge-gradient-arc.svg b/tests/testthat/_snaps/plot/edge-gradient-arc.svg new file mode 100644 index 00000000000..ac5a80d06a4 --- /dev/null +++ b/tests/testthat/_snaps/plot/edge-gradient-arc.svg @@ -0,0 +1,157 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 + + diff --git a/tests/testthat/_snaps/plot/edge-gradient.svg b/tests/testthat/_snaps/plot/edge-gradient.svg new file mode 100644 index 00000000000..9e197ef9dc9 --- /dev/null +++ b/tests/testthat/_snaps/plot/edge-gradient.svg @@ -0,0 +1,199 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 + + diff --git a/tests/testthat/_snaps/plot/vertex-edge-alpha.svg b/tests/testthat/_snaps/plot/vertex-edge-alpha.svg new file mode 100644 index 00000000000..5773907b7fe --- /dev/null +++ b/tests/testthat/_snaps/plot/vertex-edge-alpha.svg @@ -0,0 +1,58 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 + + diff --git a/tests/testthat/test-plot-params.R b/tests/testthat/test-plot-params.R index 10c8c1cf610..c2a8cf9b09f 100644 --- a/tests/testthat/test-plot-params.R +++ b/tests/testthat/test-plot-params.R @@ -112,12 +112,16 @@ test_that("i.edge_aes_table expands scalars and is sliceable by edge index", { label.font = 1, label.cex = 1, style = "auto", + alpha = 1, + gradient = FALSE, n = 3 ) expect_equal(nrow(tbl), 3) expect_equal(tbl$color, rep("red", 3)) # scalar expanded expect_equal(tbl$width, c(1, 2, 3)) # vector preserved expect_equal(tbl$style, rep("auto", 3)) + expect_equal(tbl$alpha, rep(1, 3)) + expect_equal(tbl$gradient, rep(FALSE, 3)) sliced <- vctrs::vec_slice(tbl, c(1, 3)) expect_equal(nrow(sliced), 2) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index d7856d8572f..3533ddca730 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -270,6 +270,27 @@ test_that("i.loop_angles distributes loops and returns aligned vectors", { expect_false(res$angles[1] == res$angles[2]) }) +test_that("i.apply_alpha multiplies alpha and is a no-op at 1", { + # no-op: fully opaque returns the input unchanged (keeps snapshots stable) + expect_identical(i.apply_alpha(c("red", "blue"), 1), c("red", "blue")) + expect_identical(i.apply_alpha(c("red", "blue"), c(1, 1)), c("red", "blue")) + + # fractional alpha reduces the alpha channel + a <- i.apply_alpha("red", 0.5) + expect_equal(unname(grDevices::col2rgb(a, alpha = TRUE)["alpha", ]), 128) + + # vectorised over colour and alpha (recycled) + v <- i.apply_alpha(c("red", "green", "blue"), c(0.5, 1, 0.25)) + av <- grDevices::col2rgb(v, alpha = TRUE)["alpha", ] + expect_equal(unname(av), c(128, 255, 64)) + + # already-translucent input is further reduced (multiplicative) + half <- i.apply_alpha(grDevices::rgb(1, 0, 0, 0.5), 0.5) + expect_equal(unname(grDevices::col2rgb(half, alpha = TRUE)["alpha", ]), 64) + + expect_identical(i.apply_alpha(character(0), 0.5), character(0)) +}) + test_that("i.elbow_path is a two-corner route along the dominant axis", { # horizontal dominant: leave horizontally, turn at mid-x e <- i.elbow_path(0, 0, 10, 4) @@ -433,6 +454,48 @@ test_that("vector edge params are subset correctly across loops and non-loops", vdiffr::expect_doppelganger("vector-edge-params-loops", vector_edge_params) }) +test_that("edge.gradient blends source to target vertex colours", { + skip_if_not_installed("vdiffr") + + vdiffr::expect_doppelganger("edge-gradient", function() { + g <- make_graph(c(1, 2, 2, 3, 3, 1, 1, 4), directed = TRUE) + g$layout <- layout_in_circle(g) + V(g)$color <- c("red", "green", "blue", "orange") + plot( + g, + edge.gradient = TRUE, + vertex.size = 24, + edge.width = 3, + edge.arrow.size = 0.6 + ) + }) + + vdiffr::expect_doppelganger("edge-gradient-arc", function() { + g <- make_graph(c(1, 2, 2, 3, 3, 1), directed = TRUE) + g$layout <- layout_in_circle(g) + V(g)$color <- c("red", "green", "blue") + plot(g, edge.gradient = TRUE, edge.style = "arc", vertex.size = 24, edge.width = 3) + }) +}) + +test_that("vertex.alpha and edge.alpha render translucently", { + skip_if_not_installed("vdiffr") + + vdiffr::expect_doppelganger("vertex-edge-alpha", function() { + g <- make_full_graph(6) + g$layout <- layout_in_circle(g) + plot( + g, + vertex.alpha = 0.4, + edge.alpha = 0.4, + vertex.size = 30, + vertex.color = "steelblue", + edge.width = 3, + edge.color = "firebrick" + ) + }) +}) + test_that("edge.style routes edges (elbow / diagonal / mixed / arc)", { skip_if_not_installed("vdiffr") From 8a6dd0b6144e6e7d68380c8e7937e0e1f433050b Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 19:37:00 +0200 Subject: [PATCH 19/30] refactor(plot): route base drawing through a renderer (F5 phase 1) Introduce a Stage-3 rendering indirection: all of plot.igraph's 2D drawing now emits primitives through i.r_*() dispatchers that forward to a "current" renderer (R/plot-render.R), instead of calling base graphics directly. The default base renderer simply calls the matching base-graphics function, so on-screen output is unchanged (the full plotting snapshot suite passes byte-identical). Migrated every 2D draw site to the dispatchers: the canvas, edges/arrowheads (igraph.Arrows), loop Beziers, the gradient path, mark-group xsplines, vertex and edge labels, and the vertex shape $plot functions (circle/square/rectangle symbols, pie polygons, sphere/raster images). The public shape (coords, v, params) contract is unchanged -- shapes call the i.r_* dispatchers internally. This is the foundation for a record/SVG renderer (phase 2) consuming the same primitive stream. No user-facing change. Adds unit tests for the indirection. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-render.R | 155 ++++++++++++++++++++++++++++++ R/plot.R | 35 +++---- R/plot.shapes.R | 60 ++++++------ tests/testthat/test-plot-render.R | 62 ++++++++++++ 4 files changed, 260 insertions(+), 52 deletions(-) create mode 100644 R/plot-render.R create mode 100644 tests/testthat/test-plot-render.R diff --git a/R/plot-render.R b/R/plot-render.R new file mode 100644 index 00000000000..d22ba0b8480 --- /dev/null +++ b/R/plot-render.R @@ -0,0 +1,155 @@ +# IGraph R package +# Copyright (C) 2003-2012 Gabor Csardi +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +################################################################### + +# Stage-3 rendering indirection (feature F5). +# +# Drawing code emits primitives through the i.r_*() dispatchers instead of +# calling base graphics directly. The dispatchers forward to the "current" +# renderer, a small list of closures held in i.render_state. The default base +# renderer simply calls the corresponding base-graphics function, so on-screen +# output is unchanged. A recording / SVG renderer (added in a later step) can +# capture the same primitive stream to build a backend-neutral draw list. + +i.render_state <- new.env(parent = emptyenv()) +i.render_state$cur <- NULL + +# The base renderer: each method draws with the matching base-graphics call. +i.renderer_base <- function() { + list( + init_canvas = function( + xlim, + ylim, + xlab, + ylab, + axes, + frame.plot, + asp, + main, + sub + ) { + graphics::plot( + 0, + 0, + type = "n", + xlab = xlab, + ylab = ylab, + xlim = xlim, + ylim = ylim, + axes = axes, + frame.plot = ifelse(is.null(frame.plot), axes, frame.plot), + asp = asp, + main = main, + sub = sub + ) + }, + segments = function(x0, y0, x1, y1, col = graphics::par("fg"), lwd = 1, lty = 1) { + graphics::segments(x0, y0, x1, y1, col = col, lwd = lwd, lty = lty) + }, + polyline = function(x, y = NULL, col = graphics::par("fg"), lwd = 1, lty = 1) { + graphics::lines(x, y, col = col, lwd = lwd, lty = lty) + }, + polygon = function( + x, + y, + col = NA, + border = NULL, + lwd = 1, + lty = 1, + density = NULL, + angle = 45, + ... + ) { + graphics::polygon( + x, + y, + col = col, + border = border, + lwd = lwd, + lty = lty, + density = density, + angle = angle, + ... + ) + }, + xspline = function(x, y = NULL, shape, open, col, border, lwd) { + graphics::xspline( + x, + y, + shape = shape, + open = open, + col = col, + border = border, + lwd = lwd + ) + }, + text = function(x, y, labels, col, family, font, cex, srt = 0, adj = NULL) { + graphics::text( + x, + y, + labels = labels, + col = col, + family = family, + font = font, + cex = cex, + srt = srt, + adj = adj + ) + }, + # One symbols() call. `kind` is "circles", "squares" or "rectangles"; `dim` + # is the matching size spec (vector, or 2-column matrix for rectangles). + symbols = function(kind, x, y, dim, bg, fg, lwd) { + args <- list( + x = x, + y = y, + bg = bg, + fg = fg, + lwd = lwd, + add = TRUE, + inches = FALSE + ) + args[[kind]] <- dim + do.call(graphics::symbols, args) + }, + raster = function(image, xleft, ybottom, xright, ytop) { + graphics::rasterImage(image, xleft, ybottom, xright, ytop) + }, + # Grouping hooks for backends that tag elements (e.g. SVG ids); the base + # renderer ignores them. + group_begin = function(type, id, title = NULL) invisible(NULL), + group_end = function() invisible(NULL) + ) +} + +# The current renderer, defaulting to base on first use. +i.cur_renderer <- function() { + if (is.null(i.render_state$cur)) { + i.render_state$cur <- i.renderer_base() + } + i.render_state$cur +} + +# Evaluate `expr` with `renderer` installed as the current renderer. +i.with_renderer <- function(renderer, expr) { + old <- i.render_state$cur + i.render_state$cur <- renderer + on.exit(i.render_state$cur <- old, add = TRUE) + force(expr) +} + +# --- dispatchers ------------------------------------------------------------- +i.r_init_canvas <- function(...) i.cur_renderer()$init_canvas(...) +i.r_segments <- function(...) i.cur_renderer()$segments(...) +i.r_polyline <- function(...) i.cur_renderer()$polyline(...) +i.r_polygon <- function(...) i.cur_renderer()$polygon(...) +i.r_xspline <- function(...) i.cur_renderer()$xspline(...) +i.r_text <- function(...) i.cur_renderer()$text(...) +i.r_symbols <- function(...) i.cur_renderer()$symbols(...) +i.r_raster <- function(...) i.cur_renderer()$raster(...) +i.r_group_begin <- function(...) i.cur_renderer()$group_begin(...) +i.r_group_end <- function(...) i.cur_renderer()$group_end(...) diff --git a/R/plot.R b/R/plot.R index d7ee4c61e6a..dd2c3eed578 100644 --- a/R/plot.R +++ b/R/plot.R @@ -64,7 +64,7 @@ i.plot.bezier <- function( arr.w ) { p <- i.compute.bezier(cp, points) - polygon(p[1, ], p[2, ], border = color, lwd = width, lty = lty) + i.r_polygon(p[1, ], p[2, ], border = color, lwd = width, lty = lty) if (arr == 1 || arr == 3) { igraph.Arrows( p[1, ncol(p) - 1], @@ -179,7 +179,7 @@ i.draw.loop <- function( ly <- lab.y } - text( + i.r_text( lx, ly, label, @@ -206,16 +206,13 @@ i.init_plot_canvas <- function( main, sub ) { - plot( - 0, - 0, - type = "n", - xlab = xlab, - ylab = ylab, + i.r_init_canvas( xlim = xlim, ylim = ylim, + xlab = xlab, + ylab = ylab, axes = axes, - frame.plot = ifelse(is.null(frame.plot), axes, frame.plot), + frame.plot = frame.plot, asp = asp, main = main, sub = sub @@ -400,7 +397,7 @@ i.draw_vertex_labels <- function( shift <- sqrt((nx - x)^2 + (ny - y)^2) lead <- drawn & shift > pmax(hh, 1e-6) if (any(lead)) { - segments(x[lead], y[lead], nx[lead], ny[lead], col = "grey60", lwd = 0.5) + i.r_segments(x[lead], y[lead], nx[lead], ny[lead], col = "grey60", lwd = 0.5) } x <- nx y <- ny @@ -409,7 +406,7 @@ i.draw_vertex_labels <- function( invisible(mapply( function(x0, y0, lbl, col, fam, fnt, cex, srt, adj) { - text( + i.r_text( x0, y0, labels = lbl, @@ -1056,7 +1053,7 @@ plot.igraph <- function( invisible(mapply( function(x, y, label, col, family, font, cex) { - text( + i.r_text( x, y, labels = label, @@ -2093,7 +2090,7 @@ i.draw_gradient_path <- function(px, py, col_from, col_to, lwd, lty, n = 40) { ramp <- grDevices::colorRamp(c(col_from, col_to), alpha = TRUE) m <- ramp(seq(0, 1, length.out = n - 1)) # one RGBA row per segment cols <- grDevices::rgb(m[, 1], m[, 2], m[, 3], alpha = m[, 4], maxColorValue = 255) - segments(rx[-n], ry[-n], rx[-1], ry[-1], col = cols, lwd = lwd, lty = lty) + i.r_segments(rx[-n], ry[-n], rx[-1], ry[-1], col = cols, lwd = lwd, lty = lty) invisible(NULL) } @@ -2181,7 +2178,7 @@ igraph.Arrows <- function( sh.lty[i] ) } else { - segments( + i.r_segments( sx1, sy1, sx2, @@ -2221,7 +2218,7 @@ igraph.Arrows <- function( sh.lty[i] ) } else { - lines(spl, lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i]) + i.r_polyline(spl, col = sh.col[i], lwd = sh.lwd[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))] @@ -2251,7 +2248,7 @@ igraph.Arrows <- function( sh.lty[i] ) } else { - lines(path$x, path$y, lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i]) + i.r_polyline(path$x, path$y, col = sh.col[i], lwd = sh.lwd[i], lty = sh.lty[i]) } np <- length(path$x) mid <- max(1L, round(np / 2)) @@ -2279,9 +2276,9 @@ igraph.Arrows <- function( yhead <- py2 + r.arr * sin(ttheta) / uin[2] if (open) { - lines(xhead, yhead, lwd = h.lwd[i], col = h.col.bo[i], lty = h.lty[i]) + i.r_polyline(xhead, yhead, col = h.col.bo[i], lwd = h.lwd[i], lty = h.lty[i]) } else { - polygon( + i.r_polygon( xhead, yhead, col = h.col[i], @@ -2332,7 +2329,7 @@ igraph.polygon <- function( cl <- convex_hull(pp) - xspline( + i.r_xspline( cl$rescoords, shape = shape, open = FALSE, diff --git a/R/plot.shapes.R b/R/plot.shapes.R index a54f2f84631..74cbf3a34b6 100644 --- a/R/plot.shapes.R +++ b/R/plot.shapes.R @@ -534,15 +534,14 @@ i.hide_zero_frame <- function(color, width) { vertex.frame.width <- frame$width if (length(vertex.frame.width) == 1) { - symbols( + i.r_symbols( + "circles", x = coords[, 1], y = coords[, 2], + dim = vertex.size, bg = vertex.color, fg = vertex.frame.color, - circles = vertex.size, - lwd = vertex.frame.width, - add = TRUE, - inches = FALSE + lwd = vertex.frame.width ) } else { mapply( @@ -553,15 +552,14 @@ i.hide_zero_frame <- function(color, width) { vertex.size, vertex.frame.width, FUN = function(x, y, bg, fg, size, lwd) { - symbols( + i.r_symbols( + "circles", x = x, y = y, + dim = size, bg = bg, fg = fg, - lwd = lwd, - circles = size, - add = TRUE, - inches = FALSE + lwd = lwd ) } ) @@ -689,15 +687,14 @@ i.hide_zero_frame <- function(color, width) { vertex.frame.width <- frame$width if (length(vertex.frame.width) == 1) { - symbols( + i.r_symbols( + "squares", x = coords[, 1], y = coords[, 2], + dim = 2 * vertex.size, bg = vertex.color, fg = vertex.frame.color, - squares = 2 * vertex.size, - lwd = vertex.frame.width, - add = TRUE, - inches = FALSE + lwd = vertex.frame.width ) } else { mapply( @@ -708,15 +705,14 @@ i.hide_zero_frame <- function(color, width) { vertex.size, vertex.frame.width, FUN = function(x, y, bg, fg, size, lwd) { - symbols( + i.r_symbols( + "squares", x = x, y = y, + dim = 2 * size, bg = bg, fg = fg, - lwd = lwd, - squares = 2 * size, - add = TRUE, - inches = FALSE + lwd = lwd ) } ) @@ -938,15 +934,14 @@ i.hide_zero_frame <- function(color, width) { vertex.frame.width <- frame$width if (length(vertex.frame.width) == 1) { - symbols( + i.r_symbols( + "rectangles", x = coords[, 1], y = coords[, 2], + dim = 2 * vertex.size, bg = vertex.color, fg = vertex.frame.color, - rectangles = 2 * vertex.size, - lwd = vertex.frame.width, - add = TRUE, - inches = FALSE + lwd = vertex.frame.width ) } else { mapply( @@ -958,15 +953,14 @@ i.hide_zero_frame <- function(color, width) { vertex.size[, 2], vertex.frame.width, FUN = function(x, y, bg, fg, size, size2, lwd) { - symbols( + i.r_symbols( + "rectangles", x = x, y = y, + dim = 2 * cbind(size, size2), bg = bg, fg = fg, - lwd = lwd, - rectangles = 2 * cbind(size, size2), - add = TRUE, - inches = FALSE + lwd = lwd ) } ) @@ -1192,7 +1186,7 @@ mypie <- function( for (i in 1:nx) { n <- max(2, floor(edges * dx[i])) P <- t2xy(seq.int(values[i], values[i + 1], length.out = n)) - polygon( + i.r_polygon( x + c(P$x, 0), y + c(P$y, 0), density = density[i], @@ -1348,7 +1342,7 @@ mypie <- function( for (i in seq_len(nrow(coords))) { vsp2 <- vertex.size[i] - rasterImage( + i.r_raster( images[[whichImage[i]]], coords[i, 1] - vsp2, coords[i, 2] - vsp2, @@ -1376,7 +1370,7 @@ mypie <- function( for (i in seq_len(nrow(coords))) { ras <- if (!is.list(raster) || length(raster) == 1) raster else raster[[i]] - rasterImage( + i.r_raster( ras, coords[i, 1] - size[i], coords[i, 2] - size2[i], diff --git a/tests/testthat/test-plot-render.R b/tests/testthat/test-plot-render.R new file mode 100644 index 00000000000..06835dad860 --- /dev/null +++ b/tests/testthat/test-plot-render.R @@ -0,0 +1,62 @@ +# Stage-3 rendering indirection (F5, phase 1): drawing is emitted through the +# i.r_*() dispatchers, which forward to the current renderer. + +test_that("the default renderer is the base renderer", { + r <- i.cur_renderer() + expect_type(r, "list") + expect_true(all( + c("segments", "polyline", "polygon", "xspline", "text", "symbols", "raster") %in% + names(r) + )) +}) + +test_that("i.with_renderer installs a renderer and restores the previous one", { + before <- i.cur_renderer() + marker <- list(tag = "fake") + fake <- c(before, list(tag = "fake")) + i.with_renderer(fake, { + expect_identical(i.cur_renderer()$tag, "fake") + }) + # restored afterwards + expect_null(i.cur_renderer()$tag) +}) + +test_that("dispatchers forward primitives to the current renderer", { + rec <- new.env() + rec$calls <- character() + capture <- function(name) { + function(...) { + rec$calls <- c(rec$calls, name) + invisible(NULL) + } + } + fake <- list( + init_canvas = capture("init_canvas"), + segments = capture("segments"), + polyline = capture("polyline"), + polygon = capture("polygon"), + xspline = capture("xspline"), + text = capture("text"), + symbols = capture("symbols"), + raster = capture("raster"), + group_begin = capture("group_begin"), + group_end = capture("group_end") + ) + i.with_renderer(fake, { + i.r_segments(0, 0, 1, 1) + i.r_polyline(c(0, 1), c(0, 1)) + i.r_polygon(c(0, 1, 1), c(0, 0, 1)) + i.r_text(0, 0, "x") + i.r_symbols("circles", 0, 0, 1, "red", "black", 1) + }) + expect_equal( + rec$calls, + c("segments", "polyline", "polygon", "text", "symbols") + ) +}) + +test_that("plot.igraph still works (drawing through the base renderer)", { + grDevices::pdf(NULL) + withr::defer(grDevices::dev.off()) + expect_silent(plot(make_ring(5))) +}) From 363b41dd4c675b00f37d96e6eab207811784294f Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 19:48:58 +0200 Subject: [PATCH 20/30] feat(plot): native SVG export via the draw list (F5 phase 2) Add a recording renderer that materializes the Stage-3 draw list (primitives with hex-canonicalised colours and their vertex/edge group), and a small SVG writer that consumes it. New exported as_svg(graph, file, width, height, tooltips, ...) renders a graph to standalone SVG reusing plot.igraph's geometry (via an offscreen measurement device), emitting per-vertex with tooltips and per-edge <g id="edge-N"> groups -- lightweight hover/click interactivity with no JavaScript. Coverage: vertices (circle/square/rectangle), every edge style (straight/arc/elbow/diagonal/gradient), arrowheads, labels, mark groups and pie slices render; sphere/raster shapes draw as a placeholder box (v1). NA/empty labels are skipped to match base output. Per-edge grouping is threaded through igraph.Arrows via a new `ids` arg; the base renderer ignores grouping, so base plotting output is unchanged (snapshots byte-identical). Adds tests for the draw list and the SVG (well-formedness, per-element ids, tooltips, file output). Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com> --- R/plot-render.R | 307 ++++++++++++++++++++++++++++++ R/plot.R | 24 ++- tests/testthat/test-plot-render.R | 51 +++++ 3 files changed, 379 insertions(+), 3 deletions(-) diff --git a/R/plot-render.R b/R/plot-render.R index d22ba0b8480..b24d7d4ff0d 100644 --- a/R/plot-render.R +++ b/R/plot-render.R @@ -153,3 +153,310 @@ i.r_symbols <- function(...) i.cur_renderer()$symbols(...) i.r_raster <- function(...) i.cur_renderer()$raster(...) i.r_group_begin <- function(...) i.cur_renderer()$group_begin(...) i.r_group_end <- function(...) i.cur_renderer()$group_end(...) + +################################################################### +# Recording renderer + SVG writer (feature F5, phase 2) +################################################################### + +# Canonicalise a colour vector to "#RRGGBBAA" hex (resolving palette indices and +# names against the active device), keeping NA as NA. Self-contained output. +i.col_to_hex <- function(col) { + if (is.null(col)) { + return(NA_character_) + } + out <- rep(NA_character_, length(col)) + ok <- !is.na(col) + if (any(ok)) { + m <- grDevices::col2rgb(col[ok], alpha = TRUE) + out[ok] <- grDevices::rgb(m[1, ], m[2, ], m[3, ], m[4, ], maxColorValue = 255) + } + out +} + +# A renderer that records primitives into a backend-neutral draw list instead of +# drawing. init_canvas still sets up the coordinate system on the (offscreen) +# device so geometry that reads par("usr")/xyinch() resolves correctly; nothing +# else is drawn. Colours are canonicalised to hex at record time. The current +# group (set by group_begin/end) is attached to each primitive. +i.renderer_record <- function() { + st <- new.env(parent = emptyenv()) + st$prims <- list() + st$canvas <- NULL + st$group <- NULL + add <- function(p) { + p$group <- st$group + st$prims[[length(st$prims) + 1L]] <- p + } + base <- i.renderer_base() + list( + .state = st, + init_canvas = function(xlim, ylim, xlab, ylab, axes, frame.plot, asp, main, sub) { + # establish the coordinate system (discarded device); record the range + base$init_canvas(xlim, ylim, "", "", FALSE, FALSE, asp, "", "") + st$canvas <- list(usr = graphics::par("usr")) + }, + segments = function(x0, y0, x1, y1, col = NA, lwd = 1, lty = 1) { + add(list(type = "segments", x0 = x0, y0 = y0, x1 = x1, y1 = y1, + col = i.col_to_hex(col), lwd = lwd)) + }, + polyline = function(x, y = NULL, col = NA, lwd = 1, lty = 1) { + xy <- grDevices::xy.coords(x, y) + add(list(type = "polyline", x = xy$x, y = xy$y, col = i.col_to_hex(col), lwd = lwd)) + }, + polygon = function(x, y = NULL, col = NA, border = NULL, lwd = 1, lty = 1, + density = NULL, angle = 45, ...) { + xy <- grDevices::xy.coords(x, y) + add(list(type = "polygon", x = xy$x, y = xy$y, col = i.col_to_hex(col), + border = i.col_to_hex(border), lwd = lwd)) + }, + xspline = function(x, y = NULL, shape, open, col = NA, border = NA, lwd = 1) { + pts <- grDevices::xspline(x, y, shape = shape, open = open, draw = FALSE) + add(list(type = "polygon", x = pts$x, y = pts$y, col = i.col_to_hex(col), + border = i.col_to_hex(border), lwd = lwd)) + }, + text = function(x, y, labels, col = NA, family = "", font = 1, cex = 1, + srt = 0, adj = NULL) { + add(list(type = "text", x = x, y = y, labels = labels, + col = i.col_to_hex(col), cex = cex, srt = srt, adj = adj)) + }, + symbols = function(kind, x, y, dim, bg = NA, fg = NA, lwd = 1) { + add(list(type = "symbols", kind = kind, x = x, y = y, dim = dim, + bg = i.col_to_hex(bg), fg = i.col_to_hex(fg), lwd = lwd)) + }, + raster = function(image, xleft, ybottom, xright, ytop) { + add(list(type = "raster", xleft = xleft, ybottom = ybottom, + xright = xright, ytop = ytop)) + }, + group_begin = function(type, id = NULL, title = NULL) { + st$group <- list(type = type, id = id, title = title) + }, + group_end = function() { + st$group <- NULL + } + ) +} + +# ---- SVG writer ------------------------------------------------------------- + +i.svg_attr_esc <- function(x) { + x <- gsub("&", "&", x, fixed = TRUE) + x <- gsub("<", "<", x, fixed = TRUE) + x <- gsub(">", ">", x, fixed = TRUE) + gsub("'", "'", x, fixed = TRUE) +} + +# SVG colour + opacity from an "#RRGGBBAA" hex; returns c(fill, opacity). +i.svg_col <- function(hex) { + if (length(hex) == 0 || is.na(hex)) { + return(c("none", "1")) + } + if (nchar(hex) >= 9) { + a <- strtoi(substr(hex, 8, 9), 16L) / 255 + c(substr(hex, 1, 7), format(round(a, 3))) + } else { + c(hex, "1") + } +} + +# Build an SVG document string from a recorded draw list. `wpx`/`hpx` are the +# pixel canvas size; primitives (in user coords) are mapped via the recorded +# usr range with the y axis flipped. Vertices get per-element ids/titles; edges +# are wrapped per-edge group; everything else is grouped by phase. +i.svg_from_record <- function(state, wpx, hpx) { + usr <- state$canvas$usr + if (is.null(usr)) { + usr <- c(-1, 1, -1, 1) + } + sxr <- wpx / (usr[2] - usr[1]) + syr <- hpx / (usr[4] - usr[3]) + X <- function(x) (x - usr[1]) * sxr + Y <- function(y) hpx - (y - usr[3]) * syr + S <- function(s) s * sxr # user-length -> px (asp == 1) + + pts_str <- function(x, y) paste(sprintf("%.2f,%.2f", X(x), Y(y)), collapse = " ") + stroke <- function(hex, lwd) { + sc <- i.svg_col(hex) + sprintf("stroke='%s' stroke-opacity='%s' stroke-width='%.2f'", sc[1], sc[2], max(lwd, 0.1)) + } + fillattr <- function(hex) { + fc <- i.svg_col(hex) + sprintf("fill='%s' fill-opacity='%s'", fc[1], fc[2]) + } + + one <- function(p, vtitle) { + # returns a character vector of SVG element strings + switch( + p$type, + segments = { + n <- length(p$x0) + col <- rep(p$col, length.out = n) + vapply(seq_len(n), function(k) { + sprintf( + "<line x1='%.2f' y1='%.2f' x2='%.2f' y2='%.2f' %s fill='none'/>", + X(p$x0[k]), Y(p$y0[k]), X(p$x1[k]), Y(p$y1[k]), + stroke(col[k], p$lwd) + ) + }, character(1)) + }, + polyline = sprintf( + "<polyline points='%s' fill='none' %s/>", + pts_str(p$x, p$y), stroke(p$col, p$lwd) + ), + polygon = sprintf( + "<polygon points='%s' %s %s/>", + pts_str(p$x, p$y), fillattr(p$col), stroke(p$border, p$lwd) + ), + text = { + n <- length(p$x) + col <- rep(p$col, length.out = n) + adj <- if (is.null(p$adj)) 0.5 else p$adj[1] + anchor <- c("start", "middle", "end")[findInterval(adj, c(-Inf, 0.25, 0.75, Inf))] + fc <- i.svg_col(col[1]) + lab <- as.character(p$labels) + keep <- which(!is.na(lab) & nzchar(lab)) # base skips NA/empty labels + vapply(keep, function(k) { + rot <- if (p$srt != 0) sprintf(" transform='rotate(%.2f %.2f %.2f)'", -p$srt, X(p$x[k]), Y(p$y[k])) else "" + sprintf( + "<text x='%.2f' y='%.2f' font-size='%.1f' text-anchor='%s' dominant-baseline='central' fill='%s' fill-opacity='%s'%s>%s</text>", + X(p$x[k]), Y(p$y[k]), p$cex * 12, anchor, fc[1], fc[2], rot, + i.svg_attr_esc(lab[k]) + ) + }, character(1)) + }, + symbols = { + n <- length(p$x) + bg <- rep(p$bg, length.out = n) + fg <- rep(p$fg, length.out = n) + out <- character(n) + for (k in seq_len(n)) { + idattr <- "" + if (!is.null(vtitle)) { + kk <- vtitle$counter + idattr <- sprintf(" id='vertex-%d'", kk) + ttl <- if (!is.null(vtitle$titles)) sprintf("<title>%s", i.svg_attr_esc(vtitle$titles[kk])) else "" + vtitle$counter <- kk + 1L + } else { + ttl <- "" + } + shp <- if (p$kind == "circles") { + sprintf("", + X(p$x[k]), Y(p$y[k]), S(p$dim[k]), fillattr(bg[k]), stroke(fg[k], p$lwd)) + } else if (p$kind == "squares") { + h <- p$dim[k] / 2 + sprintf("", + X(p$x[k] - h), Y(p$y[k] + h), S(p$dim[k]), S(p$dim[k]), fillattr(bg[k]), stroke(fg[k], p$lwd)) + } else { + # rectangles: dim is n x 2 (full width, height) + w <- if (is.matrix(p$dim)) p$dim[k, 1] else p$dim[1] + hh <- if (is.matrix(p$dim)) p$dim[k, 2] else p$dim[2] + sprintf("", + X(p$x[k] - w / 2), Y(p$y[k] + hh / 2), S(w), S(hh), fillattr(bg[k]), stroke(fg[k], p$lwd)) + } + out[k] <- paste0(if (nzchar(idattr)) sprintf("%s%s", idattr, ttl, shp) else shp) + } + out + }, + raster = sprintf( + # v1 placeholder for sphere/raster shapes + "", + X(p$xleft), Y(p$ytop), S(p$xright - p$xleft), S(p$ytop - p$ybottom) + ), + character(0) + ) + } + + body <- character(0) + prims <- state$prims + cur_key <- NA_character_ + open_g <- FALSE + vtitle <- NULL # environment-like tracker for vertex ids within a vertices group + + group_key <- function(g) if (is.null(g)) "" else paste0(g$type, ":", if (is.null(g$id)) "" else g$id) + + for (p in prims) { + g <- p$group + key <- group_key(g) + if (!identical(key, cur_key)) { + if (open_g) { + body <- c(body, "") + open_g <- FALSE + } + vtitle <- NULL + if (!is.null(g)) { + if (identical(g$type, "vertices")) { + body <- c(body, "") + vtitle <- new.env(parent = emptyenv()) + vtitle$counter <- 1L + vtitle$titles <- g$title + } else if (identical(g$type, "edge")) { + ttl <- if (!is.null(g$title)) sprintf("%s", i.svg_attr_esc(as.character(g$title))) else "" + body <- c(body, sprintf("%s", as.character(g$id), ttl)) + } else { + body <- c(body, sprintf("", g$type)) + } + open_g <- TRUE + } + cur_key <- key + } + body <- c(body, one(p, vtitle)) + } + if (open_g) { + body <- c(body, "") + } + + c( + sprintf("", wpx, hpx, wpx, hpx), + "", + body, + "" + ) +} + +#' Render a graph to SVG +#' +#' `as_svg()` draws a graph to a standalone SVG string using the same geometry +#' as [plot.igraph()], but emits per-vertex `` groups with +#' `` tooltips (and per-edge groups), giving lightweight interactivity +#' (hover) with no JavaScript. It accepts the usual plotting parameters via +#' `...`. +#' +#' Vertices, edges (all styles), arrowheads, labels, mark groups and pie shapes +#' are rendered; `sphere`/`raster` vertex shapes are drawn as a placeholder box +#' in this version. +#' +#' @param graph The graph to plot. +#' @param file Optional path to write the SVG to. If `NULL` (default) the SVG +#' string is returned invisibly. +#' @param width,height Size in inches (the SVG is `width*72` x `height*72` px). +#' @param tooltips Optional vertex attribute name to use for the `<title>` +#' tooltips; defaults to the vertex `name` attribute (or vertex index). +#' @param ... Further plotting parameters passed to [plot.igraph()]. +#' @return The SVG string, invisibly (also written to `file` if given). +#' @export +as_svg <- function(graph, file = NULL, width = 7, height = 7, tooltips = NULL, ...) { + ensure_igraph(graph) + + titles <- if (!is.null(tooltips)) { + as.character(vertex_attr(graph, tooltips)) + } else if ("name" %in% vertex_attr_names(graph)) { + as.character(V(graph)$name) + } else { + as.character(seq_len(vcount(graph))) + } + + rec <- i.renderer_record() + grDevices::pdf(NULL, width = width, height = height) + on.exit(grDevices::dev.off(), add = TRUE) + i.with_renderer(rec, { + i.render_state$vertex_titles <- titles + on.exit(i.render_state$vertex_titles <- NULL, add = TRUE) + plot(graph, ...) + }) + + svg <- i.svg_from_record(rec$.state, wpx = round(width * 72), hpx = round(height * 72)) + svg <- paste(svg, collapse = "\n") + if (!is.null(file)) { + writeLines(svg, file) + } + invisible(svg) +} diff --git a/R/plot.R b/R/plot.R index dd2c3eed578..aad543db68e 100644 --- a/R/plot.R +++ b/R/plot.R @@ -999,7 +999,8 @@ plot.igraph <- function( curved = curved, style = edge.style, gradient = edge.gradient, - col.to = col.to.e + col.to = col.to.e, + ids = nonloops.e ) lc.x <- lc$lab.x lc.y <- lc$lab.y @@ -1031,7 +1032,8 @@ plot.igraph <- function( curved = curved[valid], style = edge.style[valid], gradient = edge.gradient[valid], - col.to = col.to.e[valid] + col.to = col.to.e[valid], + ids = nonloops.e[valid] ) lc.x[valid] <- lc$lab.x lc.y[valid] <- lc$lab.y @@ -1078,6 +1080,14 @@ plot.igraph <- function( ################################################################ # add the vertices if (vc > 0) { + vtitles <- if (!is.null(i.render_state$vertex_titles)) { + i.render_state$vertex_titles + } else if ("name" %in% vertex_attr_names(graph)) { + as.character(V(graph)$name) + } else { + as.character(seq_len(vc)) + } + i.r_group_begin("vertices", title = vtitles) if (length(unique(shape)) == 1) { .igraph.shapes[[shape[1]]]$plot(layout, params = params) } else { @@ -1089,6 +1099,7 @@ plot.igraph <- function( ) }) } + i.r_group_end() } ################################################################ @@ -2116,7 +2127,8 @@ igraph.Arrows <- function( curved = FALSE, style = "auto", gradient = FALSE, - col.to = sh.col + col.to = sh.col, + ids = NULL ) { n <- length(x1) @@ -2146,6 +2158,9 @@ igraph.Arrows <- function( label_y <- numeric(n) for (i in seq_len(n)) { + if (!is.null(ids)) { + i.r_group_begin("edge", id = ids[i]) + } cin <- size[i] * par("cin")[2] w <- width[i] * (ARROW_WIDTH_FACTOR / cin) delta <- sqrt(h.lwd[i]) * par("cin")[2] * 0.005 @@ -2303,6 +2318,9 @@ igraph.Arrows <- function( atan2((y1[i] - y2[i]) * uin[2], (x1[i] - x2[i]) * uin[1]) ) } + if (!is.null(ids)) { + i.r_group_end() + } } list(lab.x = label_x, lab.y = label_y) diff --git a/tests/testthat/test-plot-render.R b/tests/testthat/test-plot-render.R index 06835dad860..b30c52f7fd7 100644 --- a/tests/testthat/test-plot-render.R +++ b/tests/testthat/test-plot-render.R @@ -60,3 +60,54 @@ test_that("plot.igraph still works (drawing through the base renderer)", { withr::defer(grDevices::dev.off()) expect_silent(plot(make_ring(5))) }) + +test_that("the record renderer captures a backend-neutral draw list", { + g <- make_ring(3) + V(g)$name <- c("x", "y", "z") + rec <- i.renderer_record() + grDevices::pdf(NULL) + withr::defer(grDevices::dev.off()) + i.with_renderer(rec, plot(g, vertex.size = 20)) + + prims <- rec$.state$prims + expect_gt(length(prims), 0) + types <- vapply(prims, function(p) p$type, character(1)) + expect_true("symbols" %in% types) # vertices + expect_true(any(types %in% c("segments", "polyline"))) # edges + grp <- vapply( + prims, + function(p) if (is.null(p$group)) "" else p$group$type, + character(1) + ) + expect_true("vertices" %in% grp) + expect_true("edge" %in% grp) + # colours are canonicalised to hex + sym <- prims[[which(types == "symbols")[1]]] + expect_match(sym$bg[1], "^#") +}) + +test_that("as_svg produces well-formed SVG with per-vertex/edge ids and titles", { + skip_if_not_installed("xml2") + g <- make_ring(4, directed = TRUE) + V(g)$name <- c("a", "b", "c", "d") + svg <- as_svg(g) + + # well-formed + expect_s3_class(xml2::read_xml(svg), "xml_document") + # one group per vertex and per edge + expect_length(gregexpr("id='vertex-", svg, fixed = TRUE)[[1]], 4) + expect_length(gregexpr("id='edge-", svg, fixed = TRUE)[[1]], 4) + # tooltip from the vertex name + expect_match(svg, "<title>a", fixed = TRUE) +}) + +test_that("as_svg writes to a file and honours the tooltips argument", { + g <- make_ring(3) + V(g)$kind <- c("p", "q", "r") + + f <- withr::local_tempfile(fileext = ".svg") + out <- as_svg(g, file = f, tooltips = "kind") + expect_true(file.exists(f)) + expect_match(paste(readLines(f), collapse = ""), "p", fixed = TRUE) +}) From f3d5eedbcc71c52a30b9099622aac1b71826be4b Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 20:51:03 +0200 Subject: [PATCH 21/30] feat: label halos and label_top() decluttering helper (F6) Add two opt-in, default-no-op label features to plot.igraph(): - Label halo: a shadowtext-style legibility outline behind vertex and edge label text, via new i.r_text_halo() and `vertex.label.halo` / `edge.label.halo` (colour, default NA) + `*.halo.width` params. With NA the draw path is byte-identical to before, so existing snapshots are unchanged. - label_top(): an exported helper returning a label vector with NA outside the top-N by a metric, composing with plot.igraph()'s NA-omission to declutter dense graphs (mirrors the scale_*() helper style). Halo params flow through i.edge_aes_table, the default registry, and the length checks; routed through all three 2D label sites (vertex, non-loop edge, loop edge). Adds label_top unit tests, halo vdiffr snapshots, and an as_svg halo smoke test. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-aes.R | 4 + R/plot-labels.R | 81 +++++++++++ R/plot.R | 115 ++++++++++++++-- R/plot.common.R | 23 ++++ .../testthat/_snaps/plot/edge-label-halo.svg | 115 ++++++++++++++++ .../_snaps/plot/vertex-label-halo.svg | 126 ++++++++++++++++++ tests/testthat/test-plot-labels.R | 59 ++++++++ tests/testthat/test-plot-params.R | 2 + tests/testthat/test-plot-render.R | 17 +++ tests/testthat/test-plot.R | 41 ++++++ 10 files changed, 569 insertions(+), 14 deletions(-) create mode 100644 R/plot-labels.R create mode 100644 tests/testthat/_snaps/plot/edge-label-halo.svg create mode 100644 tests/testthat/_snaps/plot/vertex-label-halo.svg create mode 100644 tests/testthat/test-plot-labels.R diff --git a/R/plot-aes.R b/R/plot-aes.R index b039cca6431..da200832c0b 100644 --- a/R/plot-aes.R +++ b/R/plot-aes.R @@ -75,6 +75,8 @@ i.edge_aes_table <- function( label.family, label.font, label.cex, + label.halo, + label.halo.width, style, alpha, gradient, @@ -93,6 +95,8 @@ i.edge_aes_table <- function( label.family = label.family, label.font = label.font, label.cex = label.cex, + label.halo = label.halo, + label.halo.width = label.halo.width, style = style, alpha = alpha, gradient = gradient diff --git a/R/plot-labels.R b/R/plot-labels.R new file mode 100644 index 00000000000..20a22150f65 --- /dev/null +++ b/R/plot-labels.R @@ -0,0 +1,81 @@ +# IGraph R package +# Copyright (C) 2003-2012 Gabor Csardi +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +################################################################### + +# Label decluttering (feature F6): a helper that keeps only the most prominent +# labels and blanks the rest with NA. Because plot.igraph() omits NA labels, +# the result can be passed straight to a label argument, e.g. +# plot(g, vertex.label = label_top(degree(g), n = 10)). + +#' Keep only the most prominent labels +#' +#' `label_top()` returns a label vector with `NA` everywhere except the entries +#' that rank highest by `by`. Because [plot.igraph()] omits `NA` labels, this is +#' a convenient way to declutter dense graphs by labelling only the most +#' important vertices (or edges). Pass it to a label argument, e.g. +#' `plot(g, vertex.label = label_top(degree(g), n = 10))`. +#' +#' To label everything above a fixed cutoff instead of a fixed count, you do not +#' need this helper: `ifelse(metric > cutoff, labels, NA)` works directly. +#' +#' @param by A numeric vector of scores to rank by, e.g. `degree(g)` or +#' `betweenness(g)`. One score per vertex (or edge). +#' @param n Number of labels to keep (the top `n` by `by`). Give either `n` or +#' `prop`, not both. If neither is given, all labels are kept. +#' @param prop Proportion of labels to keep, between 0 and 1; rounded up. Give +#' either `n` or `prop`, not both. +#' @param labels The labels to thin. Defaults to `names(by)` if present, +#' otherwise the integer positions. Must have the same length as `by`. +#' @param decreasing Logical; if `TRUE` (the default) the highest `by` values +#' are kept, otherwise the lowest. +#' @return A character vector the same length as `by`, with `NA` in the +#' positions that are not kept. +#' @examples +#' g <- make_ring(10) +#' plot(g, vertex.label = label_top(degree(g), n = 3)) +#' @export +label_top <- function( + by, + n = NULL, + prop = NULL, + labels = NULL, + decreasing = TRUE +) { + if (!is.numeric(by)) { + cli::cli_abort("{.arg by} must be a numeric vector.") + } + if (!is.null(n) && !is.null(prop)) { + cli::cli_abort("Give either {.arg n} or {.arg prop}, not both.") + } + + labels <- labels %||% names(by) %||% as.character(seq_along(by)) + if (length(labels) != length(by)) { + cli::cli_abort("{.arg labels} must have the same length as {.arg by}.") + } + + k <- if (!is.null(n)) { + as.integer(n) + } else if (!is.null(prop)) { + if (prop < 0 || prop > 1) { + cli::cli_abort("{.arg prop} must be between 0 and 1.") + } + as.integer(ceiling(prop * length(by))) + } else { + length(by) + } + + keep <- rank( + if (decreasing) -by else by, + ties.method = "min", + na.last = TRUE + ) <= + k + out <- as.character(labels) + out[!keep] <- NA_character_ + out +} diff --git a/R/plot.R b/R/plot.R index aad543db68e..d2ca782198b 100644 --- a/R/plot.R +++ b/R/plot.R @@ -114,6 +114,8 @@ i.draw.loop <- function( label.font, label.family, label.cex, + label.halo = NA, + label.halo.width = 0.15, width = 1, arr = 2, lty = 1, @@ -179,14 +181,16 @@ i.draw.loop <- function( ly <- lab.y } - i.r_text( + i.r_text_halo( lx, ly, label, col = label.color, font = label.font, family = label.family, - cex = label.cex + cex = label.cex, + halo = label.halo, + halo.width = label.halo.width ) } } @@ -352,7 +356,9 @@ i.draw_vertex_labels <- function( label.cex, label.angle, label.adj, - repel = FALSE + repel = FALSE, + label.halo = NA, + label.halo.width = 0.15 ) { vc <- nrow(layout) if (vc == 0) { @@ -380,6 +386,8 @@ i.draw_vertex_labels <- function( label.ang <- rep(label.angle, length.out = vc) label.adj <- rep(list(label.adj), length.out = vc) label.text <- rep(labels, length.out = vc) + label.halo <- rep(label.halo, length.out = vc) + label.halo.w <- rep(label.halo.width, length.out = vc) if (isTRUE(any(repel)) && vc > 1) { drawn <- !is.na(label.text) & nzchar(as.character(label.text)) @@ -405,8 +413,8 @@ i.draw_vertex_labels <- function( } invisible(mapply( - function(x0, y0, lbl, col, fam, fnt, cex, srt, adj) { - i.r_text( + function(x0, y0, lbl, col, fam, fnt, cex, srt, adj, halo, halo.w) { + i.r_text_halo( x0, y0, labels = lbl, @@ -415,7 +423,9 @@ i.draw_vertex_labels <- function( font = fnt, cex = cex, srt = srt, - adj = adj + adj = adj, + halo = halo, + halo.width = halo.w ) }, x, @@ -426,10 +436,65 @@ i.draw_vertex_labels <- function( label.fnt, label.cex, label.ang, - label.adj + label.adj, + label.halo, + label.halo.w )) } +# Draw one label with an optional shadowtext halo for legibility (Stage 4). +# `halo = NA` (the default) is exactly `i.r_text()` -> byte-identical to before. +# Otherwise the glyphs are drawn `halo.steps` times offset on a circle of radius +# (halo.width * strheight) in the `halo` colour, then the real text on top, which +# produces a tight outline that reads over edges. Operates on a single label. +i.r_text_halo <- function( + x, + y, + labels, + col, + family = "", + font = 1, + cex = 1, + srt = 0, + adj = NULL, + halo = NA, + halo.width = 0.15, + halo.steps = 16 +) { + if ( + !is.na(halo) && + !is.na(labels) && + nzchar(as.character(labels)) + ) { + r <- halo.width * strheight(labels, cex = cex) + th <- seq(0, 2 * pi, length.out = halo.steps + 1)[-1] + for (a in th) { + i.r_text( + x + r * cos(a), + y + r * sin(a), + labels = labels, + col = halo, + family = family, + font = font, + cex = cex, + srt = srt, + adj = adj + ) + } + } + i.r_text( + x, + y, + labels = labels, + col = col, + family = family, + font = font, + cex = cex, + srt = srt, + adj = adj + ) +} + #' Plotting of graphs #' #' `plot.igraph()` is able to plot graphs to any R device. It is the @@ -545,6 +610,8 @@ plot.igraph <- function( label.angle <- params("vertex", "label.angle") label.adj <- params("vertex", "label.adj") label.repel <- params("vertex", "label.repel") + label.halo <- params("vertex", "label.halo") + label.halo.width <- params("vertex", "label.halo.width") labels <- params("vertex", "label") shape <- igraph.check.shapes(params("vertex", "shape")) @@ -567,6 +634,8 @@ plot.igraph <- function( edge.label.family <- params("edge", "label.family") edge.label.cex <- params("edge", "label.cex") edge.label.color <- params("edge", "label.color") + edge.label.halo <- params("edge", "label.halo") + edge.label.halo.width <- params("edge", "label.halo.width") elab.x <- params("edge", "label.x") elab.y <- params("edge", "label.y") arrow.size <- params("edge", "arrow.size") @@ -628,7 +697,9 @@ plot.igraph <- function( label.degree = label.degree, label.angle = label.angle, label.font = label.font, - label.family = label.family + label.family = label.family, + label.halo = label.halo, + label.halo.width = label.halo.width ), edge = list( color = edge.color, @@ -640,7 +711,9 @@ plot.igraph <- function( label.color = edge.label.color, label.cex = edge.label.cex, label.font = edge.label.font, - label.family = edge.label.family + label.family = edge.label.family, + label.halo = edge.label.halo, + label.halo.width = edge.label.halo.width ), vc = vc, ec = ecount(graph) @@ -865,6 +938,8 @@ plot.igraph <- function( label.family = edge.label.family, label.font = edge.label.font, label.cex = edge.label.cex, + label.halo = edge.label.halo, + label.halo.width = edge.label.halo.width, style = edge.style, alpha = edge.alpha, gradient = edge.gradient, @@ -896,6 +971,8 @@ plot.igraph <- function( lfam <- loop_aes$label.family lfon <- loop_aes$label.font lcex <- loop_aes$label.cex + lhalo <- loop_aes$label.halo + lhalo.w <- loop_aes$label.halo.width # Place loops in the largest angular gap at each vertex (flower-petal style). loop_geo <- i.loop_angles(graph, layout, loops.v) @@ -928,6 +1005,8 @@ plot.igraph <- function( label.family = lfam, label.font = lfon, label.cex = lcex, + label.halo = lhalo, + label.halo.width = lhalo.w, lty = lty, width = ew, arr = arr, @@ -1052,17 +1131,21 @@ plot.igraph <- function( efam <- nl_aes$label.family efon <- nl_aes$label.font ecex <- nl_aes$label.cex + ehalo <- nl_aes$label.halo + ehalo.w <- nl_aes$label.halo.width invisible(mapply( - function(x, y, label, col, family, font, cex) { - i.r_text( + function(x, y, label, col, family, font, cex, halo, halo.w) { + i.r_text_halo( x, y, labels = label, col = col, family = family, font = font, - cex = cex + cex = cex, + halo = halo, + halo.width = halo.w ) }, lc.x, @@ -1071,7 +1154,9 @@ plot.igraph <- function( ecol, efam, efon, - ecex + ecex, + ehalo, + ehalo.w )) } @@ -1116,7 +1201,9 @@ plot.igraph <- function( label.cex, label.angle, label.adj, - repel = label.repel + repel = label.repel, + label.halo = label.halo, + label.halo.width = label.halo.width ) ################################################################ diff --git a/R/plot.common.R b/R/plot.common.R index 4c183b34f8a..9f81b82635f 100644 --- a/R/plot.common.R +++ b/R/plot.common.R @@ -241,6 +241,16 @@ #' apart (in the spirit of \pkg{ggrepel}) and a thin leader line connects each #' moved label to its original position. The default is `FALSE`. #' } +#' \item{label.halo}{ +#' The colour of a legibility halo (outline) drawn behind the vertex label +#' text, so labels remain readable over edges and other vertices. The halo is +#' drawn shadowtext-style: the glyphs are repeated, offset in a ring, in this +#' colour, with the real label on top. `NA` (the default) draws no halo. +#' } +#' \item{label.halo.width}{ +#' The width of the label halo, as a fraction of the label height. Only has an +#' effect when `label.halo` is not `NA`. The default is `0.15`. +#' } #' \item{size.scaling}{ #' Switches between absolute vertex sizing (FALSE,default) and relative (TRUE). @@ -308,6 +318,15 @@ #' \item{label.color}{ #' The color of the edge labels, see the `color` vertex parameters on how to specify colors. #' } +#' \item{label.halo}{ +#' The colour of a legibility halo (outline) drawn behind the edge label text. +#' See the vertex parameter with the same name for details. `NA` (the default) +#' draws no halo. +#' } +#' \item{label.halo.width}{ +#' The width of the edge label halo, as a fraction of the label height. Only +#' has an effect when `label.halo` is not `NA`. The default is `0.15`. +#' } #' \item{label.x}{ #' The horizontal `NA` elements will be replaced by automatically calculated coordinates. #' If `NULL`, then all edge horizontal coordinates are calculated automatically. @@ -4907,6 +4926,8 @@ i.vertex.default <- list( label.angle = 0, label.adj = NULL, label.repel = FALSE, + label.halo = NA, + label.halo.width = 0.15, alpha = 1, frame.color = "black", frame.width = 1, @@ -4939,6 +4960,8 @@ i.edge.default <- list( label.font = 1, label.cex = 1, label.color = "darkblue", + label.halo = NA, + label.halo.width = 0.15, label.x = NULL, label.y = NULL, arrow.size = 1, diff --git a/tests/testthat/_snaps/plot/edge-label-halo.svg b/tests/testthat/_snaps/plot/edge-label-halo.svg new file mode 100644 index 00000000000..a7593bb798f --- /dev/null +++ b/tests/testthat/_snaps/plot/edge-label-halo.svg @@ -0,0 +1,115 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e1 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e2 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e3 +e4 +e4 +e4 +e4 +e4 +e4 +e4 +e4 +e4 +e4 +e4 +e4 +e4 +e4 +e4 +e4 +e4 + + + + + + +1 +2 +3 +4 + + diff --git a/tests/testthat/_snaps/plot/vertex-label-halo.svg b/tests/testthat/_snaps/plot/vertex-label-halo.svg new file mode 100644 index 00000000000..df72cb7b93a --- /dev/null +++ b/tests/testthat/_snaps/plot/vertex-label-halo.svg @@ -0,0 +1,126 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +alpha +alpha +alpha +alpha +alpha +alpha +alpha +alpha +alpha +alpha +alpha +alpha +alpha +alpha +alpha +alpha +alpha +beta +beta +beta +beta +beta +beta +beta +beta +beta +beta +beta +beta +beta +beta +beta +beta +beta +gamma +gamma +gamma +gamma +gamma +gamma +gamma +gamma +gamma +gamma +gamma +gamma +gamma +gamma +gamma +gamma +gamma +delta +delta +delta +delta +delta +delta +delta +delta +delta +delta +delta +delta +delta +delta +delta +delta +delta +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon +epsilon + + diff --git a/tests/testthat/test-plot-labels.R b/tests/testthat/test-plot-labels.R new file mode 100644 index 00000000000..051d447c537 --- /dev/null +++ b/tests/testthat/test-plot-labels.R @@ -0,0 +1,59 @@ +# Label decluttering helper (F6): label_top() keeps the highest-ranked labels +# and blanks the rest with NA so plot.igraph() omits them. + +test_that("label_top keeps exactly n labels, the highest by `by`", { + by <- c(5, 1, 9, 3, 7) + out <- label_top(by, n = 2, labels = letters[1:5]) + expect_length(out, 5) + expect_equal(sum(!is.na(out)), 2) + # the two highest are 9 (pos 3, "c") and 7 (pos 5, "e") + expect_equal(which(!is.na(out)), c(3, 5)) + expect_equal(out[!is.na(out)], c("c", "e")) +}) + +test_that("label_top supports prop (rounded up)", { + by <- 1:10 + out <- label_top(by, prop = 0.25, labels = as.character(1:10)) + expect_equal(sum(!is.na(out)), 3) # ceiling(0.25 * 10) + expect_equal(out[!is.na(out)], c("8", "9", "10")) +}) + +test_that("label_top decreasing = FALSE keeps the lowest", { + by <- c(5, 1, 9, 3, 7) + out <- label_top(by, n = 2, labels = letters[1:5], decreasing = FALSE) + expect_equal(which(!is.na(out)), c(2, 4)) # values 1 and 3 +}) + +test_that("label_top defaults labels to names then indices", { + named <- c(a = 5, b = 1, c = 9) + expect_equal(label_top(named, n = 1), c(NA, NA, "c")) + + unnamed <- c(5, 1, 9) + expect_equal(label_top(unnamed, n = 1), c(NA, NA, "3")) +}) + +test_that("label_top keeps everything when neither n nor prop given", { + by <- c(5, 1, 9) + expect_equal(label_top(by, labels = letters[1:3]), c("a", "b", "c")) +}) + +test_that("label_top handles ties via rank ties.method = 'min'", { + by <- c(5, 5, 1) + out <- label_top(by, n = 1, labels = letters[1:3]) + # both 5s rank 1 (min), so both kept even though n = 1 + expect_equal(which(!is.na(out)), c(1, 2)) +}) + +test_that("label_top validates its arguments", { + expect_error(label_top("x", n = 1), "numeric") + expect_error(label_top(1:3, n = 1, prop = 0.5), "either") + expect_error(label_top(1:3, prop = 2), "between 0 and 1") + expect_error(label_top(1:3, labels = letters[1:2]), "same length") +}) + +test_that("label_top composes with plot.igraph (NA labels omitted)", { + g <- make_ring(6) + grDevices::pdf(NULL) + withr::defer(grDevices::dev.off()) + expect_silent(plot(g, vertex.label = label_top(degree(g), n = 2))) +}) diff --git a/tests/testthat/test-plot-params.R b/tests/testthat/test-plot-params.R index c2a8cf9b09f..115404700bd 100644 --- a/tests/testthat/test-plot-params.R +++ b/tests/testthat/test-plot-params.R @@ -111,6 +111,8 @@ test_that("i.edge_aes_table expands scalars and is sliceable by edge index", { label.family = "serif", label.font = 1, label.cex = 1, + label.halo = NA, + label.halo.width = 0.15, style = "auto", alpha = 1, gradient = FALSE, diff --git a/tests/testthat/test-plot-render.R b/tests/testthat/test-plot-render.R index b30c52f7fd7..1a2401bef0d 100644 --- a/tests/testthat/test-plot-render.R +++ b/tests/testthat/test-plot-render.R @@ -111,3 +111,20 @@ test_that("as_svg writes to a file and honours the tooltips argument", { expect_match(paste(readLines(f), collapse = ""), "p", fixed = TRUE) }) + +test_that("a label halo emits the offset copies plus the real label in SVG (F6)", { + skip_if_not_installed("xml2") + g <- make_ring(3) + V(g)$name <- c("aa", "bb", "cc") + + plain <- as_svg(g) + haloed <- as_svg(g, vertex.label.halo = "white", vertex.label.halo.width = 0.2) + + expect_s3_class(xml2::read_xml(haloed), "xml_document") + # the halo adds offset copies of every glyph, so there are strictly more + # elements than without it, and the real labels are still present. + n_plain <- length(gregexpr("aa<", fixed = TRUE) +}) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 3533ddca730..23c2d934428 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -677,3 +677,44 @@ test_that("plot rescales correctly", { } vdiffr::expect_doppelganger("rescale-coords", rescale_coords) }) + +test_that("vertex label halo draws an outline (F6)", { + skip_if_not_installed("vdiffr") + + g <- make_ring(5) + V(g)$name <- c("alpha", "beta", "gamma", "delta", "epsilon") + g$layout <- layout_in_circle(g) + + vdiffr::expect_doppelganger( + "vertex-label-halo", + function() { + plot( + g, + vertex.size = 30, + vertex.label.color = "black", + vertex.label.halo = "white", + vertex.label.halo.width = 0.25 + ) + } + ) +}) + +test_that("edge label halo draws an outline (F6)", { + skip_if_not_installed("vdiffr") + + g <- make_ring(4, directed = TRUE) + E(g)$label <- c("e1", "e2", "e3", "e4") + g$layout <- layout_in_circle(g) + + vdiffr::expect_doppelganger( + "edge-label-halo", + function() { + plot( + g, + edge.label.color = "black", + edge.label.halo = "yellow", + edge.label.cex = 1.5 + ) + } + ) +}) From 5c17e5df3f45918752b7e3d3a89a1e1108877e33 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 21:11:15 +0200 Subject: [PATCH 22/30] docs: add comprehensive plotting article Add a web-only pkgdown article (vignettes/articles/plotting.Rmd) that walks through every plotting feature at least once: layouts, vertex shapes/colour/ size/alpha, all label controls plus repel and halos, edge width/lty/arrows, curved fans and the arc/elbow/diagonal edge styles, edge alpha and gradients, palettes, scales & legends (categorical legend + colourbar + size legend), label_top() decluttering, mark.groups highlighting, annotations, custom shapes, igraph_options precedence, and as_svg() with an inline embedded SVG. Register it in the _pkgdown.yml Articles navbar, and trim the now-redundant plotting reference tables in igraph.Rmd down to a teaser that links to the new article. Co-Authored-By: Claude Opus 4.8 (1M context) --- _pkgdown.yml | 2 + vignettes/articles/plotting.Rmd | 605 ++++++++++++++++++++++++++++++++ vignettes/igraph.Rmd | 43 +-- 3 files changed, 610 insertions(+), 40 deletions(-) create mode 100644 vignettes/articles/plotting.Rmd diff --git a/_pkgdown.yml b/_pkgdown.yml index c4502f3b72b..dbdbfc14d8a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -19,6 +19,8 @@ navbar: articles: text: Articles menu: + - text: Plotting graphs + href: articles/plotting.html - text: Installation FAQs href: articles/installation-troubleshooting.html - text: ------- diff --git a/vignettes/articles/plotting.Rmd b/vignettes/articles/plotting.Rmd new file mode 100644 index 00000000000..d825a5f35df --- /dev/null +++ b/vignettes/articles/plotting.Rmd @@ -0,0 +1,605 @@ +--- +title: "Plotting graphs" +--- + +```{r include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + fig.width = 6, + fig.height = 6, + fig.align = "center", + dev = "png" +) +set.seed(42) # stable force-directed layouts across rebuilds +``` + +```{r setup} +library(igraph) +``` + +`igraph` ships a native, dependency-light plotting engine built on base R +graphics. A single call to `plot()` "just works", and every visual detail — +vertex shapes, edge routing, colours, labels, legends — is controllable through +arguments to `plot()` or through vertex/edge/graph attributes. + +This article is a complete tour of that engine: it walks through both the +long-standing features and the more recent additions (scales and legends, +label repelling and halos, richer edge styles, colour gradients and +transparency, and SVG export). Everything is shown at least once. + +```{r} +# A small attributed social network used throughout this article. +g <- make_graph( + ~ Alice - Boris:Himari:Moshe, Himari - Alice:Nang:Moshe:Samira, + Ibrahim - Nang:Moshe, Nang - Samira +) +V(g)$gender <- c("f", "m", "f", "m", "m", "f", "m") +E(g)$kind <- rep(c("friend", "colleague"), length.out = ecount(g)) +``` + +## Quick start + +The simplest possible call lays the graph out automatically and draws it: + +```{r} +plot(g) +``` + +There are two ways to control appearance: + +* **As an argument to `plot()`**, prefixed with `vertex.` / `edge.` / + (none for plot-level), e.g. `vertex.color = "tomato"`. +* **As a graph attribute**, e.g. `V(g)$color <- "tomato"`. + +Arguments to `plot()` take precedence over attributes, which in turn take +precedence over options and built-in defaults (see +[Setting defaults](#setting-defaults)). Keeping the styling in the `plot()` +call keeps the visual representation separate from the graph data: + +```{r} +plot( + g, + vertex.color = ifelse(V(g)$gender == "m", "skyblue", "pink"), + vertex.size = 30, + edge.width = ifelse(E(g)$kind == "colleague", 3, 1) +) +``` + +## Layouts + +A graph is an abstract object; to draw it we first map vertices to coordinates +with a *layout algorithm*. All layout functions start with `layout_`: + +| Method name | Algorithm description | +|--------------------|---------------------------------------------------------------| +| `layout_randomly` | Places vertices completely randomly | +| `layout_in_circle` | Deterministic; places vertices on a circle | +| `layout_on_sphere` | Deterministic; places vertices evenly on a sphere surface | +| `layout_with_drl` | DrL (Distributed Recursive Layout), for large graphs | +| `layout_with_fr` | Fruchterman–Reingold force-directed algorithm | +| `layout_with_kk` | Kamada–Kawai force-directed algorithm | +| `layout_with_lgl` | LGL (Large Graph Layout), for large graphs | +| `layout_as_tree` | Reingold–Tilford tree layout | +| `layout_nicely` | Picks a sensible algorithm automatically (the default) | + +A layout function returns a matrix with one row per vertex. You can pass either +a precomputed matrix or the function itself: + +```{r} +lay <- layout_with_kk(g) +plot(g, layout = lay, main = "Kamada-Kawai layout") +``` + +```{r} +plot(g, layout = layout_in_circle, main = "Circular layout") +``` + +By default coordinates are rescaled to fit a `[-1, 1]` square with aspect ratio +1. Disable rescaling and set the limits/aspect/margins yourself when you need +the layout's own coordinates: + +```{r} +plot( + g, + layout = lay, + rescale = FALSE, + xlim = range(lay[, 1]), + ylim = range(lay[, 2]), + asp = 1, + margin = 0.1 +) +``` + +## Vertices + +Vertex colour, size and frame are the basic knobs. `vertex.size2` sets the +second dimension for non-square shapes (e.g. rectangles). + +```{r} +plot( + g, + vertex.color = "gold", + vertex.size = 35, + vertex.frame.color = "grey30", + vertex.frame.width = 2 +) +``` + +### Transparency + +`vertex.alpha` (and `edge.alpha`, later) set opacity in `[0, 1]`, folded into +the fill colour: + +```{r} +plot(g, vertex.color = "purple", vertex.alpha = 0.4, vertex.size = 40) +``` + +### Shape gallery + +The built-in shapes are `circle`, `square`, `csquare` (centred square), +`rectangle`, `crectangle` (centred rectangle), `vrectangle` (vertical +rectangle), `none` (labels only), `pie`, `sphere`, and `raster`. Use `shapes()` +to list everything currently registered: + +```{r} +shapes() +``` + +```{r fig.width = 7, fig.height = 7} +shp <- c( + "circle", "square", "csquare", "rectangle", + "crectangle", "vrectangle", "none", "pie", "sphere", "raster" +) +ring <- make_ring(length(shp)) +plot( + ring, + vertex.shape = shp, + vertex.label = shp, + vertex.label.dist = 1.4, + vertex.size = 26, + vertex.size2 = 18, + # pie data is only used by the "pie" shape + vertex.pie = lapply(shp, function(s) if (s == "pie") c(2, 3, 1) else 0), + vertex.pie.color = list(c("tomato", "gold", "skyblue")) +) +``` + +The `pie` shape draws a small pie chart per vertex; its slices, colours, shading +angle, shading density and line type are controlled by `vertex.pie`, +`vertex.pie.color`, `vertex.pie.angle`, `vertex.pie.density` and +`vertex.pie.lty`. The `raster` shape draws an image (defaulting to the igraph +logo); supply your own with `vertex.raster`. + +### Relative sizing + +By default `vertex.size` is in absolute units. Set `vertex.size.scaling = TRUE` +to size vertices relative to the plot region, controlled by `relative.size`: + +```{r} +plot( + make_star(8), + vertex.size.scaling = TRUE, + vertex.relative.size = c(0.02, 0.06) +) +``` + +## Vertex labels + +Labels default to vertex names (or IDs). They are positioned at a distance +`label.dist` from the vertex, in the direction `label.degree` (an angle in +radians), and styled with the usual font controls. `label.angle` rotates the +text and `label.adj` fine-tunes its anchor. + +```{r} +plot( + g, + vertex.size = 30, + vertex.label.color = "black", + vertex.label.family = "sans", + vertex.label.font = 2, # bold + vertex.label.cex = 1.1, + vertex.label.dist = 2.2, + vertex.label.degree = -pi / 2 # place labels above the vertices +) +``` + +`vertex.label.angle` rotates the label text (in degrees) and `vertex.label.adj` +adjusts its anchor, exactly like `srt` and `adj` in `graphics::text()`: + +```{r} +plot( + g, + vertex.size = 36, + vertex.label.angle = 30, + vertex.label.adj = c(0.5, 0.5) +) +``` + +### Avoiding overlaps with `label.repel` + +On dense graphs labels collide. Set `vertex.label.repel = TRUE` to iteratively +nudge overlapping labels apart, drawing a thin leader line from each moved label +back to its vertex: + +```{r} +gr <- make_ring(12) +V(gr)$name <- paste0("node-", seq_len(vcount(gr))) +plot(gr, layout = layout_in_circle, vertex.size = 8, vertex.label.repel = TRUE) +``` + +### Legibility with `label.halo` + +`vertex.label.halo` draws a halo (outline) behind the label text so it stays +readable over edges and other vertices. `vertex.label.halo.width` controls the +outline thickness as a fraction of the label height. The default `NA` draws no +halo. + +```{r} +plot( + g, + vertex.size = 30, + vertex.color = "steelblue", + vertex.label.color = "white", + vertex.label.halo = "black", + vertex.label.halo.width = 0.3 +) +``` + +## Edges + +Edges are styled with colour, width and line type, and (for directed graphs) +arrowheads. `edge.arrow.mode` chooses the arrow direction (`0` none, `1` +backward, `2` forward, `3` both, or the symbolic `"<"`, `">"`, `"<>"`); it also +accepts `"a:attr"` to read the mode from a vertex attribute. + +```{r} +dg <- make_graph(~ A -+ B, B -+ C, C -+ A, A -+ D) +plot( + dg, + edge.color = "grey40", + edge.width = 2, + edge.lty = "dashed", + edge.arrow.size = 0.8, + edge.arrow.width = 1.2 +) +``` + +### Curved edges and multi-edge fans + +`edge.curved` bends edges: `TRUE` means curvature 0.5, numeric values set the +amount (negative bends the other way). For graphs with parallel edges, +`curve_multiple()` fans them apart so they don't overlap: + +```{r} +multi <- graph_from_edgelist( + matrix(c(1, 2, 1, 2, 1, 2, 2, 3), ncol = 2, byrow = TRUE) +) +plot(multi, edge.curved = curve_multiple(multi), edge.arrow.size = 0.6) +``` + +### Edge styles + +The `edge.style` argument selects an edge-routing style: + +* `"auto"` (default) — straight, or an arc when `edge.curved` is non-zero +* `"straight"` — always straight +* `"arc"` — a curved arc whose height comes from `edge.curved` +* `"elbow"` — a two-corner orthogonal (right-angle) connector +* `"diagonal"` — a smooth S-curve with axis-aligned ends + +The orthogonal and diagonal styles are well suited to tree- and grid-like +layouts: + +```{r fig.width = 7, fig.height = 3.2} +tree <- make_tree(7, children = 2) +op <- par(mfrow = c(1, 3), mar = c(1, 1, 2, 1)) +plot(tree, layout = layout_as_tree, edge.style = "arc", main = "arc") +plot(tree, layout = layout_as_tree, edge.style = "elbow", main = "elbow") +plot(tree, layout = layout_as_tree, edge.style = "diagonal", main = "diagonal") +par(op) +``` + +### Transparency and colour gradients + +`edge.alpha` sets edge opacity. `edge.gradient = TRUE` colours each edge with a +gradient running from the source vertex's colour to the target's — a way to show +direction without arrowheads: + +```{r} +ring_d <- make_ring(8, directed = TRUE) +V(ring_d)$color <- rainbow(vcount(ring_d)) +plot( + ring_d, + layout = layout_in_circle, + vertex.size = 18, + edge.gradient = TRUE, + edge.width = 4, + edge.arrow.mode = 0 +) +``` + +```{r} +plot(dg, edge.color = "navy", edge.alpha = 0.3, edge.width = 6) +``` + +### Self-loops + +Loops are drawn as small arcs. `edge.loop.angle` sets the direction of a loop +(in radians) and the plot-level `loop.size` scales them: + +```{r} +loops <- make_graph(~ A -+ A, A -+ B, B -+ B) +plot(loops, edge.loop.angle = pi / 4, loop.size = 1.2, edge.arrow.size = 0.6) +``` + +## Edge labels + +Edge labels are added with `edge.label` and styled with the matching +`edge.label.*` controls, including a halo (`edge.label.halo`) just like vertex +labels. `edge.label.x` / `edge.label.y` override the automatic placement. + +```{r} +plot( + dg, + edge.label = c("a", "b", "c", "d"), + edge.label.color = "black", + edge.label.cex = 1.2, + edge.label.family = "sans", + edge.label.halo = "yellow", + edge.label.halo.width = 0.4, + edge.arrow.size = 0.6 +) +``` + +## Colours and palettes + +igraph provides perceptually sensible palettes: +`categorical_pal()` for unordered categories, `sequential_pal()` for ordered +magnitudes, `diverging_pal()` for signed data, and `r_pal()` for R's classic +palette. + +```{r fig.width = 8, fig.height = 2.4} +op <- par(mfrow = c(1, 4), mar = c(0, 1, 2, 1)) +pie(rep(1, 8), col = categorical_pal(8), main = "categorical_pal(8)") +pie(rep(1, 9), col = sequential_pal(9), main = "sequential_pal(9)") +pie(rep(1, 9), col = diverging_pal(9), main = "diverging_pal(9)") +pie(rep(1, 8), col = r_pal(8), main = "r_pal(8)") +par(op) +``` + +When a vertex/edge colour is given as a factor or integer, it indexes into the +active `palette`: + +```{r} +plot( + g, + vertex.color = as.factor(V(g)$gender), + palette = categorical_pal(8), + vertex.size = 30 +) +``` + +## Scales and legends + +Passing a raw colour vector means igraph never learns what the colours *mean*, +so it cannot explain them. The `scale_*()` helpers fix this: they map a data +column to an aesthetic **and record the mapping**, so `plot()` can draw a +matching guide automatically. + +`scale_color()` on a discrete variable produces a categorical legend: + +```{r} +plot( + g, + vertex.color = scale_color(V(g)$gender, name = "Gender"), + vertex.size = 30 +) +``` + +On a numeric variable it produces a continuous **colourbar**: + +```{r} +plot( + g, + vertex.color = scale_color(degree(g), name = "Degree"), + vertex.size = 30 +) +``` + +`scale_size()` maps a numeric variable to a size range and draws a size legend: + +```{r} +plot( + g, + vertex.size = scale_size(degree(g), range = c(10, 35), name = "Degree"), + vertex.color = "lightgrey" +) +``` + +The `legend` argument controls placement: `TRUE` (default, right side), +`"left"`, `"top"`, `"bottom"`, or `FALSE` to suppress the guide. Multiple scales +combine into one guide region: + +```{r} +plot( + g, + vertex.color = scale_color(V(g)$gender, name = "Gender"), + vertex.size = scale_size(degree(g), range = c(12, 34), name = "Degree"), + legend = "bottom" +) +``` + +## Decluttering with `label_top()` + +On large graphs, labelling every vertex is unreadable. `label_top()` keeps only +the highest-ranking labels by some metric and blanks the rest with `NA` (which +`plot()` omits): + +```{r} +big <- sample_gnp(40, 0.08) +plot( + big, + vertex.size = 6, + vertex.label = label_top(degree(big), n = 5), + vertex.label.dist = 1, + vertex.label.color = "black" +) +``` + +Use `prop` to keep a fraction instead of a count, and `decreasing = FALSE` to +keep the lowest: + +```{r} +plot( + big, + vertex.size = 6, + vertex.label = label_top(degree(big), prop = 0.1, decreasing = FALSE), + vertex.label.dist = 1, + vertex.label.color = "black" +) +``` + +To label everything above a fixed cutoff you don't need the helper — +`ifelse(metric > cutoff, labels, NA)` works directly. + +## Highlighting groups + +`mark.groups` draws a smoothed, filled polygon "under" a set of vertices. The +fill, border, smoothness, padding and border width are set by `mark.col`, +`mark.border`, `mark.shape`, `mark.expand` and `mark.lwd`: + +```{r} +plot( + g, + vertex.size = 25, + mark.groups = list(c("Alice", "Himari", "Moshe"), c("Nang", "Samira")), + mark.col = c("#ffd9d9", "#d9ecff"), + mark.border = c("tomato", "steelblue"), + mark.shape = 1 / 2, + mark.expand = 20, + mark.lwd = 2 +) +``` + +## Annotations and frame + +Plot-level titles and axes follow base graphics conventions: `main`, `sub`, +`xlab`, `ylab`, `axes` and `frame.plot`. + +```{r} +plot( + g, + vertex.size = 25, + main = "Friendship network", + sub = "an igraph example", + xlab = "x", + ylab = "y", + axes = TRUE, + frame.plot = TRUE +) +``` + +## Custom vertex shapes + +You can register your own shape with `add_shape()`. A shape is defined by a +*clip* function (where edges stop) and a *plot* function (how the vertex is +drawn); `shape_noclip` and `shape_noplot` are no-op building blocks, and +`shapes("circle")$clip` reuses an existing clipper. + +```{r} +mytriangle <- function(coords, v = NULL, params) { + vertex.color <- params("vertex", "color") + if (length(vertex.color) != 1 && !is.null(v)) { + vertex.color <- vertex.color[v] + } + vertex.size <- params("vertex", "size") + if (length(vertex.size) != 1 && !is.null(v)) { + vertex.size <- vertex.size[v] + } + symbols( + x = coords[, 1], y = coords[, 2], bg = vertex.color, + stars = cbind(vertex.size, vertex.size, vertex.size), + add = TRUE, inches = FALSE + ) +} + +add_shape("triangle", clip = shapes("circle")$clip, plot = mytriangle) + +plot( + g, + vertex.shape = "triangle", + vertex.color = "seagreen", + vertex.size = 40 +) +``` + +`shape_noclip` (edges run all the way to the centre) and `shape_noplot` (draw +nothing) are the no-op building blocks; registering a shape from them gives an +"invisible" vertex that still carries a label: + +```{r} +add_shape("blank", clip = shape_noclip, plot = shape_noplot) +plot(g, vertex.shape = "blank", vertex.label.dist = 0) +``` + +## Setting defaults {#setting-defaults} + +`igraph_options()` sets defaults for every subsequent plot, and `igraph_opt()` +reads one back. Plotting options use the same `vertex.` / `edge.` prefixes: + +```{r} +old <- igraph_options( + vertex.color = "orange", + vertex.size = 30, + edge.color = "grey70" +) +plot(g) +igraph_opt("vertex.color") # read one option back +igraph_options(old) # restore +``` + +The full precedence order, from highest to lowest, is: + +1. an explicit argument to `plot()`, +2. a vertex/edge/graph attribute, +3. an `igraph_options()` setting, +4. the built-in default. + +Setting `igraph_options(annotate.plot = TRUE)` makes `plot()` annotate the +figure with the graph's name and its vertex/edge counts by default. + +## SVG export with tooltips + +`as_svg()` renders a graph to a standalone SVG. Beyond crisp vector output, it +tags each vertex and edge with element IDs and a ``, so the SVG has +hover tooltips with **no JavaScript dependency**. The `tooltips` argument picks +which vertex attribute to use for the titles (defaulting to the vertex name). + +```{r} +svg <- as_svg(g, width = 6, height = 6, tooltips = "gender") +# write to a file ... +tmp <- tempfile(fileext = ".svg") +cat(svg, file = tmp) +substr(svg, 1, 60) +``` + +Each vertex becomes `<g id="vertex-N"><title>......` and each edge a +matching group, so downstream tools (or a browser) can offer hover and click +interactions. Embedded directly into this page, hovering a vertex shows its +tooltip: + +```{r results = "asis", echo = TRUE} +cat(as_svg(g, width = 6, height = 6, tooltips = "gender", vertex.size = 30)) +``` + +## Where to go next + +* The per-function reference: , in particular + `?plot.igraph` and `?igraph.plotting` for the full list of parameters. +* The main [igraph](igraph.html) introduction for graph construction and + analysis. + +```{r} +sessionInfo() +``` diff --git a/vignettes/igraph.Rmd b/vignettes/igraph.Rmd index 6682bc6b3fc..b32a7486f3e 100644 --- a/vignettes/igraph.Rmd +++ b/vignettes/igraph.Rmd @@ -576,46 +576,9 @@ plot(g, This latter approach is preferred if you want to keep the properties of the visual representation of your graph separate from the graph itself. -In summary, there are special vertex and edge properties that correspond to the visual representation of the graph. These attributes override the default settings of igraph (i.e color, weight, name, shape, layout, etc.). The following two tables summarise the most frequently used visual attributes for vertices and edges, respectively: - -### Vertex attributes controlling graph plots - -| Attribute name | Keyword argument | Purpose | -|----------------------|----------------------|-----------------------------| -| `color` | `vertex.color` | Color of the vertex | -| `label` | `vertex.label` | Label of the vertex. They will be converted to character. Specify NA to omit vertex labels. The default vertex labels are the vertex ids. | -| `label.cex` | `vertex.label.cex` | Font size of the vertex label, interpreted as a multiplicative factor, similarly to R's `text` function | -| `label.color` | `vertex.label.color` | Color of the vertex label | -| `label.degree` | `vertex.label.degree` | It defines the position of the vertex labels, relative to the center of the vertices. It is interpreted as an angle in radian, zero means 'to the right', and 'pi' means to the left, up is -pi/2 and down is pi/2. The default value is -pi/4 | -| `label.dist` | `vertex.label.dist` | Distance of the vertex label from the vertex itself, relative to the vertex size | -| `label.family` | `vertex.label.family` | Font family of the vertex, similarly to R's `text` function | -| `label.font` | `vertex.label.font` | Font within the font family of the vertex, similarly to R's `text` function | -| `shape` | `vertex.shape` | The shape of the vertex, currently "circle", "square", "csquare", "rectangle", "crectangle", "vrectangle", "pie" (see vertex.shape.pie), 'sphere', and "none" are supported, and only by the plot.igraph command. | -| `size` | `vertex.size` | The size of the vertex, a numeric scalar or vector, in the latter case each vertex sizes may differ | - -### Edge attributes controlling graph plots - -| Attribute name | Keyword argument | Purpose | -|-------------------------|-----------------------------|------------------| -| `color` | `edge.color` | Color of the edge | -| `curved` | `edge.curved` | A numeric value specifies the curvature of the edge; zero curvature means straight edges, negative values means the edge bends clockwise, positive values the opposite. TRUE means curvature 0.5, FALSE means curvature zero | -| `arrow.size` | `edge.arrow.size` | 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, that is to say if this is taken from an edge attribute then only the attribute of the first edge is used for all arrows. | -| `arrow.width` | `edge.arrow.width` | The width of the arrows. Currently this is a constant, so it is the same for every edge | -| `width` | `edge.width` | Width of the edge in pixels | -| `label` | `edge.label` | If specified, it adds a label to the edge. | -| `label.cex` | `edge.label.cex` | Font size of the edge label, interpreted as a multiplicative factor, similarly to R's `text` function | -| `label.color` | `edge.label.color` | Color of the edge label | -| `label.family` | `edge.label.family` | Font family of the edge, similarly to R's `text` function | -| `label.font` | `edge.label.font` | Font within the font family of the edge, similarly to R's `text` function | - -### Generic arguments of `plot()` - -These settings can be specified as arguments to the `plot` function to control the overall appearance of the plot. - -| Keyword argument | Purpose | -|--------------------------------|----------------------------------------| -| `layout` | The layout to be used. It can be an instance of `Layout`, a list of tuples containing X-Y coordinates, or the name of a layout algorithm. The default is `auto`, which selects a layout algorithm automatically based on the size and connectedness of the graph. | -| `margin` | The amount of empty space below, over, at the left and right of the plot, it is a numeric vector of length four. | +In summary, there are special vertex and edge properties that correspond to the visual representation of the graph. These attributes override the default settings of igraph (i.e color, weight, name, shape, layout, etc.). + +igraph's plotting engine is far richer than this short overview: vertex shapes, colour scales with automatic legends, edge styles and gradients, label repelling and halos, group highlighting, custom shapes and SVG export are all supported. For a complete, runnable tour of every plotting feature, see the [**Plotting graphs**](plotting.html) article. ## igraph and the outside world From 5392c72ca7bd5e06a405f99f2ecb083dd780b9a1 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 21:29:41 +0200 Subject: [PATCH 23/30] fix: named vertex aesthetics no longer break edge label placement MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A named per-vertex numeric aesthetic — e.g. vertex.size = scale_size(degree(g)), since degree() returns a named vector — propagated its names through edge clipping into i.edge_label_pos(). There, c(x = , y = ) produced names like "x.Alice" instead of "x"/"y", so the downstream lab[["x"]] / lab[["y"]] lookups failed with "subscript out of bounds". unname() the components in i.edge_label_pos() so the result is always named x/y regardless of the inputs. Add regression tests covering a named scale, a named raw size vector, and i.edge_label_pos() directly. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot.R | 9 ++++++++- tests/testthat/test-plot-scales.R | 28 ++++++++++++++++++++++++++++ 2 files changed, 36 insertions(+), 1 deletion(-) diff --git a/R/plot.R b/R/plot.R index d2ca782198b..8af32d3f914 100644 --- a/R/plot.R +++ b/R/plot.R @@ -2114,7 +2114,14 @@ i.arrow_shaft_endpoints <- function(x1, y1, x2, y2, code, r.seg, uin) { i.edge_label_pos <- function(x1, y1, x2, y2) { phi <- atan2(y1 - y2, x1 - x2) r <- sqrt((x1 - x2)^2 + (y1 - y2)^2) - c(x = x2 + 2 / 3 * r * cos(phi), y = y2 + 2 / 3 * r * sin(phi)) + # unname() the components: when the coordinates carry names (e.g. a named + # vertex.size such as scale_size(degree(g)) propagates names through edge + # clipping), `c(x = , y = )` would yield names like "x.Alice" + # instead of "x"/"y", breaking the lab[["x"]] / lab[["y"]] lookups downstream. + c( + x = unname(x2 + 2 / 3 * r * cos(phi)), + y = unname(y2 + 2 / 3 * r * sin(phi)) + ) } # Geometry (Stage 2): the X-spline of a curved edge. The control point is offset diff --git a/tests/testthat/test-plot-scales.R b/tests/testthat/test-plot-scales.R index 94d6b644167..e422ac5b042 100644 --- a/tests/testthat/test-plot-scales.R +++ b/tests/testthat/test-plot-scales.R @@ -91,3 +91,31 @@ test_that("a wrong-length scale is rejected by strict recycling at plot time", { "length 3" ) }) + +test_that("named per-vertex aesthetics don't break edge drawing (#regression)", { + # A named vertex.size (e.g. scale_size(degree(g)) carries degree()'s names) + # used to propagate names into the clipped edge coordinates, where + # i.edge_label_pos()'s c(x = ..., y = ...) produced names like "x.Alice" + # instead of "x"/"y", crashing with "subscript out of bounds". + g <- make_graph(~ A - B, B - C, C - A, A - D) + grDevices::pdf(NULL) + withr::defer(grDevices::dev.off()) + + expect_silent(plot(g, vertex.size = scale_size(degree(g), range = c(10, 30)))) + expect_silent(plot( + g, + vertex.size = stats::setNames(c(10, 20, 30, 15), V(g)$name) + )) +}) + +test_that("i.edge_label_pos returns x/y names even for named inputs", { + pos <- i.edge_label_pos( + stats::setNames(0, "a"), + stats::setNames(0, "a"), + stats::setNames(1, "b"), + stats::setNames(1, "b") + ) + expect_named(pos, c("x", "y")) + expect_equal(pos[["x"]], 1 / 3) + expect_equal(pos[["y"]], 1 / 3) +}) From 619a3abcbd5505c4bcd04d4ac65941db15554523 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 21:29:50 +0200 Subject: [PATCH 24/30] docs: fix broken examples in the plotting article Two examples produced empty/partial figures: - Self-loops: make_graph(~ A -+ A, ...) silently drops self-loops, so only the A->B edge rendered. Build the edge list explicitly with make_graph(c("A","A","A","B","B","B"), directed = TRUE) and add a fixed layout/margin so both loops are clearly visible. - Custom triangle shape: with a uniform shape, plot.igraph() calls the shape plot function once for all vertices (v = NULL), so a scalar vertex.size mismatched the coordinate matrix. Recycle the size with rep(..., length.out = nrow(coords)), as the built-in shapes do. Co-Authored-By: Claude Opus 4.8 (1M context) --- vignettes/articles/plotting.Rmd | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/vignettes/articles/plotting.Rmd b/vignettes/articles/plotting.Rmd index d825a5f35df..02e03479b19 100644 --- a/vignettes/articles/plotting.Rmd +++ b/vignettes/articles/plotting.Rmd @@ -328,9 +328,18 @@ plot(dg, edge.color = "navy", edge.alpha = 0.3, edge.width = 6) Loops are drawn as small arcs. `edge.loop.angle` sets the direction of a loop (in radians) and the plot-level `loop.size` scales them: -```{r} -loops <- make_graph(~ A -+ A, A -+ B, B -+ B) -plot(loops, edge.loop.angle = pi / 4, loop.size = 1.2, edge.arrow.size = 0.6) +```{r fig.width = 6, fig.height = 4} +# the formula interface drops self-loops, so build the edge list directly +loops <- make_graph(c("A", "A", "A", "B", "B", "B"), directed = TRUE) +plot( + loops, + layout = matrix(c(-0.5, 0.5, 0, 0), ncol = 2), + vertex.size = 36, + edge.loop.angle = pi / 2, + loop.size = 1.5, + edge.arrow.size = 0.6, + margin = 0.25 +) ``` ## Edge labels @@ -517,6 +526,9 @@ mytriangle <- function(coords, v = NULL, params) { if (length(vertex.size) != 1 && !is.null(v)) { vertex.size <- vertex.size[v] } + # When all vertices share a shape, the plot function is called once for the + # whole layout (with v = NULL), so recycle scalars to one value per row. + vertex.size <- rep(vertex.size, length.out = nrow(coords)) symbols( x = coords[, 1], y = coords[, 2], bg = vertex.color, stars = cbind(vertex.size, vertex.size, vertex.size), From 6e3aa025dc2602249393871e0c59a58612e1964b Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 21:47:07 +0200 Subject: [PATCH 25/30] docs: improve plotting article label-repel and self-loop examples - Use a denser make_full_graph(25) with larger labels for the vertex.label.repel example so the de-overlapping is clearly visible. - Add an example of several self-loops on a single vertex, which igraph arranges in a flower-petal pattern. - Drop the trailing sessionInfo() chunk. Co-Authored-By: Claude Opus 4.8 (1M context) --- vignettes/articles/plotting.Rmd | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/vignettes/articles/plotting.Rmd b/vignettes/articles/plotting.Rmd index 02e03479b19..8518b19ec0e 100644 --- a/vignettes/articles/plotting.Rmd +++ b/vignettes/articles/plotting.Rmd @@ -223,9 +223,9 @@ nudge overlapping labels apart, drawing a thin leader line from each moved label back to its vertex: ```{r} -gr <- make_ring(12) +gr <- make_full_graph(25) V(gr)$name <- paste0("node-", seq_len(vcount(gr))) -plot(gr, layout = layout_in_circle, vertex.size = 8, vertex.label.repel = TRUE) +plot(gr, vertex.size = 25, vertex.label.cex = 2, vertex.label.repel = TRUE) ``` ### Legibility with `label.halo` @@ -342,6 +342,15 @@ plot( ) ``` +When a single vertex carries *several* loops, igraph spreads them around the +vertex in a "flower-petal" arrangement so they don't overlap: + +```{r fig.width = 5, fig.height = 5} +# six self-loops on a single vertex +many <- make_graph(rep(1, 12), n = 1, directed = TRUE) +plot(many, vertex.size = 30, edge.arrow.size = 0.5, margin = 0.2) +``` + ## Edge labels Edge labels are added with `edge.label` and styled with the matching @@ -611,7 +620,3 @@ cat(as_svg(g, width = 6, height = 6, tooltips = "gender", vertex.size = 30)) `?plot.igraph` and `?igraph.plotting` for the full list of parameters. * The main [igraph](igraph.html) introduction for graph construction and analysis. - -```{r} -sessionInfo() -``` From 6a873f1e94d7f699db9ad5d8b4dccd04861d64b0 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 21:57:25 +0200 Subject: [PATCH 26/30] chore(plot): drop plan/phase references from code comments Remove the development-scaffolding tags from comments and test labels (feature F1-F6, B-numbers, "phase N", and the pipeline "Stage N" labels), keeping the descriptive prose. These referred to the planning notes and add no value in the shipped code. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-aes.R | 4 ++-- R/plot-labels.R | 4 ++-- R/plot-render.R | 4 ++-- R/plot-scales.R | 4 ++-- R/plot.R | 22 +++++++++++----------- tests/testthat/test-plot-labels.R | 4 ++-- tests/testthat/test-plot-params.R | 2 +- tests/testthat/test-plot-render.R | 6 +++--- tests/testthat/test-plot-scales.R | 4 ++-- tests/testthat/test-plot.R | 8 ++++---- 10 files changed, 31 insertions(+), 31 deletions(-) diff --git a/R/plot-aes.R b/R/plot-aes.R index da200832c0b..799c28f9444 100644 --- a/R/plot-aes.R +++ b/R/plot-aes.R @@ -7,8 +7,8 @@ # (at your option) any later version. ################################################################### -# Stage 1 of the plotting pipeline: turn resolved plotting parameters into a -# typed, rectangular aesthetic table so that downstream code can slice it by +# Turn resolved plotting parameters into a typed, rectangular aesthetic table +# so that downstream code can slice it by # vertex/edge index instead of re-implementing the # `if (length(x) > 1) x[idx]` idiom for every parameter. # diff --git a/R/plot-labels.R b/R/plot-labels.R index 20a22150f65..3869ecdc256 100644 --- a/R/plot-labels.R +++ b/R/plot-labels.R @@ -7,8 +7,8 @@ # (at your option) any later version. ################################################################### -# Label decluttering (feature F6): a helper that keeps only the most prominent -# labels and blanks the rest with NA. Because plot.igraph() omits NA labels, +# Label decluttering: a helper that keeps only the most prominent labels and +# blanks the rest with NA. Because plot.igraph() omits NA labels, # the result can be passed straight to a label argument, e.g. # plot(g, vertex.label = label_top(degree(g), n = 10)). diff --git a/R/plot-render.R b/R/plot-render.R index b24d7d4ff0d..6f7199e0b17 100644 --- a/R/plot-render.R +++ b/R/plot-render.R @@ -7,7 +7,7 @@ # (at your option) any later version. ################################################################### -# Stage-3 rendering indirection (feature F5). +# Rendering indirection. # # Drawing code emits primitives through the i.r_*() dispatchers instead of # calling base graphics directly. The dispatchers forward to the "current" @@ -155,7 +155,7 @@ i.r_group_begin <- function(...) i.cur_renderer()$group_begin(...) i.r_group_end <- function(...) i.cur_renderer()$group_end(...) ################################################################### -# Recording renderer + SVG writer (feature F5, phase 2) +# Recording renderer + SVG writer ################################################################### # Canonicalise a colour vector to "#RRGGBBAA" hex (resolving palette indices and diff --git a/R/plot-scales.R b/R/plot-scales.R index 6ace752022e..3808d7860a6 100644 --- a/R/plot-scales.R +++ b/R/plot-scales.R @@ -7,8 +7,8 @@ # (at your option) any later version. ################################################################### -# Scales (feature F1): map a data vector to a plotting aesthetic (colour or -# size) AND record a "guide" describing the mapping, so that plot.igraph() can +# Scales: map a data vector to a plotting aesthetic (colour or size) AND record +# a "guide" describing the mapping, so that plot.igraph() can # draw a matching legend or colorbar. A scale is passed to an existing argument, # e.g. plot(g, vertex.color = scale_color(V(g)$type)). diff --git a/R/plot.R b/R/plot.R index 8af32d3f914..86143f460e8 100644 --- a/R/plot.R +++ b/R/plot.R @@ -195,7 +195,7 @@ i.draw.loop <- function( } } -# Initialize the plotting canvas (Stage 4 device setup): an empty plot region +# Initialize the plotting canvas: an empty plot region # with the requested limits, axes, aspect ratio and titles. Isolated from the # drawing orchestration in plot.igraph() so the latter reads as # setup -> edges -> vertices -> labels. @@ -223,7 +223,7 @@ i.init_plot_canvas <- function( ) } -# Distribute self-loops around each vertex (Stage 2 geometry). For a vertex with +# Distribute self-loops around each vertex. For a vertex with # k loops, place them evenly inside the largest angular gap between its incident # (non-loop) edges, and compute a narrowing factor that compresses the loops # when that gap is tight. Returns per-loop `angles` and `narrowing` vectors @@ -339,7 +339,7 @@ i.repel_labels <- function(x, y, hw, hh, iter = 200, spring = 0.04) { list(x = px, y = py) } -# Draw vertex labels (Stage 4), offset from each vertex by label.dist along +# Draw vertex labels, offset from each vertex by label.dist along # label.degree. xpd = TRUE is scoped to this call so labels may spill outside # the plot region. With `repel = TRUE`, overlapping labels are nudged apart and # a leader line connects each moved label to its anchor. No-op for an empty @@ -442,7 +442,7 @@ i.draw_vertex_labels <- function( )) } -# Draw one label with an optional shadowtext halo for legibility (Stage 4). +# Draw one label with an optional shadowtext halo for legibility. # `halo = NA` (the default) is exactly `i.r_text()` -> byte-identical to before. # Otherwise the glyphs are drawn `halo.steps` times offset on a circle of radius # (halo.width * strheight) in the `halo` colour, then the real text on top, which @@ -923,7 +923,7 @@ plot.igraph <- function( x1 <- ec[, 3] y1 <- ec[, 4] - # Stage 1: resolve the per-edge aesthetics into one table (length ecount), + # Resolve the per-edge aesthetics into one table (length ecount), # then slice it by loop-edge / non-loop-edge index instead of repeating the # `if (length(x) > 1) x[idx]` idiom for every parameter. edge_aes <- i.edge_aes_table( @@ -2073,7 +2073,7 @@ rglplot.igraph <- function(x, ...) { # This is taken from the IDPmisc package, # slightly modified: code argument added -# Pure geometry (Stage 2): the outline of an arrowhead in polar coordinates +# Pure geometry: the outline of an arrowhead in polar coordinates # (angle + radius from the tip), used by igraph.Arrows() to draw or outline the # head. Depends only on scalar inputs, so it is testable without a device. # cin arrow length, already scaled by the character size (par("cin")) @@ -2090,7 +2090,7 @@ i.arrowhead_shape <- function(cin, w, delta) { ) } -# Pure geometry (Stage 2): shaft segment endpoints for a single edge, pulled +# Pure geometry: shaft segment endpoints for a single edge, pulled # back from the vertices by `r.seg` at whichever end carries an arrowhead (per # `code`) so the shaft does not poke through the head. `uin` is the # inches-per-user-unit scale from 1/xyinch(). Returns sx1/sy1/sx2/sy2. @@ -2109,7 +2109,7 @@ i.arrow_shaft_endpoints <- function(x1, y1, x2, y2, code, r.seg, uin) { list(sx1 = x1 + x1d, sy1 = y1 + y1d, sx2 = x2 + x2d, sy2 = y2 + y2d) } -# Pure geometry (Stage 2): label anchor two thirds of the way along a straight +# Pure geometry: label anchor two thirds of the way along a straight # edge from (x2, y2) toward (x1, y1). i.edge_label_pos <- function(x1, y1, x2, y2) { phi <- atan2(y1 - y2, x1 - x2) @@ -2124,7 +2124,7 @@ i.edge_label_pos <- function(x1, y1, x2, y2) { ) } -# Geometry (Stage 2): the X-spline of a curved edge. The control point is offset +# Geometry: the X-spline of a curved edge. The control point is offset # from the edge midpoint perpendicular to the shaft by `lambda`. Returns the # xspline() coordinate list (draw = FALSE; needs an active device). i.curved_spline <- function(x1, y1, x2, y2, sx1, sy1, sx2, sy2, lambda) { @@ -2140,7 +2140,7 @@ i.curved_spline <- function(x1, y1, x2, y2, sx1, sy1, sx2, sy2, lambda) { ) } -# Geometry (Stage 2): two-corner orthogonal ("elbow") path between two points. +# Geometry: two-corner orthogonal ("elbow") path between two points. # Leaves along the dominant axis (larger absolute delta), turns at the midpoint # of that axis, crosses, then turns into the target. Returns list(x, y) of the # four polyline vertices. @@ -2154,7 +2154,7 @@ i.elbow_path <- function(x0, y0, x1, y1) { } } -# Geometry (Stage 2): smooth "diagonal" S-curve between two points, a cubic +# Geometry: smooth "diagonal" S-curve between two points, a cubic # Bezier whose control points sit on the dominant axis so the curve leaves and # enters along that axis. Returns list(x, y) sampled at `n` points. i.diagonal_path <- function(x0, y0, x1, y1, n = 30) { diff --git a/tests/testthat/test-plot-labels.R b/tests/testthat/test-plot-labels.R index 051d447c537..aa3707d1e4e 100644 --- a/tests/testthat/test-plot-labels.R +++ b/tests/testthat/test-plot-labels.R @@ -1,5 +1,5 @@ -# Label decluttering helper (F6): label_top() keeps the highest-ranked labels -# and blanks the rest with NA so plot.igraph() omits them. +# Label decluttering helper: label_top() keeps the highest-ranked labels and +# blanks the rest with NA so plot.igraph() omits them. test_that("label_top keeps exactly n labels, the highest by `by`", { by <- c(5, 1, 9, 3, 7) diff --git a/tests/testthat/test-plot-params.R b/tests/testthat/test-plot-params.R index 115404700bd..a9551d206c1 100644 --- a/tests/testthat/test-plot-params.R +++ b/tests/testthat/test-plot-params.R @@ -87,7 +87,7 @@ test_that("i.parse.plot.params() silently replaces NA labels with empty string", }) # --------------------------------------------------------------------------- -# Stage 1 aesthetic tables (i.aes_table / i.edge_aes_table) +# Aesthetic tables (i.aes_table / i.edge_aes_table) # --------------------------------------------------------------------------- test_that("i.aes_table recycles columns to n rows", { diff --git a/tests/testthat/test-plot-render.R b/tests/testthat/test-plot-render.R index 1a2401bef0d..93a8c91c290 100644 --- a/tests/testthat/test-plot-render.R +++ b/tests/testthat/test-plot-render.R @@ -1,5 +1,5 @@ -# Stage-3 rendering indirection (F5, phase 1): drawing is emitted through the -# i.r_*() dispatchers, which forward to the current renderer. +# Rendering indirection: drawing is emitted through the i.r_*() dispatchers, +# which forward to the current renderer. test_that("the default renderer is the base renderer", { r <- i.cur_renderer() @@ -112,7 +112,7 @@ test_that("as_svg writes to a file and honours the tooltips argument", { expect_match(out, "p", fixed = TRUE) }) -test_that("a label halo emits the offset copies plus the real label in SVG (F6)", { +test_that("a label halo emits the offset copies plus the real label in SVG", { skip_if_not_installed("xml2") g <- make_ring(3) V(g)$name <- c("aa", "bb", "cc") diff --git a/tests/testthat/test-plot-scales.R b/tests/testthat/test-plot-scales.R index e422ac5b042..baabf21f63b 100644 --- a/tests/testthat/test-plot-scales.R +++ b/tests/testthat/test-plot-scales.R @@ -1,5 +1,5 @@ -# Unit tests for the scale layer (feature F1): scale_color() / scale_size() -# and the internal i.apply_scales() that feeds plot.igraph(). +# Unit tests for the scale layer: scale_color() / scale_size() and the internal +# i.apply_scales() that feeds plot.igraph(). test_that("scale_color() maps a discrete vector to categorical colours", { s <- scale_color(c("a", "b", "a", "c")) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 23c2d934428..6bfb8bda80b 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -316,7 +316,7 @@ test_that("i.diagonal_path is a smooth path between the endpoints", { }) test_that("i.arrowhead_shape returns matched polar arrays ending in NA", { - # Pure geometry helper extracted from igraph.Arrows (Stage 2); device-free. + # Pure geometry helper extracted from igraph.Arrows; device-free. head <- i.arrowhead_shape(cin = 0.2, w = 1.5, delta = 0.01) expect_named(head, c("deg.arr", "r.arr")) expect_equal(length(head$deg.arr), length(head$r.arr)) @@ -535,7 +535,7 @@ test_that("edge.style routes edges (elbow / diagonal / mixed / arc)", { }) test_that("mixed arrow modes with per-edge curved/size and loops render correctly", { - # Regression guard for B2: the per-arrow-code branch used to double-slice + # Regression guard: the per-arrow-code branch used to double-slice # `curved` and ignored per-edge arrow.size/width. Exercise that path with a # graph that has loops, non-loop edges, mixed arrow modes, and per-edge # curved + arrow.size vectors. @@ -678,7 +678,7 @@ test_that("plot rescales correctly", { vdiffr::expect_doppelganger("rescale-coords", rescale_coords) }) -test_that("vertex label halo draws an outline (F6)", { +test_that("vertex label halo draws an outline", { skip_if_not_installed("vdiffr") g <- make_ring(5) @@ -699,7 +699,7 @@ test_that("vertex label halo draws an outline (F6)", { ) }) -test_that("edge label halo draws an outline (F6)", { +test_that("edge label halo draws an outline", { skip_if_not_installed("vdiffr") g <- make_ring(4, directed = TRUE) From b069ab2c261dcc83cb6c253d98368c5fbad86372 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Wed, 24 Jun 2026 22:03:10 +0200 Subject: [PATCH 27/30] refactor(plot): tidy as_svg() title handling and minor polish - as_svg(): set/reset i.render_state$vertex_titles in the function's own frame instead of inside the i.with_renderer() block, where it relied on a subtle on.exit(add = TRUE) interaction across the forced-promise boundary. Clearer and more robust; behaviour unchanged. - base renderer init_canvas(): use if/else instead of ifelse() for the scalar frame.plot fallback. - reflow an aesthetic-table comment. Co-Authored-By: Claude Opus 4.8 (1M context) --- R/plot-aes.R | 7 +++---- R/plot-render.R | 13 +++++++------ 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/R/plot-aes.R b/R/plot-aes.R index 799c28f9444..682790c47d8 100644 --- a/R/plot-aes.R +++ b/R/plot-aes.R @@ -7,10 +7,9 @@ # (at your option) any later version. ################################################################### -# Turn resolved plotting parameters into a typed, rectangular aesthetic table -# so that downstream code can slice it by -# vertex/edge index instead of re-implementing the -# `if (length(x) > 1) x[idx]` idiom for every parameter. +# Turn resolved plotting parameters into a typed, rectangular aesthetic table so +# that downstream code can slice it by vertex/edge index instead of +# re-implementing the `if (length(x) > 1) x[idx]` idiom for every parameter. # # Aesthetic resolution itself (the precedence chain # argument > graph attribute > igraph option > default) still lives in diff --git a/R/plot-render.R b/R/plot-render.R index 6f7199e0b17..57d2a89b197 100644 --- a/R/plot-render.R +++ b/R/plot-render.R @@ -42,7 +42,7 @@ i.renderer_base <- function() { xlim = xlim, ylim = ylim, axes = axes, - frame.plot = ifelse(is.null(frame.plot), axes, frame.plot), + frame.plot = if (is.null(frame.plot)) axes else frame.plot, asp = asp, main = main, sub = sub @@ -447,11 +447,12 @@ as_svg <- function(graph, file = NULL, width = 7, height = 7, tooltips = NULL, . rec <- i.renderer_record() grDevices::pdf(NULL, width = width, height = height) on.exit(grDevices::dev.off(), add = TRUE) - i.with_renderer(rec, { - i.render_state$vertex_titles <- titles - on.exit(i.render_state$vertex_titles <- NULL, add = TRUE) - plot(graph, ...) - }) + + # plot.igraph() reads i.render_state$vertex_titles to title the per-vertex SVG + # groups; set it here (and reset on exit) rather than inside i.with_renderer(). + i.render_state$vertex_titles <- titles + on.exit(i.render_state$vertex_titles <- NULL, add = TRUE) + i.with_renderer(rec, plot(graph, ...)) svg <- i.svg_from_record(rec$.state, wpx = round(width * 72), hpx = round(height * 72)) svg <- paste(svg, collapse = "\n") From ab0ab3864e32a3cebd88d6ba5c2458e57a82c831 Mon Sep 17 00:00:00 2001 From: schochastics Date: Wed, 24 Jun 2026 20:14:35 +0000 Subject: [PATCH 28/30] chore: Auto-update from GitHub Actions Run: https://github.com/igraph/rigraph/actions/runs/28126122425 --- NAMESPACE | 5 + R/plot-aes.R | 8 +- R/plot-render.R | 301 ++++++++++++++++++++++++------ R/plot-scales.R | 38 +++- R/plot.R | 46 ++++- man/as_svg.Rd | 40 ++++ man/label_top.Rd | 43 +++++ man/plot.common.Rd | 55 ++++++ man/plot.igraph.Rd | 10 +- man/scale_color.Rd | 43 +++++ man/scale_size.Rd | 35 ++++ tests/testthat/test-plot-render.R | 6 +- tests/testthat/test-plot-scales.R | 4 +- tests/testthat/test-plot.R | 58 +++++- tests/testthat/test-plot.shapes.R | 32 +++- 15 files changed, 639 insertions(+), 85 deletions(-) create mode 100644 man/as_svg.Rd create mode 100644 man/label_top.Rd create mode 100644 man/scale_color.Rd create mode 100644 man/scale_size.Rd diff --git a/NAMESPACE b/NAMESPACE index b1c451a2dc7..ea622acdfa1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -162,6 +162,7 @@ export(as_long_data_frame) export(as_membership) export(as_phylo) export(as_star) +export(as_svg) export(as_tree) export(as_undirected) export(assortativity) @@ -593,6 +594,7 @@ export(kautz_graph) export(keeping_degseq) export(knn) export(label.propagation.community) +export(label_top) export(laplacian_matrix) export(largest.cliques) export(largest.independent.vertex.sets) @@ -803,6 +805,9 @@ export(sample_traits_callaway) export(sample_tree) export(sbm) export(sbm.game) +export(scale_color) +export(scale_colour) +export(scale_size) export(scan_stat) export(sequential_pal) export(set.edge.attribute) diff --git a/R/plot-aes.R b/R/plot-aes.R index 682790c47d8..3b8d38dbfb5 100644 --- a/R/plot-aes.R +++ b/R/plot-aes.R @@ -38,7 +38,13 @@ i.aes_table <- function(cols, n) { # aesthetics with special length semantics (vertex `label.adj`, list-valued # `pie`/`raster`, the vertex-attribute `arrow.mode` "a:" form) are intentionally # excluded by the caller. -i.check_aes_lengths <- function(vertex, edge, vc, ec, call = rlang::caller_env()) { +i.check_aes_lengths <- function( + vertex, + edge, + vc, + ec, + call = rlang::caller_env() +) { one_scope <- function(lst, n, scope, plural) { for (nm in names(lst)) { len <- length(lst[[nm]]) diff --git a/R/plot-render.R b/R/plot-render.R index 57d2a89b197..4e69b783e0d 100644 --- a/R/plot-render.R +++ b/R/plot-render.R @@ -48,10 +48,24 @@ i.renderer_base <- function() { sub = sub ) }, - segments = function(x0, y0, x1, y1, col = graphics::par("fg"), lwd = 1, lty = 1) { + segments = function( + x0, + y0, + x1, + y1, + col = graphics::par("fg"), + lwd = 1, + lty = 1 + ) { graphics::segments(x0, y0, x1, y1, col = col, lwd = lwd, lty = lty) }, - polyline = function(x, y = NULL, col = graphics::par("fg"), lwd = 1, lty = 1) { + polyline = function( + x, + y = NULL, + col = graphics::par("fg"), + lwd = 1, + lty = 1 + ) { graphics::lines(x, y, col = col, lwd = lwd, lty = lty) }, polygon = function( @@ -168,7 +182,13 @@ i.col_to_hex <- function(col) { ok <- !is.na(col) if (any(ok)) { m <- grDevices::col2rgb(col[ok], alpha = TRUE) - out[ok] <- grDevices::rgb(m[1, ], m[2, ], m[3, ], m[4, ], maxColorValue = 255) + out[ok] <- grDevices::rgb( + m[1, ], + m[2, ], + m[3, ], + m[4, ], + maxColorValue = 255 + ) } out } @@ -190,42 +210,124 @@ i.renderer_record <- function() { base <- i.renderer_base() list( .state = st, - init_canvas = function(xlim, ylim, xlab, ylab, axes, frame.plot, asp, main, sub) { + init_canvas = function( + xlim, + ylim, + xlab, + ylab, + axes, + frame.plot, + asp, + main, + sub + ) { # establish the coordinate system (discarded device); record the range base$init_canvas(xlim, ylim, "", "", FALSE, FALSE, asp, "", "") st$canvas <- list(usr = graphics::par("usr")) }, segments = function(x0, y0, x1, y1, col = NA, lwd = 1, lty = 1) { - add(list(type = "segments", x0 = x0, y0 = y0, x1 = x1, y1 = y1, - col = i.col_to_hex(col), lwd = lwd)) + add(list( + type = "segments", + x0 = x0, + y0 = y0, + x1 = x1, + y1 = y1, + col = i.col_to_hex(col), + lwd = lwd + )) }, polyline = function(x, y = NULL, col = NA, lwd = 1, lty = 1) { xy <- grDevices::xy.coords(x, y) - add(list(type = "polyline", x = xy$x, y = xy$y, col = i.col_to_hex(col), lwd = lwd)) + add(list( + type = "polyline", + x = xy$x, + y = xy$y, + col = i.col_to_hex(col), + lwd = lwd + )) }, - polygon = function(x, y = NULL, col = NA, border = NULL, lwd = 1, lty = 1, - density = NULL, angle = 45, ...) { + polygon = function( + x, + y = NULL, + col = NA, + border = NULL, + lwd = 1, + lty = 1, + density = NULL, + angle = 45, + ... + ) { xy <- grDevices::xy.coords(x, y) - add(list(type = "polygon", x = xy$x, y = xy$y, col = i.col_to_hex(col), - border = i.col_to_hex(border), lwd = lwd)) + add(list( + type = "polygon", + x = xy$x, + y = xy$y, + col = i.col_to_hex(col), + border = i.col_to_hex(border), + lwd = lwd + )) }, - xspline = function(x, y = NULL, shape, open, col = NA, border = NA, lwd = 1) { + xspline = function( + x, + y = NULL, + shape, + open, + col = NA, + border = NA, + lwd = 1 + ) { pts <- grDevices::xspline(x, y, shape = shape, open = open, draw = FALSE) - add(list(type = "polygon", x = pts$x, y = pts$y, col = i.col_to_hex(col), - border = i.col_to_hex(border), lwd = lwd)) + add(list( + type = "polygon", + x = pts$x, + y = pts$y, + col = i.col_to_hex(col), + border = i.col_to_hex(border), + lwd = lwd + )) }, - text = function(x, y, labels, col = NA, family = "", font = 1, cex = 1, - srt = 0, adj = NULL) { - add(list(type = "text", x = x, y = y, labels = labels, - col = i.col_to_hex(col), cex = cex, srt = srt, adj = adj)) + text = function( + x, + y, + labels, + col = NA, + family = "", + font = 1, + cex = 1, + srt = 0, + adj = NULL + ) { + add(list( + type = "text", + x = x, + y = y, + labels = labels, + col = i.col_to_hex(col), + cex = cex, + srt = srt, + adj = adj + )) }, symbols = function(kind, x, y, dim, bg = NA, fg = NA, lwd = 1) { - add(list(type = "symbols", kind = kind, x = x, y = y, dim = dim, - bg = i.col_to_hex(bg), fg = i.col_to_hex(fg), lwd = lwd)) + add(list( + type = "symbols", + kind = kind, + x = x, + y = y, + dim = dim, + bg = i.col_to_hex(bg), + fg = i.col_to_hex(fg), + lwd = lwd + )) }, raster = function(image, xleft, ybottom, xright, ytop) { - add(list(type = "raster", xleft = xleft, ybottom = ybottom, - xright = xright, ytop = ytop)) + add(list( + type = "raster", + xleft = xleft, + ybottom = ybottom, + xright = xright, + ytop = ytop + )) }, group_begin = function(type, id = NULL, title = NULL) { st$group <- list(type = type, id = id, title = title) @@ -273,10 +375,17 @@ i.svg_from_record <- function(state, wpx, hpx) { Y <- function(y) hpx - (y - usr[3]) * syr S <- function(s) s * sxr # user-length -> px (asp == 1) - pts_str <- function(x, y) paste(sprintf("%.2f,%.2f", X(x), Y(y)), collapse = " ") + pts_str <- function(x, y) { + paste(sprintf("%.2f,%.2f", X(x), Y(y)), collapse = " ") + } stroke <- function(hex, lwd) { sc <- i.svg_col(hex) - sprintf("stroke='%s' stroke-opacity='%s' stroke-width='%.2f'", sc[1], sc[2], max(lwd, 0.1)) + sprintf( + "stroke='%s' stroke-opacity='%s' stroke-width='%.2f'", + sc[1], + sc[2], + max(lwd, 0.1) + ) } fillattr <- function(hex) { fc <- i.svg_col(hex) @@ -290,38 +399,70 @@ i.svg_from_record <- function(state, wpx, hpx) { segments = { n <- length(p$x0) col <- rep(p$col, length.out = n) - vapply(seq_len(n), function(k) { - sprintf( - "", - X(p$x0[k]), Y(p$y0[k]), X(p$x1[k]), Y(p$y1[k]), - stroke(col[k], p$lwd) - ) - }, character(1)) + vapply( + seq_len(n), + function(k) { + sprintf( + "", + X(p$x0[k]), + Y(p$y0[k]), + X(p$x1[k]), + Y(p$y1[k]), + stroke(col[k], p$lwd) + ) + }, + character(1) + ) }, polyline = sprintf( "", - pts_str(p$x, p$y), stroke(p$col, p$lwd) + pts_str(p$x, p$y), + stroke(p$col, p$lwd) ), polygon = sprintf( "", - pts_str(p$x, p$y), fillattr(p$col), stroke(p$border, p$lwd) + pts_str(p$x, p$y), + fillattr(p$col), + stroke(p$border, p$lwd) ), text = { n <- length(p$x) col <- rep(p$col, length.out = n) adj <- if (is.null(p$adj)) 0.5 else p$adj[1] - anchor <- c("start", "middle", "end")[findInterval(adj, c(-Inf, 0.25, 0.75, Inf))] + anchor <- c("start", "middle", "end")[findInterval( + adj, + c(-Inf, 0.25, 0.75, Inf) + )] fc <- i.svg_col(col[1]) lab <- as.character(p$labels) keep <- which(!is.na(lab) & nzchar(lab)) # base skips NA/empty labels - vapply(keep, function(k) { - rot <- if (p$srt != 0) sprintf(" transform='rotate(%.2f %.2f %.2f)'", -p$srt, X(p$x[k]), Y(p$y[k])) else "" - sprintf( - "%s", - X(p$x[k]), Y(p$y[k]), p$cex * 12, anchor, fc[1], fc[2], rot, - i.svg_attr_esc(lab[k]) - ) - }, character(1)) + vapply( + keep, + function(k) { + rot <- if (p$srt != 0) { + sprintf( + " transform='rotate(%.2f %.2f %.2f)'", + -p$srt, + X(p$x[k]), + Y(p$y[k]) + ) + } else { + "" + } + sprintf( + "%s", + X(p$x[k]), + Y(p$y[k]), + p$cex * 12, + anchor, + fc[1], + fc[2], + rot, + i.svg_attr_esc(lab[k]) + ) + }, + character(1) + ) }, symbols = { n <- length(p$x) @@ -333,33 +474,66 @@ i.svg_from_record <- function(state, wpx, hpx) { if (!is.null(vtitle)) { kk <- vtitle$counter idattr <- sprintf(" id='vertex-%d'", kk) - ttl <- if (!is.null(vtitle$titles)) sprintf("%s", i.svg_attr_esc(vtitle$titles[kk])) else "" + ttl <- if (!is.null(vtitle$titles)) { + sprintf("%s", i.svg_attr_esc(vtitle$titles[kk])) + } else { + "" + } vtitle$counter <- kk + 1L } else { ttl <- "" } shp <- if (p$kind == "circles") { - sprintf("", - X(p$x[k]), Y(p$y[k]), S(p$dim[k]), fillattr(bg[k]), stroke(fg[k], p$lwd)) + sprintf( + "", + X(p$x[k]), + Y(p$y[k]), + S(p$dim[k]), + fillattr(bg[k]), + stroke(fg[k], p$lwd) + ) } else if (p$kind == "squares") { h <- p$dim[k] / 2 - sprintf("", - X(p$x[k] - h), Y(p$y[k] + h), S(p$dim[k]), S(p$dim[k]), fillattr(bg[k]), stroke(fg[k], p$lwd)) + sprintf( + "", + X(p$x[k] - h), + Y(p$y[k] + h), + S(p$dim[k]), + S(p$dim[k]), + fillattr(bg[k]), + stroke(fg[k], p$lwd) + ) } else { # rectangles: dim is n x 2 (full width, height) w <- if (is.matrix(p$dim)) p$dim[k, 1] else p$dim[1] hh <- if (is.matrix(p$dim)) p$dim[k, 2] else p$dim[2] - sprintf("", - X(p$x[k] - w / 2), Y(p$y[k] + hh / 2), S(w), S(hh), fillattr(bg[k]), stroke(fg[k], p$lwd)) + sprintf( + "", + X(p$x[k] - w / 2), + Y(p$y[k] + hh / 2), + S(w), + S(hh), + fillattr(bg[k]), + stroke(fg[k], p$lwd) + ) } - out[k] <- paste0(if (nzchar(idattr)) sprintf("%s%s", idattr, ttl, shp) else shp) + out[k] <- paste0( + if (nzchar(idattr)) { + sprintf("%s%s", idattr, ttl, shp) + } else { + shp + } + ) } out }, raster = sprintf( # v1 placeholder for sphere/raster shapes "", - X(p$xleft), Y(p$ytop), S(p$xright - p$xleft), S(p$ytop - p$ybottom) + X(p$xleft), + Y(p$ytop), + S(p$xright - p$xleft), + S(p$ytop - p$ybottom) ), character(0) ) @@ -371,7 +545,9 @@ i.svg_from_record <- function(state, wpx, hpx) { open_g <- FALSE vtitle <- NULL # environment-like tracker for vertex ids within a vertices group - group_key <- function(g) if (is.null(g)) "" else paste0(g$type, ":", if (is.null(g$id)) "" else g$id) + group_key <- function(g) { + if (is.null(g)) "" else paste0(g$type, ":", if (is.null(g$id)) "" else g$id) + } for (p in prims) { g <- p$group @@ -389,7 +565,11 @@ i.svg_from_record <- function(state, wpx, hpx) { vtitle$counter <- 1L vtitle$titles <- g$title } else if (identical(g$type, "edge")) { - ttl <- if (!is.null(g$title)) sprintf("%s", i.svg_attr_esc(as.character(g$title))) else "" + ttl <- if (!is.null(g$title)) { + sprintf("%s", i.svg_attr_esc(as.character(g$title))) + } else { + "" + } body <- c(body, sprintf("%s", as.character(g$id), ttl)) } else { body <- c(body, sprintf("", g$type)) @@ -433,7 +613,14 @@ i.svg_from_record <- function(state, wpx, hpx) { #' @param ... Further plotting parameters passed to [plot.igraph()]. #' @return The SVG string, invisibly (also written to `file` if given). #' @export -as_svg <- function(graph, file = NULL, width = 7, height = 7, tooltips = NULL, ...) { +as_svg <- function( + graph, + file = NULL, + width = 7, + height = 7, + tooltips = NULL, + ... +) { ensure_igraph(graph) titles <- if (!is.null(tooltips)) { @@ -454,7 +641,11 @@ as_svg <- function(graph, file = NULL, width = 7, height = 7, tooltips = NULL, . on.exit(i.render_state$vertex_titles <- NULL, add = TRUE) i.with_renderer(rec, plot(graph, ...)) - svg <- i.svg_from_record(rec$.state, wpx = round(width * 72), hpx = round(height * 72)) + svg <- i.svg_from_record( + rec$.state, + wpx = round(width * 72), + hpx = round(height * 72) + ) svg <- paste(svg, collapse = "\n") if (!is.null(file)) { writeLines(svg, file) diff --git a/R/plot-scales.R b/R/plot-scales.R index 3808d7860a6..37a0bcaccf4 100644 --- a/R/plot-scales.R +++ b/R/plot-scales.R @@ -138,7 +138,9 @@ scale_size <- function( vals[na] <- na.value breaks <- pretty(x[!na], n = 3) - breaks <- breaks[breaks >= min(x, na.rm = TRUE) & breaks <= max(x, na.rm = TRUE)] + breaks <- breaks[ + breaks >= min(x, na.rm = TRUE) & breaks <= max(x, na.rm = TRUE) + ] guide <- list( aesthetic = "size", type = "discrete", @@ -325,8 +327,21 @@ i.colorbar <- function(g, x, y, xjust, yjust, horiz, plot) { bar_top <- top - title_h if (horiz) { xs <- seq(left, left + barw, length.out = 51) - graphics::rect(xs[-51], bar_top - barh, xs[-1], bar_top, col = fill, border = NA) - graphics::rect(left, bar_top - barh, left + barw, bar_top, border = "grey40") + graphics::rect( + xs[-51], + bar_top - barh, + xs[-1], + bar_top, + col = fill, + border = NA + ) + graphics::rect( + left, + bar_top - barh, + left + barw, + bar_top, + border = "grey40" + ) ylab <- bar_top - barh - 0.2 * lh graphics::text(left, ylab, labs[1], adj = c(0, 1), cex = 0.8) graphics::text(left + barw, ylab, labs[2], adj = c(1, 1), cex = 0.8) @@ -335,8 +350,21 @@ i.colorbar <- function(g, x, y, xjust, yjust, horiz, plot) { } } else { ys <- seq(bar_top - barh, bar_top, length.out = 51) - graphics::rect(left, ys[-51], left + barw, ys[-1], col = fill, border = NA) - graphics::rect(left, bar_top - barh, left + barw, bar_top, border = "grey40") + graphics::rect( + left, + ys[-51], + left + barw, + ys[-1], + col = fill, + border = NA + ) + graphics::rect( + left, + bar_top - barh, + left + barw, + bar_top, + border = "grey40" + ) graphics::text( left + barw + 0.02, c(bar_top - barh, bar_top), diff --git a/R/plot.R b/R/plot.R index 86143f460e8..5a2276945fd 100644 --- a/R/plot.R +++ b/R/plot.R @@ -394,8 +394,12 @@ i.draw_vertex_labels <- function( if (sum(drawn) > 1) { hw <- rep(0, vc) hh <- rep(0, vc) - hw[drawn] <- strwidth(label.text[drawn], cex = label.cex[drawn]) / 2 * 1.15 - hh[drawn] <- strheight(label.text[drawn], cex = label.cex[drawn]) / 2 * 1.6 + hw[drawn] <- strwidth(label.text[drawn], cex = label.cex[drawn]) / + 2 * + 1.15 + hh[drawn] <- strheight(label.text[drawn], cex = label.cex[drawn]) / + 2 * + 1.6 moved <- i.repel_labels(x[drawn], y[drawn], hw[drawn], hh[drawn]) nx <- x ny <- y @@ -405,7 +409,14 @@ i.draw_vertex_labels <- function( shift <- sqrt((nx - x)^2 + (ny - y)^2) lead <- drawn & shift > pmax(hh, 1e-6) if (any(lead)) { - i.r_segments(x[lead], y[lead], nx[lead], ny[lead], col = "grey60", lwd = 0.5) + i.r_segments( + x[lead], + y[lead], + nx[lead], + ny[lead], + col = "grey60", + lwd = 0.5 + ) } x <- nx y <- ny @@ -1045,7 +1056,10 @@ plot.igraph <- function( col.to.e <- edge.color if (any(edge.gradient)) { to_hex <- function(x) { - grDevices::rgb(t(grDevices::col2rgb(x, alpha = TRUE)), maxColorValue = 255) + grDevices::rgb( + t(grDevices::col2rgb(x, alpha = TRUE)), + maxColorValue = 255 + ) } ealpha <- nl_aes$alpha grad_from <- i.apply_alpha(to_hex(vcol_base[el[, 1]]), ealpha) @@ -2194,7 +2208,13 @@ i.draw_gradient_path <- function(px, py, col_from, col_to, lwd, lty, n = 40) { ry <- stats::approx(d, py, at)$y ramp <- grDevices::colorRamp(c(col_from, col_to), alpha = TRUE) m <- ramp(seq(0, 1, length.out = n - 1)) # one RGBA row per segment - cols <- grDevices::rgb(m[, 1], m[, 2], m[, 3], alpha = m[, 4], maxColorValue = 255) + cols <- grDevices::rgb( + m[, 1], + m[, 2], + m[, 3], + alpha = m[, 4], + maxColorValue = 255 + ) i.r_segments(rx[-n], ry[-n], rx[-1], ry[-1], col = cols, lwd = lwd, lty = lty) invisible(NULL) } @@ -2357,7 +2377,13 @@ igraph.Arrows <- function( sh.lty[i] ) } else { - i.r_polyline(path$x, path$y, col = sh.col[i], lwd = sh.lwd[i], lty = sh.lty[i]) + i.r_polyline( + path$x, + path$y, + col = sh.col[i], + lwd = sh.lwd[i], + lty = sh.lty[i] + ) } np <- length(path$x) mid <- max(1L, round(np / 2)) @@ -2385,7 +2411,13 @@ igraph.Arrows <- function( yhead <- py2 + r.arr * sin(ttheta) / uin[2] if (open) { - i.r_polyline(xhead, yhead, col = h.col.bo[i], lwd = h.lwd[i], lty = h.lty[i]) + i.r_polyline( + xhead, + yhead, + col = h.col.bo[i], + lwd = h.lwd[i], + lty = h.lty[i] + ) } else { i.r_polygon( xhead, diff --git a/man/as_svg.Rd b/man/as_svg.Rd new file mode 100644 index 00000000000..039b7e37730 --- /dev/null +++ b/man/as_svg.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-render.R +\name{as_svg} +\alias{as_svg} +\title{Render a graph to SVG} +\usage{ +as_svg(graph, file = NULL, width = 7, height = 7, tooltips = NULL, ...) +} +\arguments{ +\item{graph}{The graph to plot.} + +\item{file}{Optional path to write the SVG to. If \code{NULL} (default) the SVG +string is returned invisibly.} + +\item{width, height}{Size in inches (the SVG is \code{width*72} x \code{height*72} px).} + +\item{tooltips}{Optional vertex attribute name to use for the \verb{} +tooltips; defaults to the vertex \code{name} attribute (or vertex index).} + +\item{...}{Further plotting parameters passed to \code{\link[=plot.igraph]{plot.igraph()}}.} +} +\value{ +The SVG string, invisibly (also written to \code{file} if given). +} +\description{ +\code{as_svg()} draws a graph to a standalone SVG string using the same geometry +as \code{\link[=plot.igraph]{plot.igraph()}}, but emits per-vertex \verb{<g id="vertex-N">} groups with +\verb{<title>} tooltips (and per-edge groups), giving lightweight interactivity +(hover) with no JavaScript. It accepts the usual plotting parameters via +\code{...}. +} +\details{ +Vertices, edges (all styles), arrowheads, labels, mark groups and pie shapes +are rendered; \code{sphere}/\code{raster} vertex shapes are drawn as a placeholder box +in this version. +} +\section{Related documentation in the C library}{ +\href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_vcount}{\code{vcount()}} +} + diff --git a/man/label_top.Rd b/man/label_top.Rd new file mode 100644 index 00000000000..28f7d6cfb27 --- /dev/null +++ b/man/label_top.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-labels.R +\name{label_top} +\alias{label_top} +\title{Keep only the most prominent labels} +\usage{ +label_top(by, n = NULL, prop = NULL, labels = NULL, decreasing = TRUE) +} +\arguments{ +\item{by}{A numeric vector of scores to rank by, e.g. \code{degree(g)} or +\code{betweenness(g)}. One score per vertex (or edge).} + +\item{n}{Number of labels to keep (the top \code{n} by \code{by}). Give either \code{n} or +\code{prop}, not both. If neither is given, all labels are kept.} + +\item{prop}{Proportion of labels to keep, between 0 and 1; rounded up. Give +either \code{n} or \code{prop}, not both.} + +\item{labels}{The labels to thin. Defaults to \code{names(by)} if present, +otherwise the integer positions. Must have the same length as \code{by}.} + +\item{decreasing}{Logical; if \code{TRUE} (the default) the highest \code{by} values +are kept, otherwise the lowest.} +} +\value{ +A character vector the same length as \code{by}, with \code{NA} in the +positions that are not kept. +} +\description{ +\code{label_top()} returns a label vector with \code{NA} everywhere except the entries +that rank highest by \code{by}. Because \code{\link[=plot.igraph]{plot.igraph()}} omits \code{NA} labels, this is +a convenient way to declutter dense graphs by labelling only the most +important vertices (or edges). Pass it to a label argument, e.g. +\code{plot(g, vertex.label = label_top(degree(g), n = 10))}. +} +\details{ +To label everything above a fixed cutoff instead of a fixed count, you do not +need this helper: \code{ifelse(metric > cutoff, labels, NA)} works directly. +} +\examples{ +g <- make_ring(10) +plot(g, vertex.label = label_top(degree(g), n = 3)) +} diff --git a/man/plot.common.Rd b/man/plot.common.Rd index 5cd7128d499..3bc7775585d 100644 --- a/man/plot.common.Rd +++ b/man/plot.common.Rd @@ -124,6 +124,11 @@ color name. The default value is \dQuote{\code{SkyBlue2}}. } +\item{alpha}{ +Opacity of the vertex fill, a number (or vector) in \verb{[0, 1]}, multiplied +into any alpha already present in \code{color}. \code{1} (the default) means fully +opaque. Frame colour, pie slices and labels are not affected. +} \item{frame.color}{ The color of the frame of the vertices, the same formats are allowed as for the fill color. @@ -240,6 +245,21 @@ The rotation of the vertex labels, in degrees. Corresponds to the \code{srt} par \item{label.adj}{ one or two numeric values, giving the horizontal and vertical adjustment of the vertex labels. See also \code{adj} in \code{\link[graphics:text]{graphics::text()}}. } +\item{label.repel}{ +Logical scalar. If \code{TRUE}, overlapping vertex labels are iteratively nudged +apart (in the spirit of \pkg{ggrepel}) and a thin leader line connects each +moved label to its original position. The default is \code{FALSE}. +} +\item{label.halo}{ +The colour of a legibility halo (outline) drawn behind the vertex label +text, so labels remain readable over edges and other vertices. The halo is +drawn shadowtext-style: the glyphs are repeated, offset in a ring, in this +colour, with the real label on top. \code{NA} (the default) draws no halo. +} +\item{label.halo.width}{ +The width of the label halo, as a fraction of the label height. Only has an +effect when \code{label.halo} is not \code{NA}. The default is \code{0.15}. +} \item{size.scaling}{ Switches between absolute vertex sizing (FALSE,default) and relative (TRUE). If FALSE, \code{vertex.size} and \code{vertex.size2} are used as is. @@ -306,6 +326,15 @@ The font size for the edge labels, see the corresponding vertex parameter for de \item{label.color}{ The color of the edge labels, see the \code{color} vertex parameters on how to specify colors. } +\item{label.halo}{ +The colour of a legibility halo (outline) drawn behind the edge label text. +See the vertex parameter with the same name for details. \code{NA} (the default) +draws no halo. +} +\item{label.halo.width}{ +The width of the edge label halo, as a fraction of the label height. Only +has an effect when \code{label.halo} is not \code{NA}. The default is \code{0.15}. +} \item{label.x}{ The horizontal \code{NA} elements will be replaced by automatically calculated coordinates. If \code{NULL}, then all edge horizontal coordinates are calculated automatically. @@ -332,6 +361,32 @@ The default value is \code{FALSE}. This parameter is currently ignored by \code{\link[=rglplot]{rglplot()}}. } +\item{style}{ +The routing style for (non-loop) edges, a character scalar or vector, +replicated to the number of edges. One of: +\describe{ +\item{\code{"auto"}}{(default) straight, unless \code{curved} is non-zero (in which +case an arc), reproducing the historical behaviour.} +\item{\code{"straight"}}{a straight segment.} +\item{\code{"arc"}}{a curved arc; the strength is taken from \code{curved} if it is +non-zero, otherwise a default is used.} +\item{\code{"elbow"}}{a two-corner orthogonal (right-angle) connector.} +\item{\code{"diagonal"}}{a smooth S-curve with axis-aligned ends.} +} +This parameter is ignored for loop edges and by \code{\link[=rglplot]{rglplot()}}. +} +\item{alpha}{ +Opacity of the edge, a number (or vector) in \verb{[0, 1]}, multiplied into any +alpha already present in \code{color} (and in the gradient endpoint colours). +\code{1} (the default) means fully opaque. +} +\item{gradient}{ +Logical scalar or vector. If \code{TRUE}, the edge is drawn as a colour gradient +running from its source vertex's colour to its target vertex's colour (a +direction cue), and the arrowhead takes the target colour; \code{color} is then +ignored for that edge's shaft. The default is \code{FALSE}. Ignored for loop +edges and by \code{\link[=rglplot]{rglplot()}}. +} \item{arrow.mode}{ This parameter can be used to specify for which edges should arrows be drawn. If this parameter is given by the user (in either of the three ways) diff --git a/man/plot.igraph.Rd b/man/plot.igraph.Rd index a1c56863940..72353f47477 100644 --- a/man/plot.igraph.Rd +++ b/man/plot.igraph.Rd @@ -18,6 +18,7 @@ mark.expand = 15, mark.lwd = 1, loop.size = 1, + legend = TRUE, ... ) } @@ -68,6 +69,13 @@ groups.} of the network. The default loop size is 1. Larger values will produce larger loops.} +\item{legend}{Controls drawing of legends/colorbars for any aesthetics +supplied via \code{\link[=scale_color]{scale_color()}} / \code{\link[=scale_size]{scale_size()}}. The guide is drawn in the +reserved outer margin on one side of the plot: \code{TRUE} (default) or +\code{"right"} places it to the right, \code{"left"}/\code{"top"}/\code{"bottom"} on the +corresponding side (\code{"top"}/\code{"bottom"} arrange entries horizontally); +\code{FALSE} suppresses it. Has no effect when no scale is used.} + \item{\dots}{Additional plotting parameters. See \link{igraph.plotting} for the complete list.} } @@ -85,7 +93,7 @@ first, handtune the placement of the vertices, query the coordinates by the plot the graph to any R device. } \section{Related documentation in the C library}{ -\href{https://igraph.org/c/html/0.10.17/igraph-Structural.html#igraph_get_edgelist}{\code{get_edgelist()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_incident}{\code{incident()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_edges}{\code{edges()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_vcount}{\code{vcount()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Structural.html#igraph_is_loop}{\code{is_loop()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_is_directed}{\code{is_directed()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Nongraph.html#igraph_convex_hull_2d}{\code{convex_hull_2d()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_ecount}{\code{ecount()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_get_eids}{\code{get_eids()}} +\href{https://igraph.org/c/html/0.10.17/igraph-Structural.html#igraph_get_edgelist}{\code{get_edgelist()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_vcount}{\code{vcount()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_incident}{\code{incident()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_edges}{\code{edges()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Structural.html#igraph_is_loop}{\code{is_loop()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Nongraph.html#igraph_convex_hull_2d}{\code{convex_hull_2d()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_is_directed}{\code{is_directed()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_get_eids}{\code{get_eids()}}, \href{https://igraph.org/c/html/0.10.17/igraph-Basic.html#igraph_ecount}{\code{ecount()}} } \examples{ diff --git a/man/scale_color.Rd b/man/scale_color.Rd new file mode 100644 index 00000000000..d3c60fa1b03 --- /dev/null +++ b/man/scale_color.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-scales.R +\name{scale_color} +\alias{scale_color} +\alias{scale_colour} +\title{Map data to a colour aesthetic with an automatic legend} +\usage{ +scale_color(x, palette = NULL, na.value = "grey70", name = NULL) + +scale_colour(x, palette = NULL, na.value = "grey70", name = NULL) +} +\arguments{ +\item{x}{The data vector to map. Its length must be 1 or the number of +vertices/edges of the graph it is used with.} + +\item{palette}{Colours to map to. For discrete \code{x}, a vector of colours (one +per level, recycled); defaults to \code{\link[=categorical_pal]{categorical_pal()}}. For numeric \code{x}, the +anchor colours of the ramp; defaults to \code{\link[=sequential_pal]{sequential_pal()}}.} + +\item{na.value}{Colour used for \code{NA} entries in \code{x}.} + +\item{name}{Optional guide title; defaults to the name of the argument the +scale is assigned to (e.g. \code{"vertex.color"}).} +} +\value{ +An \code{igraph_scale} object. +} +\description{ +\code{scale_color()} (alias \code{scale_colour()}) maps a data vector to vertex or edge +colours and records the mapping so that \code{\link[=plot.igraph]{plot.igraph()}} draws a matching +guide. Pass it to a colour argument, e.g. +\code{plot(g, vertex.color = scale_color(V(g)$group))}. +} +\details{ +A non-numeric \code{x} (factor, character, logical) produces a discrete mapping +and a categorical legend; a numeric \code{x} produces a continuous mapping (a +colour ramp) and a colorbar. +} +\seealso{ +Other scales: +\code{\link[=scale_size]{scale_size()}} +} +\concept{scales} diff --git a/man/scale_size.Rd b/man/scale_size.Rd new file mode 100644 index 00000000000..95046b1fc74 --- /dev/null +++ b/man/scale_size.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-scales.R +\name{scale_size} +\alias{scale_size} +\title{Map data to a size aesthetic with an automatic legend} +\usage{ +scale_size(x, range = c(2, 15), na.value = NA, name = NULL, trans = NULL) +} +\arguments{ +\item{x}{A numeric data vector to map. Its length must be 1 or the number of +vertices/edges of the graph it is used with.} + +\item{range}{Numeric length-2 vector giving the output size range.} + +\item{na.value}{Size used for \code{NA} entries in \code{x}.} + +\item{name}{Optional guide title; defaults to the argument name.} + +\item{trans}{Optional transformation applied to \code{x} before rescaling, given +as a function or its name (e.g. \code{"sqrt"}, \code{"log"}).} +} +\value{ +An \code{igraph_scale} object. +} +\description{ +\code{scale_size()} linearly maps a numeric data vector to a size range (suitable +for \code{vertex.size} or \code{edge.width}) and records the mapping so that +\code{\link[=plot.igraph]{plot.igraph()}} draws a matching size legend. Pass it to a size argument, +e.g. \code{plot(g, vertex.size = scale_size(degree(g)))}. +} +\seealso{ +Other scales: +\code{\link[=scale_color]{scale_color()}} +} +\concept{scales} diff --git a/tests/testthat/test-plot-render.R b/tests/testthat/test-plot-render.R index 93a8c91c290..103ae42a273 100644 --- a/tests/testthat/test-plot-render.R +++ b/tests/testthat/test-plot-render.R @@ -118,7 +118,11 @@ test_that("a label halo emits the offset copies plus the real label in SVG", { V(g)$name <- c("aa", "bb", "cc") plain <- as_svg(g) - haloed <- as_svg(g, vertex.label.halo = "white", vertex.label.halo.width = 0.2) + haloed <- as_svg( + g, + vertex.label.halo = "white", + vertex.label.halo.width = 0.2 + ) expect_s3_class(xml2::read_xml(haloed), "xml_document") # the halo adds offset copies of every glyph, so there are strictly more diff --git a/tests/testthat/test-plot-scales.R b/tests/testthat/test-plot-scales.R index baabf21f63b..b0d4fb11d9e 100644 --- a/tests/testthat/test-plot-scales.R +++ b/tests/testthat/test-plot-scales.R @@ -77,7 +77,9 @@ test_that("i.apply_scales replaces scale args and collects guides", { }) test_that("a scale's explicit name overrides the argument-name default", { - res <- i.apply_scales(list(vertex.color = scale_color(c("a", "b"), name = "Group"))) + res <- i.apply_scales(list( + vertex.color = scale_color(c("a", "b"), name = "Group") + )) expect_equal(res$guides[[1]]$name, "Group") }) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 6bfb8bda80b..c4b50bfe7a4 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -237,12 +237,22 @@ test_that("mark border linewidth", { test_that("i.repel_labels separates overlapping labels and is deterministic", { # two boxes stacked at the same point should be pushed apart (here along y, # the smaller-overlap axis) - r <- i.repel_labels(x = c(0, 0), y = c(0, 0), hw = c(0.2, 0.2), hh = c(0.1, 0.1)) + r <- i.repel_labels( + x = c(0, 0), + y = c(0, 0), + hw = c(0.2, 0.2), + hh = c(0.1, 0.1) + ) sep <- max(abs(r$x[1] - r$x[2]), abs(r$y[1] - r$y[2])) expect_gt(sep, 0.15) # was 0; now nearly the box height sum (0.2) # deterministic - r2 <- i.repel_labels(x = c(0, 0), y = c(0, 0), hw = c(0.2, 0.2), hh = c(0.1, 0.1)) + r2 <- i.repel_labels( + x = c(0, 0), + y = c(0, 0), + hw = c(0.2, 0.2), + hh = c(0.1, 0.1) + ) expect_equal(r, r2) # a single label is returned unchanged @@ -386,7 +396,12 @@ test_that("scales draw matching legends and colorbars", { vdiffr::expect_doppelganger("scale-legend-bottom-horizontal", function() { g <- ring10() V(g)$grp <- rep(c("alpha", "beta"), 5) - plot(g, vertex.color = scale_color(V(g)$grp), vertex.size = 20, legend = "bottom") + plot( + g, + vertex.color = scale_color(V(g)$grp), + vertex.size = 20, + legend = "bottom" + ) }) vdiffr::expect_doppelganger("scale-continuous-colorbar-top", function() { @@ -397,7 +412,12 @@ test_that("scales draw matching legends and colorbars", { vdiffr::expect_doppelganger("scale-edge-color", function() { g <- ring10() E(g)$type <- rep(c("x", "y"), length.out = ecount(g)) - plot(g, edge.color = scale_color(E(g)$type), edge.width = 2, vertex.size = 15) + plot( + g, + edge.color = scale_color(E(g)$type), + edge.width = 2, + vertex.size = 15 + ) }) }) @@ -425,7 +445,12 @@ test_that("legend = FALSE suppresses the guide", { g <- make_ring(10) g$layout <- layout_in_circle(g) V(g)$grp <- rep(c("alpha", "beta"), 5) - plot(g, vertex.color = scale_color(V(g)$grp), vertex.size = 20, legend = FALSE) + plot( + g, + vertex.color = scale_color(V(g)$grp), + vertex.size = 20, + legend = FALSE + ) }) }) @@ -474,7 +499,13 @@ test_that("edge.gradient blends source to target vertex colours", { g <- make_graph(c(1, 2, 2, 3, 3, 1), directed = TRUE) g$layout <- layout_in_circle(g) V(g)$color <- c("red", "green", "blue") - plot(g, edge.gradient = TRUE, edge.style = "arc", vertex.size = 24, edge.width = 3) + plot( + g, + edge.gradient = TRUE, + edge.style = "arc", + vertex.size = 24, + edge.width = 3 + ) }) }) @@ -510,7 +541,12 @@ test_that("edge.style routes edges (elbow / diagonal / mixed / arc)", { }) vdiffr::expect_doppelganger("edge-style-diagonal", function() { - plot(tree(), edge.style = "diagonal", vertex.size = 12, edge.arrow.size = 0.4) + plot( + tree(), + edge.style = "diagonal", + vertex.size = 12, + edge.arrow.size = 0.4 + ) }) vdiffr::expect_doppelganger("edge-style-mixed", function() { @@ -624,7 +660,13 @@ test_that("add = TRUE overlays a second graph on the same device", { g1$layout <- cbind(c(0, 1, 2), c(0, 0, 0)) g2 <- make_ring(3) g2$layout <- cbind(c(0, 1, 2), c(1, 1, 1)) - plot(g1, rescale = FALSE, xlim = c(-1, 3), ylim = c(-1, 2), vertex.color = "red") + plot( + g1, + rescale = FALSE, + xlim = c(-1, 3), + ylim = c(-1, 2), + vertex.color = "red" + ) plot(g2, rescale = FALSE, add = TRUE, vertex.color = "blue") } vdiffr::expect_doppelganger("add-overlay", overlay) diff --git a/tests/testthat/test-plot.shapes.R b/tests/testthat/test-plot.shapes.R index dc755abe280..b070dc83c5a 100644 --- a/tests/testthat/test-plot.shapes.R +++ b/tests/testthat/test-plot.shapes.R @@ -179,9 +179,21 @@ test_that("non-circle clip functions return the right column structure", { all_clip <- c("square", "csquare", "rectangle", "crectangle", "vrectangle", "pie") for (shape_name in all_clip) { clip_func <- shapes(shape_name)$clip - expect_equal(ncol(clip_func(coords, el, params, "from")), 2, info = shape_name) - expect_equal(ncol(clip_func(coords, el, params, "to")), 2, info = shape_name) - expect_equal(ncol(clip_func(coords, el, params, "both")), 4, info = shape_name) + expect_equal( + ncol(clip_func(coords, el, params, "from")), + 2, + info = shape_name + ) + expect_equal( + ncol(clip_func(coords, el, params, "to")), + 2, + info = shape_name + ) + expect_equal( + ncol(clip_func(coords, el, params, "both")), + 4, + info = shape_name + ) } }) @@ -197,8 +209,14 @@ test_that("non-centered clip functions clip endpoints inward", { # edge), so the inward check applies only to the non-centered shapes. for (shape_name in c("square", "rectangle", "vrectangle", "pie")) { clip_func <- shapes(shape_name)$clip - expect_true(clip_func(coords, el, params, "from")[1, 1] > 0, info = shape_name) - expect_true(clip_func(coords, el, params, "to")[1, 1] < 10, info = shape_name) + expect_true( + clip_func(coords, el, params, "from")[1, 1] > 0, + info = shape_name + ) + expect_true( + clip_func(coords, el, params, "to")[1, 1] < 10, + info = shape_name + ) } }) @@ -211,7 +229,9 @@ test_that("clip functions select vertex.size per endpoint from a vector", { el <- rbind(c(1, 2), c(3, 4)) sizes <- c(2, 2, 8, 8) # vertices 3 and 4 are larger params <- function(type, param) { - if (param == "size") return(sizes) + if (param == "size") { + return(sizes) + } 1 } From 70e36ff28204ab43804f7708f9a2524ebcc81825 Mon Sep 17 00:00:00 2001 From: David Schoch <david@schochastics.net> Date: Thu, 25 Jun 2026 09:55:06 +0200 Subject: [PATCH 29/30] fix(plot): centre elbow/diagonal edges on the vertex axis MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Elbow and diagonal edges attached to vertices at the centre-to-centre boundary point (the shape clip functions clip along the straight line between centres, regardless of style). Since these styles route along an axis, their first/last segment then started off the vertex's centre axis — very visible in tree layouts, where a parent's stubs left from down-left/down-right of its bottom and children were entered left/right of their top. For elbow/diagonal edges, re-clip the endpoints along the dominant axis (chosen from the vertex centres) so they attach at the top/bottom- or left/right-centre of each vertex, and pass that axis into the path builders so routing matches the attachment. Straight, arc and self-loop edges are unchanged. - i.elbow_path()/i.diagonal_path(): new `vertical` arg (NULL = infer as before). - igraph.Arrows(): new `axis` arg, recycled and forwarded to the path builders. - plot.igraph(): re-clip elbow/diagonal endpoints via new i.axis_clip_endpoints() (reuses the shape clip functions with axis-aligned synthetic segments) and pass the per-edge axis to igraph.Arrows. - Tests: explicit-axis unit tests; an integration test asserting centre-axis attachment via the record renderer; re-blessed the elbow/diagonal/mixed snapshots (arc/straight snapshots unchanged). Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com> --- R/plot.R | 119 +++++++++++++++--- .../_snaps/plot/edge-style-diagonal.svg | 56 ++++----- .../testthat/_snaps/plot/edge-style-elbow.svg | 56 ++++----- .../testthat/_snaps/plot/edge-style-mixed.svg | 8 +- tests/testthat/test-plot.R | 56 +++++++++ 5 files changed, 220 insertions(+), 75 deletions(-) diff --git a/R/plot.R b/R/plot.R index 5a2276945fd..292cbf0472c 100644 --- a/R/plot.R +++ b/R/plot.R @@ -1047,6 +1047,30 @@ plot.igraph <- function( edge.style <- nl_aes$style edge.gradient <- as.logical(nl_aes$gradient) + # Axis-aware attachment for elbow/diagonal edges: re-clip their endpoints to + # the dominant-axis boundary (top/bottom- or left/right-centre) instead of + # the centre-to-centre diagonal point, so the orthogonal/diagonal routing + # meets each vertex on its centre axis. The chosen axis is passed to + # igraph.Arrows so the path builders route to match. Other styles keep the + # centre-to-centre clip from above. + eff.style <- ifelse( + edge.style == "auto", + ifelse(curved != 0, "arc", "straight"), + edge.style + ) + is.ed <- eff.style %in% c("elbow", "diagonal") + edge.axis <- rep(NA, length(x0)) + if (any(is.ed)) { + vert <- abs(edge.coords[, 4] - edge.coords[, 2]) >= + abs(edge.coords[, 3] - edge.coords[, 1]) + adj <- i.axis_clip_endpoints(edge.coords, el, shape, params, vert) + x0[is.ed] <- adj[is.ed, 1] + y0[is.ed] <- adj[is.ed, 2] + x1[is.ed] <- adj[is.ed, 3] + y1[is.ed] <- adj[is.ed, 4] + edge.axis[is.ed] <- vert[is.ed] + } + # Gradient edges: shaft colour runs from the source vertex colour to the # target vertex colour; the arrowhead uses the target colour. Only touch the # colour vectors when a gradient is actually requested, so plain plots are @@ -1093,7 +1117,8 @@ plot.igraph <- function( style = edge.style, gradient = edge.gradient, col.to = col.to.e, - ids = nonloops.e + ids = nonloops.e, + axis = edge.axis ) lc.x <- lc$lab.x lc.y <- lc$lab.y @@ -1126,7 +1151,8 @@ plot.igraph <- function( style = edge.style[valid], gradient = edge.gradient[valid], col.to = col.to.e[valid], - ids = nonloops.e[valid] + ids = nonloops.e[valid], + axis = edge.axis[valid] ) lc.x[valid] <- lc$lab.x lc.y[valid] <- lc$lab.y @@ -2155,11 +2181,14 @@ i.curved_spline <- function(x1, y1, x2, y2, sx1, sy1, sx2, sy2, lambda) { } # Geometry: two-corner orthogonal ("elbow") path between two points. -# Leaves along the dominant axis (larger absolute delta), turns at the midpoint -# of that axis, crosses, then turns into the target. Returns list(x, y) of the -# four polyline vertices. -i.elbow_path <- function(x0, y0, x1, y1) { - if (abs(x1 - x0) >= abs(y1 - y0)) { +# Leaves along the dominant axis, turns at the midpoint of that axis, crosses, +# then turns into the target. `vertical` forces the leaving axis (TRUE = leave +# vertically); when NULL the dominant axis is inferred from the endpoints. The +# caller passes it explicitly so it matches the axis used to attach the +# endpoints. Returns list(x, y) of the four polyline vertices. +i.elbow_path <- function(x0, y0, x1, y1, vertical = NULL) { + vert <- if (is.null(vertical)) abs(y1 - y0) > abs(x1 - x0) else vertical + if (!vert) { mid <- (x0 + x1) / 2 list(x = c(x0, mid, mid, x1), y = c(y0, y0, y1, y1)) } else { @@ -2168,11 +2197,13 @@ i.elbow_path <- function(x0, y0, x1, y1) { } } -# Geometry: smooth "diagonal" S-curve between two points, a cubic -# Bezier whose control points sit on the dominant axis so the curve leaves and -# enters along that axis. Returns list(x, y) sampled at `n` points. -i.diagonal_path <- function(x0, y0, x1, y1, n = 30) { - if (abs(x1 - x0) >= abs(y1 - y0)) { +# Geometry: smooth "diagonal" S-curve between two points, a cubic Bezier whose +# control points sit on the dominant axis so the curve leaves and enters along +# that axis. `vertical` forces the leaving axis (see i.elbow_path); when NULL it +# is inferred from the endpoints. Returns list(x, y) sampled at `n` points. +i.diagonal_path <- function(x0, y0, x1, y1, n = 30, vertical = NULL) { + vert <- if (is.null(vertical)) abs(y1 - y0) > abs(x1 - x0) else vertical + if (!vert) { mid <- (x0 + x1) / 2 cp <- rbind(c(x0, y0), c(mid, y0), c(mid, y1), c(x1, y1)) } else { @@ -2183,6 +2214,57 @@ i.diagonal_path <- function(x0, y0, x1, y1, n = 30) { list(x = p[1, ], y = p[2, ]) } +# Re-clip edge endpoints along the dominant axis instead of the centre-to-centre +# line, for elbow/diagonal edges. `edge.coords` holds the centre-to-centre +# coordinates (columns from.x, from.y, to.x, to.y); `el` is the edge list, +# `shape` the per-vertex shape vector, `params` the resolved plotting params, and +# `vertical` a per-edge flag (TRUE = leave/enter vertically). Returns a 4-column +# matrix of axis-aligned boundary points. It reuses the shape clip functions by +# feeding them axis-aligned synthetic segments, so the boundary is correct for +# every shape (circle/square/rectangle). +i.axis_clip_endpoints <- function(edge.coords, el, shape, params, vertical) { + cx1 <- edge.coords[, 1] + cy1 <- edge.coords[, 2] + cx2 <- edge.coords[, 3] + cy2 <- edge.coords[, 4] + + # Synthetic segments whose direction at each end is axis-aligned: the "from" + # end leaves toward the target along the axis, the "to" end enters from the + # source side along the axis. + synth_from <- cbind( + cx1, + cy1, + ifelse(vertical, cx1, cx2), + ifelse(vertical, cy2, cy1) + ) + synth_to <- cbind( + ifelse(vertical, cx2, cx1), + ifelse(vertical, cy1, cy2), + cx2, + cy2 + ) + + clip_end <- function(coords, end) { + if (length(unique(shape)) == 1) { + .igraph.shapes[[shape[1]]]$clip(coords, el, params = params, end = end) + } else { + idx <- if (end == "from") el[, 1] else el[, 2] + t(sapply(seq_len(nrow(coords)), function(x) { + .igraph.shapes[[shape[idx[x]]]]$clip( + coords[x, , drop = FALSE], + el[x, , drop = FALSE], + params = params, + end = end + ) + })) + } + } + + from <- clip_end(synth_from, "from") + to <- clip_end(synth_to, "to") + cbind(from[, 1], from[, 2], to[, 1], to[, 2]) +} + # Apply a per-element alpha (transparency, in [0, 1]) to a colour vector by # multiplying any existing alpha. A no-op when every alpha is 1, so the default # leaves colours — and snapshots — byte-identical. @@ -2242,12 +2324,18 @@ igraph.Arrows <- function( style = "auto", gradient = FALSE, col.to = sh.col, - ids = NULL + ids = NULL, + axis = NULL ) { n <- length(x1) recycle <- function(x) rep(x, length.out = n) + # Per-edge leaving axis for elbow/diagonal styles (TRUE = vertical). When the + # caller supplies it (from the vertex centres) the path builders route to match + # the axis-aligned endpoint attachment; NULL leaves the auto inference. + axis <- if (is.null(axis)) rep(NA, n) else recycle(axis) + x1 <- recycle(x1) y1 <- recycle(y1) x2 <- recycle(x2) @@ -2362,10 +2450,11 @@ igraph.Arrows <- function( } } else { # elbow or diagonal: a polyline between the shaft endpoints + vert <- if (is.na(axis[i])) NULL else axis[i] path <- if (eff_style == "elbow") { - i.elbow_path(sx1, sy1, sx2, sy2) + i.elbow_path(sx1, sy1, sx2, sy2, vertical = vert) } else { - i.diagonal_path(sx1, sy1, sx2, sy2) + i.diagonal_path(sx1, sy1, sx2, sy2, vertical = vert) } if (gradient[i]) { i.draw_gradient_path( diff --git a/tests/testthat/_snaps/plot/edge-style-diagonal.svg b/tests/testthat/_snaps/plot/edge-style-diagonal.svg index c9c5fbb9cee..9ad71946bfc 100644 --- a/tests/testthat/_snaps/plot/edge-style-diagonal.svg +++ b/tests/testthat/_snaps/plot/edge-style-diagonal.svg @@ -25,34 +25,34 @@ </clipPath> </defs> <g clip-path='url(#cpNTkuMDR8Njg5Ljc2fDU5LjA0fDUwMi41Ng==)'> -<polyline points='367.21,95.48 366.88,101.07 365.90,106.29 364.34,111.17 362.24,115.73 359.64,120.01 356.59,124.02 353.14,127.79 349.34,131.36 345.23,134.76 340.86,138.00 336.27,141.11 331.52,144.13 326.66,147.08 321.72,149.99 316.76,152.89 311.82,155.80 306.96,158.75 302.21,161.77 297.63,164.89 293.26,168.13 289.15,171.52 285.34,175.09 281.89,178.86 278.84,182.88 276.24,187.15 274.14,191.71 272.58,196.59 271.61,201.81 271.27,207.41 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='269.82,201.55 270.33,202.64 270.82,204.05 271.20,207.40 271.34,207.41 272.12,204.12 272.77,202.78 273.41,201.76 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='381.59,95.48 381.92,101.07 382.90,106.29 384.46,111.17 386.56,115.73 389.16,120.01 392.21,124.02 395.66,127.79 399.46,131.36 403.57,134.76 407.94,138.00 412.53,141.11 417.28,144.13 422.14,147.08 427.08,149.99 432.04,152.89 436.98,155.80 441.84,158.75 446.59,161.77 451.17,164.89 455.54,168.13 459.65,171.52 463.46,175.09 466.91,178.86 469.96,182.88 472.56,187.15 474.66,191.71 476.22,196.59 477.19,201.81 477.53,207.41 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='475.39,201.76 476.03,202.78 476.68,204.12 477.46,207.41 477.60,207.40 477.98,204.05 478.47,202.64 478.98,201.55 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='259.36,226.38 259.19,231.80 258.72,236.85 257.97,241.57 256.95,245.98 255.69,250.12 254.22,254.00 252.55,257.65 250.71,261.11 248.72,264.39 246.61,267.53 244.39,270.54 242.09,273.46 239.74,276.32 237.35,279.13 234.95,281.94 232.56,284.75 230.21,287.61 227.91,290.53 225.69,293.54 223.58,296.68 221.59,299.96 219.75,303.42 218.08,307.07 216.60,310.95 215.35,315.09 214.33,319.50 213.57,324.22 213.10,329.27 212.94,334.69 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='211.31,328.88 211.86,329.95 212.39,331.34 212.87,334.69 213.01,334.69 213.69,331.38 214.30,330.02 214.91,328.98 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='268.06,226.38 268.22,231.80 268.69,236.85 269.45,241.57 270.47,245.98 271.72,250.12 273.20,254.00 274.87,257.65 276.71,261.11 278.70,264.39 280.81,267.53 283.03,270.54 285.33,273.46 287.68,276.32 290.07,279.13 292.47,281.94 294.86,284.75 297.21,287.61 299.51,290.53 301.72,293.54 303.84,296.68 305.83,299.96 307.67,303.42 309.34,307.07 310.81,310.95 312.07,315.09 313.09,319.50 313.84,324.22 314.31,329.27 314.48,334.69 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='312.50,328.98 313.11,330.02 313.73,331.38 314.40,334.69 314.55,334.69 315.02,331.34 315.56,329.95 316.10,328.88 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='480.74,226.38 480.58,231.80 480.11,236.85 479.35,241.57 478.33,245.98 477.08,250.12 475.60,254.00 473.93,257.65 472.09,261.11 470.10,264.39 467.99,267.53 465.77,270.54 463.47,273.46 461.12,276.32 458.73,279.13 456.33,281.94 453.94,284.75 451.59,287.61 449.29,290.53 447.08,293.54 444.96,296.68 442.97,299.96 441.13,303.42 439.46,307.07 437.99,310.95 436.73,315.09 435.71,319.50 434.96,324.22 434.49,329.27 434.32,334.69 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='432.70,328.88 433.24,329.95 433.78,331.34 434.25,334.69 434.40,334.69 435.07,331.38 435.69,330.02 436.30,328.98 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='489.44,226.38 489.61,231.80 490.08,236.85 490.83,241.57 491.85,245.98 493.11,250.12 494.58,254.00 496.25,257.65 498.09,261.11 500.08,264.39 502.19,267.53 504.41,270.54 506.71,273.46 509.06,276.32 511.45,279.13 513.85,281.94 516.24,284.75 518.59,287.61 520.89,290.53 523.11,293.54 525.22,296.68 527.21,299.96 529.05,303.42 530.72,307.07 532.20,310.95 533.45,315.09 534.47,319.50 535.23,324.22 535.70,329.27 535.86,334.69 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='533.89,328.98 534.50,330.02 535.11,331.38 535.79,334.69 535.93,334.69 536.41,331.34 536.94,329.95 537.49,328.88 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='206.05,356.17 205.97,361.52 205.74,366.51 205.36,371.17 204.86,375.53 204.24,379.62 203.51,383.45 202.69,387.06 201.78,390.47 200.79,393.71 199.75,396.81 198.66,399.79 197.52,402.67 196.36,405.49 195.18,408.28 193.99,411.04 192.81,413.82 191.65,416.64 190.52,419.53 189.42,422.51 188.38,425.60 187.40,428.85 186.49,432.26 185.66,435.87 184.93,439.70 184.31,443.79 183.81,448.15 183.44,452.81 183.20,457.80 183.12,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='181.41,457.36 181.97,458.43 182.53,459.81 183.05,463.14 183.20,463.15 183.82,459.83 184.42,458.46 185.01,457.41 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='210.68,356.17 210.76,361.52 210.99,366.51 211.36,371.17 211.86,375.53 212.49,379.62 213.21,383.45 214.04,387.06 214.95,390.47 215.93,393.71 216.97,396.81 218.07,399.79 219.20,402.67 220.37,405.49 221.55,408.28 222.73,411.04 223.91,413.82 225.07,416.64 226.21,419.53 227.30,422.51 228.35,425.60 229.33,428.85 230.24,432.26 231.06,435.87 231.79,439.70 232.41,443.79 232.91,448.15 233.29,452.81 233.52,457.80 233.60,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='231.71,457.41 232.31,458.46 232.90,459.83 233.53,463.15 233.67,463.14 234.20,459.81 234.75,458.43 235.31,457.36 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='316.74,356.17 316.66,361.52 316.43,366.51 316.05,371.17 315.55,375.53 314.93,379.62 314.20,383.45 313.38,387.06 312.47,390.47 311.49,393.71 310.44,396.81 309.35,399.79 308.21,402.67 307.05,405.49 305.87,408.28 304.69,411.04 303.51,413.82 302.34,416.64 301.21,419.53 300.11,422.51 299.07,425.60 298.09,428.85 297.18,432.26 296.35,435.87 295.63,439.70 295.00,443.79 294.50,448.15 294.13,452.81 293.90,457.80 293.82,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='292.10,457.36 292.66,458.43 293.22,459.81 293.74,463.14 293.89,463.15 294.51,459.83 295.11,458.46 295.70,457.41 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='321.37,356.17 321.45,361.52 321.68,366.51 322.05,371.17 322.56,375.53 323.18,379.62 323.91,383.45 324.73,387.06 325.64,390.47 326.62,393.71 327.67,396.81 328.76,399.79 329.90,402.67 331.06,405.49 332.24,408.28 333.42,411.04 334.60,413.82 335.77,416.64 336.90,419.53 337.99,422.51 339.04,425.60 340.02,428.85 340.93,432.26 341.75,435.87 342.48,439.70 343.10,443.79 343.61,448.15 343.98,452.81 344.21,457.80 344.29,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='342.41,457.41 343.00,458.46 343.59,459.83 344.22,463.15 344.36,463.14 344.89,459.81 345.45,458.43 346.01,457.36 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='427.43,356.17 427.35,361.52 427.12,366.51 426.75,371.17 426.24,375.53 425.62,379.62 424.89,383.45 424.07,387.06 423.16,390.47 422.18,393.71 421.13,396.81 420.04,399.79 418.90,402.67 417.74,405.49 416.56,408.28 415.38,411.04 414.20,413.82 413.03,416.64 411.90,419.53 410.81,422.51 409.76,425.60 408.78,428.85 407.87,432.26 407.05,435.87 406.32,439.70 405.70,443.79 405.19,448.15 404.82,452.81 404.59,457.80 404.51,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='402.79,457.36 403.35,458.43 403.91,459.81 404.44,463.14 404.58,463.15 405.21,459.83 405.80,458.46 406.39,457.41 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='432.06,356.17 432.14,361.52 432.37,366.51 432.75,371.17 433.25,375.53 433.87,379.62 434.60,383.45 435.42,387.06 436.33,390.47 437.31,393.71 438.36,396.81 439.45,399.79 440.59,402.67 441.75,405.49 442.93,408.28 444.11,411.04 445.29,413.82 446.46,416.64 447.59,419.53 448.69,422.51 449.73,425.60 450.71,428.85 451.62,432.26 452.45,435.87 453.17,439.70 453.80,443.79 454.30,448.15 454.67,452.81 454.90,457.80 454.98,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='453.10,457.41 453.69,458.46 454.29,459.83 454.91,463.15 455.06,463.14 455.58,459.81 456.14,458.43 456.70,457.36 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='538.12,356.17 538.04,361.52 537.81,366.51 537.44,371.17 536.94,375.53 536.31,379.62 535.59,383.45 534.76,387.06 533.85,390.47 532.87,393.71 531.83,396.81 530.73,399.79 529.60,402.67 528.43,405.49 527.25,408.28 526.07,411.04 524.89,413.82 523.73,416.64 522.59,419.53 521.50,422.51 520.45,425.60 519.47,428.85 518.56,432.26 517.74,435.87 517.01,439.70 516.39,443.79 515.89,448.15 515.51,452.81 515.28,457.80 515.20,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='513.49,457.36 514.05,458.43 514.60,459.81 515.13,463.14 515.27,463.15 515.90,459.83 516.49,458.46 517.09,457.41 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='542.75,356.17 542.83,361.52 543.06,366.51 543.44,371.17 543.94,375.53 544.56,379.62 545.29,383.45 546.11,387.06 547.02,390.47 548.01,393.71 549.05,396.81 550.14,399.79 551.28,402.67 552.44,405.49 553.62,408.28 554.81,411.04 555.99,413.82 557.15,416.64 558.28,419.53 559.38,422.51 560.42,425.60 561.40,428.85 562.31,432.26 563.14,435.87 563.87,439.70 564.49,443.79 564.99,448.15 565.36,452.81 565.60,457.80 565.68,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='563.79,457.41 564.38,458.46 564.98,459.83 565.60,463.15 565.75,463.14 566.27,459.81 566.83,458.43 567.39,457.36 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='374.82,98.31 374.43,103.63 373.30,108.59 371.50,113.22 369.06,117.55 366.05,121.61 362.52,125.42 358.52,129.00 354.12,132.40 349.35,135.62 344.29,138.69 338.99,141.65 333.49,144.52 327.85,147.32 322.13,150.09 316.39,152.84 310.67,155.60 305.04,158.40 299.54,161.27 294.23,164.23 289.17,167.30 284.41,170.53 280.00,173.92 276.01,177.50 272.48,181.31 269.47,185.37 267.03,189.70 265.22,194.33 264.10,199.29 263.71,204.61 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='262.33,198.73 262.83,199.83 263.30,201.24 263.64,204.60 263.78,204.61 264.60,201.34 265.27,200.01 265.92,198.99 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='373.98,98.31 374.37,103.63 375.50,108.59 377.30,113.22 379.74,117.55 382.75,121.61 386.28,125.42 390.28,129.00 394.68,132.40 399.45,135.62 404.51,138.69 409.81,141.65 415.31,144.52 420.95,147.32 426.67,150.09 432.41,152.84 438.13,155.60 443.76,158.40 449.26,161.27 454.57,164.23 459.63,167.30 464.39,170.53 468.80,173.92 472.79,177.50 476.32,181.31 479.33,185.37 481.77,189.70 483.58,194.33 484.70,199.29 485.09,204.61 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='482.88,198.99 483.53,200.01 484.20,201.34 485.02,204.61 485.16,204.60 485.50,201.24 485.97,199.83 486.47,198.73 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='263.97,227.34 263.78,232.66 263.22,237.63 262.31,242.26 261.09,246.60 259.59,250.66 257.82,254.47 255.82,258.07 253.61,261.46 251.23,264.68 248.70,267.76 246.04,270.73 243.29,273.60 240.47,276.40 237.61,279.17 234.73,281.92 231.87,284.69 229.05,287.49 226.30,290.36 223.64,293.33 221.11,296.41 218.72,299.63 216.52,303.02 214.52,306.61 212.75,310.43 211.24,314.49 210.02,318.83 209.12,323.46 208.56,328.43 208.36,333.75 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='206.77,327.93 207.31,329.00 207.84,330.40 208.29,333.74 208.43,333.75 209.13,330.45 209.76,329.09 210.37,328.06 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='263.44,227.34 263.64,232.66 264.20,237.63 265.10,242.26 266.32,246.60 267.83,250.66 269.60,254.47 271.60,258.07 273.80,261.46 276.19,264.68 278.72,267.76 281.38,270.73 284.13,273.60 286.95,276.40 289.81,279.17 292.69,281.92 295.55,284.69 298.37,287.49 301.12,290.36 303.78,293.33 306.31,296.41 308.69,299.63 310.90,303.02 312.90,306.61 314.66,310.43 316.17,314.49 317.39,318.83 318.30,323.46 318.86,328.43 319.05,333.75 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='317.05,328.06 317.66,329.09 318.29,330.45 318.98,333.75 319.13,333.74 319.58,330.40 320.11,329.00 320.64,327.93 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='485.36,227.34 485.16,232.66 484.60,237.63 483.70,242.26 482.48,246.60 480.97,250.66 479.20,254.47 477.20,258.07 475.00,261.46 472.61,264.68 470.08,267.76 467.42,270.73 464.67,273.60 461.85,276.40 458.99,279.17 456.11,281.92 453.25,284.69 450.43,287.49 447.68,290.36 445.02,293.33 442.49,296.41 440.11,299.63 437.90,303.02 435.90,306.61 434.14,310.43 432.63,314.49 431.41,318.83 430.50,323.46 429.94,328.43 429.75,333.75 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='428.16,327.93 428.69,329.00 429.22,330.40 429.67,333.74 429.82,333.75 430.51,330.45 431.14,329.09 431.75,328.06 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='484.83,227.34 485.02,232.66 485.58,237.63 486.49,242.26 487.71,246.60 489.21,250.66 490.98,254.47 492.98,258.07 495.19,261.46 497.57,264.68 500.10,267.76 502.76,270.73 505.51,273.60 508.33,276.40 511.19,279.17 514.07,281.92 516.93,284.69 519.75,287.49 522.50,290.36 525.16,293.33 527.69,296.41 530.08,299.63 532.28,303.02 534.28,306.61 536.05,310.43 537.56,314.49 538.78,318.83 539.68,323.46 540.24,328.43 540.44,333.75 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='538.43,328.06 539.04,329.09 539.67,330.45 540.37,333.75 540.51,333.74 540.96,330.40 541.49,329.00 542.03,327.93 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='208.51,356.44 208.41,361.76 208.13,366.72 207.68,371.36 207.07,375.70 206.31,379.77 205.43,383.58 204.43,387.17 203.32,390.57 202.13,393.79 200.87,396.88 199.54,399.84 198.16,402.71 196.75,405.52 195.32,408.28 193.88,411.04 192.45,413.81 191.04,416.61 189.66,419.48 188.33,422.45 187.06,425.53 185.87,428.76 184.77,432.15 183.77,435.74 182.89,439.56 182.13,443.62 181.52,447.96 181.07,452.60 180.79,457.57 180.69,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='178.99,457.10 179.55,458.16 180.10,459.55 180.62,462.89 180.76,462.89 181.40,459.57 182.00,458.21 182.59,457.16 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='208.22,356.44 208.31,361.76 208.60,366.72 209.05,371.36 209.66,375.70 210.41,379.77 211.30,383.58 212.30,387.17 213.40,390.57 214.59,393.79 215.86,396.88 217.19,399.84 218.56,402.71 219.98,405.52 221.41,408.28 222.85,411.04 224.28,413.81 225.69,416.61 227.06,419.48 228.39,422.45 229.66,425.53 230.85,428.76 231.96,432.15 232.96,435.74 233.84,439.56 234.59,443.62 235.20,447.96 235.66,452.60 235.94,457.57 236.04,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='234.13,457.16 234.73,458.21 235.33,459.57 235.96,462.89 236.11,462.89 236.62,459.55 237.17,458.16 237.73,457.10 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='319.20,356.44 319.10,361.76 318.82,366.72 318.37,371.36 317.76,375.70 317.00,379.77 316.12,383.58 315.12,387.17 314.02,390.57 312.82,393.79 311.56,396.88 310.23,399.84 308.85,402.71 307.44,405.52 306.01,408.28 304.57,411.04 303.14,413.81 301.73,416.61 300.35,419.48 299.02,422.45 297.76,425.53 296.56,428.76 295.46,432.15 294.46,435.74 293.58,439.56 292.82,443.62 292.21,447.96 291.76,452.60 291.48,457.57 291.38,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='289.69,457.10 290.24,458.16 290.79,459.55 291.31,462.89 291.45,462.89 292.09,459.57 292.69,458.21 293.29,457.16 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='318.91,356.44 319.01,361.76 319.29,366.72 319.74,371.36 320.35,375.70 321.10,379.77 321.99,383.58 322.99,387.17 324.09,390.57 325.28,393.79 326.55,396.88 327.88,399.84 329.26,402.71 330.67,405.52 332.10,408.28 333.54,411.04 334.97,413.81 336.38,416.61 337.76,419.48 339.08,422.45 340.35,425.53 341.54,428.76 342.65,432.15 343.65,435.74 344.53,439.56 345.29,443.62 345.90,447.96 346.35,452.60 346.63,457.57 346.73,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='344.82,457.16 345.42,458.21 346.02,459.57 346.66,462.89 346.80,462.89 347.31,459.55 347.87,458.16 348.42,457.10 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='429.89,356.44 429.79,361.76 429.51,366.72 429.06,371.36 428.45,375.70 427.70,379.77 426.81,383.58 425.81,387.17 424.71,390.57 423.52,393.79 422.25,396.88 420.92,399.84 419.54,402.71 418.13,405.52 416.70,408.28 415.26,411.04 413.83,413.81 412.42,416.61 411.04,419.48 409.72,422.45 408.45,425.53 407.26,428.76 406.15,432.15 405.15,435.74 404.27,439.56 403.51,443.62 402.90,447.96 402.45,452.60 402.17,457.57 402.07,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='400.38,457.10 400.93,458.16 401.49,459.55 402.00,462.89 402.14,462.89 402.78,459.57 403.38,458.21 403.98,457.16 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='429.60,356.44 429.70,361.76 429.98,366.72 430.43,371.36 431.04,375.70 431.80,379.77 432.68,383.58 433.68,387.17 434.78,390.57 435.98,393.79 437.24,396.88 438.57,399.84 439.95,402.71 441.36,405.52 442.79,408.28 444.23,411.04 445.66,413.81 447.07,416.61 448.45,419.48 449.78,422.45 451.04,425.53 452.24,428.76 453.34,432.15 454.34,435.74 455.22,439.56 455.98,443.62 456.59,447.96 457.04,452.60 457.32,457.57 457.42,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='455.51,457.16 456.11,458.21 456.71,459.57 457.35,462.89 457.49,462.89 458.01,459.55 458.56,458.16 459.11,457.10 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='540.58,356.44 540.49,361.76 540.20,366.72 539.75,371.36 539.14,375.70 538.39,379.77 537.50,383.58 536.50,387.17 535.40,390.57 534.21,393.79 532.94,396.88 531.61,399.84 530.24,402.71 528.82,405.52 527.39,408.28 525.95,411.04 524.52,413.81 523.11,416.61 521.74,419.48 520.41,422.45 519.14,425.53 517.95,428.76 516.84,432.15 515.84,435.74 514.96,439.56 514.21,443.62 513.60,447.96 513.14,452.60 512.86,457.57 512.76,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='511.07,457.10 511.63,458.16 512.18,459.55 512.69,462.89 512.84,462.89 513.47,459.57 514.07,458.21 514.67,457.16 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='540.29,356.44 540.39,361.76 540.67,366.72 541.12,371.36 541.73,375.70 542.49,379.77 543.37,383.58 544.37,387.17 545.48,390.57 546.67,393.79 547.93,396.88 549.26,399.84 550.64,402.71 552.05,405.52 553.48,408.28 554.92,411.04 556.35,413.81 557.76,416.61 559.14,419.48 560.47,422.45 561.74,425.53 562.93,428.76 564.03,432.15 565.03,435.74 565.91,439.56 566.67,443.62 567.28,447.96 567.73,452.60 568.01,457.57 568.11,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='566.21,457.16 566.80,458.21 567.40,459.57 568.04,462.89 568.18,462.89 568.70,459.55 569.25,458.16 569.81,457.10 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> <circle cx='374.40' cy='87.09' r='11.62' style='stroke-width: 0.75; fill: #E69F00;' /> <circle cx='263.71' cy='216.23' r='11.62' style='stroke-width: 0.75; fill: #E69F00;' /> <circle cx='485.09' cy='216.23' r='11.62' style='stroke-width: 0.75; fill: #E69F00;' /> diff --git a/tests/testthat/_snaps/plot/edge-style-elbow.svg b/tests/testthat/_snaps/plot/edge-style-elbow.svg index e4d8ee86e9f..60b23b847db 100644 --- a/tests/testthat/_snaps/plot/edge-style-elbow.svg +++ b/tests/testthat/_snaps/plot/edge-style-elbow.svg @@ -25,34 +25,34 @@ </clipPath> </defs> <g clip-path='url(#cpNTkuMDR8Njg5Ljc2fDU5LjA0fDUwMi41Ng==)'> -<polyline points='367.21,95.48 367.21,151.44 271.27,151.44 271.27,207.41 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='269.47,201.65 270.05,202.70 270.62,204.08 271.20,207.41 271.34,207.41 271.92,204.08 272.50,202.70 273.07,201.65 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='381.59,95.48 381.59,151.44 477.53,151.44 477.53,207.41 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='475.73,201.65 476.30,202.70 476.88,204.08 477.46,207.41 477.60,207.41 478.18,204.08 478.75,202.70 479.33,201.65 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='259.36,226.38 259.36,280.54 212.94,280.54 212.94,334.69 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='211.14,328.93 211.72,329.98 212.29,331.36 212.87,334.69 213.01,334.69 213.59,331.36 214.16,329.98 214.74,328.93 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='268.06,226.38 268.06,280.54 314.48,280.54 314.48,334.69 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='312.68,328.93 313.25,329.98 313.83,331.36 314.40,334.69 314.55,334.69 315.12,331.36 315.70,329.98 316.28,328.93 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='480.74,226.38 480.74,280.54 434.32,280.54 434.32,334.69 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='432.52,328.93 433.10,329.98 433.68,331.36 434.25,334.69 434.40,334.69 434.97,331.36 435.55,329.98 436.12,328.93 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='489.44,226.38 489.44,280.54 535.86,280.54 535.86,334.69 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='534.06,328.93 534.64,329.98 535.21,331.36 535.79,334.69 535.93,334.69 536.51,331.36 537.08,329.98 537.66,328.93 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='206.05,356.17 206.05,409.66 183.12,409.66 183.12,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='181.32,457.39 181.90,458.44 182.48,459.82 183.05,463.15 183.20,463.15 183.77,459.82 184.35,458.44 184.92,457.39 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='210.68,356.17 210.68,409.66 233.60,409.66 233.60,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='231.80,457.39 232.38,458.44 232.95,459.82 233.53,463.15 233.67,463.15 234.25,459.82 234.82,458.44 235.40,457.39 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='316.74,356.17 316.74,409.66 293.82,409.66 293.82,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='292.02,457.39 292.59,458.44 293.17,459.82 293.74,463.15 293.89,463.15 294.46,459.82 295.04,458.44 295.62,457.39 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='321.37,356.17 321.37,409.66 344.29,409.66 344.29,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='342.49,457.39 343.07,458.44 343.64,459.82 344.22,463.15 344.36,463.15 344.94,459.82 345.52,458.44 346.09,457.39 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='427.43,356.17 427.43,409.66 404.51,409.66 404.51,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='402.71,457.39 403.28,458.44 403.86,459.82 404.44,463.15 404.58,463.15 405.16,459.82 405.73,458.44 406.31,457.39 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='432.06,356.17 432.06,409.66 454.98,409.66 454.98,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='453.18,457.39 453.76,458.44 454.34,459.82 454.91,463.15 455.06,463.15 455.63,459.82 456.21,458.44 456.78,457.39 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='538.12,356.17 538.12,409.66 515.20,409.66 515.20,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='513.40,457.39 513.98,458.44 514.55,459.82 515.13,463.15 515.27,463.15 515.85,459.82 516.42,458.44 517.00,457.39 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='542.75,356.17 542.75,409.66 565.68,409.66 565.68,463.15 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='563.88,457.39 564.45,458.44 565.03,459.82 565.60,463.15 565.75,463.15 566.32,459.82 566.90,458.44 567.48,457.39 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='374.82,98.31 374.82,151.46 263.71,151.46 263.71,204.61 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='261.91,198.85 262.48,199.90 263.06,201.28 263.64,204.61 263.78,204.61 264.36,201.28 264.93,199.90 265.51,198.85 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='373.98,98.31 373.98,151.46 485.09,151.46 485.09,204.61 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='483.29,198.85 483.87,199.90 484.44,201.28 485.02,204.61 485.16,204.61 485.74,201.28 486.32,199.90 486.89,198.85 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='263.97,227.34 263.97,280.54 208.36,280.54 208.36,333.75 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='206.56,327.99 207.14,329.04 207.71,330.42 208.29,333.75 208.43,333.75 209.01,330.42 209.59,329.04 210.16,327.99 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='263.44,227.34 263.44,280.54 319.05,280.54 319.05,333.75 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='317.25,327.99 317.83,329.04 318.41,330.42 318.98,333.75 319.13,333.75 319.70,330.42 320.28,329.04 320.85,327.99 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='485.36,227.34 485.36,280.54 429.75,280.54 429.75,333.75 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='427.95,327.99 428.52,329.04 429.10,330.42 429.67,333.75 429.82,333.75 430.39,330.42 430.97,329.04 431.55,327.99 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='484.83,227.34 484.83,280.54 540.44,280.54 540.44,333.75 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='538.64,327.99 539.21,329.04 539.79,330.42 540.37,333.75 540.51,333.75 541.09,330.42 541.66,329.04 542.24,327.99 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='208.51,356.44 208.51,409.66 180.69,409.66 180.69,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='178.89,457.13 179.47,458.19 180.04,459.56 180.62,462.89 180.76,462.89 181.34,459.56 181.91,458.19 182.49,457.13 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='208.22,356.44 208.22,409.66 236.04,409.66 236.04,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='234.24,457.13 234.81,458.19 235.39,459.56 235.96,462.89 236.11,462.89 236.68,459.56 237.26,458.19 237.84,457.13 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='319.20,356.44 319.20,409.66 291.38,409.66 291.38,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='289.58,457.13 290.16,458.19 290.73,459.56 291.31,462.89 291.45,462.89 292.03,459.56 292.61,458.19 293.18,457.13 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='318.91,356.44 318.91,409.66 346.73,409.66 346.73,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='344.93,457.13 345.50,458.19 346.08,459.56 346.66,462.89 346.80,462.89 347.38,459.56 347.95,458.19 348.53,457.13 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='429.89,356.44 429.89,409.66 402.07,409.66 402.07,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='400.27,457.13 400.85,458.19 401.42,459.56 402.00,462.89 402.14,462.89 402.72,459.56 403.30,458.19 403.87,457.13 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='429.60,356.44 429.60,409.66 457.42,409.66 457.42,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='455.62,457.13 456.19,458.19 456.77,459.56 457.35,462.89 457.49,462.89 458.07,459.56 458.64,458.19 459.22,457.13 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='540.58,356.44 540.58,409.66 512.76,409.66 512.76,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='510.96,457.13 511.54,458.19 512.12,459.56 512.69,462.89 512.84,462.89 513.41,459.56 513.99,458.19 514.56,457.13 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='540.29,356.44 540.29,409.66 568.11,409.66 568.11,462.89 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='566.31,457.13 566.89,458.19 567.46,459.56 568.04,462.89 568.18,462.89 568.76,459.56 569.33,458.19 569.91,457.13 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> <circle cx='374.40' cy='87.09' r='11.62' style='stroke-width: 0.75; fill: #E69F00;' /> <circle cx='263.71' cy='216.23' r='11.62' style='stroke-width: 0.75; fill: #E69F00;' /> <circle cx='485.09' cy='216.23' r='11.62' style='stroke-width: 0.75; fill: #E69F00;' /> diff --git a/tests/testthat/_snaps/plot/edge-style-mixed.svg b/tests/testthat/_snaps/plot/edge-style-mixed.svg index 17e8d49d91f..aeaf32bb50b 100644 --- a/tests/testthat/_snaps/plot/edge-style-mixed.svg +++ b/tests/testthat/_snaps/plot/edge-style-mixed.svg @@ -29,10 +29,10 @@ <polygon points='510.58,130.59 511.39,129.84 512.37,129.03 513.68,128.15 517.04,126.75 517.01,126.61 513.38,126.96 511.81,126.80 510.57,126.55 509.50,126.26 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> <polyline points='528.99,137.55 528.99,137.63 529.02,138.19 529.09,139.61 529.20,142.17 529.36,146.01 529.56,151.16 529.79,157.49 530.02,164.78 530.25,172.76 530.45,181.11 530.61,189.56 530.70,197.89 530.72,205.93 530.67,213.58 530.52,220.78 530.29,227.52 529.96,233.83 529.52,239.75 528.98,245.33 528.33,250.65 527.55,255.76 526.65,260.74 525.63,265.64 525.42,266.57 524.24,271.44 522.91,276.31 521.42,281.24 519.74,286.28 517.84,291.51 515.70,296.97 513.31,302.73 510.64,308.83 507.69,315.29 504.47,322.12 501.00,329.29 497.32,336.70 493.52,344.22 489.71,351.67 486.00,358.80 482.57,365.36 479.53,371.10 477.03,375.80 475.12,379.36 473.82,381.78 473.07,383.17 472.75,383.75 472.69,383.86 472.69,383.86 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> <polygon points='474.04,376.45 474.08,377.55 474.02,378.82 473.81,380.39 472.62,383.83 472.75,383.90 474.90,380.96 476.07,379.88 477.07,379.12 478.00,378.51 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='454.37,402.11 366.86,402.11 366.86,435.77 279.35,435.77 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='286.55,433.53 285.58,434.07 284.44,434.61 282.95,435.15 279.35,435.69 279.35,435.84 282.95,436.38 284.44,436.92 285.58,437.46 286.55,438.00 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> -<polyline points='260.88,423.97 260.74,413.64 260.32,404.00 259.64,394.99 258.74,386.57 257.62,378.68 256.30,371.27 254.82,364.30 253.18,357.71 251.41,351.44 249.53,345.46 247.55,339.71 245.51,334.13 243.41,328.69 241.28,323.31 239.15,317.97 237.02,312.59 234.92,307.15 232.88,301.57 230.90,295.82 229.02,289.84 227.25,283.57 225.61,276.98 224.12,270.01 222.81,262.60 221.69,254.71 220.78,246.29 220.11,237.29 219.69,227.64 219.55,217.31 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> -<polygon points='221.88,224.48 221.33,223.52 220.77,222.39 220.21,220.90 219.62,217.31 219.48,217.31 218.99,220.92 218.47,222.42 217.94,223.57 217.42,224.54 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='454.08,399.10 366.85,399.10 366.85,438.75 279.63,438.75 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='286.83,436.52 285.87,437.06 284.72,437.60 283.23,438.14 279.63,438.68 279.63,438.82 283.23,439.36 284.72,439.90 285.87,440.44 286.83,440.98 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> +<polyline points='264.00,423.66 263.83,413.36 263.35,403.74 262.58,394.76 261.53,386.37 260.24,378.50 258.73,371.12 257.02,364.17 255.14,357.59 253.10,351.35 250.94,345.39 248.66,339.65 246.31,334.09 243.90,328.66 241.45,323.30 239.00,317.97 236.55,312.62 234.14,307.18 231.78,301.63 229.51,295.89 227.35,289.93 225.31,283.68 223.42,277.11 221.71,270.16 220.20,262.77 218.92,254.91 217.87,246.51 217.10,237.53 216.62,227.92 216.45,217.62 ' style='stroke-width: 0.75; stroke: #A9A9A9;' /> +<polygon points='218.80,224.78 218.24,223.83 217.69,222.69 217.12,221.21 216.52,217.62 216.38,217.62 215.90,221.23 215.38,222.73 214.86,223.88 214.34,224.86 ' style='stroke-width: 0.75; stroke: #A9A9A9; fill: #A9A9A9;' /> <circle cx='216.45' cy='201.83' r='15.79' style='stroke-width: 0.75; fill: #E69F00;' /> <circle cx='532.35' cy='122.85' r='15.79' style='stroke-width: 0.75; fill: #E69F00;' /> <circle cx='469.17' cy='399.26' r='15.79' style='stroke-width: 0.75; fill: #E69F00;' /> diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index c4b50bfe7a4..8c53400c2ef 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -325,6 +325,62 @@ test_that("i.diagonal_path is a smooth path between the endpoints", { expect_equal(d, i.diagonal_path(0, 0, 10, 4, n = 30)) }) +test_that("an explicit `vertical` overrides the inferred dominant axis", { + # horizontal-dominant deltas, but vertical = TRUE forces a vertical leave + e <- i.elbow_path(0, 0, 10, 4, vertical = TRUE) + expect_equal(e$x, c(0, 0, 10, 10)) + expect_equal(e$y, c(0, 2, 2, 4)) + # and vertical = FALSE forces a horizontal leave on vertical-dominant deltas + h <- i.elbow_path(0, 0, 4, 10, vertical = FALSE) + expect_equal(h$x, c(0, 2, 2, 4)) + expect_equal(h$y, c(0, 0, 10, 10)) +}) + +test_that("elbow/diagonal edges attach on the vertex centre axis", { + # vertical-dominant edge whose endpoints have different x: a centre-to-centre + # clip would attach off the parent/child x; the axis-aware clip must keep the + # first/last shaft point on each vertex's centre x. + g <- make_graph(c(1, 2), directed = TRUE) + lay <- matrix(c(0, 1, 0.3, -1), ncol = 2, byrow = TRUE) + + grDevices::pdf(NULL) + withr::defer(grDevices::dev.off()) + + shaft_x <- function(style) { + rec <- i.renderer_record() + i.with_renderer( + rec, + plot( + g, + layout = lay, + rescale = FALSE, + xlim = c(-1, 1), + ylim = c(-1, 1), + edge.style = style, + vertex.size = 20, + # no arrowhead: avoids the shaft pull-back so the path starts/ends + # exactly at the clipped attachment points + edge.arrow.mode = 0 + ) + ) + prims <- rec$.state$prims + pl <- Filter( + function(p) { + identical(p$type, "polyline") && + !is.null(p$group) && identical(p$group$type, "edge") + }, + prims + )[[1]] + c(first = pl$x[1], last = pl$x[length(pl$x)]) + } + + for (style in c("elbow", "diagonal")) { + xs <- shaft_x(style) + expect_equal(unname(xs["first"]), 0, tolerance = 1e-6) # parent centre x + expect_equal(unname(xs["last"]), 0.3, tolerance = 1e-6) # child centre x + } +}) + test_that("i.arrowhead_shape returns matched polar arrays ending in NA", { # Pure geometry helper extracted from igraph.Arrows; device-free. head <- i.arrowhead_shape(cin = 0.2, w = 1.5, delta = 0.01) From 3728a88edfe3e09256a25f9fbf362d67f82cd425 Mon Sep 17 00:00:00 2001 From: schochastics <schochastics@users.noreply.github.com> Date: Thu, 25 Jun 2026 08:07:01 +0000 Subject: [PATCH 30/30] chore: Auto-update from GitHub Actions Run: https://github.com/igraph/rigraph/actions/runs/28155463550 --- tests/testthat/test-plot.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 8c53400c2ef..3a5f8c10257 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -367,7 +367,8 @@ test_that("elbow/diagonal edges attach on the vertex centre axis", { pl <- Filter( function(p) { identical(p$type, "polyline") && - !is.null(p$group) && identical(p$group$type, "edge") + !is.null(p$group) && + identical(p$group$type, "edge") }, prims )[[1]]