diff --git a/R/plot.R b/R/plot.R index b31d66a27cd..518c17c581a 100644 --- a/R/plot.R +++ b/R/plot.R @@ -431,7 +431,8 @@ plot.igraph <- function( arr.w = arr.w, lab.x, lab.y, - loopSize = loop.size + loopSize = loop.size, + narrowing = 1 ) { rad <- angle center <- c(cx, cy) @@ -440,22 +441,23 @@ plot.igraph <- function( x0, y0, x0 + .4 * loopSize, - y0 + .2 * loopSize, + y0 + narrowing * .2 * loopSize, x0 + .4 * loopSize, - y0 - .2 * loopSize, + y0 - narrowing * .2 * loopSize, x0, y0 ), ncol = 2, byrow = TRUE ) - phi <- atan2(cp[, 2] - center[2], cp[, 1] - center[1]) - r <- sqrt((cp[, 1] - center[1])**2 + (cp[, 2] - center[2])**2) + cp_centered <- cp - + matrix(rep(center, each = nrow(cp)), ncol = 2, byrow = FALSE) - phi <- phi + rad + rotation_matrix <- matrix(c(cos(rad), -sin(rad), sin(rad), cos(rad)), ncol = 2) + cp_rotated <- t(rotation_matrix %*% t(cp_centered)) - cp[, 1] <- cx + r * cos(phi) - cp[, 2] <- cy + r * sin(phi) + cp <- cp_rotated + + matrix(rep(center, each = nrow(cp_rotated)), ncol = 2, byrow = FALSE) if (is.na(width)) { width <- 1 @@ -473,16 +475,13 @@ plot.igraph <- function( ) if (is.language(label) || !is.na(label)) { - lx <- x0 + .3 - ly <- y0 - phi <- atan2(ly - center[2], lx - center[1]) - r <- sqrt((lx - center[1])**2 + (ly - center[2])**2) - - phi <- phi + rad - - lx <- cx + r * cos(phi) - ly <- cy + r * sin(phi) + # 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 } @@ -547,8 +546,82 @@ plot.igraph <- function( lcex <- lcex[loops.e] } - xx0 <- layout[loops.v, 1] + cos(la) * vs - yy0 <- layout[loops.v, 2] - sin(la) * vs + # 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 + } + if (is.null(la)) { + la <- rep(NA, length(loops.v)) + } + + la[is.na(la)] <- la_dyn[is.na(la)] + + adjusted_loop_size <- rep(loop.size, length(loops.v)) + + r_offset <- 0 + xx0 <- layout[loops.v, 1] + cos(la) * r_offset + yy0 <- layout[loops.v, 2] + sin(la) * r_offset + mapply( loop, xx0, @@ -566,7 +639,9 @@ plot.igraph <- function( arrow.size = asize, arr.w = arrow.width, lab.x = loop.labx, - lab.y = loop.laby + lab.y = loop.laby, + loopSize = adjusted_loop_size, + narrowing = narrowing ) } diff --git a/R/plot.common.R b/R/plot.common.R index 5f055c1fb0d..72b07c6d1e6 100644 --- a/R/plot.common.R +++ b/R/plot.common.R @@ -348,7 +348,7 @@ #' Gives the angle in radians for plotting loop edges. #' See the `label.dist` vertex parameter to see how this is interpreted. #' -#' The default value is 0. +#' The default value is NULL. This means that the loop edges will be drawn automatically in the largest gap possible. #' } #' \item{loop.angle2}{ #' Gives the second angle in radians for plotting loop edges. @@ -4881,7 +4881,7 @@ i.edge.default <- list( label = i.get.edge.labels, lty = 1, width = 1, - loop.angle = 0, + loop.angle = NULL, loop.angle2 = 0, label.family = "serif", label.font = 1, diff --git a/man/plot.common.Rd b/man/plot.common.Rd index 36a2f9ca91d..09b4ddb6cee 100644 --- a/man/plot.common.Rd +++ b/man/plot.common.Rd @@ -356,7 +356,7 @@ This is not very surprising, it is the expected behavior. Gives the angle in radians for plotting loop edges. See the \code{label.dist} vertex parameter to see how this is interpreted. -The default value is 0. +The default value is NULL. This means that the loop edges will be drawn automatically in the largest gap possible. } \item{loop.angle2}{ Gives the second angle in radians for plotting loop edges. diff --git a/tests/testthat/_snaps/plot/basic-graph-layout-1.svg b/tests/testthat/_snaps/plot/basic-graph-layout-1.svg index d8d1dc241fa..447b8f3955e 100644 --- a/tests/testthat/_snaps/plot/basic-graph-layout-1.svg +++ b/tests/testthat/_snaps/plot/basic-graph-layout-1.svg @@ -25,7 +25,7 @@ - + diff --git a/tests/testthat/_snaps/plot/basic-graph-layout-2.svg b/tests/testthat/_snaps/plot/basic-graph-layout-2.svg index f0808d3e4c3..994da3fe66c 100644 --- a/tests/testthat/_snaps/plot/basic-graph-layout-2.svg +++ b/tests/testthat/_snaps/plot/basic-graph-layout-2.svg @@ -25,7 +25,7 @@ - + diff --git a/tests/testthat/_snaps/plot/basic-graph-spheres.svg b/tests/testthat/_snaps/plot/basic-graph-spheres.svg index f35282245e1..9e047bf05d8 100644 --- a/tests/testthat/_snaps/plot/basic-graph-spheres.svg +++ b/tests/testthat/_snaps/plot/basic-graph-spheres.svg @@ -25,16 +25,16 @@ - - - - - - + + + + + + -1 -2 -3 +1 +2 +3 diff --git a/tests/testthat/_snaps/plot/loop-graph.svg b/tests/testthat/_snaps/plot/loop-graph.svg index 91cf9f3730a..8f6af5eaa43 100644 --- a/tests/testthat/_snaps/plot/loop-graph.svg +++ b/tests/testthat/_snaps/plot/loop-graph.svg @@ -25,19 +25,19 @@ - -green - - -red -blue - - - + +green + + +red +blue + + + -1 -2 -3 +1 +2 +3 diff --git a/tests/testthat/_snaps/plot/multi-loops-many.svg b/tests/testthat/_snaps/plot/multi-loops-many.svg new file mode 100644 index 00000000000..c99ed95be4b --- /dev/null +++ b/tests/testthat/_snaps/plot/multi-loops-many.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 + + diff --git a/tests/testthat/_snaps/plot/multi-loops-triangle.svg b/tests/testthat/_snaps/plot/multi-loops-triangle.svg new file mode 100644 index 00000000000..701ee9df382 --- /dev/null +++ b/tests/testthat/_snaps/plot/multi-loops-triangle.svg @@ -0,0 +1,44 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 + + diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 4ab64fd6c61..d690532fd3a 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -67,7 +67,7 @@ test_that("basic plot test, spheres", { vdiffr::expect_doppelganger( "Basic graph, spheres", function() { - plot(g, vertex.shape = "sphere", vertex.size = 100) + plot(g, vertex.shape = "sphere", vertex.size = 40) } ) }) @@ -105,7 +105,13 @@ test_that("label colors are correct when loops are present", { vdiffr::expect_doppelganger( "loop graph", function() { - plot(g, edge.color = cols, edge.label.color = cols, edge.label = cols) + plot( + g, + edge.color = cols, + edge.label.color = cols, + edge.label = cols, + margin = 0.5 + ) } ) }) @@ -132,6 +138,28 @@ test_that("Edges stop at outside of rectangle node", { vdiffr::expect_doppelganger("rectangle-edges", rectangle_edges) }) +test_that("Multi loops are arranged correctly", { + skip_if_not_installed("vdiffr") + + multi_loops_triangle <- function() { + g <- make_graph(c(1,2,2,3,3,1,1,1,1,1,1,1,1,1),directed = FALSE) + V(g)$x <- c(1,1.5,2) + V(g)$y <- c(0,1,0) + plot(g, margin = 0.2, loop.size = 2) + } + + vdiffr::expect_doppelganger("multi-loops-triangle", multi_loops_triangle) + + multi_loops_many <- function() { + g2 <- make_graph(c(1,2, 2,3, 3,1, 1,4, 4,5, 5,1, 3,4, 5,2, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1),directed = FALSE) + V(g2)$x <- c(1,2,2,0,0) + V(g2)$y <- c(1,0,2,2,0) + plot(g2, loop.size = 2) + } + + vdiffr::expect_doppelganger("multi-loops-many", multi_loops_many) +}) + test_that("Vertex label rotation works", { skip_if_not_installed("vdiffr")