From 3410fb78e7fbb3812109fc907b62ac7dde5d524a Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sat, 20 Jun 2026 00:07:20 +0200 Subject: [PATCH 1/5] Update .Rbuildignore and .gitignore to include blog-posts directory --- .Rbuildignore | 2 ++ .gitignore | 3 ++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/.Rbuildignore b/.Rbuildignore index 5f0efe0..8f65c59 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -29,3 +29,5 @@ Gmisc/inst/extdata/Full_test_suite_files/* ^README\.Rmd$ ^README\.html$ ^Rplots\.pdf$ +^blog-posts$ +^blog-posts/.*$ diff --git a/.gitignore b/.gitignore index 2119504..ed822dc 100644 --- a/.gitignore +++ b/.gitignore @@ -20,4 +20,5 @@ inst/extdata/Full_test_suite_files/* /doc/ /Meta/ # Ignore generated R plots -Rplots.pdf \ No newline at end of file +Rplots.pdf +blog-posts/ From 149deb453f259da2c3966dbe9ebd6bf13d029439 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sat, 20 Jun 2026 12:03:38 +0200 Subject: [PATCH 2/5] flowchart: side-connector routing, align/spread helpers, and shape bounds Side connectors (type = "side"): - Add many-to-one grouped fan-in: connect(list("a","b"), "target", type="side") routes a shared return bus to the requested outer side instead of each line picking the closest side. - Add one-to-many grouped fan-out, with optional connector labels centered on the offset bus. - Fix one-to-one side connectors to honor the route/offset; previously the vertical segment hugged the box edge and the offset was ignored. - Rename side_fan_in_route/side_fan_in_offset -> side_route/side_offset now that they apply to one-to-one, fan-out, and fan-in (params are unreleased 3.4.0, so no deprecation path needed). Alignment / spread / move: - align(): add `references` to center a box at the midpoint of two references. - spread(): add `exclude` to keep side branches out of the main spread, and support deferred position() endpoints for from/to. - move(): document edge-based `just` for absolute moves (right -> right border). Shapes: - Expose visible bounds (box_fn_bounds) and per-shape text padding for ellipse/database/document/tape so labels stay inside and connectors hit the visible edge; thread bounds through coords(). - fan_in_top trunks now terminate exactly on the target's top edge. Docs/tests: - Modernize the vignette to the define-then-spread/align/move style (phaseLabel example now spreads arms instead of absolute moves). - Update NEWS for 3.4.0 and add tests covering side fan-in/fan-out/one-to-one offset, references, spread exclude, and shape bounds. --- NEWS.md | 10 ++ R/boxGrobs_align.R | 94 +++++++++--- R/boxGrobs_align_pr_helpers.R | 100 ++++++++++++ R/boxGrobs_boxGrob.R | 3 +- R/boxGrobs_boxShapes.R | 25 ++- R/boxGrobs_connect.R | 33 ++-- ...nnect_pr_many_to_one_fan_in_on_top_boxes.R | 2 +- R/boxGrobs_connect_pr_single_boxes.R | 28 ++-- R/boxGrobs_connect_strategies.R | 4 +- R/boxGrobs_move.R | 4 +- R/boxGrobs_prCreateBoxCoordinates.R | 34 ++++- R/boxGrobs_s3_connect.R | 144 ++++++++++++++++-- R/boxGrobs_spread.R | 102 +++++++++++-- inst/examples/alignBox_ex.R | 14 ++ man/align.Rd | 31 +++- man/connect.Rd | 26 ++-- man/moveBox.Rd | 4 +- man/prCreateBoxCoordinates.Rd | 6 +- man/spread.Rd | 12 +- tests/testthat/test-align-pipeline.R | 78 ++++++++++ tests/testthat/test-boxGrob_move.R | 18 +++ tests/testthat/test-boxGrob_spread.R | 106 +++++++++++++ tests/testthat/test-boxShapes.R | 29 ++++ tests/testthat/test-connectGrob_fan_in_top.R | 21 +++ .../test-flowchart-issue76-connectors.R | 89 ++++++++++- vignettes/Grid-based_flowcharts.Rmd | 74 ++++----- 26 files changed, 959 insertions(+), 132 deletions(-) diff --git a/NEWS.md b/NEWS.md index dc01cae..eebc134 100644 --- a/NEWS.md +++ b/NEWS.md @@ -12,6 +12,16 @@ NEWS for the Gmisc package - Improved interactive example ergonomics by pausing between graph pages in multi-plot examples. - Added `box_fn_args` parameter to `boxGrob()` for passing extra arguments directly to the box drawing function. The default is now `list(r = unit(5, "pt"))`, giving every box a fixed 5 pt corner radius (approximately equivalent to the widely-used 5 px CSS `border-radius`) regardless of box size — solving the issue where larger boxes had visibly rounder corners than smaller ones. Override per box or globally via `options(boxGrobFnArgs = list(...))`. - Added `equalizeHeights()` for flowchart box lists, mirroring the existing `equalizeWidths()`. It sets selected boxes to a shared height (defaulting to the tallest among the selection) and supports the same `subelement` path syntax as `equalizeWidths()`. +- Added `exclude` to `spreadVertical()`/`spreadHorizontal()` and the S3 `spread()` wrapper, allowing side branches to be left out of the main spread while preserving them in the flowchart list for later `align()`, `move()`, and `connect()` calls. +- Improved `spread()` span handling: explicit `from`/`to` spans now work naturally with `margin` as an inset inside that span (for example `spread(axis = "x", from = 0, to = 0.7, margin = 0.05)` spreads within the left 70% of the viewport with padding), and subelement spreads can use deferred `position()` endpoints such as `from = position("log", "top", "y")`. +- Added `references` to `alignVertical()`/`alignHorizontal()` and the S3 `align()` wrapper. Supplying two references aligns the target to their midpoint on the selected axis, useful for centering side boxes between the main boxes before and after them. +- Clarified and tested `moveBox()`/`move()` justification semantics: for absolute moves, `just = "right"` makes `x` the right border, `just = "left"` makes `x` the left border, and the same edge-based interpretation applies vertically for top/bottom. +- Added one-to-many grouped side fan-out support to the S3 `connect()` API for `connect("source", "group", type = "side")`. The shared fan-out bus now honors `side_route = "outside"` and `side_offset` before branching to the destination boxes, which keeps side-branch arrows away from the source box edge. +- Added many-to-one grouped side fan-in to the S3 `connect()` API for `connect(list("a", "b"), "target", type = "side")`. The shared return bus now honors `side`/`end_side` and `side_route`/`side_offset`, routing to the requested outer side instead of letting each line independently pick the closest side of the target. +- Fixed one-to-one `connect(..., type = "side")` connectors so they honor `side_route`/`side_offset`. The vertical segment now steps out from the source box edge by the offset (matching the grouped fan-in/fan-out behavior); previously the offset was ignored and the line hugged the box edge. Use `side_route = "edge"` to keep the old edge-hugging route. +- Extended connector labels to grouped side fan-out connectors. `label` can now be used directly on a grouped `type = "side"` fan-out; the label is centered on the offset bus, drawn on the outgoing line, and uses a semi-transparent white background by default so the line remains visually legible. +- Added and expanded alternate flowchart shape examples using `boxEllipseGrob()`, `boxDatabaseGrob()`, `boxDocumentGrob()`, `boxDocumentsGrob()`, `boxDiamondGrob()`, and `boxTapeGrob()` together with `spread()`/`align()` positioning. +- Improved alternate shape helpers so non-rectangular shapes add appropriate text padding and expose visible bounds for connector anchoring. This keeps labels inside ellipse/database/document/tape shapes and lets connectors hit the visible shape edge instead of the surrounding viewport, and `fan_in_top` trunks now terminate exactly on the target's top edge. - Added `position()` with relative moves. - Added dotted arrows lines for flowcharts - Added regex selector for box lists diff --git a/R/boxGrobs_align.R b/R/boxGrobs_align.R index cce2e75..35792c6 100644 --- a/R/boxGrobs_align.R +++ b/R/boxGrobs_align.R @@ -5,6 +5,12 @@ #' @param reference A [`boxGrob`]/[`boxPropGrob`]/[`coords`] object or a [`unit`][grid::unit] or a #' numerical value that can be converted into a [`unit`][grid::unit] of `npc` type. If a numeric scalar is #' provided and is `0` or greater than the number of boxes, it is treated as a coordinate (no error is raised). +#' @param references Optional pair of references. When supplied, the alignment +#' reference is the midpoint between the two references on the selected axis. +#' This is useful for centering side boxes, such as excluded patients, between +#' the main boxes before and after them. Each reference can be anything +#' accepted by `reference`, including a path such as `"assessed"` or +#' `c("arms", 1)`. #' @param ... A set of boxes. #' @param position How to align the boxes, differs slightly for vertical and horizontal alignment #' see the accepted arguments @@ -31,7 +37,7 @@ #' @rdname align -alignVertical <- function(reference, ..., position = c("center", "top", "bottom"), subelement = NULL) { +alignVertical <- function(reference = NULL, ..., position = c("center", "top", "bottom"), subelement = NULL, references = NULL) { position <- match.arg(position) boxes2align <- list(...) @@ -71,7 +77,7 @@ alignVertical <- function(reference, ..., position = c("center", "top", "bottom" # boxes to align and use its first element as the reference. if (length(boxes2align) == 0 && is.list(reference) && !inherits(reference, "box")) { boxes2align <- reference - reference <- boxes2align[[1]] + reference <- if (is.null(references)) boxes2align[[1]] else NULL } # If a list of boxes was piped into '...' as a single element (e.g., using @@ -81,6 +87,13 @@ alignVertical <- function(reference, ..., position = c("center", "top", "bottom" boxes2align <- boxes2align[[1]] } + if (!is.null(references)) { + if (!is.null(reference)) { + stop("Use either `reference` or `references`, not both.", call. = FALSE) + } + prValidateReferencePair(references) + } + if (!is.null(subelement)) { # Normalize into a list of paths (each path is an atomic vector) paths <- prResolveSubelementSelector(subelement, boxes2align) @@ -103,13 +116,19 @@ alignVertical <- function(reference, ..., position = c("center", "top", "bottom" ) } - # Resolve the reference path against the original list so recursive calls get an object - ref_for_call <- prResolveReference(reference, boxes2align) + ref_for_call <- prResolveAlignReference( + reference = reference, + references = references, + boxes2align = boxes2align, + axis = "vertical" + ) - aligned <- alignVertical( - reference = ref_for_call, - target, - position = position + target_boxes <- if (inherits(target, "box")) list(target) else target + aligned <- prApplyAlign( + boxes2align = prNormalizeAndValidateBoxes(target_boxes), + ref_positions = prConvert2Coords(ref_for_call), + position = position, + axis = "vertical" ) # If the target was a single box, the recursive call returns a @@ -133,8 +152,12 @@ alignVertical <- function(reference, ..., position = c("center", "top", "bottom" # Normalize and validate boxes now that subelement processing is done boxes2align <- prNormalizeAndValidateBoxes(boxes2align) - # Resolve reference if it's a path into the boxes - reference <- prResolveReference(reference, boxes2align) + reference <- prResolveAlignReference( + reference = reference, + references = references, + boxes2align = boxes2align, + axis = "vertical" + ) ref_positions <- prConvert2Coords(reference) # Apply vertical alignment @@ -148,11 +171,12 @@ alignVertical <- function(reference, ..., position = c("center", "top", "bottom" #' @md #' @export alignHorizontal <- function( - reference, + reference = NULL, ..., position = c("center", "left", "right"), sub_position = c("none", "left", "right"), - subelement = NULL + subelement = NULL, + references = NULL ) { position <- match.arg(position) sub_position <- match.arg(sub_position) @@ -189,7 +213,7 @@ alignHorizontal <- function( # boxes to align and use its first element as the reference. if (length(boxes2align) == 0 && is.list(reference) && !inherits(reference, "box")) { boxes2align <- reference - reference <- boxes2align[[1]] + reference <- if (is.null(references)) boxes2align[[1]] else NULL } # If a list of boxes was piped into '...' as a single element (e.g., using @@ -199,6 +223,13 @@ alignHorizontal <- function( boxes2align <- boxes2align[[1]] } + if (!is.null(references)) { + if (!is.null(reference)) { + stop("Use either `reference` or `references`, not both.", call. = FALSE) + } + prValidateReferencePair(references) + } + if (!is.null(subelement)) { # Normalize into a list of paths (each path is an atomic vector) paths <- prResolveSubelementSelector(subelement, boxes2align) @@ -215,14 +246,31 @@ alignHorizontal <- function( ) } - # Resolve the reference path against the original list so recursive calls get an object - ref_for_call <- prResolveReference(reference, boxes2align) + ref_for_call <- prResolveAlignReference( + reference = reference, + references = references, + boxes2align = boxes2align, + axis = "horizontal" + ) + ref_positions <- prConvert2Coords(ref_for_call) + if (sub_position != "none") { + if (sub_position == "left") { + assert_class(ref_positions$left_x, "unit") + ref_positions$x <- ref_positions$left_x + ref_positions$right <- ref_positions$prop_x + } else { + assert_class(ref_positions$right_x, "unit") + ref_positions$x <- ref_positions$right_x + ref_positions$left <- ref_positions$prop_x + } + } - aligned <- alignHorizontal( - reference = ref_for_call, - target, + target_boxes <- if (inherits(target, "box")) list(target) else target + aligned <- prApplyAlign( + boxes2align = prNormalizeAndValidateBoxes(target_boxes), + ref_positions = ref_positions, position = position, - sub_position = sub_position + axis = "horizontal" ) # Unwrap single-element aligned box when target is a single box to @@ -244,8 +292,12 @@ alignHorizontal <- function( # Normalize and validate boxes now that subelement processing is done boxes2align <- prNormalizeAndValidateBoxes(boxes2align) - # Resolve reference if it's a path into the boxes - reference <- prResolveReference(reference, boxes2align) + reference <- prResolveAlignReference( + reference = reference, + references = references, + boxes2align = boxes2align, + axis = "horizontal" + ) ref_positions <- prConvert2Coords(reference) if (sub_position != "none") { if (sub_position == "left") { diff --git a/R/boxGrobs_align_pr_helpers.R b/R/boxGrobs_align_pr_helpers.R index a07aea5..209dc8f 100644 --- a/R/boxGrobs_align_pr_helpers.R +++ b/R/boxGrobs_align_pr_helpers.R @@ -77,6 +77,106 @@ prResolveReference <- function(reference, boxes2align) { reference } +prValidateReferencePair <- function(references) { + if (!is.list(references) || length(references) != 2) { + stop("`references` must be a list containing exactly two references.", call. = FALSE) + } +} + +prResolveReferenceStrict <- function(reference, boxes2align) { + resolved <- prResolveReference(reference, boxes2align) + + if (identical(resolved, reference) && + (is.atomic(reference) || is.list(reference)) && + !inherits(reference, "box") && + !inherits(reference, "coords") && + !inherits(reference, "unit") && + !is.numeric(reference)) { + stop( + "The reference '", + paste(reference, collapse = " -> "), + "' was not found in the provided boxes.", + call. = FALSE + ) + } + + resolved +} + +prResolveAlignReferenceArgs <- function(reference, references, boxes2align, axis = c("vertical", "horizontal")) { + axis <- match.arg(axis) + + if (is.null(references)) { + return(list( + reference = prResolveReference(reference, boxes2align), + references = NULL + )) + } + + list( + reference = NULL, + references = lapply(references, prResolveReferenceStrict, boxes2align = boxes2align) + ) +} + +prResolveAlignReference <- function(reference, references, boxes2align, axis = c("vertical", "horizontal")) { + axis <- match.arg(axis) + + if (is.null(references)) { + if (is.null(reference)) { + reference <- boxes2align[[1]] + } + return(prResolveReference(reference, boxes2align)) + } + + resolved <- prResolveAlignReferenceArgs( + reference = reference, + references = references, + boxes2align = boxes2align, + axis = axis + )$references + + prReferencePairMidpoint(resolved, axis = axis) +} + +prReferencePairMidpoint <- function(references, axis = c("vertical", "horizontal")) { + axis <- match.arg(axis) + coords_pair <- lapply(references, prConvert2Coords) + + c1 <- coords_pair[[1]] + c2 <- coords_pair[[2]] + + if (axis == "vertical") { + y <- c1$y + (c2$y - c1$y) * 0.5 + return(structure(list( + x = unit(0.5, "npc"), + y = y, + top = y, + bottom = y, + left = unit(0.5, "npc"), + right = unit(0.5, "npc"), + width = unit(0, "npc"), + height = unit(0, "npc"), + half_width = unit(0, "npc"), + half_height = unit(0, "npc") + ), class = c("coords", "box_coords", "list"))) + } + + x <- c1$x + (c2$x - c1$x) * 0.5 + structure(list( + x = x, + y = unit(0.5, "npc"), + top = unit(0.5, "npc"), + bottom = unit(0.5, "npc"), + left = x, + right = x, + width = unit(0, "npc"), + height = unit(0, "npc"), + half_width = unit(0, "npc"), + half_height = unit(0, "npc") + ), class = c("coords", "box_coords", "list")) +} + # Apply alignment given resolved boxes and ref positions prApplyAlign <- function(boxes2align, ref_positions, position, axis = c("vertical", "horizontal")) { axis <- match.arg(axis) diff --git a/R/boxGrobs_boxGrob.R b/R/boxGrobs_boxGrob.R index b8ca480..c83684d 100644 --- a/R/boxGrobs_boxGrob.R +++ b/R/boxGrobs_boxGrob.R @@ -128,6 +128,7 @@ boxGrob <- function(label, } ) } + box_fn_bounds <- attr(rect, "box_fn_bounds") # Create text grob using the (possibly) adjusted padding txt <- textGrob( @@ -197,7 +198,7 @@ boxGrob <- function(label, ) structure(gl, - coords = prCreateBoxCoordinates(viewport_data = vp_args), + coords = prCreateBoxCoordinates(viewport_data = vp_args, box_fn_bounds = box_fn_bounds), viewport_data = vp_args ) } diff --git a/R/boxGrobs_boxShapes.R b/R/boxGrobs_boxShapes.R index 980a860..9987fd3 100644 --- a/R/boxGrobs_boxShapes.R +++ b/R/boxGrobs_boxShapes.R @@ -92,7 +92,10 @@ ellipse_box_fn <- function(x = .5, y = .5, gp = gpar()) { t <- seq(0, 2 * pi, length.out = 80) xs <- .5 + .48 * cos(t) ys <- .5 + .36 * sin(t) - polygonGrob(x = xs, y = ys, gp = gp) + grob <- polygonGrob(x = xs, y = ys, gp = gp) + attr(grob, "box_fn_padding") <- unit(4, "mm") + attr(grob, "box_fn_bounds") <- list(left = .02, right = .98, bottom = .14, top = .86) + grob } @@ -171,7 +174,10 @@ database_box_fn <- function(x = .5, y = .5, gp = gpar()) { col_edge <- if (!is.null(gp$col)) gp$col else "black" bot_edge <- linesGrob(x = xs_bot, y = ys_bot, gp = gpar(col = col_edge)) - gTree(children = gList(body, bot_fill, top, bot_edge)) + grob <- gTree(children = gList(body, bot_fill, top, bot_edge)) + attr(grob, "box_fn_padding") <- unit(4, "mm") + attr(grob, "box_fn_bounds") <- list(left = .08, right = .92, bottom = .08, top = .92) + grob } #' @rdname boxShapes @@ -206,7 +212,10 @@ document_box_fn <- function(x = .5, y = .5, gp = gpar()) { xpoly <- c(xs, rev(xs)) ypoly <- c(rep(top_y, n), rev(wave)) - polygonGrob(x = xpoly, y = ypoly, gp = gp) + grob <- polygonGrob(x = xpoly, y = ypoly, gp = gp) + attr(grob, "box_fn_padding") <- unit(3, "mm") + attr(grob, "box_fn_bounds") <- list(left = .08, right = .92, bottom = .085, top = .88) + grob } #' @rdname boxShapes @@ -254,7 +263,10 @@ documents_box_fn <- function(x = .5, y = .5, gp = gpar()) { polygonGrob(x = xpoly, y = ypoly, gp = gp) }) - gTree(children = do.call(gList, docs)) + grob <- gTree(children = do.call(gList, docs)) + attr(grob, "box_fn_padding") <- unit(3, "mm") + attr(grob, "box_fn_bounds") <- list(left = .08, right = .95, bottom = .065, top = .88) + grob } #' @rdname boxShapes @@ -302,7 +314,10 @@ tape_box_fn <- function(x = .5, y = .5, gp = gpar()) { right_y <- 0.5 + cap_y_radius * sin(t) right_cap <- polygonGrob(x = c(right_x, right_x[1]), y = c(right_y, right_y[1]), gp = gp) - gTree(children = gList(body, left_cap, right_cap)) + grob <- gTree(children = gList(body, left_cap, right_cap)) + attr(grob, "box_fn_padding") <- unit(4, "mm") + attr(grob, "box_fn_bounds") <- list(left = .08, right = .92, bottom = .18, top = .82) + grob } #' @rdname boxShapes diff --git a/R/boxGrobs_connect.R b/R/boxGrobs_connect.R index 4888a5a..d6517d6 100644 --- a/R/boxGrobs_connect.R +++ b/R/boxGrobs_connect.R @@ -55,12 +55,15 @@ #' #' ## Labels #' -#' For one-to-one connectors you can add a text label (for example `"yes"` / `"no"`). -#' The label is placed near the midpoint of the connector. - -#' The label is drawn with a white background for readability. -#' Use `label_pad` to control padding around the text and `label_offset` to move -#' the label away from the connector. +#' For one-to-one connectors and grouped side fan-out connectors you can add a +#' text label (for example `"yes"` / `"no"`). For one-to-one connectors the +#' label is placed near the midpoint of the connector; for grouped side fan-out +#' connectors it is centered at the offset fan-out bus and drawn on the +#' outgoing line. +#' +#' The label is drawn with a semi-transparent white background for readability. +#' Use `label_pad` to control padding around the text and `label_offset` to nudge +#' the label away from the connector when needed. #' #' ## Split boxes #' @@ -97,14 +100,14 @@ #' `"auto"` (default) picks the side that faces the end box. #' @param end_side For `type = "side"`, which side of the end box to enter. #' `"auto"` (default) picks the side that faces the start box. -#' @param side_fan_in_route For grouped `connect(..., type = "side")` calls in +#' @param side_route For grouped `connect(..., type = "side")` calls in #' the S3 flowchart API, where to draw the shared vertical return path. #' `"outside"` offsets it away from the source boxes; `"edge"` draws it on #' the source box edge. -#' @param side_fan_in_offset Offset used when `side_fan_in_route = "outside"`. +#' @param side_offset Offset used when `side_route = "outside"`. #' Numeric values are interpreted as millimeters. -#' @param label Optional text label for one-to-one connectors (e.g. `"yes"` / `"no"`). -#' Only supported when both `start` and `end` are single boxes. +#' @param label Optional text label for one-to-one connectors and grouped +#' `type = "side"` fan-out connectors (e.g. `"yes"` / `"no"`). #' @param label_gp A [grid::gpar()] controlling label appearance. #' @param label_pos Where to place the label along the connector: `"mid"`, `"near_start"`, or `"near_end"`. #' @param label_offset Offset for the label away from the connector line. @@ -137,8 +140,8 @@ connectGrob <- function( corner_radius = unit(3, "mm"), side = c("auto", "left", "right"), end_side = c("auto", "left", "right"), - side_fan_in_route = c("outside", "edge"), - side_fan_in_offset = unit(5, "mm"), + side_route = c("outside", "edge"), + side_offset = unit(5, "mm"), label = NULL, label_gp = grid::gpar(cex = 0.9), label_bg_gp = grid::gpar(fill = "white", col = NA), @@ -163,7 +166,7 @@ connectGrob <- function( label_pos <- match.arg(label_pos) side <- match.arg(side) end_side <- match.arg(end_side) - side_fan_in_route <- match.arg(side_fan_in_route) + side_route <- match.arg(side_route) if (!is.null(arrow_size)) { ends_map <- c("1" = "first", "2" = "last", "3" = "both") @@ -257,8 +260,8 @@ connectGrob <- function( corner_radius = corner_radius, side = side, end_side = end_side, - side_fan_in_route = side_fan_in_route, - side_fan_in_offset = side_fan_in_offset, + side_route = side_route, + side_offset = side_offset, label = label, label_gp = label_gp, label_bg_gp = label_bg_gp, diff --git a/R/boxGrobs_connect_pr_many_to_one_fan_in_on_top_boxes.R b/R/boxGrobs_connect_pr_many_to_one_fan_in_on_top_boxes.R index 28a9bba..7d4ac1d 100644 --- a/R/boxGrobs_connect_pr_many_to_one_fan_in_on_top_boxes.R +++ b/R/boxGrobs_connect_pr_many_to_one_fan_in_on_top_boxes.R @@ -129,7 +129,7 @@ prGenerateLines <- function(starts, end, bend_y, xs_end, lty_gp, arrow_obj, sube mk( x = unit.c(x_start, x_end), - y = unit.c(bend_y, e$top + unit(0.5, "mm")), + y = unit.c(bend_y, e$top), arrow = arrow_obj ) }) diff --git a/R/boxGrobs_connect_pr_single_boxes.R b/R/boxGrobs_connect_pr_single_boxes.R index 5278a24..3a803cd 100644 --- a/R/boxGrobs_connect_pr_single_boxes.R +++ b/R/boxGrobs_connect_pr_single_boxes.R @@ -96,8 +96,8 @@ prConnect1 <- function( corner_radius = unit(3, "mm"), side = c("auto", "left", "right"), end_side = c("auto", "left", "right"), - side_fan_in_route = c("outside", "edge"), - side_fan_in_offset = unit(5, "mm"), + side_route = c("outside", "edge"), + side_offset = unit(5, "mm"), label = NULL, label_gp = grid::gpar(cex = 0.9), label_bg_gp = grid::gpar(fill = "white", col = NA), @@ -114,7 +114,10 @@ prConnect1 <- function( label_pos <- match.arg(label_pos) side <- match.arg(side) end_side <- match.arg(end_side) - side_fan_in_route <- match.arg(side_fan_in_route) + side_route <- match.arg(side_route) + if (is.numeric(side_offset)) { + side_offset <- unit(side_offset, "mm") + } start <- coords(start) end <- coords(end) @@ -206,13 +209,16 @@ prConnect1 <- function( line$x <- unit.c(axis_x, target_x) line$y <- unit.c(edges$start_edge, edges$target_edge) } else if (type == "side") { - # Vertical-first side route: leave from a selected start side, travel vertically - # outside/alongside the flow, then enter the selected side of the end box. + # Vertical-first side route: leave from a selected start side, optionally step + # out to an offset bus (side_route = "outside"), travel vertically + # alongside the flow, then enter the selected side of the end box. end_is_right <- prConvertWidthToMm(getX4elmnt(end, "x")) > prConvertWidthToMm(start$x) - exit_x <- if (side == "right" || (side == "auto" && end_is_right)) { - start$right - } else { - start$left + exit_is_right <- side == "right" || (side == "auto" && end_is_right) + exit_x <- if (exit_is_right) start$right else start$left + + bus_x <- exit_x + if (side_route == "outside") { + bus_x <- if (exit_is_right) bus_x + side_offset else bus_x - side_offset } start_is_left <- prConvertWidthToMm(start$x) < prConvertWidthToMm(getX4elmnt(end, "x")) @@ -221,8 +227,8 @@ prConnect1 <- function( } else { end$right } - line$x <- unit.c(exit_x, exit_x, entry_x) - line$y <- unit.c(start$y, end$y, end$y) + line$x <- unit.c(exit_x, bus_x, bus_x, entry_x) + line$y <- unit.c(start$y, start$y, end$y, end$y) } else if (type == "horizontal_axis") { axis_y <- start$y target_y <- prClampUnit(axis_y, end$bottom, end$top, axis = "y") diff --git a/R/boxGrobs_connect_strategies.R b/R/boxGrobs_connect_strategies.R index 10ba584..47daced 100644 --- a/R/boxGrobs_connect_strategies.R +++ b/R/boxGrobs_connect_strategies.R @@ -107,8 +107,8 @@ prCalculateConnector.ConnectorStrategy <- function(strategy, ...) { corner_radius = args$corner_radius, side = args$side, end_side = args$end_side, - side_fan_in_route = args$side_fan_in_route, - side_fan_in_offset = args$side_fan_in_offset, + side_route = args$side_route, + side_offset = args$side_offset, label = args$label, label_gp = args$label_gp, label_bg_gp = args$label_bg_gp, diff --git a/R/boxGrobs_move.R b/R/boxGrobs_move.R index 5b3a52d..4473467 100644 --- a/R/boxGrobs_move.R +++ b/R/boxGrobs_move.R @@ -12,7 +12,9 @@ #' @param just The justification of an argument as used by [`viewport`][grid::viewport] some tiny differences: #' (1) you only want to change the justification in the vertical direction you can retain the #' existing justification by using `NA`, e.g. `c(NA, 'top')`, (2) if you specify only one string -#' and that string is either `top` or `bottom` it will assume vertical justification. +#' and that string is either `top` or `bottom` it will assume vertical justification. For absolute +#' moves, `just` also controls which part of the box is placed at `x`/`y`; for example +#' `just = "right"` makes `x` the right border and `just = "left"` makes `x` the left border. #' @param subelement If a `list` of boxes is provided, this can be a name, #' index, a deep path (e.g. `c("detail", 1)`), a regex selector created with #' [stringr::regex()] that is matched against top-level names diff --git a/R/boxGrobs_prCreateBoxCoordinates.R b/R/boxGrobs_prCreateBoxCoordinates.R index 8650254..bcf009f 100644 --- a/R/boxGrobs_prCreateBoxCoordinates.R +++ b/R/boxGrobs_prCreateBoxCoordinates.R @@ -5,7 +5,7 @@ #' parameters #' @return \code{list} of class \code{coords} #' @importFrom checkmate assert_list -prCreateBoxCoordinates <- function(viewport_data, extra_coordinate_functions = NULL) { +prCreateBoxCoordinates <- function(viewport_data, extra_coordinate_functions = NULL, box_fn_bounds = NULL) { # Adjust center depending on the viewport position x <- prAdjustPos(viewport_data$just, viewport_data$x, viewport_data$width, axis = "x") y <- prAdjustPos(viewport_data$just, viewport_data$y, viewport_data$height, axis = "y") @@ -32,6 +32,38 @@ prCreateBoxCoordinates <- function(viewport_data, extra_coordinate_functions = N half_width = half_width ) + if (!is.null(box_fn_bounds)) { + if (!is.list(box_fn_bounds) || + !all(c("left", "right", "bottom", "top") %in% names(box_fn_bounds))) { + stop("`box_fn_bounds` must be a list with left, right, bottom, and top.", call. = FALSE) + } + + bounds <- unlist(box_fn_bounds[c("left", "right", "bottom", "top")], use.names = TRUE) + if (!is.numeric(bounds) || + any(!is.finite(bounds)) || + bounds[["left"]] < 0 || + bounds[["right"]] > 1 || + bounds[["bottom"]] < 0 || + bounds[["top"]] > 1 || + bounds[["left"]] >= bounds[["right"]] || + bounds[["bottom"]] >= bounds[["top"]]) { + stop("`box_fn_bounds` values must be finite proportions with left < right and bottom < top.", call. = FALSE) + } + + full_left <- x - half_width + full_bottom <- y - half_height + coordinates$left <- full_left + width * bounds[["left"]] + coordinates$right <- full_left + width * bounds[["right"]] + coordinates$bottom <- full_bottom + height * bounds[["bottom"]] + coordinates$top <- full_bottom + height * bounds[["top"]] + coordinates$x <- (coordinates$left + coordinates$right) / 2 + coordinates$y <- (coordinates$bottom + coordinates$top) / 2 + coordinates$width <- coordinates$right - coordinates$left + coordinates$height <- coordinates$top - coordinates$bottom + coordinates$half_width <- coordinates$width * 0.5 + coordinates$half_height <- coordinates$height * 0.5 + } + if (!is.null(extra_coordinate_functions)) { assert_list(extra_coordinate_functions, names = "strict") diff --git a/R/boxGrobs_s3_connect.R b/R/boxGrobs_s3_connect.R index 8feb52b..065fab5 100644 --- a/R/boxGrobs_s3_connect.R +++ b/R/boxGrobs_s3_connect.R @@ -101,15 +101,15 @@ connect.Gmisc_list_of_boxes <- function(x, from = NULL, to = NULL, ...) { arrow_size <- get_arg("arrow_size", NULL) side <- match.arg(get_arg("side", "auto"), c("auto", "left", "right")) end_side <- match.arg(get_arg("end_side", "auto"), c("auto", "left", "right")) - side_fan_in_route <- match.arg(get_arg("side_fan_in_route", "outside"), c("outside", "edge")) - side_fan_in_offset <- get_arg("side_fan_in_offset", unit(5, "mm")) + side_route <- match.arg(get_arg("side_route", "outside"), c("outside", "edge")) + side_offset <- get_arg("side_offset", unit(5, "mm")) smooth <- get_arg("smooth", FALSE) corner_radius <- get_arg("corner_radius", unit(3, "mm")) - if (is.numeric(side_fan_in_offset)) { - side_fan_in_offset <- unit(side_fan_in_offset, "mm") + if (is.numeric(side_offset)) { + side_offset <- unit(side_offset, "mm") } - if (!inherits(side_fan_in_offset, "unit")) { - stop("`side_fan_in_offset` must be a unit or numeric.", call. = FALSE) + if (!inherits(side_offset, "unit")) { + stop("`side_offset` must be a unit or numeric.", call. = FALSE) } if (!is.null(arrow_size)) { @@ -137,11 +137,11 @@ connect.Gmisc_list_of_boxes <- function(x, from = NULL, to = NULL, ...) { } else { exit_xs[[which.min(vapply(exit_xs, prConvertWidthToMm, numeric(1)))]] } - if (side_fan_in_route == "outside") { + if (side_route == "outside") { bus_x <- if (exit_side == "right") { - bus_x + side_fan_in_offset + bus_x + side_offset } else { - bus_x - side_fan_in_offset + bus_x - side_offset } } entry_x <- e[[entry_side]] @@ -190,6 +190,125 @@ connect.Gmisc_list_of_boxes <- function(x, from = NULL, to = NULL, ...) { structure(gt, line = line, class = c("connect_boxes", class(gt))) } + connect_side_fan_out <- function(start, ends) { + get_arg <- function(name, default) { + if (!is.null(args[[name]])) args[[name]] else default + } + + lty_gp <- get_arg("lty_gp", getOption("connectGrob", default = gpar(fill = "black"))) + arrow_obj <- get_arg("arrow_obj", getOption("connectGrobArrow", default = arrow(ends = "last", type = "closed"))) + arrow_size <- get_arg("arrow_size", NULL) + side <- match.arg(get_arg("side", "auto"), c("auto", "left", "right")) + end_side <- match.arg(get_arg("end_side", "auto"), c("auto", "left", "right")) + side_route <- match.arg(get_arg("side_route", "outside"), c("outside", "edge")) + side_offset <- get_arg("side_offset", unit(5, "mm")) + smooth <- get_arg("smooth", FALSE) + corner_radius <- get_arg("corner_radius", unit(3, "mm")) + label <- get_arg("label", NULL) + label_gp <- get_arg("label_gp", grid::gpar(cex = 0.9)) + label_bg_gp <- get_arg("label_bg_gp", grid::gpar(fill = "white", col = NA, alpha = 0.85)) + label_pad <- get_arg("label_pad", unit(1.5, "mm")) + label_offset <- get_arg("label_offset", unit(0, "mm")) + + if (is.numeric(side_offset)) { + side_offset <- unit(side_offset, "mm") + } + if (!inherits(side_offset, "unit")) { + stop("`side_offset` must be a unit or numeric.", call. = FALSE) + } + if (!is.null(label)) assert_class(label_gp, "gpar") + if (is.numeric(label_pad)) label_pad <- unit(label_pad, "mm") + if (is.numeric(label_offset)) label_offset <- unit(label_offset, "mm") + + if (!is.null(arrow_size)) { + ends_map <- c("1" = "first", "2" = "last", "3" = "both") + type_map <- c("1" = "open", "2" = "closed") + arrow_obj <- arrow( + ends = ends_map[as.character(arrow_obj$ends)], + type = type_map[as.character(arrow_obj$type)], + angle = arrow_obj$angle, + length = unit(arrow_size, "mm") + ) + } + + s <- coords(start) + e_coords <- lapply(ends, coords) + ends_right <- mean(vapply(e_coords, function(e) prConvertWidthToMm(e$x), numeric(1))) > + prConvertWidthToMm(s$x) + + exit_side <- if (side == "right" || (side == "auto" && ends_right)) "right" else "left" + entry_side <- if (end_side == "left" || (end_side == "auto" && ends_right)) "left" else "right" + + exit_x <- s[[exit_side]] + bus_x <- exit_x + if (side_route == "outside") { + bus_x <- if (exit_side == "right") { + bus_x + side_offset + } else { + bus_x - side_offset + } + } + + stub <- prRenderLine( + x = unit.c(exit_x, bus_x), + y = unit.c(s$y, s$y), + smooth = FALSE, + corner_radius = corner_radius, + gp = lty_gp, + arrow = NULL + ) + + y_mm <- vapply(e_coords, function(e) prConvertHeightToMm(e$y), numeric(1)) + start_y_mm <- prConvertHeightToMm(s$y) + bus_end_y <- if (mean(y_mm) < start_y_mm) { + e_coords[[which.min(y_mm)]]$y + } else { + e_coords[[which.max(y_mm)]]$y + } + + spine <- prRenderLine( + x = unit.c(bus_x, bus_x), + y = unit.c(s$y, bus_end_y), + smooth = FALSE, + corner_radius = corner_radius, + gp = lty_gp, + arrow = NULL + ) + + finals <- lapply(e_coords, function(e) { + prRenderLine( + x = unit.c(bus_x, e[[entry_side]]), + y = unit.c(e$y, e$y), + smooth = smooth, + corner_radius = corner_radius, + gp = lty_gp, + arrow = arrow_obj + ) + }) + + line <- list( + x = unit.c(exit_x, bus_x, bus_x, e_coords[[1]][[entry_side]]), + y = unit.c(s$y, s$y, bus_end_y, e_coords[[1]]$y) + ) + label_grobs <- list() + if (!is.null(label)) { + label_x <- bus_x + label_y <- s$y + label_offset + tg <- grid::textGrob(label, x = label_x, y = label_y, just = "center", gp = label_gp) + w <- grid::grobWidth(tg) + label_pad + h <- grid::grobHeight(tg) + label_pad + bg <- grid::roundrectGrob( + x = label_x, y = label_y, + width = w, height = h, + r = unit(1, "mm"), + gp = label_bg_gp + ) + label_grobs <- list(bg, tg) + } + gt <- grid::grobTree(do.call(grid::gList, c(list(stub, spine), finals, label_grobs))) + structure(gt, line = line, class = c("connect_boxes", class(gt))) + } + connect_armwise <- function(starts, ends) { arm_count <- length(ends) bad <- which(vapply(starts, length, integer(1)) != arm_count) @@ -246,6 +365,13 @@ connect.Gmisc_list_of_boxes <- function(x, from = NULL, to = NULL, ...) { cg <- connect_armwise(start_boxes, end_boxes) } else if (prIsBoxList(start_boxes) && is_list_of_box_lists(end_boxes)) { cg <- connect_armwise_to_groups(start_boxes, end_boxes) + } else if (inherits(start_boxes, "box") && prIsBoxList(end_boxes) && identical(args$type, "side")) { + cg <- connect_side_fan_out(start_boxes, end_boxes) + } else if (prIsBoxList(start_boxes) && inherits(end_boxes, "box") && identical(args$type, "side")) { + # Many-to-one side fan-in, e.g. connect(list("ex1", "ex2"), "analysis", type = "side"). + # Routes the shared bus to the requested side (honoring side/end_side and the + # side_route/offset) instead of letting each line pick the closest side. + cg <- connect_side_fan_in(start_boxes, end_boxes) # Support pairwise list-to-list mapping in the S3 flowchart API. # This keeps connectGrob() many-to-many unsupported while making # connect("groups", "groups2") behave as users expect. diff --git a/R/boxGrobs_spread.R b/R/boxGrobs_spread.R index 3c97d01..757a518 100644 --- a/R/boxGrobs_spread.R +++ b/R/boxGrobs_spread.R @@ -29,6 +29,11 @@ #' Bare character strings are always treated as literal paths. #' The function will return the original list with the targeted element(s) #' replaced by their spread version(s). +#' @param exclude Optional selector for elements to leave out of the spread. +#' Uses the same selector syntax as `subelement`, but each excluded path must +#' resolve to an element directly inside the list currently being spread. This +#' is useful for side branches that should be positioned separately, such as +#' lost-to-follow-up boxes centered between the rows before and after them. #' #' @details #' `spreadVertical()`/`spreadHorizontal()` return updated box objects. They do @@ -52,7 +57,8 @@ spreadVertical <- function( to = NULL, margin = unit(0, "npc"), type = c("between", "center"), - subelement = NULL + subelement = NULL, + exclude = NULL ) { type <- match.arg(type) @@ -85,8 +91,8 @@ spreadVertical <- function( endpoint } - resolved_from <- resolve_endpoint(from) - resolved_to <- resolve_endpoint(to) + resolved_from <- prResolvePositionValue(resolve_endpoint(from), boxes2spread) + resolved_to <- prResolvePositionValue(resolve_endpoint(to), boxes2spread) for (path in paths) { target <- get_list_element_by_path(boxes2spread, path) @@ -108,7 +114,8 @@ spreadVertical <- function( from = resolved_from, to = resolved_to, margin = margin, - type = type + type = type, + exclude = exclude ) if (container_is_first) { @@ -126,6 +133,11 @@ spreadVertical <- function( prAssertBoxOrListOfBoxes(box) } + excluded <- prExtractSpreadExclusions(boxes2spread, exclude) + if (!is.null(excluded)) { + boxes2spread <- excluded$included + } + span_info <- prGetSpanSpace( boxes2spread = boxes2spread, from = from, @@ -141,19 +153,22 @@ spreadVertical <- function( orientation = "vertical" ) - prApplyBoxSpread( + spread_boxes <- prApplyBoxSpread( boxes2spread = boxes2spread, distances = new_y_distances, move_fn = function(box, pos) { moveBox(box, y = pos, space = "absolute", just = c(NA, "center")) } ) + + prRestoreSpreadExclusions(spread_boxes, excluded) } #' @rdname spread #' @export spreadHorizontal <- function(..., from = NULL, to = NULL, margin = unit(0, "npc"), - type = c("between", "center"), subelement = NULL) { + type = c("between", "center"), subelement = NULL, + exclude = NULL) { type <- match.arg(type) boxes2spread <- list(...) @@ -185,8 +200,8 @@ spreadHorizontal <- function(..., from = NULL, to = NULL, margin = unit(0, "npc" endpoint } - resolved_from <- resolve_endpoint(from) - resolved_to <- resolve_endpoint(to) + resolved_from <- prResolvePositionValue(resolve_endpoint(from), boxes2spread) + resolved_to <- prResolvePositionValue(resolve_endpoint(to), boxes2spread) for (path in paths) { target <- get_list_element_by_path(boxes2spread, path) @@ -208,7 +223,8 @@ spreadHorizontal <- function(..., from = NULL, to = NULL, margin = unit(0, "npc" from = resolved_from, to = resolved_to, margin = margin, - type = type + type = type, + exclude = exclude ) if (container_is_first) { @@ -226,6 +242,11 @@ spreadHorizontal <- function(..., from = NULL, to = NULL, margin = unit(0, "npc" prAssertBoxOrListOfBoxes(box) } + excluded <- prExtractSpreadExclusions(boxes2spread, exclude) + if (!is.null(excluded)) { + boxes2spread <- excluded$included + } + span_info <- prGetSpanSpace( boxes2spread = boxes2spread, from = from, @@ -241,13 +262,74 @@ spreadHorizontal <- function(..., from = NULL, to = NULL, margin = unit(0, "npc" orientation = "horizontal" ) - prApplyBoxSpread( + spread_boxes <- prApplyBoxSpread( boxes2spread = boxes2spread, distances = new_x_distances, move_fn = function(box, pos) { moveBox(box, x = pos, space = "absolute", just = "center") } ) + + prRestoreSpreadExclusions(spread_boxes, excluded) +} + +prExtractSpreadExclusions <- function(boxes2spread, exclude) { + if (is.null(exclude)) { + return(NULL) + } + + paths <- prResolveSubelementSelector(exclude, boxes2spread) + if (length(paths) == 0) { + return(NULL) + } + + normalize_index <- function(path) { + if (length(path) != 1) { + stop( + "`exclude` paths must refer to elements directly inside the list being spread.", + call. = FALSE + ) + } + + idx <- path[[1]] + if (is.character(idx)) { + nms <- names(boxes2spread) + if (is.null(nms) || !idx %in% nms) { + stop("The exclude element '", idx, "' was not found in the provided boxes.", call. = FALSE) + } + return(match(idx, nms)) + } + + idx <- as.integer(idx) + if (is.na(idx) || idx < 1 || idx > length(boxes2spread)) { + stop("The exclude element '", paste(path, collapse = " -> "), "' was not found in the provided boxes.", call. = FALSE) + } + idx + } + + exclude_idx <- unique(vapply(paths, normalize_index, integer(1))) + if (length(exclude_idx) >= length(boxes2spread)) { + stop("`exclude` cannot remove every element from the spread.", call. = FALSE) + } + + list( + original = boxes2spread, + included = boxes2spread[-exclude_idx], + included_idx = setdiff(seq_along(boxes2spread), exclude_idx) + ) +} + +prRestoreSpreadExclusions <- function(spread_boxes, excluded) { + if (is.null(excluded)) { + return(spread_boxes) + } + + ret <- excluded$original + for (i in seq_along(excluded$included_idx)) { + ret[[excluded$included_idx[[i]]]] <- spread_boxes[[i]] + } + + prExtendClass(ret, "Gmisc_list_of_boxes") } prGetSpanSpace <- function( diff --git a/inst/examples/alignBox_ex.R b/inst/examples/alignBox_ex.R index eef6f8e..4685a2e 100644 --- a/inst/examples/alignBox_ex.R +++ b/inst/examples/alignBox_ex.R @@ -39,7 +39,21 @@ complex_list <- complex_list |> subelement = c("detail", 1) ) +# Center a side branch between the boxes before and after it +side_branch <- flowchart( + assessed = boxGrob("Assessed", y = .9), + randomised = boxGrob("Randomised", y = .5) +) |> + insert(list(excluded = boxGrob("Excluded")), after = "assessed") |> + move(subelement = "excluded", x = .85) |> + align( + axis = "y", + subelement = "excluded", + references = list("assessed", "randomised") + ) + # Print the reference and the aligned boxes box aligned_boxes complex_list +side_branch diff --git a/man/align.Rd b/man/align.Rd index 770b28a..7e0ff01 100644 --- a/man/align.Rd +++ b/man/align.Rd @@ -10,18 +10,20 @@ \title{Align boxes} \usage{ alignVertical( - reference, + reference = NULL, ..., position = c("center", "top", "bottom"), - subelement = NULL + subelement = NULL, + references = NULL ) alignHorizontal( - reference, + reference = NULL, ..., position = c("center", "left", "right"), sub_position = c("none", "left", "right"), - subelement = NULL + subelement = NULL, + references = NULL ) align(x, ...) @@ -56,6 +58,13 @@ function will unwrap a single-element wrapper so nested \code{.subelement} targe The function will return the original list with the targeted element(s) replaced by their aligned version(s).} +\item{references}{Optional pair of references. When supplied, the alignment +reference is the midpoint between the two references on the selected axis. +This is useful for centering side boxes, such as excluded patients, between +the main boxes before and after them. Each reference can be anything +accepted by \code{reference}, including a path such as \code{"assessed"} or +\code{c("arms", 1)}.} + \item{sub_position}{When the box is a \code{\link{boxPropGrob}} it not only has the general \code{.positions} but also \code{left} and \code{right} which can be viewed as separate boxes that have simply been merged.} @@ -115,10 +124,24 @@ complex_list <- complex_list |> subelement = c("detail", 1) ) +# Center a side branch between the boxes before and after it +side_branch <- flowchart( + assessed = boxGrob("Assessed", y = .9), + randomised = boxGrob("Randomised", y = .5) +) |> + insert(list(excluded = boxGrob("Excluded")), after = "assessed") |> + move(subelement = "excluded", x = .85) |> + align( + axis = "y", + subelement = "excluded", + references = list("assessed", "randomised") + ) + # Print the reference and the aligned boxes box aligned_boxes complex_list +side_branch } \seealso{ Other flowchart components: diff --git a/man/connect.Rd b/man/connect.Rd index a45c9ec..eb207d6 100644 --- a/man/connect.Rd +++ b/man/connect.Rd @@ -28,8 +28,8 @@ connectGrob( corner_radius = unit(3, "mm"), side = c("auto", "left", "right"), end_side = c("auto", "left", "right"), - side_fan_in_route = c("outside", "edge"), - side_fan_in_offset = unit(5, "mm"), + side_route = c("outside", "edge"), + side_offset = unit(5, "mm"), label = NULL, label_gp = grid::gpar(cex = 0.9), label_bg_gp = grid::gpar(fill = "white", col = NA), @@ -91,16 +91,16 @@ A \code{\link[grid:unit]{grid::unit()}} or numeric (interpreted as millimeters). \item{end_side}{For \code{type = "side"}, which side of the end box to enter. \code{"auto"} (default) picks the side that faces the start box.} -\item{side_fan_in_route}{For grouped \code{connect(..., type = "side")} calls in +\item{side_route}{For grouped \code{connect(..., type = "side")} calls in the S3 flowchart API, where to draw the shared vertical return path. \code{"outside"} offsets it away from the source boxes; \code{"edge"} draws it on the source box edge.} -\item{side_fan_in_offset}{Offset used when \code{side_fan_in_route = "outside"}. +\item{side_offset}{Offset used when \code{side_route = "outside"}. Numeric values are interpreted as millimeters.} -\item{label}{Optional text label for one-to-one connectors (e.g. \code{"yes"} / \code{"no"}). -Only supported when both \code{start} and \code{end} are single boxes.} +\item{label}{Optional text label for one-to-one connectors and grouped +\code{type = "side"} fan-out connectors (e.g. \code{"yes"} / \code{"no"}).} \item{label_gp}{A \code{\link[grid:gpar]{grid::gpar()}} controlling label appearance.} @@ -199,11 +199,15 @@ diagonal line is acceptable. \subsection{Labels}{ -For one-to-one connectors you can add a text label (for example \code{"yes"} / \code{"no"}). -The label is placed near the midpoint of the connector. -The label is drawn with a white background for readability. -Use \code{label_pad} to control padding around the text and \code{label_offset} to move -the label away from the connector. +For one-to-one connectors and grouped side fan-out connectors you can add a +text label (for example \code{"yes"} / \code{"no"}). For one-to-one connectors the +label is placed near the midpoint of the connector; for grouped side fan-out +connectors it is centered at the offset fan-out bus and drawn on the +outgoing line. + +The label is drawn with a semi-transparent white background for readability. +Use \code{label_pad} to control padding around the text and \code{label_offset} to nudge +the label away from the connector when needed. } \subsection{Split boxes}{ diff --git a/man/moveBox.Rd b/man/moveBox.Rd index 228cd18..37c939c 100644 --- a/man/moveBox.Rd +++ b/man/moveBox.Rd @@ -26,7 +26,9 @@ moveBox( \item{just}{The justification of an argument as used by \code{\link[grid:viewport]{viewport}} some tiny differences: (1) you only want to change the justification in the vertical direction you can retain the existing justification by using \code{NA}, e.g. \code{c(NA, 'top')}, (2) if you specify only one string -and that string is either \code{top} or \code{bottom} it will assume vertical justification.} +and that string is either \code{top} or \code{bottom} it will assume vertical justification. For absolute +moves, \code{just} also controls which part of the box is placed at \code{x}/\code{y}; for example +\code{just = "right"} makes \code{x} the right border and \code{just = "left"} makes \code{x} the left border.} \item{subelement}{If a \code{list} of boxes is provided, this can be a name, index, a deep path (e.g. \code{c("detail", 1)}), a regex selector created with diff --git a/man/prCreateBoxCoordinates.Rd b/man/prCreateBoxCoordinates.Rd index e39e21d..da7d98a 100644 --- a/man/prCreateBoxCoordinates.Rd +++ b/man/prCreateBoxCoordinates.Rd @@ -4,7 +4,11 @@ \alias{prCreateBoxCoordinates} \title{Creates coordinates for box} \usage{ -prCreateBoxCoordinates(viewport_data, extra_coordinate_functions = NULL) +prCreateBoxCoordinates( + viewport_data, + extra_coordinate_functions = NULL, + box_fn_bounds = NULL +) } \arguments{ \item{viewport_data}{The arguments that will be used for generating the \code{viewport}} diff --git a/man/spread.Rd b/man/spread.Rd index ab5c584..d9f6dcf 100644 --- a/man/spread.Rd +++ b/man/spread.Rd @@ -23,7 +23,8 @@ spreadVertical( to = NULL, margin = unit(0, "npc"), type = c("between", "center"), - subelement = NULL + subelement = NULL, + exclude = NULL ) spreadHorizontal( @@ -32,7 +33,8 @@ spreadHorizontal( to = NULL, margin = unit(0, "npc"), type = c("between", "center"), - subelement = NULL + subelement = NULL, + exclude = NULL ) } \arguments{ @@ -67,6 +69,12 @@ as a list of paths or selectors (e.g., Bare character strings are always treated as literal paths. The function will return the original list with the targeted element(s) replaced by their spread version(s).} + +\item{exclude}{Optional selector for elements to leave out of the spread. +Uses the same selector syntax as \code{subelement}, but each excluded path must +resolve to an element directly inside the list currently being spread. This +is useful for side branches that should be positioned separately, such as +lost-to-follow-up boxes centered between the rows before and after them.} } \value{ The list of boxes with updated positions (class `Gmisc_list_of_boxes`). diff --git a/tests/testthat/test-align-pipeline.R b/tests/testthat/test-align-pipeline.R index b946a2b..254e866 100644 --- a/tests/testthat/test-align-pipeline.R +++ b/tests/testthat/test-align-pipeline.R @@ -45,3 +45,81 @@ testthat::test_that("alignVertical accepts piped positional reference path", { expect_s3_class(aligned, "Gmisc_list_of_boxes") expect_equal(length(aligned$groups2), 2) }) + +testthat::test_that("alignVertical centers a subelement between two references", { + library(grid) + + boxes <- flowchart( + assessed = boxGrob("Assessed", y = 0.9), + randomised = boxGrob("Randomised", y = 0.5) + ) |> + insert(list(excluded = boxGrob("Excluded")), after = "assessed") |> + move(subelement = "excluded", x = 0.85) |> + align( + axis = "y", + subelement = "excluded", + references = list("assessed", "randomised"), + position = "center" + ) + + y <- convertY(coords(boxes$excluded)$y, "npc", valueOnly = TRUE) + expected <- mean(c( + convertY(coords(boxes$assessed)$y, "npc", valueOnly = TRUE), + convertY(coords(boxes$randomised)$y, "npc", valueOnly = TRUE) + )) + + expect_equal(y, expected, tolerance = 1e-6) + expect_equal(convertX(coords(boxes$excluded)$x, "npc", valueOnly = TRUE), 0.85, tolerance = 1e-6) +}) + +testthat::test_that("alignHorizontal centers a subelement between two references", { + library(grid) + + boxes <- flowchart( + left = boxGrob("Left", x = 0.2), + middle = boxGrob("Middle", x = 0.9), + right = boxGrob("Right", x = 0.8) + ) |> + align( + axis = "x", + subelement = "middle", + references = list("left", "right"), + position = "center" + ) + + x <- convertX(coords(boxes$middle)$x, "npc", valueOnly = TRUE) + expected <- mean(c( + convertX(coords(boxes$left)$x, "npc", valueOnly = TRUE), + convertX(coords(boxes$right)$x, "npc", valueOnly = TRUE) + )) + + expect_equal(x, expected, tolerance = 1e-6) +}) + +testthat::test_that("align reference pair validates invalid inputs", { + library(grid) + + boxes <- flowchart( + assessed = boxGrob("Assessed", y = 0.9), + randomised = boxGrob("Randomised", y = 0.5), + excluded = boxGrob("Excluded") + ) + + expect_error( + boxes |> align(axis = "y", subelement = "excluded", references = list("assessed")), + "`references` must be a list containing exactly two references.", + fixed = TRUE + ) + + expect_error( + boxes |> align(axis = "y", subelement = "excluded", reference = "assessed", references = list("assessed", "randomised")), + "Use either `reference` or `references`, not both.", + fixed = TRUE + ) + + expect_error( + boxes |> align(axis = "y", subelement = "excluded", references = list("assessed", "missing")), + "The reference 'missing' was not found in the provided boxes.", + fixed = TRUE + ) +}) diff --git a/tests/testthat/test-boxGrob_move.R b/tests/testthat/test-boxGrob_move.R index 58ce98a..e8c3c2b 100644 --- a/tests/testthat/test-boxGrob_move.R +++ b/tests/testthat/test-boxGrob_move.R @@ -24,6 +24,24 @@ test_that("Box move absolute", { expect_gt(cvt(attr(box1, "viewport_data")$x), cvt(attr(box3, "viewport_data")$x)) }) +test_that("Box move absolute uses justification as the target edge", { + box <- boxGrob("A simple box", x = .5, y = .5) + + right_aligned <- moveBox(box, x = .85, just = "right") + expect_equal( + convertX(coords(right_aligned)$right, "npc", valueOnly = TRUE), + .85, + tolerance = 1e-6 + ) + + left_aligned <- moveBox(box, x = .15, just = "left") + expect_equal( + convertX(coords(left_aligned)$left, "npc", valueOnly = TRUE), + .15, + tolerance = 1e-6 + ) +}) + test_that("subelement moves a single element in a list (shallow)", { b1 <- boxGrob("b1", x = .1, y = .1) diff --git a/tests/testthat/test-boxGrob_spread.R b/tests/testthat/test-boxGrob_spread.R index 3b7df6e..6538cb1 100644 --- a/tests/testthat/test-boxGrob_spread.R +++ b/tests/testthat/test-boxGrob_spread.R @@ -102,6 +102,50 @@ test_that("Box spread vertically with between", { ) }) +test_that("Box spread vertically can exclude top-level elements", { + boxes <- flowchart( + start = boxGrob("Start", y = .9), + excluded = boxGrob("Excluded", y = .44), + middle = boxGrob("Middle", y = .6), + end = boxGrob("End", y = .2) + ) + + out <- boxes |> spread(axis = "y", exclude = "excluded", type = "center") + + expect_equal( + convertY(coords(out$excluded)$y, "npc", valueOnly = TRUE), + convertY(coords(boxes$excluded)$y, "npc", valueOnly = TRUE), + tolerance = 1e-6 + ) + + main_y <- vapply(out[c("start", "middle", "end")], function(box) { + convertY(coords(box)$y, "npc", valueOnly = TRUE) + }, numeric(1)) + + expect_equal(length(unique(round(main_y, 6))), 3) + expect_equal(unname(abs(main_y[1] - main_y[2])), unname(abs(main_y[2] - main_y[3])), tolerance = 1e-6) +}) + +test_that("Box spread exclude validates selectors", { + boxes <- flowchart( + start = boxGrob("Start"), + excluded = boxGrob("Excluded"), + end = boxGrob("End") + ) + + expect_error( + boxes |> spread(axis = "y", exclude = c("missing", 1)), + "`exclude` paths must refer to elements directly inside the list being spread.", + fixed = TRUE + ) + + expect_error( + boxes |> spread(axis = "y", exclude = list("start", "excluded", "end")), + "`exclude` cannot remove every element from the spread.", + fixed = TRUE + ) +}) + test_that("Box spread horizontally with center", { box1 <- boxGrob("B1 some long text", x = .2, y = .8) box2 <- boxGrob("B2", x = .2, y = .8) @@ -206,3 +250,65 @@ test_that("Box spread horizontally with between", { distance(spread_boxes[4:5], type = "h") ) }) + +test_that("spread resolves position references for subelement spans", { + fc <- flowchart( + target = boxGrob("Target", y = .5, height = unit(.3, "npc")), + side = list( + boxGrob("A"), + boxGrob("B"), + boxGrob("C") + ) + ) |> + spread( + axis = "y", + subelement = "side", + from = position("target", position = "top", type = "y"), + to = position("target", position = "bottom", type = "y"), + margin = unit(0, "npc") + ) + + expect_lte( + convertY(coords(fc$side[[1]])$top, "npc", valueOnly = TRUE), + convertY(coords(fc$target)$top, "npc", valueOnly = TRUE) + ) + expect_gte( + convertY(coords(fc$side[[3]])$bottom, "npc", valueOnly = TRUE), + convertY(coords(fc$target)$bottom, "npc", valueOnly = TRUE) + ) + expect_equal( + convertY(position(fc$side, position = "center", type = "y"), "npc", valueOnly = TRUE), + convertY(coords(fc$target)$y, "npc", valueOnly = TRUE), + tolerance = 1e-6 + ) + + fc <- flowchart( + target = boxGrob("Target", x = .5, width = unit(.5, "npc")), + side = list( + boxGrob("A"), + boxGrob("B"), + boxGrob("C") + ) + ) |> + spread( + axis = "x", + subelement = "side", + from = position("target", position = "left", type = "x"), + to = position("target", position = "right", type = "x"), + margin = unit(0, "npc") + ) + + expect_gte( + convertX(coords(fc$side[[1]])$left, "npc", valueOnly = TRUE), + convertX(coords(fc$target)$left, "npc", valueOnly = TRUE) + ) + expect_lte( + convertX(coords(fc$side[[3]])$right, "npc", valueOnly = TRUE), + convertX(coords(fc$target)$right, "npc", valueOnly = TRUE) + ) + expect_equal( + convertX(position(fc$side, position = "center", type = "x"), "npc", valueOnly = TRUE), + convertX(coords(fc$target)$x, "npc", valueOnly = TRUE), + tolerance = 1e-6 + ) +}) diff --git a/tests/testthat/test-boxShapes.R b/tests/testthat/test-boxShapes.R index 123b881..fa23132 100644 --- a/tests/testthat/test-boxShapes.R +++ b/tests/testthat/test-boxShapes.R @@ -15,3 +15,32 @@ test_that("box shapes construct without error", { expect_silent(con <- connectGrob(db, list(doc, srv), type = "N")) expect_true(inherits(con, "connect_boxes_list")) }) + +test_that("non-rectangular shapes expose visible bounds for sizing and connectors", { + tape <- boxTapeGrob("Tape", + width = unit(100, "mm"), + height = unit(50, "mm")) + tape_coords <- coords(tape) + + expect_equal( + convertWidth(tape_coords$width, "mm", valueOnly = TRUE), + 84, + tolerance = 1e-6 + ) + expect_equal( + convertHeight(tape_coords$height, "mm", valueOnly = TRUE), + 32, + tolerance = 1e-6 + ) + + plain <- boxGrob("REDCap\nform") + ellipse <- boxEllipseGrob("REDCap\nform") + expect_gt( + convertWidth(attr(ellipse, "viewport_data")$width, "mm", valueOnly = TRUE), + convertWidth(attr(plain, "viewport_data")$width, "mm", valueOnly = TRUE) + ) + expect_gt( + convertHeight(attr(ellipse, "viewport_data")$height, "mm", valueOnly = TRUE), + convertHeight(attr(plain, "viewport_data")$height, "mm", valueOnly = TRUE) + ) +}) diff --git a/tests/testthat/test-connectGrob_fan_in_top.R b/tests/testthat/test-connectGrob_fan_in_top.R index fafc622..33d9821 100644 --- a/tests/testthat/test-connectGrob_fan_in_top.R +++ b/tests/testthat/test-connectGrob_fan_in_top.R @@ -39,3 +39,24 @@ test_that("fan_in_top works with default margin and nested lists", { # trunks should be diagonal (start x != end x) at least for one trunk expect_true(any(abs(trunk_x_end_mm - trunk_x_start_mm) > 1e-6)) }) + +test_that("fan_in_top ends on the target top edge", { + starts <- list( + boxGrob("A", x = .2, y = .8), + boxGrob("B", x = .5, y = .8), + boxGrob("C", x = .8, y = .8) + ) + end <- boxTapeGrob("Validation", x = .5, y = .45, + width = unit(80, "mm"), + height = unit(24, "mm")) + + con <- connectGrob(starts, end, type = "fan_in_top") + trunks <- tail(con, length(starts)) + target_top <- convertY(coords(end)$top, "mm", valueOnly = TRUE) + + trunk_y_end <- vapply(trunks, function(g) { + convertY(tail(attr(g, "line")$y, 1), "mm", valueOnly = TRUE) + }, numeric(1)) + + expect_equal(trunk_y_end, rep(target_top, length(starts)), tolerance = 1e-6) +}) diff --git a/tests/testthat/test-flowchart-issue76-connectors.R b/tests/testthat/test-flowchart-issue76-connectors.R index 3816e01..d8ee116 100644 --- a/tests/testthat/test-flowchart-issue76-connectors.R +++ b/tests/testthat/test-flowchart-issue76-connectors.R @@ -50,7 +50,7 @@ test_that("connect() accepts regex selectors for arm-wise fan-in", { type = "side", lty_gp = gpar(lty = 2), side = "right", - side_fan_in_offset = unit(5, "mm") + side_offset = unit(5, "mm") ) con <- tail(attr(fc, "connections"), 1)[[1]] @@ -67,6 +67,93 @@ test_that("connect() accepts regex selectors for arm-wise fan-in", { expect_gt(first_x[1], convertX(coords(make_issue76_fc()$ex1[[1]])$right, "npc", valueOnly = TRUE)) }) +test_that("one-to-many side connectors offset the fan-out bus from the source edge", { + offset <- unit(8, "mm") + fc <- flowchart( + start = boxGrob("Linked", x = .4, y = .7, width = unit(35, "mm")), + ends = list( + boxGrob("A", x = .85, y = .72), + boxGrob("B", x = .85, y = .60), + boxGrob("C", x = .85, y = .48) + ) + ) |> + connect( + from = "start", + to = "ends", + type = "side", + side = "right", + end_side = "left", + side_offset = offset, + label = "Excluded\nn = 3" + ) + + con <- tail(attr(fc, "connections"), 1)[[1]] + line <- attr(con, "line") + xs <- convertX(line$x, "mm", valueOnly = TRUE) + start_right <- convertX(coords(fc$start)$right, "mm", valueOnly = TRUE) + offset_mm <- convertWidth(offset, "mm", valueOnly = TRUE) + + expect_s3_class(con, "connect_boxes") + expect_equal(xs[2], start_right + offset_mm, tolerance = 1e-6) + expect_gte(length(con$children), 6) +}) + +test_that("many-to-one side fan-in routes the shared bus to the requested outer side", { + offset <- unit(4, "mm") + fc <- flowchart( + ex = list( + boxGrob("Ex 1", x = .15, y = .7), + boxGrob("Ex 2", x = .15, y = .45) + ), + target = boxGrob("Analysed", x = .6, y = .2) + ) |> + connect( + from = list("ex$1", "ex$2"), + to = "target", + type = "side", + side = "left", + end_side = "left", + side_offset = offset + ) + + con <- tail(attr(fc, "connections"), 1)[[1]] + expect_s3_class(con, "connect_boxes") # single merged fan-in grob, not a per-line list + + xs <- convertX(attr(con, "line")$x, "mm", valueOnly = TRUE) + ex_left <- convertX(coords(fc$ex[[1]])$left, "mm", valueOnly = TRUE) + offset_mm <- convertWidth(offset, "mm", valueOnly = TRUE) + target_left <- convertX(coords(fc$target)$left, "mm", valueOnly = TRUE) + + # Bus sits outside (to the left of) the excluded boxes, not on the closest side. + expect_equal(xs[1], ex_left - offset_mm, tolerance = 1e-6) + # The merged line enters the target on its left side. + expect_equal(tail(xs, 1), target_left, tolerance = 1e-6) +}) + +test_that("one-to-one side connectors offset the vertical segment from the source edge", { + start <- boxGrob("Source", x = .5, y = .7) + end <- boxGrob("Excluded", x = .1, y = .4) + offset <- unit(6, "mm") + + con <- connectGrob(start, end, type = "side", + side = "left", end_side = "right", + side_offset = offset) + xs <- convertX(attr(con, "line")$x, "mm", valueOnly = TRUE) + start_left <- convertX(coords(start)$left, "mm", valueOnly = TRUE) + offset_mm <- convertWidth(offset, "mm", valueOnly = TRUE) + + # The vertical bus steps out to the left of the source edge by the offset. + expect_equal(xs[2], start_left - offset_mm, tolerance = 1e-6) + expect_equal(xs[3], start_left - offset_mm, tolerance = 1e-6) + + # `edge` keeps the vertical segment on the box edge (no offset). + con_edge <- connectGrob(start, end, type = "side", + side = "left", end_side = "right", + side_route = "edge") + xs_edge <- convertX(attr(con_edge, "line")$x, "mm", valueOnly = TRUE) + expect_equal(xs_edge[2], start_left, tolerance = 1e-6) +}) + test_that("side connectors can enter a requested destination side", { start <- boxGrob("Excluded", x = .1, y = .7) end <- boxGrob("Analysed", x = .4, y = .2) diff --git a/vignettes/Grid-based_flowcharts.Rmd b/vignettes/Grid-based_flowcharts.Rmd index 373b828..e8e5635 100644 --- a/vignettes/Grid-based_flowcharts.Rmd +++ b/vignettes/Grid-based_flowcharts.Rmd @@ -88,7 +88,8 @@ just above it, centred between the randomisation arms. plus a small corner lap; for three or more arms it becomes a banner across the full stage width. Pass `width` to override. -The arms are given a clear central gap (boxes spread to `x = 0.27`/`0.73`). Equal +Each stage's arms are spread across the viewport with a small outer `margin`, +leaving a clear central gap for the labels to sit in. Equal arm widths give a symmetric corner overlap — use `equalizeWidths()` if the arms differ. For custom overlays beyond phase labels, the lower-level `insert(..., on_top = TRUE)` is still available. @@ -123,15 +124,11 @@ flowchart( ) ) |> spread(axis = "y", margin = unit(0.04, "npc")) |> - # Give the two arms a clear central gap for the labels to sit in - move(subelement = list(c("groups", 1), - c("followup", 1), - c("analysis", 1)), - x = 0.27) |> - move(subelement = list(c("groups", 2), - c("followup", 2), - c("analysis", 2)), - x = 0.73) |> + # Spread each stage's arms within the viewport, leaving an outer margin — + # this gives the two arms a clear central gap for the labels to sit in + spread(subelement = "groups", axis = "x", margin = unit(0.05, "npc")) |> + spread(subelement = "followup", axis = "x", margin = unit(0.05, "npc")) |> + spread(subelement = "analysis", axis = "x", margin = unit(0.05, "npc")) |> # One call per stage: centred between the arms, slightly above, drawn on top phaseLabel("groups", "Allocation", box_gp = heading_gp) |> phaseLabel("followup", "Follow-up", box_gp = heading_gp) |> @@ -154,10 +151,14 @@ Key points: - `arms`, `lost`, and `analysis` are all **named lists** — `connect("arms", "lost", ...)` automatically creates one connector per matching pair (same list index). +- `spread(..., exclude = "lost")` keeps side-branch boxes out of the main + vertical spacing, and `align(..., references = list("arms", "analysis"))` + then centres them between the rows they describe. - `type = "L"` exits the **bottom** of the assessed box and turns right, giving the classic "down then right" exclusion branch instead of a direct side-exit. -- `insert()` places the exclusion box into the list at the right vertical position; - `move()` shifts it into the right-hand column. +- `insert()` adds the exclusion box; `move(..., just = "right")` places its + right edge at the outer exclusion margin, and `align(..., references = ...)` + centres it between the before/after boxes. - Badge labels extend above the box top and are not counted in the height used by `spread()`, so a `margin` of 10 mm is used to leave room at the top. @@ -171,12 +172,11 @@ excl_fill <- gpar(fill = "#fff8e1", col = "#cc8800", lwd = 1.2) badge_gp <- gpar(fill = "#336699", col = NA) badge_txt_gp <- gpar(col = "white", cex = 0.65) -# Arms span the inner portion; lost boxes flank outside on each side. -# Using 0.28–0.72 keeps the arm centres far enough from the viewport edges -# that the lost boxes' right/left edges don't cross the arm centres. -left_from <- 0.28 -left_to <- 0.72 -main_x <- (left_from + left_to) / 2 # centre of the arms column (= 0.5) +# Main arms use an inner horizontal span; exclusions use the outer span. +main_arm_margin <- 0.28 +exclusion_margin <- 0.05 +main_x <- 0.5 +exclusion_to <- 1 - exclusion_margin grid.newpage() flowchart( @@ -200,8 +200,8 @@ flowchart( badge_label = "64", badge_gp = badge_gp, badge_txt_gp = badge_txt_gp) ), - # Lost-to-follow-up: one per arm — spread from 0 to 1 so they land - # on the outside of each arm (left of cast, right of surgical) + # Lost-to-follow-up: one per arm, placed on the outer exclusion span + # and centred vertically between allocation and analysis. lost = list( lost_cast = boxGrob("Lost to follow-up (n = 2)\n 1 No response\n 1 Other surgery", just = "left", box_gp = excl_fill), @@ -219,8 +219,10 @@ flowchart( badge_gp = badge_gp, badge_txt_gp = badge_txt_gp) ) ) |> - # Vertical spacing — extra margin to keep badges from being clipped at the top - spread(axis = "y", margin = unit(5, "mm")) |> + # Vertical spacing — lost boxes are side branches, not main pathway rows + spread(axis = "y", margin = unit(5, "mm"), exclude = "lost") |> + align(axis = "y", subelement = "lost", + references = list("arms", "analysis")) |> # Make arms and analysis boxes the same width so the same from/to spread # places their centres at matching x positions (otherwise the wider arm text # shifts centres relative to the narrower analysis text). @@ -228,27 +230,29 @@ flowchart( # e.g. with `align(axis = "x", reference = "analysis", subelement = "arms")` # (equivalent to `alignHorizontal(reference = "analysis", subelement = "arms")`). equalizeWidths(subelement = list("arms", "analysis")) |> - # Arms and analysis in the inner span; lost boxes spread across full width + # Arms and analysis in the inner span; lost boxes use the outer span # so that lost_cast lands left of cast and lost_surgical right of surgical - spread(axis = "x", subelement = "arms", from = left_from, to = left_to) |> - spread(axis = "x", subelement = "analysis", from = left_from, to = left_to) |> - spread(axis = "x", subelement = "lost", from = 0, to = 1) |> - # Exclusion box: auto-positioned between assessed and randomised, then moved right + spread(axis = "x", subelement = "arms", margin = main_arm_margin) |> + spread(axis = "x", subelement = "analysis", margin = main_arm_margin) |> + spread(axis = "x", subelement = "lost", margin = exclusion_margin) |> + # Exclusion box: right edge on the outer span, vertically centred between rows insert(list(excluded = boxGrob( "Excluded (n = 714)\n 477 Stable ankle mortise\n 64 Incongruent ankle mortise\n 30 Previous serious trauma\n 143 Other reasons", just = "left", box_gp = excl_fill )), after = "assessed") |> - move(subelement = "excluded", x = 0.85) |> - # Main-flow connectors - connect("assessed", "randomised", type = "v", lty_gp = con_gp, arrow_size = 3, smooth = TRUE) |> - connect("randomised", "arms", type = "N", lty_gp = con_gp, arrow_size = 3, smooth = TRUE) |> - connect("arms", "analysis", type = "v", lty_gp = con_gp, arrow_size = 3) |> + move(subelement = "excluded", x = exclusion_to, just = "right") |> + align(axis = "y", subelement = "excluded", + references = list("assessed", "randomised")) |> # type = "L": exits assessed's *bottom* then turns right — the "down then right" branch connect("assessed", "excluded", type = "L", lty_gp = side_gp, arrow_size = 3, smooth = TRUE) |> # Pairwise arm -> lost: sharp corners (smooth = FALSE) avoid a colour-transition # artefact where the orange arc would diverge from the shared blue vertical path # a few mm above the junction, making the line appear doubled. - connect("arms", "lost", type = "L", lty_gp = side_gp, arrow_size = 3, smooth = TRUE) + connect("arms", "lost", type = "L", lty_gp = side_gp, arrow_size = 3, smooth = TRUE) |> + # Main-flow connectors, put last so that the main lines end up on top of the exclusion/lost lines + connect("assessed", "randomised", type = "v", lty_gp = con_gp, arrow_size = 3, smooth = TRUE) |> + connect("randomised", "arms", type = "N", lty_gp = con_gp, arrow_size = 3, smooth = TRUE) |> + connect("arms", "analysis", type = "v", lty_gp = con_gp, arrow_size = 3) options(old_opts) ``` @@ -334,8 +338,8 @@ flowchart( lty_gp = dotted_gp, arrow_size = 3, side = "right", end_side = "right", - side_fan_in_route = "outside", - side_fan_in_offset = ex_gap) + side_route = "outside", + side_offset = ex_gap) options(old_opts) ``` From e5d0b0fdb0ee0d4d49de92cd7ff811755103ba4d Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sat, 20 Jun 2026 12:05:18 +0200 Subject: [PATCH 3/5] Enhance documentation for prCreateBoxCoordinates: add box_fn_bounds parameter description --- R/boxGrobs_prCreateBoxCoordinates.R | 4 ++++ man/prCreateBoxCoordinates.Rd | 5 +++++ 2 files changed, 9 insertions(+) diff --git a/R/boxGrobs_prCreateBoxCoordinates.R b/R/boxGrobs_prCreateBoxCoordinates.R index bcf009f..dee908b 100644 --- a/R/boxGrobs_prCreateBoxCoordinates.R +++ b/R/boxGrobs_prCreateBoxCoordinates.R @@ -3,6 +3,10 @@ #' @param viewport_data The arguments that will be used for generating the \code{viewport} #' @param extra_coordinate_functions A list with named functions if we want additional #' parameters +#' @param box_fn_bounds Optional named list with `left`, `right`, `bottom`, and `top` +#' proportions (each in `[0, 1]`, with `left < right` and `bottom < top`) describing the +#' visible bounds of a non-rectangular box shape within its viewport. When supplied the +#' coordinates are shrunk to these bounds so connectors anchor to the visible shape edge. #' @return \code{list} of class \code{coords} #' @importFrom checkmate assert_list prCreateBoxCoordinates <- function(viewport_data, extra_coordinate_functions = NULL, box_fn_bounds = NULL) { diff --git a/man/prCreateBoxCoordinates.Rd b/man/prCreateBoxCoordinates.Rd index da7d98a..d79bc93 100644 --- a/man/prCreateBoxCoordinates.Rd +++ b/man/prCreateBoxCoordinates.Rd @@ -15,6 +15,11 @@ prCreateBoxCoordinates( \item{extra_coordinate_functions}{A list with named functions if we want additional parameters} + +\item{box_fn_bounds}{Optional named list with `left`, `right`, `bottom`, and `top` +proportions (each in `[0, 1]`, with `left < right` and `bottom < top`) describing the +visible bounds of a non-rectangular box shape within its viewport. When supplied the +coordinates are shrunk to these bounds so connectors anchor to the visible shape edge.} } \value{ \code{list} of class \code{coords} From f815bf5cf3341c3e8b158e627f4d3c5437aeceee Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sat, 20 Jun 2026 12:49:29 +0200 Subject: [PATCH 4/5] Enhance box function attributes: add box_fn_bounds to various grob functions and update documentation --- R/boxGrobs_boxGrob.R | 3 +- R/boxGrobs_connect.R | 2 +- R/boxGrobs_connect_pr_single_boxes.R | 2 +- R/boxGrobs_equalizeWidths.R | 5 +- R/boxGrobs_move.R | 5 +- man/connect.Rd | 2 +- tests/testthat/test-boxShapes.R | 14 ++++ vignettes/Grid-based_flowcharts.Rmd | 113 +++++++++++++++------------ 8 files changed, 92 insertions(+), 54 deletions(-) diff --git a/R/boxGrobs_boxGrob.R b/R/boxGrobs_boxGrob.R index c83684d..e4dbd8b 100644 --- a/R/boxGrobs_boxGrob.R +++ b/R/boxGrobs_boxGrob.R @@ -199,6 +199,7 @@ boxGrob <- function(label, structure(gl, coords = prCreateBoxCoordinates(viewport_data = vp_args, box_fn_bounds = box_fn_bounds), - viewport_data = vp_args + viewport_data = vp_args, + box_fn_bounds = box_fn_bounds ) } diff --git a/R/boxGrobs_connect.R b/R/boxGrobs_connect.R index d6517d6..06ac467 100644 --- a/R/boxGrobs_connect.R +++ b/R/boxGrobs_connect.R @@ -144,7 +144,7 @@ connectGrob <- function( side_offset = unit(5, "mm"), label = NULL, label_gp = grid::gpar(cex = 0.9), - label_bg_gp = grid::gpar(fill = "white", col = NA), + label_bg_gp = grid::gpar(fill = "white", col = NA, alpha = 0.85), label_pad = unit(1.5, "mm"), label_pos = c("mid", "near_start", "near_end"), label_offset = unit(2, "mm") diff --git a/R/boxGrobs_connect_pr_single_boxes.R b/R/boxGrobs_connect_pr_single_boxes.R index 3a803cd..c18d864 100644 --- a/R/boxGrobs_connect_pr_single_boxes.R +++ b/R/boxGrobs_connect_pr_single_boxes.R @@ -100,7 +100,7 @@ prConnect1 <- function( side_offset = unit(5, "mm"), label = NULL, label_gp = grid::gpar(cex = 0.9), - label_bg_gp = grid::gpar(fill = "white", col = NA), + label_bg_gp = grid::gpar(fill = "white", col = NA, alpha = 0.85), label_pos = c("mid", "near_start", "near_end"), label_offset = unit(2, "mm"), label_pad = unit(1.5, "mm") diff --git a/R/boxGrobs_equalizeWidths.R b/R/boxGrobs_equalizeWidths.R index 3913a7b..6dd3b6a 100644 --- a/R/boxGrobs_equalizeWidths.R +++ b/R/boxGrobs_equalizeWidths.R @@ -158,10 +158,13 @@ prSetBoxDimensions <- function(element, width = NULL, height = NULL) { gl <- editGrob(element, vp = do.call(viewport, vp_args)) attr(gl, "viewport_data") <- vp_args + box_fn_bounds <- attr(element, "box_fn_bounds") attr(gl, "coords") <- prCreateBoxCoordinates( viewport_data = vp_args, - extra_coordinate_functions = attr(element, "extra_coordinate_functions") + extra_coordinate_functions = attr(element, "extra_coordinate_functions"), + box_fn_bounds = box_fn_bounds ) + attr(gl, "box_fn_bounds") <- box_fn_bounds gl } diff --git a/R/boxGrobs_move.R b/R/boxGrobs_move.R index 4473467..1948a62 100644 --- a/R/boxGrobs_move.R +++ b/R/boxGrobs_move.R @@ -211,9 +211,12 @@ moveBox <- function(element, gl <- editGrob(element, vp = do.call(viewport, vp_args)) attr(gl, "viewport_data") <- vp_args + box_fn_bounds <- attr(element, "box_fn_bounds") attr(gl, "coords") <- prCreateBoxCoordinates( viewport_data = vp_args, - extra_coordinate_functions = attr(element, "extra_coordinate_functions") + extra_coordinate_functions = attr(element, "extra_coordinate_functions"), + box_fn_bounds = box_fn_bounds ) + attr(gl, "box_fn_bounds") <- box_fn_bounds return(gl) } diff --git a/man/connect.Rd b/man/connect.Rd index eb207d6..f8d645f 100644 --- a/man/connect.Rd +++ b/man/connect.Rd @@ -32,7 +32,7 @@ connectGrob( side_offset = unit(5, "mm"), label = NULL, label_gp = grid::gpar(cex = 0.9), - label_bg_gp = grid::gpar(fill = "white", col = NA), + label_bg_gp = grid::gpar(fill = "white", col = NA, alpha = 0.85), label_pad = unit(1.5, "mm"), label_pos = c("mid", "near_start", "near_end"), label_offset = unit(2, "mm") diff --git a/tests/testthat/test-boxShapes.R b/tests/testthat/test-boxShapes.R index fa23132..1d0f91e 100644 --- a/tests/testthat/test-boxShapes.R +++ b/tests/testthat/test-boxShapes.R @@ -44,3 +44,17 @@ test_that("non-rectangular shapes expose visible bounds for sizing and connector convertHeight(attr(plain, "viewport_data")$height, "mm", valueOnly = TRUE) ) }) + +test_that("visible shape bounds survive move()/equalizeWidths() repositioning", { + tape <- boxTapeGrob("Tape", width = unit(100, "mm"), height = unit(50, "mm")) + visible0 <- convertWidth(coords(tape)$width, "mm", valueOnly = TRUE) + expect_equal(visible0, 84, tolerance = 1e-6) + + moved <- moveBox(tape, x = 0.7, y = 0.3) + expect_equal(convertWidth(coords(moved)$width, "mm", valueOnly = TRUE), 84, tolerance = 1e-6) + expect_false(is.null(attr(moved, "box_fn_bounds"))) + + # Bounds are proportional, so they scale with an equalized width (0.84 * 120). + eq <- equalizeWidths(list(a = tape, b = boxGrob("x")), width = unit(120, "mm")) + expect_equal(convertWidth(coords(eq$a)$width, "mm", valueOnly = TRUE), 100.8, tolerance = 1e-6) +}) diff --git a/vignettes/Grid-based_flowcharts.Rmd b/vignettes/Grid-based_flowcharts.Rmd index e8e5635..39ce87c 100644 --- a/vignettes/Grid-based_flowcharts.Rmd +++ b/vignettes/Grid-based_flowcharts.Rmd @@ -387,36 +387,63 @@ stay on the source box's x- or y-axis and land on the target boundary. This is useful for shared destination boxes: each upstream item can land cleanly on its own projected position without adding invisible helper boxes. -```{r axis_preserving_connectors, fig.width = 10, fig.height = 6} -axis_box_gp <- gpar(fill = "#F3F8FF", col = "#3B73C5", lwd = 1.3) -target_gp <- gpar(fill = "#FFF4C7", col = "#C69214", lwd = 1.3) -axis_con_gp <- gpar(col = "#555555", fill = "#555555", lwd = 1.3) +The layout below is built entirely with `spread()`/`align()`/`move()` — no box is +given an absolute `x`/`y`. The three inputs are spread across the top and drop +onto the shared **validation** tape with `vertical_axis`, while the three issue +diamonds are spread down a left column and project onto the tall **issue log** +with `horizontal_axis`. + +```{r axis_preserving_connectors, fig.width = 10, fig.height = 7} +input_gp <- gpar(fill = "#F3F8FF", col = "#3B73C5", lwd = 1.3) +process_gp <- gpar(fill = "#FFF4C7", col = "#C69214", lwd = 1.3) +issue_gp <- gpar(fill = "#FCE4EC", col = "#AD1457", lwd = 1.2) +output_gp <- gpar(fill = "#E8F5E9", col = "#2E7D32", lwd = 1.3) +con_gp <- gpar(col = "#555555", fill = "#555555", lwd = 1.3) +issue_con_gp <- gpar(col = "#AD1457", fill = "#AD1457", lwd = 1.1) +main_path <- list("validation", "clean") grid.newpage() flowchart( - web = boxGrob("Web form", x = .18, y = .78, box_gp = axis_box_gp), - api = boxGrob("API upload", x = .38, y = .78, box_gp = axis_box_gp), - manual = boxGrob("Manual entry", x = .58, y = .78, box_gp = axis_box_gp), - validation = boxGrob( - "Data validation queue", - x = .38, y = .42, - width = unit(.55, "npc"), - box_gp = target_gp + inputs = list( + web = boxEllipseGrob("REDCap\nform", width = unit(42, "mm"), height = unit(24, "mm"), box_gp = input_gp), + import = boxDatabaseGrob("CSV\nimport", width = unit(42, "mm"), height = unit(24, "mm"), box_gp = input_gp), + manual = boxDocumentGrob("Manual\nentry", width = unit(42, "mm"), height = unit(24, "mm"), box_gp = input_gp) ), - missing = boxGrob("Missing fields", x = .12, y = .32, box_gp = axis_box_gp), - duplicate = boxGrob("Duplicate ID", x = .12, y = .21, box_gp = axis_box_gp), - outlier = boxGrob("Outlier value", x = .12, y = .10, box_gp = axis_box_gp), - log = boxGrob( - "Issue log", - x = .72, y = .21, - height = unit(.34, "npc"), - box_gp = target_gp + validation = boxTapeGrob( + "Validation queue\nIDs, dates, ranges, missingness", + width = unit(.58, "npc"), height = unit(.14, "npc"), box_gp = process_gp + ), + issues = list( + missing = boxDiamondGrob("Missing\nfields", width = unit(48, "mm"), height = unit(14, "mm"), box_gp = issue_gp), + duplicate = boxDiamondGrob("Duplicate\nID", width = unit(48, "mm"), height = unit(14, "mm"), box_gp = issue_gp), + outlier = boxDiamondGrob("Outlier\nvalue", width = unit(48, "mm"), height = unit(14, "mm"), box_gp = issue_gp) + ), + log = boxDocumentsGrob( + "Issue log\nqueries sent\nchanges reviewed", + width = unit(48, "mm"), height = unit(.44, "npc"), box_gp = issue_gp + ), + clean = boxDatabaseGrob( + "Analysis-ready dataset\nlocked for report", + width = unit(.44, "npc"), height = unit(.16, "npc"), box_gp = output_gp ) ) |> - connect(c("web", "api", "manual"), "validation", - type = "vertical_axis", lty_gp = axis_con_gp, arrow_size = 3) |> - connect(c("missing", "duplicate", "outlier"), "log", - type = "horizontal_axis", lty_gp = axis_con_gp, arrow_size = 3) |> + # Main vertical flow (inputs -> validation -> clean); issues are a side column + spread(axis = "y", margin = unit(7, "mm"), exclude = "issues") |> + spread(axis = "x", subelement = "inputs", from = 0, to = 0.7, margin = 0.05, type = "center") |> + equalizeWidths(subelement = main_path) |> + align(axis = "x", subelement = "validation", reference = "inputs") |> + align(axis = "x", subelement = "clean", reference = "validation") |> + # Place the issue log beside the main flow and stack the diamonds along it + align(axis = "y", subelement = "log", references = list("validation", "clean")) |> + spread(axis = "y", subelement = "issues", + from = position("log", position = "top", type = "y"), + to = position("log", position = "bottom", type = "y"), + margin = unit(2, "mm")) |> + move(subelement = "issues", x = 0.08, just = "left") |> + move(subelement = "log", x = 0.92, just = "right") |> + connect("inputs", "validation", type = "vertical_axis", lty_gp = con_gp, arrow_size = 3) |> + connect("issues", "log", type = "horizontal_axis", lty_gp = issue_con_gp, arrow_size = 3) |> + connect("validation", "clean", type = "vertical_axis", lty_gp = con_gp, arrow_size = 3, smooth = TRUE) |> print() ``` @@ -561,37 +588,27 @@ or use the convenience helpers `boxDiamondGrob()`, `boxEllipseGrob()` and `boxRackGrob()` that ship with the package. ```{r extra_shapes, fig.height = 3, fig.width = 6} -# --- Branch labels + sharp diamond variant --- +# --- Branch labels on alternate shapes --- grid.newpage() -# rounded and sharp diamond examples -d_rounded <- boxDiamondGrob("Decision", box_gp = gpar(fill = "#FFF4E6")) -d_sharp <- boxDiamondGrob("Decision\n(sharp)", rounded = FALSE, box_gp = gpar(fill = "#FFF4E6")) - -# outcomes -e <- boxEllipseGrob("Local", box_gp = gpar(fill = "#E6FFF4")) -r <- boxServerGrob("Server", box_gp = gpar(fill = "#E8F0FF")) +decision <- boxDiamondGrob("Decision", box_gp = gpar(fill = "#FFF4E6")) +local <- boxEllipseGrob("Local", box_gp = gpar(fill = "#E6FFF4")) +server <- boxServerGrob("Server", box_gp = gpar(fill = "#E8F0FF")) -# arrange and draw -boxes <- list(decision = d_rounded, outcomes = list(e, r)) |> +# Position the boxes, then draw them. The ellipse carries extra padding so its +# text fits the curved outline, making it taller than the server box; equalize +# the outcome heights so both branches line up symmetrically. +boxes <- list(decision = decision, outcomes = list(local, server)) |> + equalizeHeights(subelement = "outcomes") |> spreadHorizontal(from = unit(.1, "npc"), to = unit(.9, "npc"), subelement = "outcomes") |> spreadVertical() |> print() -# 1) quick many-to-many style connector (no labels) -con <- connectGrob(boxes$decision, boxes$outcomes, type = "N") -print(con) - -# 2) explicit per-branch connectors with labels (preferred when you want text) -connectGrob(boxes$decision, boxes$outcomes[[1]], type = "N", label = "Local") |> print() -connectGrob(boxes$decision, boxes$outcomes[[2]], type = "N", label = "Server") |> print() - -# 3) If you prefer the single connector and want labels on each branch: -# place text at the midpoint of each returned grob (example) -con_list <- connectGrob(boxes$decision, boxes$outcomes, type = "N") -# Preferred: attach labels and let `print()` handle rendering -con_list <- setConnectorLabels(con_list, c("Local", "Server")) -print(con_list) +# Build one N connector for both branches and attach a label to each with +# setConnectorLabels(); print() then draws the lines and labels together. +connectGrob(boxes$decision, boxes$outcomes, type = "N") |> + setConnectorLabels(c("Local", "Server")) |> + print() ``` # Standard flowchart shapes From 2441076c92bfdc431c7ca92271f1dec90b39a363 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sat, 20 Jun 2026 12:50:57 +0200 Subject: [PATCH 5/5] Updated CRAN-SUBMISSION --- CRAN-SUBMISSION | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/CRAN-SUBMISSION b/CRAN-SUBMISSION index 0fac47a..76f80e9 100644 --- a/CRAN-SUBMISSION +++ b/CRAN-SUBMISSION @@ -1,3 +1,3 @@ -Version: 3.3.0 -Date: 2026-05-30 11:26:21 UTC -SHA: eb6e18687a408a6af6aaf9a28205b286a95d1e5e +Version: 3.4.0 +Date: 2026-06-20 10:50:07 UTC +SHA: f815bf5cf3341c3e8b158e627f4d3c5437aeceee