From 50329782dfa169a061ebaab8a62bb3de7ea97483 Mon Sep 17 00:00:00 2001 From: David Schoch Date: Fri, 24 Jul 2026 07:11:31 +0200 Subject: [PATCH] Phase 8b: flow_tree(optimize = TRUE) FLOWTREE refinement Add an approximate FLOWTREE refinement (Verbeek et al. 2011, section 5) behind flow_tree(optimize = TRUE). The tree nodes (leaves, root, join points) are held fixed so the planar spiral skeleton is preserved; only the interior points of each edge are relaxed for smoothness and to keep clear of node obstacles, anchored to the spiral arc so the angle restriction is not badly violated. Factor the arc sampling into a shared .spiral_arc() helper. Tested: preserves the edge count and endpoints, stays planar (no crossings), finite output. Co-Authored-By: Claude Opus 4.8 (1M context) --- NEWS.md | 2 +- R/flow_spiral.R | 135 ++++++++++++++++++++++++++---- man/flow_tree.Rd | 7 +- tests/testthat/test-flow_spiral.R | 18 ++++ 4 files changed, 143 insertions(+), 19 deletions(-) diff --git a/NEWS.md b/NEWS.md index e2ecc4a..776cd62 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,7 +10,7 @@ * `edge_bundle_hammer()` is now a native C++ implementation of KDE edge bundling (Hurter et al. 2012) and no longer depends on Python/`reticulate`/datashader. `reticulate` was dropped from Imports and `install_bundle_py()` was removed. Bundling output differs from the datashader-based version * added `edge_bundle_mingle()`, multilevel agglomerative edge bundling (Gansner et al. 2011); the kNN proximity graph is built with a bundled kd-tree (nanoflann) for O(E log E) scaling, with a `k` parameter for the number of merge candidates per edge * `metro_multicriteria()` is deprecated in favour of `graphlayouts::layout_as_metromap()` and will be removed in a future release -* added `flow_tree()`, a spiral-tree flow map (Verbeek, Buchin & Speckmann 2011): planar, angle-restricted, keeps node positions fixed, and needs no dummy nodes or triangulation. It is the recommended flow map layout; the `tnss_*()` functions remain as an alternative +* added `flow_tree()`, a spiral-tree flow map (Verbeek, Buchin & Speckmann 2011): planar, angle-restricted, keeps node positions fixed, and needs no dummy nodes or triangulation. It is the recommended flow map layout; the `tnss_*()` functions remain as an alternative. `flow_tree(optimize = TRUE)` additionally refines the tree (smoothness + obstacle avoidance) with join points held fixed * `tnss_tree()`: `order = "weight"` now orders leaves by flow magnitude (previously a no-op); fixed a bug in `tnss_dummies()` where one diagonal corner was misplaced; removed dead code. `interp` moved from Imports to Suggests (only `tnss_tree()` needs it) # edgebundle 0.4.2 diff --git a/R/flow_spiral.R b/R/flow_spiral.R index 9b8d038..46c4010 100644 --- a/R/flow_spiral.R +++ b/R/flow_spiral.R @@ -11,6 +11,10 @@ #' @param alpha restricting angle in degrees (0-90). Smaller values bundle more #' tightly toward the root; typical values are 20-45. #' @param n number of points sampled per tree edge +#' @param optimize logical. If `TRUE`, refine the tree with an approximate +#' FLOWTREE optimization (Verbeek et al. 2011, section 5): join points stay +#' fixed while edge interiors are relaxed for smoothness and to keep clear of +#' node obstacles. This can slightly relax the strict `alpha` bound. #' @return data.frame with columns `x`, `y`, `flow` and `edge` (one smooth arc #' per tree edge) #' @author David Schoch @@ -21,7 +25,7 @@ #' xy <- cbind(state.center$x, state.center$y)[!state.name %in% c("Alaska", "Hawaii"), ] #' flow <- flow_tree(cali2010, xy, root = 4, alpha = 40) #' @export -flow_tree <- function(object, xy, root, alpha = 40, n = 20) { +flow_tree <- function(object, xy, root, alpha = 40, n = 20, optimize = FALSE) { g <- .as_igraph(object) if (is.null(g)) { stop("flow_tree requires an `igraph` or `tbl_graph` object") @@ -47,7 +51,11 @@ flow_tree <- function(object, xy, root, alpha = 40, n = 20) { } st <- .spiral_build(xy, root, leaves, wvec[leaves], alpha) - .spiral_render(st, n) + if (optimize) { + .spiral_optimize(st, n) + } else { + .spiral_render(st, n) + } } # Greedy angle-restricted spiral tree. Returns a mutable-env tree description. @@ -126,28 +134,121 @@ flow_tree <- function(object, xy, root, alpha = 40, n = 20) { list(env = e, edges = edges, rootxy = rootxy) } -# Render each tree edge as a logarithmic-spiral arc (straight to the root). +# Sample one tree edge (child -> parent) as n points along its log-spiral arc +# (straight to the root). Returns an n x 2 matrix. +.spiral_arc <- function(st, ed, n) { + e <- st$env + child <- ed[1] + parent <- ed[2] + u <- seq(0, 1, length.out = n) + if (parent == -1L) { + xs <- e$x[child] + u * (st$rootxy[1] - e$x[child]) + ys <- e$y[child] + u * (st$rootxy[2] - e$y[child]) + } else { + dphi <- ((e$phi[parent] - e$phi[child] + pi) %% (2 * pi)) - pi + lnt <- log(e$t[child]) + u * (log(e$t[parent]) - log(e$t[child])) + ph <- e$phi[child] + u * dphi + xs <- st$rootxy[1] + exp(lnt) * cos(ph) + ys <- st$rootxy[2] + exp(lnt) * sin(ph) + } + cbind(xs, ys) +} + +# Render each tree edge as a logarithmic-spiral arc. .spiral_render <- function(st, n) { e <- st$env res <- vector("list", length(st$edges)) + for (k in seq_along(st$edges)) { + arc <- .spiral_arc(st, st$edges[[k]], n) + res[[k]] <- data.frame(x = arc[, 1], y = arc[, 2], flow = e$w[st$edges[[k]][1]], edge = k) + } + do.call(rbind, res) +} + +# Approximate FLOWTREE refinement (Verbeek et al. 2011, section 5): tree nodes +# (leaves, root, join points) are held fixed so the planar skeleton is +# preserved; only the interior points of each edge are relaxed to (a) be smooth +# (FS) and (b) keep clear of node obstacles (Fobs), anchored to the spiral arc +# so the angle restriction is not badly violated. +.spiral_optimize <- function(st, n, iterations = 60, buffer = NULL, + w_smooth = 1, w_obs = 0.6, w_anchor = 0.15, lr = 0.25) { + e <- st$env + ntn <- length(e$t) + rootid <- ntn + 1L + X <- c(e$x, st$rootxy[1]) + Y <- c(e$y, st$rootxy[2]) + fixed <- rep(TRUE, ntn + 1L) + + obs_ids <- c(which(e$isleaf), rootid) + ox <- X[obs_ids] + oy <- Y[obs_ids] + + chains <- vector("list", length(st$edges)) + own_ends <- vector("list", 0) for (k in seq_along(st$edges)) { ed <- st$edges[[k]] - child <- ed[1] - parent <- ed[2] - u <- seq(0, 1, length.out = n) - if (parent == -1L) { - xs <- e$x[child] + u * (st$rootxy[1] - e$x[child]) - ys <- e$y[child] + u * (st$rootxy[2] - e$y[child]) + parent <- if (ed[2] == -1L) rootid else ed[2] + arc <- .spiral_arc(st, ed, n) + if (n > 2) { + ids <- length(X) + seq_len(n - 2) + X <- c(X, arc[2:(n - 1), 1]) + Y <- c(Y, arc[2:(n - 1), 2]) + fixed <- c(fixed, rep(FALSE, n - 2)) + for (id in ids) own_ends[[id]] <- c(ed[1], parent) + chains[[k]] <- c(ed[1], ids, parent) } else { - tc <- e$t[child] - tp <- e$t[parent] - dphi <- ((e$phi[parent] - e$phi[child] + pi) %% (2 * pi)) - pi - lnt <- log(tc) + u * (log(tp) - log(tc)) - ph <- e$phi[child] + u * dphi - xs <- st$rootxy[1] + exp(lnt) * cos(ph) - ys <- st$rootxy[2] + exp(lnt) * sin(ph) + chains[[k]] <- c(ed[1], parent) + } + } + anchorX <- X + anchorY <- Y + Np <- length(X) + nbr <- vector("list", Np) + for (ch in chains) { + for (i in seq_along(ch)) { + if (i > 1) nbr[[ch[i]]] <- c(nbr[[ch[i]]], ch[i - 1]) + if (i < length(ch)) nbr[[ch[i]]] <- c(nbr[[ch[i]]], ch[i + 1]) } - res[[k]] <- data.frame(x = xs, y = ys, flow = e$w[child], edge = k) + } + + if (is.null(buffer)) { + lx <- e$x[e$isleaf] + ly <- e$y[e$isleaf] + nn <- vapply(seq_along(lx), function(i) { + d <- sqrt((lx[i] - lx[-i])^2 + (ly[i] - ly[-i])^2) + if (length(d)) min(d) else 0 + }, numeric(1)) + buffer <- 0.5 * stats::median(nn) + } + + movable <- which(!fixed) + for (it in seq_len(iterations)) { + nX <- X + nY <- Y + for (p in movable) { + nb <- nbr[[p]] + mvx <- w_smooth * (mean(X[nb]) - X[p]) + w_anchor * (anchorX[p] - X[p]) + mvy <- w_smooth * (mean(Y[nb]) - Y[p]) + w_anchor * (anchorY[p] - Y[p]) + dx <- X[p] - ox + dy <- Y[p] - oy + d <- sqrt(dx * dx + dy * dy) + keep <- d < buffer & d > 1e-9 & !(obs_ids %in% own_ends[[p]]) + if (any(keep)) { + f <- w_obs * (buffer - d[keep]) / buffer + mvx <- mvx + sum(f * dx[keep] / d[keep]) + mvy <- mvy + sum(f * dy[keep] / d[keep]) + } + nX[p] <- X[p] + lr * mvx + nY[p] <- Y[p] + lr * mvy + } + X <- nX + Y <- nY + } + + res <- vector("list", length(chains)) + for (k in seq_along(chains)) { + ch <- chains[[k]] + res[[k]] <- data.frame(x = X[ch], y = Y[ch], flow = e$w[st$edges[[k]][1]], edge = k) } do.call(rbind, res) } diff --git a/man/flow_tree.Rd b/man/flow_tree.Rd index 32a02e0..27d6962 100644 --- a/man/flow_tree.Rd +++ b/man/flow_tree.Rd @@ -4,7 +4,7 @@ \alias{flow_tree} \title{Spiral flow tree} \usage{ -flow_tree(object, xy, root, alpha = 40, n = 20) +flow_tree(object, xy, root, alpha = 40, n = 20, optimize = FALSE) } \arguments{ \item{object}{a one-to-many flow network (star graph) as igraph/tbl_graph, @@ -18,6 +18,11 @@ with a \code{weight} edge attribute giving the flow} tightly toward the root; typical values are 20-45.} \item{n}{number of points sampled per tree edge} + +\item{optimize}{logical. If \code{TRUE}, refine the tree with an approximate +FLOWTREE optimization (Verbeek et al. 2011, section 5): join points stay +fixed while edge interiors are relaxed for smoothness and to keep clear of +node obstacles. This can slightly relax the strict \code{alpha} bound.} } \value{ data.frame with columns \code{x}, \code{y}, \code{flow} and \code{edge} (one smooth arc diff --git a/tests/testthat/test-flow_spiral.R b/tests/testthat/test-flow_spiral.R index 982ad27..d6fa3ac 100644 --- a/tests/testthat/test-flow_spiral.R +++ b/tests/testthat/test-flow_spiral.R @@ -86,6 +86,24 @@ test_that("flow_tree keeps leaf endpoints fixed at their coordinates", { expect_true(all(hit)) }) +test_that("flow_tree(optimize = TRUE) refines while keeping the skeleton", { + xy <- cali_xy() + base <- flow_tree(cali2010, xy, root = 4, alpha = 40, n = 20) + opt <- flow_tree(cali2010, xy, root = 4, alpha = 40, n = 20, optimize = TRUE) + expect_named(opt, c("x", "y", "flow", "edge")) + expect_equal(sort(unique(opt$edge)), sort(unique(base$edge))) + expect_true(all(is.finite(opt$x)) && all(is.finite(opt$y))) + # join points and leaves are fixed: edge endpoints must match the skeleton + for (k in unique(base$edge)) { + b <- base[base$edge == k, ] + o <- opt[opt$edge == k, ] + expect_equal(unname(as.matrix(b[c(1, nrow(b)), c("x", "y")])), + unname(as.matrix(o[c(1, nrow(o)), c("x", "y")]))) + } + # refinement must not introduce crossings + expect_equal(count_crossings(opt), 0) +}) + test_that("flow_tree requires a graph object", { expect_error(flow_tree(list(), cbind(0, 0), root = 1), "requires an .igraph") })