From 238040787705efbf93eaaae9a4432a51c82a16fc Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Tue, 9 Jun 2026 19:51:33 +0200 Subject: [PATCH 1/7] fix(boxGrob): fixed corner radii + equalizeHeights() (closes #74) - Add box_fn_args parameter to boxGrob() forwarding extra args to the box drawing function. Default is list(r = unit(5, 'pt')) giving every roundrectGrob box a fixed 5 pt corner radius regardless of size, fixing the issue where larger boxes had visibly rounder corners. Args unsupported by the box_fn (e.g. custom shapes) are silently dropped via formals() inspection so existing code is unaffected. Override per-box or globally via options(boxGrobFnArgs = list(...)). - Add equalizeHeights() mirroring equalizeWidths(). Sets selected boxes to a shared height (defaults to the tallest among the selection) and supports the same subelement path syntax. - Add tests: test-boxGrob-corner-radius.R, test-equalizeHeights.R - Add visual tests: tests/visual_tests/corner_box.R, equal_heights.R - Export equalizeHeights() in NAMESPACE - Update NEWS.md --- NAMESPACE | 1 + NEWS.md | 3 + R/boxGrobs_boxGrob.R | 22 ++- R/boxGrobs_equalizeWidths.R | 134 ++++++++++++++++++ .../vdiffr-connect/two-box-connector.svg | 24 ---- tests/testthat/_snaps/vdiffr/basic-box.svg | 24 ---- tests/testthat/test-boxGrob-corner-radius.R | 39 +++++ tests/testthat/test-equalizeHeights.R | 69 +++++++++ tests/visual_tests/corner_box.R | 55 +++++++ tests/visual_tests/equal_heights.R | 59 ++++++++ 10 files changed, 381 insertions(+), 49 deletions(-) delete mode 100644 tests/testthat/_snaps/vdiffr-connect/two-box-connector.svg delete mode 100644 tests/testthat/_snaps/vdiffr/basic-box.svg create mode 100644 tests/testthat/test-boxGrob-corner-radius.R create mode 100644 tests/testthat/test-equalizeHeights.R create mode 100644 tests/visual_tests/corner_box.R create mode 100644 tests/visual_tests/equal_heights.R diff --git a/NAMESPACE b/NAMESPACE index bc64e3e..89a7627 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -84,6 +84,7 @@ export(document_box_fn) export(documents_box_fn) export(docx_document) export(ellipse_box_fn) +export(equalizeHeights) export(equalizeWidths) export(fastDoCall) export(figCapNo) diff --git a/NEWS.md b/NEWS.md index 67465a2..567cbe5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,6 +9,9 @@ NEWS for the Gmisc package - Updated flowchart examples to emphasize the `flowchart()` + pipe (`|>`) style API in `inst/examples/connectGrob_example.R`, `inst/examples/spreadBox_ex.R`, and `inst/examples/alignBox_ex.R`. - Clarified spread/connect documentation to state that spread/align return updated objects (no in-place mutation) and that connectors should use the returned boxes. - 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()`. + ## Changes for 3.3.0 diff --git a/R/boxGrobs_boxGrob.R b/R/boxGrobs_boxGrob.R index 4b3e233..bd1c201 100644 --- a/R/boxGrobs_boxGrob.R +++ b/R/boxGrobs_boxGrob.R @@ -18,6 +18,12 @@ #' @param box_gp The \code{\link[grid]{gpar}} style to apply to the box function of `box_fn` below. #' @param box_fn Function to create box for the text. Parameters of `x=0.5`, `y=0.5` and `box_gp` will #' be passed to this function and return a \code{grob} object. +#' @param box_fn_args An optional named list of extra arguments forwarded to `box_fn`. This is useful +#' for controlling parameters such as the corner radius `r` of \code{\link[grid]{roundrectGrob}} so that +#' all boxes have the same absolute corner radius regardless of their size. Defaults to +#' \code{list(r = grid::unit(5, "pt"))} which gives every box a fixed 5 pt corner radius +#' (approximately equivalent to the widely-used 5 px CSS \code{border-radius}). +#' You can override per box or set a global default via \code{options(boxGrobFnArgs = list(r = grid::unit(5, "mm")))}. #' @seealso The package provides several convenience shape helpers that can be #' passed to `boxGrob(..., box_fn = ...)`: \code{boxDiamondGrob}, #' \code{boxEllipseGrob}, \code{boxRackGrob}, \code{boxServerGrob}, @@ -56,6 +62,7 @@ boxGrob <- function(label, txt_padding = getOption("boxGrobTxtPadding", default = unit(6 * ifelse(is.null(txt_gp$cex), 1, txt_gp$cex), "mm")), box_gp = getOption("boxGrob", default = gpar(fill = "white")), box_fn = roundrectGrob, + box_fn_args = getOption("boxGrobFnArgs", default = list(r = unit(5, "pt"))), name = NULL, badge_label = NULL, badge_position = "top", @@ -66,6 +73,9 @@ boxGrob <- function(label, checkNumeric(label), is.language(label) ) + if (!is.list(box_fn_args)) { + stop("`box_fn_args` must be a named list.", call. = FALSE) + } assert_unit(y) assert_unit(x) assert_unit(width) @@ -83,10 +93,20 @@ boxGrob <- function(label, x <- prAsUnit(x) y <- prAsUnit(y) + # Filter box_fn_args to only the parameters box_fn actually accepts. + # This lets the default r = unit(5, "pt") be silently ignored for custom + # shape functions (e.g. diamond_rounded_box_fn) that have no `r` parameter. + # Functions that accept `...` receive all args unchanged. + fn_formals <- tryCatch(formals(box_fn), error = function(e) NULL) + if (!is.null(fn_formals) && !"..." %in% names(fn_formals)) { + accepted <- names(fn_formals) + box_fn_args <- box_fn_args[names(box_fn_args) %in% accepted] + } + # Call the box function early to collect any suggested padding attributes # (e.g., diamonds may request extra padding). This allows the padding to # influence text layout and the computed box width/height. - rect <- do.call(box_fn, list(x = .5, y = .5, gp = box_gp)) + rect <- do.call(box_fn, c(list(x = .5, y = .5, gp = box_gp), box_fn_args)) extra_pad <- attr(rect, "box_fn_padding") if (!is.null(extra_pad)) { tryCatch( diff --git a/R/boxGrobs_equalizeWidths.R b/R/boxGrobs_equalizeWidths.R index 5cbc5ec..b427dd8 100644 --- a/R/boxGrobs_equalizeWidths.R +++ b/R/boxGrobs_equalizeWidths.R @@ -165,3 +165,137 @@ prSetBoxDimensions <- function(element, width = NULL, height = NULL) { ) gl } + +#' Equalize box heights +#' +#' Sets selected boxes to a shared height. This is useful when boxes in the +#' same flowchart row or group should have a uniform vertical size, regardless +#' of how much text they contain. +#' +#' @param x A list of boxes (or nested lists of boxes). Can also be a single box. +#' @param subelement Optional target(s) inside `x`. +#' Can be a single path (e.g. `c("groups", 1)`) or a list of paths +#' (e.g. `list(c("groups", 1), c("groups2", 1))`). +#' If `NULL`, all top-level boxes in `x` are used. +#' @param height Optional height to apply. If `NULL`, the maximum current height +#' among selected boxes is used. +#' +#' @return The updated object with equalized heights. +#' @export +#' @family flowchart components +#' @examples +#' fc <- flowchart( +#' groups = list("Group 1\nLine 2", "Group 2") +#' ) +#' +#' fc |> +#' equalizeHeights(subelement = "groups") +#' +#' # Global fixed height via explicit argument +#' fc |> equalizeHeights(subelement = "groups", height = grid::unit(20, "mm")) +#' @md +equalizeHeights <- function(x, subelement = NULL, height = NULL) { + if (inherits(x, "box")) { + if (is.null(height)) { + return(x) + } + return(prSetBoxDimensions(x, height = height)) + } + + if (is.list(x) && !inherits(x, "Gmisc_list_of_boxes")) { + x <- prConvertListToBoxList(x) + } + + if (!inherits(x, "Gmisc_list_of_boxes")) { + stop("equalizeHeights() requires a box or list of boxes.", call. = FALSE) + } + + if (!is.null(height) && is.numeric(height)) { + height <- unit(height, "mm") + } + if (!is.null(height) && !inherits(height, "unit")) { + stop("`height` must be a unit or numeric.", call. = FALSE) + } + + resolve_paths <- function(obj, subelement) { + if (is.null(subelement)) { + idx <- which(vapply(obj, inherits, logical(1), "box")) + return(lapply(idx, as.list)) + } + if (is.list(subelement) && all(vapply(subelement, is.atomic, logical(1)))) { + return(subelement) + } + list(subelement) + } + + fetch_target <- function(obj, path) { + target <- get_list_element_by_path(obj, path) + if (!is.null(target)) { + return(list(target = target, first_container = FALSE)) + } + + if (length(obj) > 0 && is.list(obj[[1]]) && !inherits(obj[[1]], "box")) { + target2 <- get_list_element_by_path(obj[[1]], path) + if (!is.null(target2)) { + return(list(target = target2, first_container = TRUE)) + } + } + + list(target = NULL, first_container = FALSE) + } + + paths <- resolve_paths(x, subelement) + if (length(paths) == 0) { + return(x) + } + + selected <- list() + selected_meta <- list() + + for (i in seq_along(paths)) { + res <- fetch_target(x, paths[[i]]) + if (is.null(res$target)) { + stop("The subelement '", paste(paths[[i]], collapse = " -> "), "' was not found in the provided boxes.", call. = FALSE) + } + if (inherits(res$target, "box")) { + selected[[length(selected) + 1]] <- res$target + selected_meta[[length(selected_meta) + 1]] <- list( + path = paths[[i]], + first_container = res$first_container + ) + next + } + + if (prIsBoxList(res$target)) { + for (j in seq_along(res$target)) { + selected[[length(selected) + 1]] <- res$target[[j]] + selected_meta[[length(selected_meta) + 1]] <- list( + path = c(paths[[i]], j), + first_container = res$first_container + ) + } + next + } + + stop("The subelement '", paste(paths[[i]], collapse = " -> "), "' is not a box or a list of boxes.", call. = FALSE) + } + + target_height <- height + if (is.null(target_height)) { + heights_mm <- vapply(selected, function(b) { + prConvertHeightToMm(coords(b)$height) + }, numeric(1)) + target_height <- unit(max(heights_mm), "mm") + } + + for (i in seq_along(selected)) { + updated <- prSetBoxDimensions(selected[[i]], height = target_height) + if (isTRUE(selected_meta[[i]]$first_container)) { + x[[1]] <- set_list_element_by_path(x[[1]], selected_meta[[i]]$path, updated) + } else { + x <- set_list_element_by_path(x, selected_meta[[i]]$path, updated) + } + } + + prExtendClass(x, "Gmisc_list_of_boxes") +} diff --git a/tests/testthat/_snaps/vdiffr-connect/two-box-connector.svg b/tests/testthat/_snaps/vdiffr-connect/two-box-connector.svg deleted file mode 100644 index 3b3e764..0000000 --- a/tests/testthat/_snaps/vdiffr-connect/two-box-connector.svg +++ /dev/null @@ -1,24 +0,0 @@ - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/vdiffr/basic-box.svg b/tests/testthat/_snaps/vdiffr/basic-box.svg deleted file mode 100644 index c401fb1..0000000 --- a/tests/testthat/_snaps/vdiffr/basic-box.svg +++ /dev/null @@ -1,24 +0,0 @@ - - - - - - - - - - - - - -Test - - diff --git a/tests/testthat/test-boxGrob-corner-radius.R b/tests/testthat/test-boxGrob-corner-radius.R new file mode 100644 index 0000000..f3a09fe --- /dev/null +++ b/tests/testthat/test-boxGrob-corner-radius.R @@ -0,0 +1,39 @@ +library(testthat) +library(grid) + +test_that("boxGrob accepts box_fn_args and passes r to roundrectGrob", { + # Should not error — roundrectGrob accepts r + b <- boxGrob("Test", box_fn_args = list(r = unit(5, "mm"))) + expect_s3_class(b, "box") +}) + +test_that("boxGrob box_fn_args with fixed r produces same-sized corners for different box sizes", { + r_fixed <- unit(5, "mm") + small <- boxGrob("Hi", box_fn_args = list(r = r_fixed)) + big <- boxGrob( + paste(rep("The quick brown fox jumped over the lazy dog", 3), collapse = "\n"), + box_fn_args = list(r = r_fixed) + ) + expect_s3_class(small, "box") + expect_s3_class(big, "box") + small_h <- convertHeight(coords(small)$height, "mm", valueOnly = TRUE) + big_h <- convertHeight(coords(big)$height, "mm", valueOnly = TRUE) + expect_gt(big_h, small_h) +}) + +test_that("boxGrob respects the boxGrobFnArgs global option", { + withr::with_options( + list(boxGrobFnArgs = list(r = unit(3, "mm"))), + { + b <- boxGrob("Option test") + expect_s3_class(b, "box") + } + ) +}) + +test_that("boxGrob rejects non-list box_fn_args", { + expect_error( + boxGrob("Test", box_fn_args = unit(5, "mm")), + "`box_fn_args` must be a named list" + ) +}) diff --git a/tests/testthat/test-equalizeHeights.R b/tests/testthat/test-equalizeHeights.R new file mode 100644 index 0000000..4e70c8a --- /dev/null +++ b/tests/testthat/test-equalizeHeights.R @@ -0,0 +1,69 @@ +library(testthat) +library(grid) + +test_that("equalizeHeights() equalizes selected nested boxes and preserves centers", { + fc <- flowchart( + groups = list( + "Short", + "A much longer label\nwith two lines" + ), + groups2 = list( + "Tiny", + "Another longer\nlabel here" + ) + ) |> + spread(axis = "y", margin = unit(0.02, "npc")) |> + spread(subelement = "groups", axis = "x", margin = unit(.05, "npc")) |> + spread(subelement = "groups2", axis = "x", margin = unit(.05, "npc")) + + target_paths <- list(c("groups", 1), c("groups2", 1), c("groups", 2), c("groups2", 2)) + + y_before <- vapply(target_paths, function(p) { + b <- Gmisc:::get_list_element_by_path(fc, p) + convertY(coords(b)$y, "npc", valueOnly = TRUE) + }, numeric(1)) + + out <- equalizeHeights(fc, subelement = target_paths) + + heights_mm <- vapply(target_paths, function(p) { + b <- Gmisc:::get_list_element_by_path(out, p) + convertHeight(coords(b)$height, "mm", valueOnly = TRUE) + }, numeric(1)) + + y_after <- vapply(target_paths, function(p) { + b <- Gmisc:::get_list_element_by_path(out, p) + convertY(coords(b)$y, "npc", valueOnly = TRUE) + }, numeric(1)) + + # All heights should be equal (max of the group) + expect_true(all(abs(heights_mm - heights_mm[1]) < 1e-6)) + # Centers should be preserved + expect_equal(y_after, y_before, tolerance = 1e-8) +}) + +test_that("equalizeHeights() supports selecting a list-of-boxes path", { + fc <- flowchart( + groups = list("A", "Longer\nlabel\nwith\nthree lines") + ) + + out <- equalizeHeights(fc, subelement = "groups", height = unit(25, "mm")) + + heights_mm <- vapply(out$groups, function(b) { + convertHeight(coords(b)$height, "mm", valueOnly = TRUE) + }, numeric(1)) + + expect_true(all(abs(heights_mm - 25) < 1e-6)) +}) + +test_that("equalizeHeights() on a single box with explicit height works", { + b <- boxGrob("Hello") + b2 <- equalizeHeights(b, height = unit(30, "mm")) + h <- convertHeight(coords(b2)$height, "mm", valueOnly = TRUE) + expect_equal(h, 30, tolerance = 1e-6) +}) + +test_that("equalizeHeights() on a single box without height returns it unchanged", { + b <- boxGrob("Hello") + b2 <- equalizeHeights(b) + expect_identical(b, b2) +}) diff --git a/tests/visual_tests/corner_box.R b/tests/visual_tests/corner_box.R new file mode 100644 index 0000000..d504b40 --- /dev/null +++ b/tests/visual_tests/corner_box.R @@ -0,0 +1,55 @@ +# Visual test: fixed corner radii via box_fn_args +# +# Run this script from the package root: +# source("tests/visual_tests/corner_box.R") +# +# What to look for: +# Row 1 (DEFAULT): now also uses r = unit(5, "pt") as the new built-in default -- +# both boxes have identical corner radii right out of the box. +# Row 2 (EXPLICIT): same result spelled out explicitly per-box via +# box_fn_args = list(r = unit(5, "pt")). +# Row 3 (OLD DEFAULT): what the old snpc default looked like -- the large box +# has noticeably rounder corners than the small one. + +library(Gmisc) +library(grid) + +grid.newpage() + +# Title +grid.text( + "Fixed corner radii - default is now r = unit(5, 'pt')", + x = 0.5, y = 0.97, + gp = gpar(fontsize = 13, fontface = "bold") +) + +small_label <- "Small box" +big_label <- paste0("Large box\n", paste(rep("The quick brown fox jumped over the lazy dog", 2), collapse = "\n")) + +# -- Row 1: new default (5pt) --------------------------------------------------- +grid.text( + "Default (r = unit(5, 'pt')) - identical corners regardless of size:", + x = 0.03, y = 0.88, just = "left", + gp = gpar(fontsize = 9, col = "grey30") +) +grid.draw(boxGrob(small_label, x = unit(0.22, "npc"), y = unit(0.77, "npc"))) +grid.draw(boxGrob(big_label, x = unit(0.70, "npc"), y = unit(0.77, "npc"))) + +# -- Row 2: explicit per-box override ------------------------------------------- +grid.text( + "Explicit (box_fn_args = list(r = unit(5, 'pt'))) - same effect:", + x = 0.03, y = 0.57, just = "left", + gp = gpar(fontsize = 9, col = "grey30") +) +r_fixed <- list(r = unit(5, "pt")) +grid.draw(boxGrob(small_label, x = unit(0.22, "npc"), y = unit(0.46, "npc"), box_fn_args = r_fixed)) +grid.draw(boxGrob(big_label, x = unit(0.70, "npc"), y = unit(0.46, "npc"), box_fn_args = r_fixed)) + +# -- Row 3: old snpc default (for comparison) ----------------------------------- +grid.text( + "Old default (r = unit(0.1, 'snpc')) - corners scaled with box size:", + x = 0.03, y = 0.27, just = "left", + gp = gpar(fontsize = 9, col = "grey30") +) +grid.draw(boxGrob(small_label, x = unit(0.22, "npc"), y = unit(0.16, "npc"), box_fn_args = list(r = unit(0.1, "snpc")))) +grid.draw(boxGrob(big_label, x = unit(0.70, "npc"), y = unit(0.16, "npc"), box_fn_args = list(r = unit(0.1, "snpc")))) diff --git a/tests/visual_tests/equal_heights.R b/tests/visual_tests/equal_heights.R new file mode 100644 index 0000000..50e3e11 --- /dev/null +++ b/tests/visual_tests/equal_heights.R @@ -0,0 +1,59 @@ +# Visual test: equalizeHeights() +# +# Run this script from the package root: +# source("tests/visual_tests/equal_heights.R") +# +# What to look for: +# Top half (BEFORE): the two "groups2" boxes have very different heights +# because one has much more text — mirroring the issue reporter's flowchart. +# Bottom half (AFTER): equalizeHeights(subelement = "groups2") sets both +# boxes to the height of the taller one, giving a uniform row. + +library(Gmisc) +library(grid) +library(glue) + +fc <- flowchart( + rando = glue("Randomised N = 100"), + groups = list( + glue("Group 1\nn = 50"), + glue("Group 2\nn = 50") + ), + groups2 = list( + glue("Excluded\nn = 1"), + glue("Excluded\nn = 2\n\nThe quick brown fox\njumped over the lazy dog\n\n\n") + ) +) |> + spread(axis = "y") |> + spread(subelement = "groups", axis = "x") |> + spread(subelement = "groups2", axis = "x") + +grid.newpage() + +# Title +grid.text( + "equalizeHeights(subelement = 'groups2')", + x = 0.5, y = 0.97, + gp = gpar(fontsize = 13, fontface = "bold") +) + +# -- Before -------------------------------------------------------------------- +grid.text( + "Before - groups2 boxes differ in height:", + x = 0.03, y = 0.91, just = "left", + gp = gpar(fontsize = 9, col = "grey30") +) +pushViewport(viewport(x = 0.5, y = 0.70, width = 0.92, height = 0.38)) +print(fc) +popViewport() + +# -- After --------------------------------------------------------------------- +grid.text( + "After - both groups2 boxes share the height of the taller one:", + x = 0.03, y = 0.48, just = "left", + gp = gpar(fontsize = 9, col = "grey30") +) +fc2 <- fc |> equalizeHeights(subelement = "groups2") +pushViewport(viewport(x = 0.5, y = 0.24, width = 0.92, height = 0.44)) +print(fc2) +popViewport() From c73d2848966c1d22d3e75ffbef3d639648def5cb Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Wed, 10 Jun 2026 14:09:49 +0200 Subject: [PATCH 2/7] Allow for subelement to be a regex() object. --- R/boxGrobs_align.R | 14 +- R/boxGrobs_equalizeWidths.R | 30 ++-- R/boxGrobs_move.R | 10 +- R/boxGrobs_spread.R | 14 +- R/boxGrobs_subelement_select.R | 59 ++++++++ tests/testthat/test-subelement-regex.R | 183 +++++++++++++++++++++++++ 6 files changed, 280 insertions(+), 30 deletions(-) create mode 100644 R/boxGrobs_subelement_select.R create mode 100644 tests/testthat/test-subelement-regex.R diff --git a/R/boxGrobs_align.R b/R/boxGrobs_align.R index 4edefe0..cce2e75 100644 --- a/R/boxGrobs_align.R +++ b/R/boxGrobs_align.R @@ -9,9 +9,13 @@ #' @param position How to align the boxes, differs slightly for vertical and horizontal alignment #' see the accepted arguments #' @param subelement If a `list` of boxes is provided, this parameter can be used -#' to target a specific element (by name or index), or a deep path into nested -#' lists (e.g., `c("detail", 1)`), for the alignment operation. You can also -#' provide multiple targets by giving a list of paths (e.g., `list(c("detail", 1), c("followup", 1))`). +#' to target a specific element (by name or index), a deep path into nested +#' lists (e.g., `c("detail", 1)`), or a regex selector created with +#' [stringr::regex()] that is matched against top-level names +#' (e.g. `stringr::regex("^groups")`). You can also provide multiple targets +#' as a list of paths or selectors (e.g., +#' `list(c("detail", 1), stringr::regex("^followup"))`). +#' Bare character strings are always treated as literal paths. #' When a list of boxes is *piped* into `alignVertical()`/`alignHorizontal()` and a named `reference` is #' provided (e.g. `my_boxes |> alignHorizontal(reference = c("grp","sub"), .subelement = ...)`), the #' function will unwrap a single-element wrapper so nested `.subelement` targets are found as expected. @@ -79,7 +83,7 @@ alignVertical <- function(reference, ..., position = c("center", "top", "bottom" if (!is.null(subelement)) { # Normalize into a list of paths (each path is an atomic vector) - paths <- if (is.list(subelement) && all(sapply(subelement, is.atomic))) subelement else list(subelement) + paths <- prResolveSubelementSelector(subelement, boxes2align) for (path in paths) { # Find target using helper (search top-level and first nested container) @@ -197,7 +201,7 @@ alignHorizontal <- function( if (!is.null(subelement)) { # Normalize into a list of paths (each path is an atomic vector) - paths <- if (is.list(subelement) && all(sapply(subelement, is.atomic))) subelement else list(subelement) + paths <- prResolveSubelementSelector(subelement, boxes2align) for (path in paths) { # Find target using helper (search top-level and first nested container) diff --git a/R/boxGrobs_equalizeWidths.R b/R/boxGrobs_equalizeWidths.R index b427dd8..3913a7b 100644 --- a/R/boxGrobs_equalizeWidths.R +++ b/R/boxGrobs_equalizeWidths.R @@ -4,10 +4,12 @@ #' levels so corresponding boxes have consistent visual width and center points. #' #' @param x A list of boxes (or nested lists of boxes). Can also be a single box. -#' @param subelement Optional target(s) inside `x`. -#' Can be a single path (e.g. `c("groups", 1)`) or a list of paths -#' (e.g. `list(c("groups", 1), c("groups2", 1))`). -#' If `NULL`, all top-level boxes in `x` are used. +#' @param subelement Optional target(s) inside `x`. Can be a single path +#' (e.g. `"groups"` or `c("groups", 1)`), a list of paths +#' (e.g. `list(c("groups", 1), c("groups2", 1))`), or a regex selector +#' created with [stringr::regex()] that is matched against top-level names +#' (e.g. `stringr::regex("^groups")`). Bare character strings are always +#' treated as literal paths. If `NULL`, all top-level boxes in `x` are used. #' @param width Optional width to apply. If `NULL`, the maximum current width #' among selected boxes is used. #' @@ -57,10 +59,7 @@ equalizeWidths <- function(x, subelement = NULL, width = NULL) { idx <- which(vapply(obj, inherits, logical(1), "box")) return(lapply(idx, as.list)) } - if (is.list(subelement) && all(vapply(subelement, is.atomic, logical(1)))) { - return(subelement) - } - list(subelement) + prResolveSubelementSelector(subelement, obj) } fetch_target <- function(obj, path) { @@ -173,10 +172,12 @@ prSetBoxDimensions <- function(element, width = NULL, height = NULL) { #' of how much text they contain. #' #' @param x A list of boxes (or nested lists of boxes). Can also be a single box. -#' @param subelement Optional target(s) inside `x`. -#' Can be a single path (e.g. `c("groups", 1)`) or a list of paths -#' (e.g. `list(c("groups", 1), c("groups2", 1))`). -#' If `NULL`, all top-level boxes in `x` are used. +#' @param subelement Optional target(s) inside `x`. Can be a single path +#' (e.g. `"groups"` or `c("groups", 1)`), a list of paths +#' (e.g. `list(c("groups", 1), c("groups2", 1))`), or a regex selector +#' created with [stringr::regex()] that is matched against top-level names +#' (e.g. `stringr::regex("^groups")`). Bare character strings are always +#' treated as literal paths. If `NULL`, all top-level boxes in `x` are used. #' @param height Optional height to apply. If `NULL`, the maximum current height #' among selected boxes is used. #' @@ -222,10 +223,7 @@ equalizeHeights <- function(x, subelement = NULL, height = NULL) { idx <- which(vapply(obj, inherits, logical(1), "box")) return(lapply(idx, as.list)) } - if (is.list(subelement) && all(vapply(subelement, is.atomic, logical(1)))) { - return(subelement) - } - list(subelement) + prResolveSubelementSelector(subelement, obj) } fetch_target <- function(obj, path) { diff --git a/R/boxGrobs_move.R b/R/boxGrobs_move.R index 9b5d270..4344eae 100644 --- a/R/boxGrobs_move.R +++ b/R/boxGrobs_move.R @@ -13,9 +13,11 @@ #' (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. -#' @param subelement If a `list` of boxes is provided, this can be a name, index, a deep path (e.g. `c("detail", 1)`) or a -#' vector of names/indices to target a single nested element to move. You can also pass -#' multiple targets as a list of paths (e.g. `list(c("detail", 1), c("followup", 1))`). +#' @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 +#' (e.g. `stringr::regex("^groups")`), or a list of any of the above. +#' Bare character strings are always treated as literal paths. #' The function will return the original list with the targeted element(s) replaced by their moved version(s). #' @return The element with updated viewport and coordinates #' @@ -45,7 +47,7 @@ moveBox <- function(element, } # Normalize into list of paths - paths <- if (is.list(subelement) && all(sapply(subelement, is.atomic))) subelement else list(subelement) + paths <- prResolveSubelementSelector(subelement, element) for (path in paths) { norm_seg <- function(s) { diff --git a/R/boxGrobs_spread.R b/R/boxGrobs_spread.R index 47e7f05..3c97d01 100644 --- a/R/boxGrobs_spread.R +++ b/R/boxGrobs_spread.R @@ -20,9 +20,13 @@ #' @param type If `between`, the space *between* boxes is identical. If `center`, #' the centers of the boxes are equally distributed across the span. #' @param subelement If a `list` of boxes is provided, this parameter can be used -#' to target a specific element (by name or index), or a deep path into nested -#' lists (e.g., `c("detail", 1)`), for the spreading operation. You can also -#' provide multiple targets by giving a list of paths (e.g., `list(c("detail", 1), c("followup", 1))`). +#' to target a specific element (by name or index), a deep path into nested +#' lists (e.g., `c("detail", 1)`), or a regex selector created with +#' [stringr::regex()] that is matched against top-level names +#' (e.g. `stringr::regex("^groups")`). You can also provide multiple targets +#' as a list of paths or selectors (e.g., +#' `list(c("detail", 1), stringr::regex("^followup"))`). +#' 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). #' @@ -64,7 +68,7 @@ spreadVertical <- function( } if (!is.null(subelement)) { - paths <- if (is.list(subelement) && all(sapply(subelement, is.atomic))) subelement else list(subelement) + paths <- prResolveSubelementSelector(subelement, boxes2spread) # Resolve from/to if they are given as paths into the top-level list resolve_endpoint <- function(endpoint) { @@ -164,7 +168,7 @@ spreadHorizontal <- function(..., from = NULL, to = NULL, margin = unit(0, "npc" } if (!is.null(subelement)) { - paths <- if (is.list(subelement) && all(sapply(subelement, is.atomic))) subelement else list(subelement) + paths <- prResolveSubelementSelector(subelement, boxes2spread) resolve_endpoint <- function(endpoint) { # Only attempt path resolution for character-like paths (e.g. c("detail", 1)) diff --git a/R/boxGrobs_subelement_select.R b/R/boxGrobs_subelement_select.R new file mode 100644 index 0000000..3785a2a --- /dev/null +++ b/R/boxGrobs_subelement_select.R @@ -0,0 +1,59 @@ +# Internal helper: resolve subelement selectors into canonical literal paths +# +# Handles three input shapes: +# - A `stringr_regex` object (from `stringr::regex()`) -> match top-level names of `x` +# - A plain list -> resolve each element recursively +# - Anything else (character, numeric, c("name", idx)) -> wrap in list() as a single literal path +# +# The recursive list branch deliberately does NOT split atomic vectors +# (e.g. `c("groups", 1)`) into individual segments -- those remain one path. +# +# @param subelement A path, list of paths, or `stringr::regex()` selector. +# @param x The named box list being operated on. +# @return A list of atomic path vectors ready for the callers' path-resolution logic. +# @keywords internal +# @noRd +prResolveSubelementSelector <- function(subelement, x) { + if (inherits(subelement, "stringr_regex")) { + nms <- names(x) + + if (is.null(nms)) { + warning( + "Cannot use regex subelement selection because the target box list has no names.", + call. = FALSE + ) + return(list()) + } + + is_match <- stringr::str_detect(nms, subelement) + is_match[is.na(is_match)] <- FALSE + matched <- nms[is_match] + + if (length(matched) == 0) { + warning( + sprintf( + "Regex subelement selector `%s` matched no top-level subelement names.", + as.character(subelement) + ), + call. = FALSE + ) + return(list()) + } + + return(as.list(matched)) + } + + # A plain list: resolve each element independently so that + # mixed lists like list(stringr::regex("^groups"), "other_exact") work, + # while atomic vectors like c("groups", 1) inside a list remain a single path. + if (is.list(subelement)) { + return(unlist( + lapply(subelement, prResolveSubelementSelector, x = x), + recursive = FALSE + )) + } + + # Literal path: a character string, a numeric index, or a multi-segment + # vector like c("groups", 1). Wrap in a list to produce one path entry. + list(subelement) +} diff --git a/tests/testthat/test-subelement-regex.R b/tests/testthat/test-subelement-regex.R new file mode 100644 index 0000000..ffbefcc --- /dev/null +++ b/tests/testthat/test-subelement-regex.R @@ -0,0 +1,183 @@ +library(testthat) +library(grid) + +# Helper: build a small flowchart with groups* and excl* elements +make_fc <- function() { + flowchart( + groups1 = list("A", "B"), + groups2 = list("C", "D"), + excl1 = list("X"), + excl2 = list("Y"), + other = list("Z") + ) |> + spread(axis = "y", margin = unit(0.02, "npc")) |> + spread(subelement = "groups1", axis = "x", margin = unit(.05, "npc")) |> + spread(subelement = "groups2", axis = "x", margin = unit(.05, "npc")) +} + +# ── regex("^groups") selects all groups* names ──────────────────────────────── + +test_that("regex('^groups') equalizes all groups* boxes", { + fc <- make_fc() + out <- equalizeWidths(fc, subelement = stringr::regex("^groups")) + + # Both groups1 and groups2 boxes should share the same width + all_paths <- list(c("groups1", 1), c("groups1", 2), c("groups2", 1), c("groups2", 2)) + widths_mm <- vapply(all_paths, function(p) { + b <- Gmisc:::get_list_element_by_path(out, p) + convertWidth(coords(b)$width, "mm", valueOnly = TRUE) + }, numeric(1)) + + expect_true(all(abs(widths_mm - widths_mm[1]) < 1e-6)) + + # excl* and other boxes must be untouched (different width) + excl1_w <- convertWidth(coords(out$excl1[[1]])$width, "mm", valueOnly = TRUE) + expect_false(isTRUE(all.equal(excl1_w, widths_mm[1], tolerance = 1e-6))) +}) + +# ── regex("^excl") selects only excl* names ─────────────────────────────────── + +test_that("regex('^excl') equalizes only excl* boxes", { + fc <- make_fc() + # Pre-widen groups* boxes so they are clearly wider than excl* boxes + fc <- equalizeWidths(fc, subelement = stringr::regex("^groups"), width = unit(60, "mm")) + + out <- equalizeWidths(fc, subelement = stringr::regex("^excl")) + + excl_paths <- list(c("excl1", 1), c("excl2", 1)) + widths_mm <- vapply(excl_paths, function(p) { + b <- Gmisc:::get_list_element_by_path(out, p) + convertWidth(coords(b)$width, "mm", valueOnly = TRUE) + }, numeric(1)) + + expect_true(all(abs(widths_mm - widths_mm[1]) < 1e-6)) + + # groups* must be untouched (still 60mm) + g1_w <- convertWidth(coords(out$groups1[[1]])$width, "mm", valueOnly = TRUE) + expect_equal(g1_w, 60, tolerance = 1e-6) + # excl boxes are auto-sized and clearly narrower than 60mm + expect_lt(widths_mm[1], 60 - 1) +}) + +# ── bare "^groups" remains a literal path, not a regex ─────────────────────── + +test_that("bare '^groups' string is a literal path and errors when not found", { + fc <- make_fc() + # "^groups" is not a name in fc, so it should error + expect_error( + equalizeWidths(fc, subelement = "^groups"), + regexp = "not found" + ) +}) + +# ── bare "groups1" preserves existing literal behavior ─────────────────────── + +test_that("bare 'groups1' still selects the groups1 list element", { + fc <- make_fc() + out <- equalizeWidths(fc, subelement = "groups1", width = unit(40, "mm")) + + widths_mm <- vapply(out$groups1, function(b) { + convertWidth(coords(b)$width, "mm", valueOnly = TRUE) + }, numeric(1)) + + expect_true(all(abs(widths_mm - 40) < 1e-6)) + + # groups2 width must differ + g2_w <- convertWidth(coords(out$groups2[[1]])$width, "mm", valueOnly = TRUE) + expect_false(isTRUE(all.equal(g2_w, 40, tolerance = 1e-6))) +}) + +# ── mixed list: regex + literal ─────────────────────────────────────────────── + +test_that("mixed list list(regex('^groups'), 'other') selects both", { + fc <- make_fc() + out <- equalizeWidths(fc, subelement = list(stringr::regex("^groups"), "other")) + + all_paths <- list( + c("groups1", 1), c("groups1", 2), + c("groups2", 1), c("groups2", 2), + c("other", 1) + ) + widths_mm <- vapply(all_paths, function(p) { + b <- Gmisc:::get_list_element_by_path(out, p) + convertWidth(coords(b)$width, "mm", valueOnly = TRUE) + }, numeric(1)) + + expect_true(all(abs(widths_mm - widths_mm[1]) < 1e-6)) +}) + +# ── nested path vectors preserved: c("groups1", 1) stays one path ──────────── + +test_that("c('groups1', 1) as a single path works unchanged", { + fc <- make_fc() + out <- equalizeWidths(fc, subelement = c("groups1", 1), width = unit(35, "mm")) + + w <- convertWidth(coords(out$groups1[[1]])$width, "mm", valueOnly = TRUE) + expect_equal(w, 35, tolerance = 1e-6) + + # Second box in groups1 must NOT be changed + w2 <- convertWidth(coords(out$groups1[[2]])$width, "mm", valueOnly = TRUE) + expect_false(isTRUE(all.equal(w2, 35, tolerance = 1e-6))) +}) + +test_that("list(c('groups1', 1), 'other') mixes nested path and literal", { + fc <- make_fc() + out <- equalizeWidths(fc, subelement = list(c("groups1", 1), c("other", 1))) + + w1 <- convertWidth(coords(out$groups1[[1]])$width, "mm", valueOnly = TRUE) + wo <- convertWidth(coords(out$other[[1]])$width, "mm", valueOnly = TRUE) + expect_equal(w1, wo, tolerance = 1e-6) +}) + +# ── no regex match emits a warning ─────────────────────────────────────────── + +test_that("regex selector matching no names warns", { + fc <- make_fc() + expect_warning( + equalizeWidths(fc, subelement = stringr::regex("^gruops")), + regexp = "matched no top-level subelement names" + ) +}) + +# ── ignore_case option is respected ────────────────────────────────────────── + +test_that("regex('^GROUPS', ignore_case = TRUE) matches lowercase names", { + fc <- make_fc() + out <- expect_no_warning( + equalizeWidths(fc, subelement = stringr::regex("^GROUPS", ignore_case = TRUE)) + ) + + all_paths <- list(c("groups1", 1), c("groups1", 2), c("groups2", 1), c("groups2", 2)) + widths_mm <- vapply(all_paths, function(p) { + b <- Gmisc:::get_list_element_by_path(out, p) + convertWidth(coords(b)$width, "mm", valueOnly = TRUE) + }, numeric(1)) + + expect_true(all(abs(widths_mm - widths_mm[1]) < 1e-6)) +}) + +# ── NA names are skipped, not turned into NA paths ─────────────────────────── + +test_that("NA element names are ignored and do not produce NA paths", { + fc <- make_fc() + + # Inject an NA name into the list — the regex should skip it (str_detect returns + # NA for NA inputs, which the resolver converts to FALSE), so the remaining + # valid 'groups*' names are still matched without error or warning. + names(fc)[length(names(fc))] <- NA_character_ + + # Should not crash: the NA name is skipped (str_detect returns NA -> FALSE), + # and the valid groups* names are still matched and equalized normally. + out <- expect_no_warning( + equalizeWidths(fc, subelement = stringr::regex("^groups")) + ) + expect_true(is.list(out)) + + # The groups* boxes should have been equalized (same width) + all_paths <- list(c("groups1", 1), c("groups1", 2), c("groups2", 1), c("groups2", 2)) + widths_mm <- vapply(all_paths, function(p) { + b <- Gmisc:::get_list_element_by_path(out, p) + convertWidth(coords(b)$width, "mm", valueOnly = TRUE) + }, numeric(1)) + expect_true(all(abs(widths_mm - widths_mm[1]) < 1e-6)) +}) From 177b58734d6ec90e0f912e8b7f7d5c46c33fd317 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Wed, 10 Jun 2026 14:48:08 +0200 Subject: [PATCH 3/7] Doc fixes and other minor things --- .Rbuildignore | 1 + man/align.Rd | 11 ++-- man/append.Rd | 1 + man/box.Rd | 9 ++++ man/boxHeaderGrob.Rd | 1 + man/boxPropGrob.Rd | 1 + man/boxShapes.Rd | 1 + man/connect.Rd | 1 + man/coords.Rd | 1 + man/distance.Rd | 1 + man/equalizeHeights.Rd | 60 +++++++++++++++++++++ man/equalizeWidths.Rd | 11 ++-- man/flowchart.Rd | 1 + man/insert.Rd | 1 + man/move.Rd | 1 + man/moveBox.Rd | 9 ++-- man/phaseLabel.Rd | 1 + man/spread.Rd | 11 ++-- tests/testthat/test-boxGrob-corner-radius.R | 12 ++--- 19 files changed, 115 insertions(+), 20 deletions(-) create mode 100644 man/equalizeHeights.Rd diff --git a/.Rbuildignore b/.Rbuildignore index ce92312..1e647c5 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -27,3 +27,4 @@ Gmisc/inst/extdata/Full_test_suite_files/* ^.github/ ^docs/ ^README\.Rmd$ +^README\.html$ diff --git a/man/align.Rd b/man/align.Rd index c5f1e92..859e6ae 100644 --- a/man/align.Rd +++ b/man/align.Rd @@ -43,9 +43,13 @@ provided and is \code{0} or greater than the number of boxes, it is treated as a see the accepted arguments} \item{subelement}{If a \code{list} of boxes is provided, this parameter can be used -to target a specific element (by name or index), or a deep path into nested -lists (e.g., \code{c("detail", 1)}), for the alignment operation. You can also -provide multiple targets by giving a list of paths (e.g., \code{list(c("detail", 1), c("followup", 1))}). +to target a specific element (by name or index), a deep path into nested +lists (e.g., \code{c("detail", 1)}), or a regex selector created with +\code{\link[stringr:regex]{stringr::regex()}} that is matched against top-level names +(e.g. \code{stringr::regex("^groups")}). You can also provide multiple targets +as a list of paths or selectors (e.g., +\code{list(c("detail", 1), stringr::regex("^followup"))}). +Bare character strings are always treated as literal paths. When a list of boxes is \emph{piped} into \code{alignVertical()}/\code{alignHorizontal()} and a named \code{reference} is provided (e.g. \code{my_boxes |> alignHorizontal(reference = c("grp","sub"), .subelement = ...)}), the function will unwrap a single-element wrapper so nested \code{.subelement} targets are found as expected. @@ -126,6 +130,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/append.Rd b/man/append.Rd index a0dc326..5b7fb5e 100644 --- a/man/append.Rd +++ b/man/append.Rd @@ -36,6 +36,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/box.Rd b/man/box.Rd index 5927b83..60cf270 100644 --- a/man/box.Rd +++ b/man/box.Rd @@ -21,6 +21,7 @@ boxGrob( ifelse(is.null(txt_gp$cex), 1, txt_gp$cex), "mm")), box_gp = getOption("boxGrob", default = gpar(fill = "white")), box_fn = roundrectGrob, + box_fn_args = getOption("boxGrobFnArgs", default = list(r = unit(5, "pt"))), name = NULL, badge_label = NULL, badge_position = "top", @@ -64,6 +65,13 @@ a global default with \code{options(boxGrobTxtPadding = ...)}.} \item{box_fn}{Function to create box for the text. Parameters of `x=0.5`, `y=0.5` and `box_gp` will be passed to this function and return a \code{grob} object.} +\item{box_fn_args}{An optional named list of extra arguments forwarded to `box_fn`. This is useful +for controlling parameters such as the corner radius `r` of \code{\link[grid]{roundrectGrob}} so that +all boxes have the same absolute corner radius regardless of their size. Defaults to +\code{list(r = grid::unit(5, "pt"))} which gives every box a fixed 5 pt corner radius +(approximately equivalent to the widely-used 5 px CSS \code{border-radius}). +You can override per box or set a global default via \code{options(boxGrobFnArgs = list(r = grid::unit(5, "mm")))}.} + \item{name}{a character identifier for the \code{grob}. Used to find the \code{grob} on the display list and/or as a child of another grob.} @@ -121,6 +129,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/boxHeaderGrob.Rd b/man/boxHeaderGrob.Rd index da260ee..e60bdb3 100644 --- a/man/boxHeaderGrob.Rd +++ b/man/boxHeaderGrob.Rd @@ -97,6 +97,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/boxPropGrob.Rd b/man/boxPropGrob.Rd index 4ad69ca..0573932 100644 --- a/man/boxPropGrob.Rd +++ b/man/boxPropGrob.Rd @@ -93,6 +93,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/boxShapes.Rd b/man/boxShapes.Rd index d79eb31..ef72dc1 100644 --- a/man/boxShapes.Rd +++ b/man/boxShapes.Rd @@ -226,6 +226,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/connect.Rd b/man/connect.Rd index 8791cb6..a8a1aac 100644 --- a/man/connect.Rd +++ b/man/connect.Rd @@ -283,6 +283,7 @@ Other flowchart components: \code{\link{boxShapes}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/coords.Rd b/man/coords.Rd index 3f388ff..1e7e889 100644 --- a/man/coords.Rd +++ b/man/coords.Rd @@ -29,6 +29,7 @@ Other flowchart components: \code{\link{boxShapes}}, \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/distance.Rd b/man/distance.Rd index b7ee148..6978f1e 100644 --- a/man/distance.Rd +++ b/man/distance.Rd @@ -60,6 +60,7 @@ Other flowchart components: \code{\link{boxShapes}}, \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/equalizeHeights.Rd b/man/equalizeHeights.Rd new file mode 100644 index 0000000..73e130b --- /dev/null +++ b/man/equalizeHeights.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/boxGrobs_equalizeWidths.R +\name{equalizeHeights} +\alias{equalizeHeights} +\title{Equalize box heights} +\usage{ +equalizeHeights(x, subelement = NULL, height = NULL) +} +\arguments{ +\item{x}{A list of boxes (or nested lists of boxes). Can also be a single box.} + +\item{subelement}{Optional target(s) inside \code{x}. Can be a single path +(e.g. \code{"groups"} or \code{c("groups", 1)}), a list of paths +(e.g. \code{list(c("groups", 1), c("groups2", 1))}), or a regex selector +created with \code{\link[stringr:regex]{stringr::regex()}} that is matched against top-level names +(e.g. \code{stringr::regex("^groups")}). Bare character strings are always +treated as literal paths. If \code{NULL}, all top-level boxes in \code{x} are used.} + +\item{height}{Optional height to apply. If \code{NULL}, the maximum current height +among selected boxes is used.} +} +\value{ +The updated object with equalized heights. +} +\description{ +Sets selected boxes to a shared height. This is useful when boxes in the +same flowchart row or group should have a uniform vertical size, regardless +of how much text they contain. +} +\examples{ +fc <- flowchart( + groups = list("Group 1\nLine 2", "Group 2") +) + +fc |> + equalizeHeights(subelement = "groups") + +# Global fixed height via explicit argument +fc |> equalizeHeights(subelement = "groups", height = grid::unit(20, "mm")) +} +\seealso{ +Other flowchart components: +\code{\link[=align]{align()}}, +\code{\link[=append]{append()}}, +\code{\link[=boxGrob]{boxGrob()}}, +\code{\link[=boxHeaderGrob]{boxHeaderGrob()}}, +\code{\link[=boxPropGrob]{boxPropGrob()}}, +\code{\link{boxShapes}}, +\code{\link[=connectGrob]{connectGrob()}}, +\code{\link[=coords]{coords()}}, +\code{\link[=distance]{distance()}}, +\code{\link[=equalizeWidths]{equalizeWidths()}}, +\code{\link[=flowchart]{flowchart()}}, +\code{\link[=insert]{insert()}}, +\code{\link[=move]{move()}}, +\code{\link[=moveBox]{moveBox()}}, +\code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=spread]{spread()}} +} +\concept{flowchart components} diff --git a/man/equalizeWidths.Rd b/man/equalizeWidths.Rd index dbccc3a..e8191c3 100644 --- a/man/equalizeWidths.Rd +++ b/man/equalizeWidths.Rd @@ -9,10 +9,12 @@ equalizeWidths(x, subelement = NULL, width = NULL) \arguments{ \item{x}{A list of boxes (or nested lists of boxes). Can also be a single box.} -\item{subelement}{Optional target(s) inside \code{x}. -Can be a single path (e.g. \code{c("groups", 1)}) or a list of paths -(e.g. \code{list(c("groups", 1), c("groups2", 1))}). -If \code{NULL}, all top-level boxes in \code{x} are used.} +\item{subelement}{Optional target(s) inside \code{x}. Can be a single path +(e.g. \code{"groups"} or \code{c("groups", 1)}), a list of paths +(e.g. \code{list(c("groups", 1), c("groups2", 1))}), or a regex selector +created with \code{\link[stringr:regex]{stringr::regex()}} that is matched against top-level names +(e.g. \code{stringr::regex("^groups")}). Bare character strings are always +treated as literal paths. If \code{NULL}, all top-level boxes in \code{x} are used.} \item{width}{Optional width to apply. If \code{NULL}, the maximum current width among selected boxes is used.} @@ -50,6 +52,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, \code{\link[=move]{move()}}, diff --git a/man/flowchart.Rd b/man/flowchart.Rd index bacf0e7..29c4c0a 100644 --- a/man/flowchart.Rd +++ b/man/flowchart.Rd @@ -51,6 +51,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=insert]{insert()}}, \code{\link[=move]{move()}}, diff --git a/man/insert.Rd b/man/insert.Rd index 35513bc..320c797 100644 --- a/man/insert.Rd +++ b/man/insert.Rd @@ -48,6 +48,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=move]{move()}}, diff --git a/man/move.Rd b/man/move.Rd index 98f642c..3535933 100644 --- a/man/move.Rd +++ b/man/move.Rd @@ -37,6 +37,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/moveBox.Rd b/man/moveBox.Rd index 9af878d..5dd14e3 100644 --- a/man/moveBox.Rd +++ b/man/moveBox.Rd @@ -28,9 +28,11 @@ moveBox( 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.} -\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)}) or a -vector of names/indices to target a single nested element to move. You can also pass -multiple targets as a list of paths (e.g. \code{list(c("detail", 1), c("followup", 1))}). +\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 +\code{\link[stringr:regex]{stringr::regex()}} that is matched against top-level names +(e.g. \code{stringr::regex("^groups")}), or a list of any of the above. +Bare character strings are always treated as literal paths. The function will return the original list with the targeted element(s) replaced by their moved version(s).} } \value{ @@ -104,6 +106,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/phaseLabel.Rd b/man/phaseLabel.Rd index 6dbb38c..7b78243 100644 --- a/man/phaseLabel.Rd +++ b/man/phaseLabel.Rd @@ -81,6 +81,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/man/spread.Rd b/man/spread.Rd index 7b07d85..b22c04c 100644 --- a/man/spread.Rd +++ b/man/spread.Rd @@ -58,9 +58,13 @@ span comes from \code{from} / \code{to} or the viewport.} the centers of the boxes are equally distributed across the span.} \item{subelement}{If a \code{list} of boxes is provided, this parameter can be used -to target a specific element (by name or index), or a deep path into nested -lists (e.g., \code{c("detail", 1)}), for the spreading operation. You can also -provide multiple targets by giving a list of paths (e.g., \code{list(c("detail", 1), c("followup", 1))}). +to target a specific element (by name or index), a deep path into nested +lists (e.g., \code{c("detail", 1)}), or a regex selector created with +\code{\link[stringr:regex]{stringr::regex()}} that is matched against top-level names +(e.g. \code{stringr::regex("^groups")}). You can also provide multiple targets +as a list of paths or selectors (e.g., +\code{list(c("detail", 1), stringr::regex("^followup"))}). +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).} } @@ -133,6 +137,7 @@ Other flowchart components: \code{\link[=connectGrob]{connectGrob()}}, \code{\link[=coords]{coords()}}, \code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, \code{\link[=equalizeWidths]{equalizeWidths()}}, \code{\link[=flowchart]{flowchart()}}, \code{\link[=insert]{insert()}}, diff --git a/tests/testthat/test-boxGrob-corner-radius.R b/tests/testthat/test-boxGrob-corner-radius.R index f3a09fe..8bade48 100644 --- a/tests/testthat/test-boxGrob-corner-radius.R +++ b/tests/testthat/test-boxGrob-corner-radius.R @@ -22,13 +22,11 @@ test_that("boxGrob box_fn_args with fixed r produces same-sized corners for diff }) test_that("boxGrob respects the boxGrobFnArgs global option", { - withr::with_options( - list(boxGrobFnArgs = list(r = unit(3, "mm"))), - { - b <- boxGrob("Option test") - expect_s3_class(b, "box") - } - ) + old_opts <- options(boxGrobFnArgs = list(r = unit(3, "mm"))) + on.exit(options(old_opts)) + + b <- boxGrob("Option test") + expect_s3_class(b, "box") }) test_that("boxGrob rejects non-list box_fn_args", { From d938f0bed49d19e70469c6f69dd1cde488704ff7 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Wed, 10 Jun 2026 21:29:30 +0200 Subject: [PATCH 4/7] ci: add vdiffr baseline snapshots and bump checkout to v4 Adds initial SVG reference snapshots for boxGrob and connectGrob visual regression tests so CI no longer fails with "Adding new file snapshot". Also upgrades actions/checkout from v3 to v4 to fix Node.js 20 deprecation warning (forced to Node.js 24 from June 16th 2026). Co-Authored-By: Claude Sonnet 4.6 --- .github/workflows/ci.yaml | 2 +- .../vdiffr-connect/two-box-connector.svg | 24 +++++++++++++++++++ tests/testthat/_snaps/vdiffr/basic-box.svg | 24 +++++++++++++++++++ 3 files changed, 49 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/_snaps/vdiffr-connect/two-box-connector.svg create mode 100644 tests/testthat/_snaps/vdiffr/basic-box.svg diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 81f44b0..76ee109 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -10,7 +10,7 @@ jobs: R-CMD-check: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-r@v2 - uses: r-lib/actions/setup-r-dependencies@v2 with: diff --git a/tests/testthat/_snaps/vdiffr-connect/two-box-connector.svg b/tests/testthat/_snaps/vdiffr-connect/two-box-connector.svg new file mode 100644 index 0000000..3b3e764 --- /dev/null +++ b/tests/testthat/_snaps/vdiffr-connect/two-box-connector.svg @@ -0,0 +1,24 @@ + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/vdiffr/basic-box.svg b/tests/testthat/_snaps/vdiffr/basic-box.svg new file mode 100644 index 0000000..8971129 --- /dev/null +++ b/tests/testthat/_snaps/vdiffr/basic-box.svg @@ -0,0 +1,24 @@ + + + + + + + + + + + + + +Test + + From 36ae315933646df3d97e36167256c3e9c18f9781 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Thu, 11 Jun 2026 13:17:54 +0200 Subject: [PATCH 5/7] Added dotted lines and position() with relative moves Closes issue #76 --- .Rbuildignore | 1 + NAMESPACE | 4 + NEWS.md | 4 +- R/boxGrobs_connect.R | 16 ++ R/boxGrobs_connect_pr_single_boxes.R | 20 +- R/boxGrobs_connect_strategies.R | 3 + R/boxGrobs_coords.R | 16 +- R/boxGrobs_move.R | 3 + R/boxGrobs_position.R | 149 ++++++++++++++ R/boxGrobs_s3_connect.R | 182 +++++++++++++++++- R/boxGrobs_s3_spread.R | 2 +- man/align.Rd | 1 + man/append.Rd | 1 + man/box.Rd | 1 + man/boxHeaderGrob.Rd | 1 + man/boxPropGrob.Rd | 1 + man/boxShapes.Rd | 1 + man/connect.Rd | 21 +- man/coords.Rd | 15 +- man/distance.Rd | 1 + man/equalizeHeights.Rd | 1 + man/equalizeWidths.Rd | 1 + man/flowchart.Rd | 1 + man/insert.Rd | 1 + man/move.Rd | 1 + man/moveBox.Rd | 1 + man/phaseLabel.Rd | 1 + man/position.Rd | 66 +++++++ man/spread.Rd | 3 +- .../test-flowchart-issue76-connectors.R | 153 +++++++++++++++ vignettes/Grid-based_flowcharts.Rmd | 91 ++++++++- 31 files changed, 742 insertions(+), 21 deletions(-) create mode 100644 R/boxGrobs_position.R create mode 100644 man/position.Rd create mode 100644 tests/testthat/test-flowchart-issue76-connectors.R diff --git a/.Rbuildignore b/.Rbuildignore index 1e647c5..3b7356f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -28,3 +28,4 @@ Gmisc/inst/extdata/Full_test_suite_files/* ^docs/ ^README\.Rmd$ ^README\.html$ +^Rplots.pdf diff --git a/NAMESPACE b/NAMESPACE index 89a7627..579cca5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,9 @@ S3method(phaseLabel,default) S3method(plot,box) S3method(plot,connect_boxes) S3method(plot,connect_boxes_list) +S3method(position,box) +S3method(position,coords) +S3method(position,default) S3method(prCalculateConnector,ConnectorStrategy) S3method(prCalculateConnector,ManyToOneFanInCenterConnectorStrategy) S3method(prCalculateConnector,ManyToOneFanInTopConnectorStrategy) @@ -110,6 +113,7 @@ export(move) export(moveBox) export(pathJoin) export(phaseLabel) +export(position) export(rack_box_fn) export(retrieve) export(server_box_fn) diff --git a/NEWS.md b/NEWS.md index 567cbe5..f6a520d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -11,7 +11,9 @@ 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 `position()` with relative moves. +- Added dotted arrows lines for flowcharts +- Added regex selector for box lists ## Changes for 3.3.0 diff --git a/R/boxGrobs_connect.R b/R/boxGrobs_connect.R index 2b95c90..95b402a 100644 --- a/R/boxGrobs_connect.R +++ b/R/boxGrobs_connect.R @@ -82,6 +82,14 @@ #' A [grid::unit()] or numeric (interpreted as millimeters). Default `unit(3, "mm")`. #' @param side For `type = "side"`, which side of the start box to exit from. #' `"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 +#' 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"`. +#' 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_gp A [grid::gpar()] controlling label appearance. @@ -114,6 +122,9 @@ connectGrob <- function( smooth = FALSE, 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"), label = NULL, label_gp = grid::gpar(cex = 0.9), label_bg_gp = grid::gpar(fill = "white", col = NA), @@ -124,6 +135,8 @@ connectGrob <- function( type <- match.arg(type) 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) if (!is.null(arrow_size)) { ends_map <- c("1" = "first", "2" = "last", "3" = "both") @@ -216,6 +229,9 @@ connectGrob <- function( smooth = smooth, 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, label = label, label_gp = label_gp, label_bg_gp = label_bg_gp, diff --git a/R/boxGrobs_connect_pr_single_boxes.R b/R/boxGrobs_connect_pr_single_boxes.R index 7269df8..258d725 100644 --- a/R/boxGrobs_connect_pr_single_boxes.R +++ b/R/boxGrobs_connect_pr_single_boxes.R @@ -95,6 +95,9 @@ prConnect1 <- function( smooth = FALSE, 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"), label = NULL, label_gp = grid::gpar(cex = 0.9), label_bg_gp = grid::gpar(fill = "white", col = NA), @@ -110,6 +113,8 @@ 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) start <- coords(start) end <- coords(end) @@ -194,20 +199,23 @@ prConnect1 <- function( line$y <- unit.c(start$bottom, end$top) } } else if (type == "side") { - # Horizontal-first exit: leave from start side, travel horizontally, - # then drop vertically to the end box. + # Horizontal-first exit: leave from a selected start side, travel vertically + # outside/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 } - line$x <- unit.c(exit_x, getX4elmnt(end, "x"), getX4elmnt(end, "x")) - if (prConvertHeightToMm(start$y) > prConvertHeightToMm(end$y)) { - line$y <- unit.c(start$y, start$y, end$top) + + start_is_left <- prConvertWidthToMm(start$x) < prConvertWidthToMm(getX4elmnt(end, "x")) + entry_x <- if (end_side == "left" || (end_side == "auto" && start_is_left)) { + end$left } else { - line$y <- unit.c(start$y, start$y, end$bottom) + end$right } + line$x <- unit.c(exit_x, exit_x, entry_x) + line$y <- unit.c(start$y, end$y, end$y) } else { # horizontal line$y <- unit.c(start$y, end$y) if (prConvertWidthToMm(getX4elmnt(start, "x")) < prConvertWidthToMm(getX4elmnt(end, "x"))) { diff --git a/R/boxGrobs_connect_strategies.R b/R/boxGrobs_connect_strategies.R index d707c17..97d2e70 100644 --- a/R/boxGrobs_connect_strategies.R +++ b/R/boxGrobs_connect_strategies.R @@ -104,6 +104,9 @@ prCalculateConnector.ConnectorStrategy <- function(strategy, ...) { smooth = args$smooth, 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, label = args$label, label_gp = args$label_gp, label_bg_gp = args$label_bg_gp, diff --git a/R/boxGrobs_coords.R b/R/boxGrobs_coords.R index 7c41b39..7904b58 100644 --- a/R/boxGrobs_coords.R +++ b/R/boxGrobs_coords.R @@ -3,7 +3,16 @@ #' Retrieves the boxes \code{"coords"} attribute. #' #' @param box The \code{\link{boxGrob}} or \code{\link{boxPropGrob}} -#' @return A list with the coordinates +#' @return A list with grid unit coordinates. Standard boxes include: +#' \describe{ +#' \item{\code{x}, \code{y}}{The box center.} +#' \item{\code{left}, \code{right}}{The horizontal edges.} +#' \item{\code{top}, \code{bottom}}{The vertical edges.} +#' \item{\code{width}, \code{height}}{The full box dimensions.} +#' \item{\code{half_width}, \code{half_height}}{Half of the box dimensions.} +#' } +#' Split boxes such as \code{\link{boxPropGrob}} may add extra coordinates, +#' for example \code{left_x}, \code{right_x}, and \code{prop_x}. #' #' @importFrom checkmate assert_class #' @family flowchart components @@ -11,6 +20,9 @@ #' @examples #' box <- boxGrob("A test box") #' coords(box) +#' +#' # Extract a single position as a unit +#' position(box, position = "left", type = "x") coords <- function(box) { # Check if not already a coordinate element if (inherits(box, "coords")) { @@ -19,4 +31,4 @@ coords <- function(box) { assert_class(box, "box") attr(box, "coords") -} \ No newline at end of file +} diff --git a/R/boxGrobs_move.R b/R/boxGrobs_move.R index 4344eae..5b3a52d 100644 --- a/R/boxGrobs_move.R +++ b/R/boxGrobs_move.R @@ -37,6 +37,9 @@ moveBox <- function(element, to_unit <- function(u) if (is.unit(u) || is.null(u)) u else unit(u, "npc") if (is.list(element) && !inherits(element, "box")) { + x <- prResolvePositionValue(x, element) + y <- prResolvePositionValue(y, element) + if (is.null(x) && is.null(y)) { stop("You have to specify at least x or y move parameters") } diff --git a/R/boxGrobs_position.R b/R/boxGrobs_position.R new file mode 100644 index 0000000..62f7ff1 --- /dev/null +++ b/R/boxGrobs_position.R @@ -0,0 +1,149 @@ +#' Reference a flowchart box position +#' +#' Creates a position reference that can be used anywhere a `move()`/`moveBox()` +#' coordinate accepts a `grid::unit()`. When `reference` is a path, the position +#' is resolved against the current box list at move time. +#' +#' @param reference A box, a `coords()` object, a list of boxes, or a path into +#' a flowchart list such as `"groups"` or `c("groups", 1)`. +#' @param position Which position to extract. For `type = "x"` use `"center"`, +#' `"left"`, or `"right"`. For `type = "y"` use `"center"`, `"top"`, or +#' `"bottom"`. +#' @param type Axis to extract: `"x"` or `"y"`. +#' +#' @return A `grid::unit()` when `reference` is already a box/coords object, or +#' a deferred position reference when `reference` is a flowchart path. +#' @export +#' @family flowchart components +#' @examples +#' fc <- flowchart(groups = list("A", "B"), ex = list("X", "Y")) |> +#' spread(axis = "x", subelement = "groups") +#' +#' fc |> +#' move(subelement = c("ex", 1), +#' x = position(c("groups", 1), position = "center", type = "x") + +#' grid::unit(5, "mm")) +position <- function(reference, position = "center", type = c("x", "y")) { + UseMethod("position") +} + +#' @export +#' @rdname position +position.default <- function(reference, position = "center", type = c("x", "y")) { + type <- match.arg(type) + position <- match.arg(position, c("center", "left", "right", "top", "bottom")) + prValidatePositionAxis(position = position, type = type) + + if (is.list(reference) && !is.null(reference) && length(reference) > 0 && + all(vapply(reference, function(x) inherits(x, "box") || inherits(x, "coords") || is.list(x), logical(1)))) { + return(prSelectPosition(prConvert2Coords(reference), position = position, type = type)) + } + + ref <- structure( + list(reference = reference, position = position, type = type), + class = "Gmisc_position_ref" + ) + structure(list(list(0, ref, 0L)), class = c("unit", "unit_v2")) +} + +#' @export +#' @rdname position +position.box <- function(reference, position = "center", type = c("x", "y")) { + type <- match.arg(type) + position <- match.arg(position, c("center", "left", "right", "top", "bottom")) + prValidatePositionAxis(position = position, type = type) + prSelectPosition(coords(reference), position = position, type = type) +} + +#' @export +#' @rdname position +position.coords <- function(reference, position = "center", type = c("x", "y")) { + type <- match.arg(type) + position <- match.arg(position, c("center", "left", "right", "top", "bottom")) + prValidatePositionAxis(position = position, type = type) + prSelectPosition(reference, position = position, type = type) +} + +prValidatePositionAxis <- function(position, type) { + if (type == "x" && !position %in% c("center", "left", "right")) { + stop("For type = 'x', `position` must be 'center', 'left', or 'right'.", call. = FALSE) + } + if (type == "y" && !position %in% c("center", "top", "bottom")) { + stop("For type = 'y', `position` must be 'center', 'top', or 'bottom'.", call. = FALSE) + } +} + +prSelectPosition <- function(coords, position, type) { + if (position == "center") { + return(coords[[type]]) + } + coords[[position]] +} + +prUnitAsExpressionPart <- function(unit_value) { + raw <- unclass(unit_value) + if (is.list(raw)) { + if (length(raw) != 1) { + stop("Expected a length-1 unit value for position reference resolution.", call. = FALSE) + } + return(raw[[1]]) + } + list(as.numeric(raw), NULL, as.integer(attr(raw, "unit"))) +} + +prResolvePositionValue <- function(value, element) { + if (!inherits(value, "unit")) { + return(value) + } + + resolve_ref <- function(ref) { + target <- if (inherits(ref$reference, "box") || inherits(ref$reference, "coords")) { + ref$reference + } else { + get_list_element_by_path(element, ref$reference) + } + + if (is.null(target)) { + stop( + "The position reference '", + paste(ref$reference, collapse = " -> "), + "' was not found in the provided boxes.", + call. = FALSE + ) + } + + prSelectPosition(prConvert2Coords(target), position = ref$position, type = ref$type) + } + + resolve_unit <- function(u) { + if (!inherits(u, "unit_v2")) { + return(u) + } + + parts <- unclass(u) + if (!is.list(parts)) { + return(u) + } + changed <- FALSE + + parts <- lapply(parts, function(part) { + data <- part[[2]] + if (inherits(data, "Gmisc_position_ref")) { + changed <<- TRUE + return(prUnitAsExpressionPart(resolve_ref(data))) + } + if (inherits(data, "unit")) { + part[[2]] <- resolve_unit(data) + changed <<- TRUE + } + part + }) + + if (!changed) { + return(u) + } + structure(parts, class = c("unit", "unit_v2")) + } + + resolve_unit(value) +} diff --git a/R/boxGrobs_s3_connect.R b/R/boxGrobs_s3_connect.R index f2d6abd..8feb52b 100644 --- a/R/boxGrobs_s3_connect.R +++ b/R/boxGrobs_s3_connect.R @@ -4,8 +4,10 @@ #' simple `list` context, designed for piping (`|>`). #' #' @param x A `list` of boxes (will be converted to `Gmisc_list_of_boxes` if needed). -#' @param from The name (string) or index of the start box in `x`. Multiple values allowed. -#' @param to The name (string) or index of the end box in `x`. Multiple values allowed. +#' @param from The name (string), index, list of selectors, or `stringr::regex()` +#' selector for the start box in `x`. Multiple values allowed. +#' @param to The name (string), index, list of selectors, or `stringr::regex()` +#' selector for the end box in `x`. Multiple values allowed. #' @param ... Arguments passed on to [`connectGrob`]. #' #' @return The original list `x` (upgraded to `Gmisc_list_of_boxes`) with a new @@ -36,9 +38,23 @@ connect.Gmisc_list_of_boxes <- function(x, from = NULL, to = NULL, ...) { stop("You must provide both 'from' and 'to' arguments.") } - # Helper to resolve box objects from x using names/indices + # Helper to resolve box objects from x using names/indices/selectors resolve_box <- function(ref) { - if (is.character(ref)) { + if (inherits(ref, "stringr_regex")) { + paths <- prResolveSubelementSelector(ref, x) + return(lapply(paths, function(path) { + el <- get_list_element_by_path(x, path) + if (is.null(el)) { + stop("Could not find box named: ", paste(path, collapse = " -> ")) + } + el + })) + } else if (is.list(ref) && !inherits(ref, "box")) { + if (prIsBoxList(ref)) { + return(ref) + } + return(unlist(lapply(ref, resolve_box), recursive = FALSE)) + } else if (is.character(ref)) { if (all(ref %in% names(x))) { return(x[ref]) } @@ -68,16 +84,172 @@ connect.Gmisc_list_of_boxes <- function(x, from = NULL, to = NULL, ...) { stop("Invalid from/to selector: must be name, index, or box object.") } + is_list_of_box_lists <- function(obj) { + is.list(obj) && + length(obj) > 0 && + !inherits(obj, "box") && + all(vapply(obj, prIsBoxList, logical(1))) + } + + connect_side_fan_in <- function(starts, end) { + 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_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")) + 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 (!inherits(side_fan_in_offset, "unit")) { + stop("`side_fan_in_offset` must be a unit or numeric.", call. = FALSE) + } + + 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 <- lapply(starts, coords) + e <- coords(end) + starts_left <- mean(vapply(s_coords, function(s) prConvertWidthToMm(s$x), numeric(1))) < + prConvertWidthToMm(e$x) + + exit_side <- if (side == "right" || (side == "auto" && !starts_left)) "right" else "left" + entry_side <- if (end_side == "left" || (end_side == "auto" && starts_left)) "left" else "right" + + exit_xs <- lapply(s_coords, `[[`, exit_side) + bus_x <- if (exit_side == "right") { + exit_xs[[which.max(vapply(exit_xs, prConvertWidthToMm, numeric(1)))]] + } else { + exit_xs[[which.min(vapply(exit_xs, prConvertWidthToMm, numeric(1)))]] + } + if (side_fan_in_route == "outside") { + bus_x <- if (exit_side == "right") { + bus_x + side_fan_in_offset + } else { + bus_x - side_fan_in_offset + } + } + entry_x <- e[[entry_side]] + + stubs <- lapply(seq_along(s_coords), function(i) { + prRenderLine( + x = unit.c(exit_xs[[i]], bus_x), + y = unit.c(s_coords[[i]]$y, s_coords[[i]]$y), + smooth = FALSE, + corner_radius = corner_radius, + gp = lty_gp, + arrow = NULL + ) + }) + + y_mm <- vapply(s_coords, function(s) prConvertHeightToMm(s$y), numeric(1)) + end_y_mm <- prConvertHeightToMm(e$y) + bus_start_y <- if (end_y_mm < mean(y_mm)) { + s_coords[[which.max(y_mm)]]$y + } else { + s_coords[[which.min(y_mm)]]$y + } + + spine <- prRenderLine( + x = unit.c(bus_x, bus_x), + y = unit.c(bus_start_y, e$y), + smooth = FALSE, + corner_radius = corner_radius, + gp = lty_gp, + arrow = NULL + ) + final <- prRenderLine( + x = unit.c(bus_x, entry_x), + y = unit.c(e$y, e$y), + smooth = smooth, + corner_radius = corner_radius, + gp = lty_gp, + arrow = arrow_obj + ) + + line <- list( + x = unit.c(bus_x, bus_x, entry_x), + y = unit.c(bus_start_y, e$y, e$y) + ) + gt <- grid::grobTree(do.call(grid::gList, c(stubs, list(spine, final)))) + 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) + if (length(bad) > 0) { + stop( + "When grouped 'from' values connect to a grouped 'to' value, each group must have the same number of boxes as 'to'.", + call. = FALSE + ) + } + + if (identical(args$type, "side")) { + cg <- lapply(seq_len(arm_count), function(i) { + connect_side_fan_in(lapply(starts, `[[`, i), ends[[i]]) + }) + } else { + cg <- unlist(lapply(starts, function(start_group) { + mapply(function(s, e) { + do.call(connectGrob, c(list(start = s, end = e), args)) + }, start_group, ends, SIMPLIFY = FALSE) + }), recursive = FALSE) + } + class(cg) <- c("connect_boxes_list", "list") + cg + } + + connect_armwise_to_groups <- function(starts, end_groups) { + arm_count <- length(starts) + bad <- which(vapply(end_groups, length, integer(1)) != arm_count) + if (length(bad) > 0) { + stop( + "When grouped 'to' values connect from a grouped 'from' value, each group must have the same number of boxes as 'from'.", + call. = FALSE + ) + } + + cg <- unlist(lapply(end_groups, function(end_group) { + mapply(function(s, e) { + do.call(connectGrob, c(list(start = s, end = e), args)) + }, starts, end_group, SIMPLIFY = FALSE) + }), recursive = FALSE) + class(cg) <- c("connect_boxes_list", "list") + cg + } + start_boxes <- resolve_box(from) end_boxes <- resolve_box(to) if (length(start_boxes) == 1) start_boxes <- start_boxes[[1]] if (length(end_boxes) == 1) end_boxes <- end_boxes[[1]] + # Support grouped-source to grouped-target mapping for CONSORT-style + # return arrows, e.g. connect(regex("^ex"), "analysis", type = "side"). + if (is_list_of_box_lists(start_boxes) && prIsBoxList(end_boxes)) { + 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) # 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. - if (prIsBoxList(start_boxes) && prIsBoxList(end_boxes)) { + } else if (prIsBoxList(start_boxes) && prIsBoxList(end_boxes)) { if (length(start_boxes) != length(end_boxes)) { stop("When both 'from' and 'to' resolve to lists of boxes, they must have the same length.", call. = FALSE) } diff --git a/R/boxGrobs_s3_spread.R b/R/boxGrobs_s3_spread.R index ae5070c..0228a5e 100644 --- a/R/boxGrobs_s3_spread.R +++ b/R/boxGrobs_s3_spread.R @@ -34,7 +34,7 @@ spread.Gmisc_list_of_boxes <- function(x, ..., axis = c("y", "x", "vertical", "h axis <- match.arg(axis) args <- list(...) - call_args <- c(x, args) + call_args <- c(list(x), args) if (axis %in% c("y", "vertical")) { return(do.call(spreadVertical, call_args)) diff --git a/man/align.Rd b/man/align.Rd index 859e6ae..770b28a 100644 --- a/man/align.Rd +++ b/man/align.Rd @@ -137,6 +137,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/append.Rd b/man/append.Rd index 5b7fb5e..b14f3e6 100644 --- a/man/append.Rd +++ b/man/append.Rd @@ -43,6 +43,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/box.Rd b/man/box.Rd index 60cf270..2cd159e 100644 --- a/man/box.Rd +++ b/man/box.Rd @@ -136,6 +136,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/boxHeaderGrob.Rd b/man/boxHeaderGrob.Rd index e60bdb3..181a4bb 100644 --- a/man/boxHeaderGrob.Rd +++ b/man/boxHeaderGrob.Rd @@ -104,6 +104,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/boxPropGrob.Rd b/man/boxPropGrob.Rd index 0573932..42d69f3 100644 --- a/man/boxPropGrob.Rd +++ b/man/boxPropGrob.Rd @@ -100,6 +100,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/boxShapes.Rd b/man/boxShapes.Rd index ef72dc1..0290603 100644 --- a/man/boxShapes.Rd +++ b/man/boxShapes.Rd @@ -233,6 +233,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/connect.Rd b/man/connect.Rd index a8a1aac..2860b8a 100644 --- a/man/connect.Rd +++ b/man/connect.Rd @@ -27,6 +27,9 @@ connectGrob( smooth = FALSE, 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"), label = NULL, label_gp = grid::gpar(cex = 0.9), label_bg_gp = grid::gpar(fill = "white", col = NA), @@ -85,6 +88,17 @@ A \code{\link[grid:unit]{grid::unit()}} or numeric (interpreted as millimeters). \item{side}{For \code{type = "side"}, which side of the start box to exit from. \code{"auto"} (default) picks the side that faces the end box.} +\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 +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"}. +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.} @@ -107,9 +121,11 @@ as millimeters.} \item{recording}{Passed to [grid::grid.draw()] when rendering each element in the list. Defaults to `TRUE` (record drawing for later replay).} -\item{from}{The name (string) or index of the start box in `x`. Multiple values allowed.} +\item{from}{The name (string), index, list of selectors, or `stringr::regex()` +selector for the start box in `x`. Multiple values allowed.} -\item{to}{The name (string) or index of the end box in `x`. Multiple values allowed.} +\item{to}{The name (string), index, list of selectors, or `stringr::regex()` +selector for the end box in `x`. Multiple values allowed.} } \value{ \itemize{ @@ -290,6 +306,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/coords.Rd b/man/coords.Rd index 1e7e889..ac2e00c 100644 --- a/man/coords.Rd +++ b/man/coords.Rd @@ -10,7 +10,16 @@ coords(box) \item{box}{The \code{\link{boxGrob}} or \code{\link{boxPropGrob}}} } \value{ -A list with the coordinates +A list with grid unit coordinates. Standard boxes include: +\describe{ + \item{\code{x}, \code{y}}{The box center.} + \item{\code{left}, \code{right}}{The horizontal edges.} + \item{\code{top}, \code{bottom}}{The vertical edges.} + \item{\code{width}, \code{height}}{The full box dimensions.} + \item{\code{half_width}, \code{half_height}}{Half of the box dimensions.} +} +Split boxes such as \code{\link{boxPropGrob}} may add extra coordinates, +for example \code{left_x}, \code{right_x}, and \code{prop_x}. } \description{ Retrieves the boxes \code{"coords"} attribute. @@ -18,6 +27,9 @@ Retrieves the boxes \code{"coords"} attribute. \examples{ box <- boxGrob("A test box") coords(box) + +# Extract a single position as a unit +position(box, position = "left", type = "x") } \seealso{ Other flowchart components: @@ -36,6 +48,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/distance.Rd b/man/distance.Rd index 6978f1e..afd7fac 100644 --- a/man/distance.Rd +++ b/man/distance.Rd @@ -67,6 +67,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/equalizeHeights.Rd b/man/equalizeHeights.Rd index 73e130b..c167b87 100644 --- a/man/equalizeHeights.Rd +++ b/man/equalizeHeights.Rd @@ -55,6 +55,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/equalizeWidths.Rd b/man/equalizeWidths.Rd index e8191c3..2856aa0 100644 --- a/man/equalizeWidths.Rd +++ b/man/equalizeWidths.Rd @@ -58,6 +58,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/flowchart.Rd b/man/flowchart.Rd index 29c4c0a..67dd48b 100644 --- a/man/flowchart.Rd +++ b/man/flowchart.Rd @@ -57,6 +57,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/insert.Rd b/man/insert.Rd index 320c797..5298d67 100644 --- a/man/insert.Rd +++ b/man/insert.Rd @@ -54,6 +54,7 @@ Other flowchart components: \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/move.Rd b/man/move.Rd index 3535933..9564856 100644 --- a/man/move.Rd +++ b/man/move.Rd @@ -43,6 +43,7 @@ Other flowchart components: \code{\link[=insert]{insert()}}, \code{\link[=moveBox]{moveBox()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/moveBox.Rd b/man/moveBox.Rd index 5dd14e3..228cd18 100644 --- a/man/moveBox.Rd +++ b/man/moveBox.Rd @@ -112,6 +112,7 @@ Other flowchart components: \code{\link[=insert]{insert()}}, \code{\link[=move]{move()}}, \code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/phaseLabel.Rd b/man/phaseLabel.Rd index 7b78243..979cb54 100644 --- a/man/phaseLabel.Rd +++ b/man/phaseLabel.Rd @@ -87,6 +87,7 @@ Other flowchart components: \code{\link[=insert]{insert()}}, \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, +\code{\link[=position]{position()}}, \code{\link[=spread]{spread()}} } \concept{flowchart components} diff --git a/man/position.Rd b/man/position.Rd new file mode 100644 index 0000000..db42995 --- /dev/null +++ b/man/position.Rd @@ -0,0 +1,66 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/boxGrobs_position.R +\name{position} +\alias{position} +\alias{position.default} +\alias{position.box} +\alias{position.coords} +\title{Reference a flowchart box position} +\usage{ +position(reference, position = "center", type = c("x", "y")) + +\method{position}{default}(reference, position = "center", type = c("x", "y")) + +\method{position}{box}(reference, position = "center", type = c("x", "y")) + +\method{position}{coords}(reference, position = "center", type = c("x", "y")) +} +\arguments{ +\item{reference}{A box, a `coords()` object, a list of boxes, or a path into +a flowchart list such as `"groups"` or `c("groups", 1)`.} + +\item{position}{Which position to extract. For `type = "x"` use `"center"`, +`"left"`, or `"right"`. For `type = "y"` use `"center"`, `"top"`, or +`"bottom"`.} + +\item{type}{Axis to extract: `"x"` or `"y"`.} +} +\value{ +A `grid::unit()` when `reference` is already a box/coords object, or + a deferred position reference when `reference` is a flowchart path. +} +\description{ +Creates a position reference that can be used anywhere a `move()`/`moveBox()` +coordinate accepts a `grid::unit()`. When `reference` is a path, the position +is resolved against the current box list at move time. +} +\examples{ +fc <- flowchart(groups = list("A", "B"), ex = list("X", "Y")) |> + spread(axis = "x", subelement = "groups") + +fc |> + move(subelement = c("ex", 1), + x = position(c("groups", 1), position = "center", type = "x") + + grid::unit(5, "mm")) +} +\seealso{ +Other flowchart components: +\code{\link[=align]{align()}}, +\code{\link[=append]{append()}}, +\code{\link[=boxGrob]{boxGrob()}}, +\code{\link[=boxHeaderGrob]{boxHeaderGrob()}}, +\code{\link[=boxPropGrob]{boxPropGrob()}}, +\code{\link{boxShapes}}, +\code{\link[=connectGrob]{connectGrob()}}, +\code{\link[=coords]{coords()}}, +\code{\link[=distance]{distance()}}, +\code{\link[=equalizeHeights]{equalizeHeights()}}, +\code{\link[=equalizeWidths]{equalizeWidths()}}, +\code{\link[=flowchart]{flowchart()}}, +\code{\link[=insert]{insert()}}, +\code{\link[=move]{move()}}, +\code{\link[=moveBox]{moveBox()}}, +\code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=spread]{spread()}} +} +\concept{flowchart components} diff --git a/man/spread.Rd b/man/spread.Rd index b22c04c..ab5c584 100644 --- a/man/spread.Rd +++ b/man/spread.Rd @@ -143,6 +143,7 @@ Other flowchart components: \code{\link[=insert]{insert()}}, \code{\link[=move]{move()}}, \code{\link[=moveBox]{moveBox()}}, -\code{\link[=phaseLabel]{phaseLabel()}} +\code{\link[=phaseLabel]{phaseLabel()}}, +\code{\link[=position]{position()}} } \concept{flowchart components} diff --git a/tests/testthat/test-flowchart-issue76-connectors.R b/tests/testthat/test-flowchart-issue76-connectors.R new file mode 100644 index 0000000..3816e01 --- /dev/null +++ b/tests/testthat/test-flowchart-issue76-connectors.R @@ -0,0 +1,153 @@ +library(testthat) +library(grid) + +make_issue76_fc <- function() { + flowchart( + rando = "Randomised N = 100", + groups = list("Group1\nn = 50", "Group2\nn = 50"), + ex1 = list("Excluded\nn = 1", "Excluded\nn = 2"), + groups1 = list("bla\nn = 49", "bla\nn = 48"), + ex2 = list("Excluded\nn = 1", "Excluded\nn = 2"), + groups2 = list("blas\nn = 49", "blas\nn = 48"), + ex3 = list("Excluded\nn = 1", "Excluded\nn = 2"), + groups3 = list("Analysed\nn = 49", "Analysed\nn = 48") + ) |> + spread(axis = "y", margin = unit(0.02, "npc")) |> + spread(subelement = stringr::regex("^groups"), axis = "x", margin = unit(.3, "npc")) |> + spread(subelement = stringr::regex("^ex"), axis = "x", margin = unit(.1, "npc")) +} + +test_that("spread() preserves regex selectors through the S3 wrapper", { + fc <- make_issue76_fc() + + left_ex <- convertX(coords(fc$ex1[[1]])$x, "npc", valueOnly = TRUE) + right_ex <- convertX(coords(fc$ex1[[2]])$x, "npc", valueOnly = TRUE) + + expect_lt(left_ex, 0.2) + expect_gt(right_ex, 0.8) +}) + +test_that("connect() accepts list selectors for grouped side return arrows", { + fc <- make_issue76_fc() |> + connect( + from = list("ex1", "ex2", "ex3"), + to = "groups3", + type = "side", + lty_gp = gpar(lty = 2) + ) + + con <- tail(attr(fc, "connections"), 1)[[1]] + expect_s3_class(con, "connect_boxes_list") + expect_equal(length(con), 2) + expect_gte(length(con[[1]]$children), 5) +}) + +test_that("connect() accepts regex selectors for arm-wise fan-in", { + fc <- make_issue76_fc() |> + connect( + from = stringr::regex("^ex"), + to = "groups3", + type = "side", + lty_gp = gpar(lty = 2), + side = "right", + side_fan_in_offset = unit(5, "mm") + ) + + con <- tail(attr(fc, "connections"), 1)[[1]] + expect_s3_class(con, "connect_boxes_list") + expect_equal(length(con), 2) + + target_left <- convertX(coords(fc$groups3[[1]])$left, "npc", valueOnly = TRUE) + first_line <- attr(con[[1]], "line") + first_x <- convertX(first_line$x, "npc", valueOnly = TRUE) + first_y <- convertY(first_line$y, "npc", valueOnly = TRUE) + + expect_equal(tail(first_x, 1), target_left, tolerance = 1e-6) + expect_equal(first_y[length(first_y) - 1], tail(first_y, 1), tolerance = 1e-6) + expect_gt(first_x[1], convertX(coords(make_issue76_fc()$ex1[[1]])$right, "npc", valueOnly = TRUE)) +}) + +test_that("side connectors can enter a requested destination side", { + start <- boxGrob("Excluded", x = .1, y = .7) + end <- boxGrob("Analysed", x = .4, y = .2) + + con <- connectGrob( + start, + end, + type = "side", + side = "left", + end_side = "left" + ) + + line <- attr(con, "line") + xs <- convertX(line$x, "npc", valueOnly = TRUE) + ys <- convertY(line$y, "npc", valueOnly = TRUE) + + expect_equal(tail(xs, 1), convertX(coords(end)$left, "npc", valueOnly = TRUE), tolerance = 1e-6) + expect_equal(ys[length(ys) - 1], tail(ys, 1), tolerance = 1e-6) +}) + +test_that("move() can use positions resolved from another flowchart box", { + offset <- unit(10, "mm") + fc <- flowchart( + groups = list("Group 1", "Group 2"), + ex = list("Excluded 1", "Excluded 2") + ) |> + spread(axis = "y") |> + spread(subelement = "groups", axis = "x", from = .25, to = .75, type = "center") |> + spread(subelement = "ex", axis = "x", from = .25, to = .75, type = "center") |> + move( + subelement = c("ex", 1), + x = position(c("groups", 1), position = "center", type = "x") + offset + ) + + expect_equal( + convertX(coords(fc$ex[[1]])$x, "mm", valueOnly = TRUE), + convertX(coords(fc$groups[[1]])$x + offset, "mm", valueOnly = TRUE), + tolerance = 1e-6 + ) +}) + +test_that("position() dispatches for boxes and coords", { + box <- boxGrob("A", x = .4, y = .6) + + expect_equal( + convertX(position(box, position = "center", type = "x"), "npc", valueOnly = TRUE), + .4, + tolerance = 1e-6 + ) + expect_equal( + convertY(position(coords(box), position = "center", type = "y"), "npc", valueOnly = TRUE), + .6, + tolerance = 1e-6 + ) + expect_s3_class(position(c("groups", 1), position = "center", type = "x"), "unit") +}) + +test_that("position() can resolve grouped list centers", { + fc <- flowchart( + rando = "Randomised", + groups = list("Group 1", "Group 2") + ) |> + spread(axis = "y") |> + spread(subelement = "groups", axis = "x", from = .1, to = .8, type = "center") |> + move(subelement = "rando", x = position("groups", position = "center", type = "x")) + + expect_equal( + convertX(coords(fc$rando)$x, "npc", valueOnly = TRUE), + mean(vapply(fc$groups, function(box) { + convertX(coords(box)$x, "npc", valueOnly = TRUE) + }, numeric(1))), + tolerance = 1e-6 + ) +}) + +test_that("arm-wise fan-in errors on incompatible grouped target lengths", { + fc <- make_issue76_fc() + fc$groups3 <- fc$groups3[1] + + expect_error( + connect(fc, from = stringr::regex("^ex"), to = "groups3", type = "side"), + "same number of boxes" + ) +}) diff --git a/vignettes/Grid-based_flowcharts.Rmd b/vignettes/Grid-based_flowcharts.Rmd index 11f9392..323be2b 100644 --- a/vignettes/Grid-based_flowcharts.Rmd +++ b/vignettes/Grid-based_flowcharts.Rmd @@ -1,7 +1,7 @@ --- title: "Building a flowchart" author: "Max Gordon" -date: "28 May 2026" +date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: true @@ -253,6 +253,93 @@ flowchart( options(old_opts) ``` +# Dotted return arrows for censored participants + +In time-to-event analyses, participants who leave follow-up may still +contribute information until censoring. Dotted side-entry arrows can show that +these participants return to the analysis set instead of being dropped from the +study. + +```{r consort_dotted_return_arrows, fig.width = 10, fig.height = 9} +old_opts <- options(boxGrobTxtPadding = unit(1, "mm")) + +main_gp <- gpar(fill = "white", col = "black") +main_con_gp <- gpar(col = "black", fill = "black") +dotted_gp <- gpar(col = "black", fill = "black", lty = 2) +arm_from <- .05 +arm_to <- .75 +box_width <- unit(56, "mm") +ex_width <- unit(36, "mm") +ex_gap <- unit(5, "mm") +ex_offset <- box_width / 2 + ex_width / 2 + ex_gap + +grid.newpage() +flowchart( + rando = boxGrob("Randomised\nN = 197", box_gp = main_gp), + groups = list( + boxGrob("96 assigned to\ndecompressive craniectomy\nplus best medical treatment\n95 received allocated\nintervention", + box_gp = main_gp), + boxGrob("101 assigned to best medical\ntreatment alone\n93 received allocated\nintervention", + box_gp = main_gp) + ), + ex1 = list( + boxGrob("8 died\n1 withdrew\nconsent", just = "left", box_gp = main_gp), + boxGrob("18 died\n1 withdrew\nconsent", just = "left", box_gp = main_gp) + ), + groups1 = list( + boxGrob("87 completed day 30\nfollow-up", box_gp = main_gp), + boxGrob("79 completed day 30\nfollow-up", box_gp = main_gp) + ), + ex2 = list( + boxGrob("8 died", just = "left", box_gp = main_gp), + boxGrob("9 died\n1 withdrew\nconsent\n2 lost to follow-up", + just = "left", box_gp = main_gp) + ), + groups2 = list( + boxGrob("79 completed day 180\nfollow-up", box_gp = main_gp), + boxGrob("68 completed day 180\nfollow-up", box_gp = main_gp) + ), + ex3 = list( + boxGrob("5 died\n2 lost to\nfollow-up", just = "left", box_gp = main_gp), + boxGrob("3 died\n2 withdrew\nconsent\n6 lost to follow-up", + just = "left", box_gp = main_gp) + ), + groups3 = list( + boxGrob("95 included in the primary\noutcome analysis\n1 withdrew consent", + box_gp = main_gp), + boxGrob("95 included in the primary\noutcome analysis\n2 withdrew consent\n2 lost to follow-up", + box_gp = main_gp) + ) +) |> + spread(axis = "y", margin = unit(0.02, "npc")) |> + equalizeWidths(subelement = stringr::regex("^groups"), width = box_width) |> + equalizeHeights(subelement = stringr::regex("^groups")) |> + equalizeWidths(subelement = stringr::regex("^ex"), width = ex_width) |> + spread(subelement = stringr::regex("^groups"), axis = "x", from = arm_from, to = arm_to, + type = "center") |> + move(subelement = "rando", + x = position("groups", position = "center", type = "x")) |> + move(subelement = list(c("ex1", 1), c("ex2", 1), c("ex3", 1)), + x = position(c("groups", 1), position = "center", type = "x") + ex_offset) |> + move(subelement = list(c("ex1", 2), c("ex2", 2), c("ex3", 2)), + x = position(c("groups", 2), position = "center", type = "x") + ex_offset) |> + connect("rando", "groups", type = "N", lty_gp = main_con_gp, arrow_size = 3) |> + connect("groups", "groups1", type = "vertical", lty_gp = main_con_gp, arrow_size = 3) |> + connect("groups1", "groups2", type = "vertical", lty_gp = main_con_gp, arrow_size = 3) |> + connect("groups2", "groups3", type = "vertical", lty_gp = main_con_gp, arrow_size = 3) |> + connect("groups", "ex1", type = "L", lty_gp = main_con_gp, arrow_size = 3) |> + connect("groups1", "ex2", type = "L", lty_gp = main_con_gp, arrow_size = 3) |> + connect("groups2", "ex3", type = "L", lty_gp = main_con_gp, arrow_size = 3) |> + connect(stringr::regex("^ex"), "groups3", type = "side", + lty_gp = dotted_gp, arrow_size = 3, + side = "right", + end_side = "right", + side_fan_in_route = "outside", + side_fan_in_offset = ex_gap) + +options(old_opts) +``` + # Consistent grouped widths and global text padding When building grouped flows (for example CONSORT-style diagrams), it is often useful to: @@ -338,7 +425,7 @@ boxPropGrob("A box with proportions", The boxes have coordinates that allow you to easily draw lines to and from it. The coordinates are stored in the `coords` attribute. Below is an illustration of the coordinates for the two boxes: -```{r, fig.height = 3, fig.width = 4} +```{r box_coordinates, fig.height = 3, fig.width = 4} grid.newpage() smpl_bx <- boxGrob( label = "A simple box", From e4d8426af30f05693cd159d7429787c2f12256d4 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sun, 14 Jun 2026 21:58:04 +0200 Subject: [PATCH 6/7] Add axis-preserving flowchart connectors - Add `vertical_axis` and `horizontal_axis` connector types - Preserve source x/y axes and clamp target landing points to box boundaries - Document how axis connectors differ from `vertical` / `horizontal` - Add examples, NEWS entry, and vignette coverage - Add tests for axis connector geometry, errors, and list behavior --- NEWS.md | 1 + R/boxGrobs_connect.R | 33 ++- R/boxGrobs_connect_pr_helpers.R | 62 +++++ R/boxGrobs_connect_pr_single_boxes.R | 14 ++ R/boxGrobs_connect_strategies.R | 2 + inst/examples/connectGrob_example.R | 29 +++ man/connect.Rd | 50 +++- .../test-connectGrob-axis-connectors.R | 228 ++++++++++++++++++ vignettes/Grid-based_flowcharts.Rmd | 43 ++++ 9 files changed, 455 insertions(+), 7 deletions(-) create mode 100644 tests/testthat/test-connectGrob-axis-connectors.R diff --git a/NEWS.md b/NEWS.md index f6a520d..dc01cae 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ NEWS for the Gmisc package ## Changes for 3.4.0 +- Added `vertical_axis` and `horizontal_axis` connector types for flowcharts. These opt-in connectors preserve the source box's x- or y-axis and project it onto the target boundary, giving true 90-degree vertical/horizontal arrows for shared wide or tall target boxes. Existing `vertical` and `horizontal` connector behavior is unchanged. - Added `phaseLabel()` for flowchart box lists: a one-call-per-stage helper that adds a CONSORT-style phase label (e.g. *Allocation*, *Follow-up*, *Analysis*) centred between a stage's arms, sitting slightly above it and drawn on top. The label width adapts to the stage — spanning the central gap (plus a small corner overlap) for two arms, or the full stage width as a banner for three or more arms — and can be set explicitly via `width`. It correctly handles nested arm lists (arms that are themselves lists of boxes) by resolving their merged bounding box. - Added `on_top` to `insert()` for flowchart box lists. A box inserted with `insert(..., on_top = TRUE)` is drawn on top of the other boxes and connections, regardless of its position in the list, and the marker is preserved through subsequent `move()`/`align()` operations. This is the lower-level overlay mechanism that `phaseLabel()` builds on. - `insert()` now resolves grouped (list) neighbours via their merged bounding box, so a box can be inserted between grouped stages without error. diff --git a/R/boxGrobs_connect.R b/R/boxGrobs_connect.R index 95b402a..4888a5a 100644 --- a/R/boxGrobs_connect.R +++ b/R/boxGrobs_connect.R @@ -21,8 +21,16 @@ #' #' `type` controls the connector shape: #' -#' - `"vertical"`: straight vertical connector -#' - `"horizontal"`: straight horizontal connector +#' - `"vertical"`: straight connector between vertical faces (top/bottom). +#' If the box centers differ on the x-axis, the line is diagonal. +#' - `"vertical_axis"`: strict vertical connector preserving the source box +#' center x-coordinate and projecting that 90-degree axis onto the target +#' boundary. Source and target must be vertically separated. +#' - `"horizontal"`: straight connector between horizontal faces (left/right). +#' If the box centers differ on the y-axis, the line is diagonal. +#' - `"horizontal_axis"`: strict horizontal connector preserving the source box +#' center y-coordinate and projecting that 90-degree axis onto the target +#' boundary. Source and target must be horizontally separated. #' - `"L"`: vertical then horizontal (direction chosen automatically) #' - `"-"`: straight horizontal connector at the end box y-position #' - `"Z"`: horizontal connector with two 90-degree turns @@ -40,6 +48,11 @@ #' bend position is computed so that the horizontal segment aligns visually across #' all connectors. #' +#' Use `"vertical_axis"` or `"horizontal_axis"` when the visual requirement is a +#' true axis-aligned connector. Use `"vertical"` or `"horizontal"` when you want +#' the shortest straight connector between the corresponding box faces and a +#' diagonal line is acceptable. +#' #' ## Labels #' #' For one-to-one connectors you can add a text label (for example `"yes"` / `"no"`). @@ -112,7 +125,8 @@ connectGrob <- function( start, end, - type = c("vertical", "horizontal", "L", "-", "Z", "N", "fan_in_top", "fan_in_center", "side"), + type = c("vertical", "vertical_axis", "horizontal", "horizontal_axis", + "L", "-", "Z", "N", "fan_in_top", "fan_in_center", "side"), subelmnt = c("right", "left"), lty_gp = getOption("connectGrob", default = gpar(fill = "black")), arrow_obj = getOption("connectGrobArrow", default = arrow(ends = "last", type = "closed")), @@ -132,6 +146,19 @@ connectGrob <- function( label_pos = c("mid", "near_start", "near_end"), label_offset = unit(2, "mm") ) { + if (length(type) == 1) { + type_aliases <- c( + "v" = "vertical", + "vert" = "vertical", + "h" = "horizontal", + "hor" = "horizontal", + "horiz" = "horizontal" + ) + if (type %in% names(type_aliases)) { + type <- unname(type_aliases[type]) + } + } + type <- match.arg(type) label_pos <- match.arg(label_pos) side <- match.arg(side) diff --git a/R/boxGrobs_connect_pr_helpers.R b/R/boxGrobs_connect_pr_helpers.R index 4aa02b9..e80aa79 100644 --- a/R/boxGrobs_connect_pr_helpers.R +++ b/R/boxGrobs_connect_pr_helpers.R @@ -66,6 +66,68 @@ prEdgeSlots <- function(left, right, n, margin = unit(0, "mm")) { unit.c(xs) } +prClampUnit <- function(value, lower, upper, axis = c("x", "y")) { + axis <- match.arg(axis) + convert_fn <- if (axis == "x") prConvertWidthToMm else prConvertHeightToMm + + value_mm <- convert_fn(value) + lower_mm <- convert_fn(lower) + upper_mm <- convert_fn(upper) + + if (value_mm < lower_mm) { + return(lower) + } + if (value_mm > upper_mm) { + return(upper) + } + value +} + +prSpansOverlap <- function(first_min, first_max, second_min, second_max, + axis = c("x", "y")) { + axis <- match.arg(axis) + convert_fn <- if (axis == "x") prConvertWidthToMm else prConvertHeightToMm + + first_min_mm <- convert_fn(first_min) + first_max_mm <- convert_fn(first_max) + second_min_mm <- convert_fn(second_min) + second_max_mm <- convert_fn(second_max) + + max(first_min_mm, second_min_mm) < min(first_max_mm, second_max_mm) +} + +prVerticalAxisEdges <- function(start, end) { + if (prSpansOverlap(start$bottom, start$top, end$bottom, end$top, axis = "y")) { + stop( + "`type = \"vertical_axis\"` requires source and target boxes to be vertically separated; ", + "use `type = \"vertical\"` or adjust the layout.", + call. = FALSE + ) + } + + target_below <- prConvertHeightToMm(start$bottom) >= prConvertHeightToMm(end$top) + if (target_below) { + return(list(start_edge = start$bottom, target_edge = end$top)) + } + list(start_edge = start$top, target_edge = end$bottom) +} + +prHorizontalAxisEdges <- function(start, end) { + if (prSpansOverlap(start$left, start$right, end$left, end$right, axis = "x")) { + stop( + "`type = \"horizontal_axis\"` requires source and target boxes to be horizontally separated; ", + "use `type = \"horizontal\"` or adjust the layout.", + call. = FALSE + ) + } + + target_right <- prConvertWidthToMm(start$right) <= prConvertWidthToMm(end$left) + if (target_right) { + return(list(start_edge = start$right, target_edge = end$left)) + } + list(start_edge = start$left, target_edge = end$right) +} + # Find the first boxed element in a possibly nested container. Useful for # making many-to-one connectors robust to inputs where the intended `end` # was wrapped in container lists by layout pipelines. diff --git a/R/boxGrobs_connect_pr_single_boxes.R b/R/boxGrobs_connect_pr_single_boxes.R index 258d725..e8a5e3b 100644 --- a/R/boxGrobs_connect_pr_single_boxes.R +++ b/R/boxGrobs_connect_pr_single_boxes.R @@ -198,6 +198,13 @@ prConnect1 <- function( } else { line$y <- unit.c(start$bottom, end$top) } + } else if (type == "vertical_axis") { + axis_x <- getX4elmnt(start, "x") + target_x <- prClampUnit(axis_x, end$left, end$right, axis = "x") + edges <- prVerticalAxisEdges(start, end) + + line$x <- unit.c(axis_x, target_x) + line$y <- unit.c(edges$start_edge, edges$target_edge) } else if (type == "side") { # Horizontal-first exit: leave from a selected start side, travel vertically # outside/alongside the flow, then enter the selected side of the end box. @@ -216,6 +223,13 @@ prConnect1 <- function( } line$x <- unit.c(exit_x, exit_x, entry_x) line$y <- unit.c(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") + edges <- prHorizontalAxisEdges(start, end) + + line$x <- unit.c(edges$start_edge, edges$target_edge) + line$y <- unit.c(axis_y, target_y) } else { # horizontal line$y <- unit.c(start$y, end$y) if (prConvertWidthToMm(getX4elmnt(start, "x")) < prConvertWidthToMm(getX4elmnt(end, "x"))) { diff --git a/R/boxGrobs_connect_strategies.R b/R/boxGrobs_connect_strategies.R index 97d2e70..10ba584 100644 --- a/R/boxGrobs_connect_strategies.R +++ b/R/boxGrobs_connect_strategies.R @@ -25,7 +25,9 @@ prGetConnectorStrategy <- function(start, end, type) { # Map types to camelCase for class names type_map <- c( "vertical" = "Vertical", + "vertical_axis" = "VerticalAxis", "horizontal" = "Horizontal", + "horizontal_axis" = "HorizontalAxis", "L" = "L", "-" = "Dash", "Z" = "Z", diff --git a/inst/examples/connectGrob_example.R b/inst/examples/connectGrob_example.R index 228eb3a..22f9be1 100644 --- a/inst/examples/connectGrob_example.R +++ b/inst/examples/connectGrob_example.R @@ -17,6 +17,8 @@ boxes <- flowchart( ) # Connect using the pipe-friendly S3 API +# Note: type = "vertical" connects top/bottom faces with a straight segment; +# if x positions differ, the segment may be diagonal. boxes <- boxes |> connect(from = "start", to = "end", type = "vertical") |> connect(from = "start", to = "side", type = "horizontal") |> @@ -49,6 +51,33 @@ flowchart( connect(from = c("start", "S2", "S3"), to = "end", type = "fan_in_center") |> print() +# Start a fresh page for axis-preserving connector examples. +grid.newpage() + +# vertical_axis is the axis-preserving alternative: it preserves each source's +# x-position when landing on the boundary of a wide shared target. +flowchart( + A = boxGrob("A", x = .25, y = .75), + B = boxGrob("B", x = .50, y = .75), + C = boxGrob("C", x = .75, y = .75), + target = boxGrob("Shared target", x = .5, y = .2, width = unit(.75, "npc")) +) |> + connect(from = c("A", "B", "C"), to = "target", type = "vertical_axis") |> + print() + +grid.newpage() + +# horizontal_axis is the axis-preserving alternative: it preserves each +# source's y-position when landing on the boundary of a tall shared target. +flowchart( + A = boxGrob("A", x = .20, y = .25), + B = boxGrob("B", x = .20, y = .50), + C = boxGrob("C", x = .20, y = .75), + target = boxGrob("Shared\ntarget", x = .8, y = .5, height = unit(.75, "npc")) +) |> + connect(from = c("A", "B", "C"), to = "target", type = "horizontal_axis") |> + print() + # Start a fresh page for spread/assignment example. grid.newpage() diff --git a/man/connect.Rd b/man/connect.Rd index 2860b8a..a45c9ec 100644 --- a/man/connect.Rd +++ b/man/connect.Rd @@ -15,8 +15,8 @@ connectGrob( start, end, - type = c("vertical", "horizontal", "L", "-", "Z", "N", "fan_in_top", "fan_in_center", - "side"), + type = c("vertical", "vertical_axis", "horizontal", "horizontal_axis", "L", "-", "Z", + "N", "fan_in_top", "fan_in_center", "side"), subelmnt = c("right", "left"), lty_gp = getOption("connectGrob", default = gpar(fill = "black")), arrow_obj = getOption("connectGrobArrow", default = arrow(ends = "last", type = @@ -163,8 +163,16 @@ custom connectors using the calculated coordinates. \code{type} controls the connector shape: \itemize{ -\item \code{"vertical"}: straight vertical connector -\item \code{"horizontal"}: straight horizontal connector +\item \code{"vertical"}: straight connector between vertical faces (top/bottom). +If the box centers differ on the x-axis, the line is diagonal. +\item \code{"vertical_axis"}: strict vertical connector preserving the source box +center x-coordinate and projecting that 90-degree axis onto the target +boundary. Source and target must be vertically separated. +\item \code{"horizontal"}: straight connector between horizontal faces (left/right). +If the box centers differ on the y-axis, the line is diagonal. +\item \code{"horizontal_axis"}: strict horizontal connector preserving the source box +center y-coordinate and projecting that 90-degree axis onto the target +boundary. Source and target must be horizontally separated. \item \code{"L"}: vertical then horizontal (direction chosen automatically) \item \code{"-"}: straight horizontal connector at the end box y-position \item \code{"Z"}: horizontal connector with two 90-degree turns @@ -182,6 +190,11 @@ arrow to represent the merged flow (e.g. a middle trunk bus). For \code{type = "N"} and \code{type = "fan_in_top"} with multi-box connections, a shared bend position is computed so that the horizontal segment aligns visually across all connectors. + +Use \code{"vertical_axis"} or \code{"horizontal_axis"} when the visual requirement is a +true axis-aligned connector. Use \code{"vertical"} or \code{"horizontal"} when you want +the shortest straight connector between the corresponding box faces and a +diagonal line is acceptable. } \subsection{Labels}{ @@ -227,6 +240,8 @@ boxes <- flowchart( ) # Connect using the pipe-friendly S3 API +# Note: type = "vertical" connects top/bottom faces with a straight segment; +# if x positions differ, the segment may be diagonal. boxes <- boxes |> connect(from = "start", to = "end", type = "vertical") |> connect(from = "start", to = "side", type = "horizontal") |> @@ -259,6 +274,33 @@ flowchart( connect(from = c("start", "S2", "S3"), to = "end", type = "fan_in_center") |> print() +# Start a fresh page for axis-preserving connector examples. +grid.newpage() + +# vertical_axis is the axis-preserving alternative: it preserves each source's +# x-position when landing on the boundary of a wide shared target. +flowchart( + A = boxGrob("A", x = .25, y = .75), + B = boxGrob("B", x = .50, y = .75), + C = boxGrob("C", x = .75, y = .75), + target = boxGrob("Shared target", x = .5, y = .2, width = unit(.75, "npc")) +) |> + connect(from = c("A", "B", "C"), to = "target", type = "vertical_axis") |> + print() + +grid.newpage() + +# horizontal_axis is the axis-preserving alternative: it preserves each +# source's y-position when landing on the boundary of a tall shared target. +flowchart( + A = boxGrob("A", x = .20, y = .25), + B = boxGrob("B", x = .20, y = .50), + C = boxGrob("C", x = .20, y = .75), + target = boxGrob("Shared\ntarget", x = .8, y = .5, height = unit(.75, "npc")) +) |> + connect(from = c("A", "B", "C"), to = "target", type = "horizontal_axis") |> + print() + # Start a fresh page for spread/assignment example. grid.newpage() diff --git a/tests/testthat/test-connectGrob-axis-connectors.R b/tests/testthat/test-connectGrob-axis-connectors.R new file mode 100644 index 0000000..16c9d22 --- /dev/null +++ b/tests/testthat/test-connectGrob-axis-connectors.R @@ -0,0 +1,228 @@ +library(grid) +library(testthat) + +npc_x <- function(x) convertX(x, "npc", valueOnly = TRUE) +npc_y <- function(y) convertY(y, "npc", valueOnly = TRUE) + +axis_box <- function(label, x, y, width = 0.1, height = 0.1) { + boxGrob( + label, + x = unit(x, "npc"), + y = unit(y, "npc"), + width = unit(width, "npc"), + height = unit(height, "npc") + ) +} + +test_that("vertical_axis uses source bottom and target top when source is above target", { + start <- axis_box("Start", x = 0.3, y = 0.7) + end <- axis_box("End", x = 0.5, y = 0.2, width = 0.8) + + con <- connectGrob(start, end, type = "vertical_axis") + line <- attr(con, "line") + + expect_equal(npc_y(line$y[1]), npc_y(coords(start)$bottom), tolerance = 1e-6) + expect_equal(npc_y(line$y[2]), npc_y(coords(end)$top), tolerance = 1e-6) +}) + +test_that("vertical_axis uses source top and target bottom when source is below target", { + start <- axis_box("Start", x = 0.3, y = 0.2) + end <- axis_box("End", x = 0.5, y = 0.7, width = 0.8) + + con <- connectGrob(start, end, type = "vertical_axis") + line <- attr(con, "line") + + expect_equal(npc_y(line$y[1]), npc_y(coords(start)$top), tolerance = 1e-6) + expect_equal(npc_y(line$y[2]), npc_y(coords(end)$bottom), tolerance = 1e-6) +}) + +test_that("vertical_axis lands at source x inside target span", { + start <- axis_box("Start", x = 0.3, y = 0.7) + end <- axis_box("End", x = 0.5, y = 0.2, width = 0.8) + + con <- connectGrob(start, end, type = "vertical_axis") + line <- attr(con, "line") + + expect_equal(npc_x(line$x[1]), npc_x(coords(start)$x), tolerance = 1e-6) + expect_equal(npc_x(line$x[2]), npc_x(coords(start)$x), tolerance = 1e-6) +}) + +test_that("vertical_axis clamps target x to target left and right boundaries", { + left_start <- axis_box("Left", x = 0.05, y = 0.7) + right_start <- axis_box("Right", x = 0.95, y = 0.7) + end <- axis_box("End", x = 0.5, y = 0.2, width = 0.6) + + left_con <- connectGrob(left_start, end, type = "vertical_axis") + right_con <- connectGrob(right_start, end, type = "vertical_axis") + + expect_equal(npc_x(attr(left_con, "line")$x[2]), npc_x(coords(end)$left), tolerance = 1e-6) + expect_equal(npc_x(attr(right_con, "line")$x[2]), npc_x(coords(end)$right), tolerance = 1e-6) +}) + +test_that("vertical_axis errors when boxes overlap vertically", { + start <- axis_box("Start", x = 0.3, y = 0.5, height = 0.3) + end <- axis_box("End", x = 0.6, y = 0.55, height = 0.3) + + expect_error( + connectGrob(start, end, type = "vertical_axis"), + "vertically separated" + ) +}) + +test_that("vertical behavior remains unchanged", { + start <- axis_box("Start", x = 0.3, y = 0.7) + end <- axis_box("End", x = 0.6, y = 0.2) + + con <- connectGrob(start, end, type = "vertical") + line <- attr(con, "line") + + expect_equal(npc_x(line$x[1]), npc_x(coords(start)$x), tolerance = 1e-6) + expect_equal(npc_x(line$x[2]), npc_x(coords(end)$x), tolerance = 1e-6) +}) + +test_that("horizontal_axis uses source right and target left when source is left of target", { + start <- axis_box("Start", x = 0.2, y = 0.4) + end <- axis_box("End", x = 0.7, y = 0.5, height = 0.6) + + con <- connectGrob(start, end, type = "horizontal_axis") + line <- attr(con, "line") + + expect_equal(npc_x(line$x[1]), npc_x(coords(start)$right), tolerance = 1e-6) + expect_equal(npc_x(line$x[2]), npc_x(coords(end)$left), tolerance = 1e-6) +}) + +test_that("horizontal_axis uses source left and target right when source is right of target", { + start <- axis_box("Start", x = 0.8, y = 0.4) + end <- axis_box("End", x = 0.3, y = 0.5, height = 0.6) + + con <- connectGrob(start, end, type = "horizontal_axis") + line <- attr(con, "line") + + expect_equal(npc_x(line$x[1]), npc_x(coords(start)$left), tolerance = 1e-6) + expect_equal(npc_x(line$x[2]), npc_x(coords(end)$right), tolerance = 1e-6) +}) + +test_that("horizontal_axis lands at source y inside target span", { + start <- axis_box("Start", x = 0.2, y = 0.4) + end <- axis_box("End", x = 0.7, y = 0.5, height = 0.6) + + con <- connectGrob(start, end, type = "horizontal_axis") + line <- attr(con, "line") + + expect_equal(npc_y(line$y[1]), npc_y(coords(start)$y), tolerance = 1e-6) + expect_equal(npc_y(line$y[2]), npc_y(coords(start)$y), tolerance = 1e-6) +}) + +test_that("horizontal_axis clamps target y to target bottom and top boundaries", { + low_start <- axis_box("Low", x = 0.2, y = 0.05) + high_start <- axis_box("High", x = 0.2, y = 0.95) + end <- axis_box("End", x = 0.7, y = 0.5, height = 0.6) + + low_con <- connectGrob(low_start, end, type = "horizontal_axis") + high_con <- connectGrob(high_start, end, type = "horizontal_axis") + + expect_equal(npc_y(attr(low_con, "line")$y[2]), npc_y(coords(end)$bottom), tolerance = 1e-6) + expect_equal(npc_y(attr(high_con, "line")$y[2]), npc_y(coords(end)$top), tolerance = 1e-6) +}) + +test_that("horizontal_axis errors when boxes overlap horizontally", { + start <- axis_box("Start", x = 0.5, y = 0.3, width = 0.3) + end <- axis_box("End", x = 0.55, y = 0.7, width = 0.3) + + expect_error( + connectGrob(start, end, type = "horizontal_axis"), + "horizontally separated" + ) +}) + +test_that("horizontal behavior remains unchanged", { + start <- axis_box("Start", x = 0.2, y = 0.3) + end <- axis_box("End", x = 0.7, y = 0.6) + + con <- connectGrob(start, end, type = "horizontal") + line <- attr(con, "line") + + expect_equal(npc_y(line$y[1]), npc_y(coords(start)$y), tolerance = 1e-6) + expect_equal(npc_y(line$y[2]), npc_y(coords(end)$y), tolerance = 1e-6) +}) + +test_that("many-to-one vertical_axis gives each source its own target landing point", { + starts <- list( + axis_box("A", x = 0.25, y = 0.7), + axis_box("B", x = 0.50, y = 0.7), + axis_box("C", x = 0.75, y = 0.7) + ) + end <- axis_box("End", x = 0.5, y = 0.2, width = 0.8) + + con <- connectGrob(starts, end, type = "vertical_axis") + + expect_s3_class(con, "connect_boxes_list") + expect_equal(length(con), 3) + expect_equal( + vapply(con, function(g) npc_x(attr(g, "line")$x[2]), numeric(1)), + vapply(starts, function(s) npc_x(coords(s)$x), numeric(1)), + tolerance = 1e-6 + ) +}) + +test_that("many-to-one horizontal_axis gives each source its own target landing point", { + starts <- list( + axis_box("A", x = 0.2, y = 0.25), + axis_box("B", x = 0.2, y = 0.50), + axis_box("C", x = 0.2, y = 0.75) + ) + end <- axis_box("End", x = 0.8, y = 0.5, height = 0.8) + + con <- connectGrob(starts, end, type = "horizontal_axis") + + expect_s3_class(con, "connect_boxes_list") + expect_equal(length(con), 3) + expect_equal( + vapply(con, function(g) npc_y(attr(g, "line")$y[2]), numeric(1)), + vapply(starts, function(s) npc_y(coords(s)$y), numeric(1)), + tolerance = 1e-6 + ) +}) + +test_that("one-to-many axis connectors return one connector per target", { + start <- axis_box("Start", x = 0.5, y = 0.8) + vertical_targets <- list( + axis_box("A", x = 0.3, y = 0.2, width = 0.4), + axis_box("B", x = 0.7, y = 0.2, width = 0.4) + ) + + vertical_con <- connectGrob(start, vertical_targets, type = "vertical_axis") + + expect_s3_class(vertical_con, "connect_boxes_list") + expect_equal(length(vertical_con), 2) + + h_start <- axis_box("Start", x = 0.2, y = 0.5) + horizontal_targets <- list( + axis_box("A", x = 0.8, y = 0.3, height = 0.4), + axis_box("B", x = 0.8, y = 0.7, height = 0.4) + ) + + horizontal_con <- connectGrob(h_start, horizontal_targets, type = "horizontal_axis") + + expect_s3_class(horizontal_con, "connect_boxes_list") + expect_equal(length(horizontal_con), 2) +}) + +test_that("S3 list-to-list axis connector behavior remains pairwise", { + fc <- flowchart( + starts = list( + axis_box("A", x = 0.25, y = 0.7), + axis_box("B", x = 0.75, y = 0.7) + ), + ends = list( + axis_box("C", x = 0.25, y = 0.2), + axis_box("D", x = 0.75, y = 0.2) + ) + ) |> + connect("starts", "ends", type = "vertical_axis") + + con <- tail(attr(fc, "connections"), 1)[[1]] + + expect_s3_class(con, "connect_boxes_list") + expect_equal(length(con), 2) +}) diff --git a/vignettes/Grid-based_flowcharts.Rmd b/vignettes/Grid-based_flowcharts.Rmd index 323be2b..373b828 100644 --- a/vignettes/Grid-based_flowcharts.Rmd +++ b/vignettes/Grid-based_flowcharts.Rmd @@ -373,6 +373,49 @@ flowchart( options(old_opts) ``` +# Axis-preserving connectors for shared targets + +The regular `vertical` and `horizontal` connectors draw a straight line between +the relevant box faces. If the box centres are offset, that straight line can be +diagonal. Use `vertical_axis` or `horizontal_axis` when the connector itself must +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) + +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 + ), + 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 + ) +) |> + 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) |> + print() +``` + # Basic components explained There is a basic set of components that are used for generating flowcharts: From 681bfb0f1362a13d45289348cd6fd15cd42c8bfa Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Fri, 19 Jun 2026 23:35:33 +0200 Subject: [PATCH 7/7] Copilot fixes --- .Rbuildignore | 2 +- R/boxGrobs_boxGrob.R | 12 ++++++++++- R/boxGrobs_connect_pr_single_boxes.R | 2 +- tests/testthat/test-boxGrob-corner-radius.R | 24 +++++++++++++++++++++ 4 files changed, 37 insertions(+), 3 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 3b7356f..5f0efe0 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -28,4 +28,4 @@ Gmisc/inst/extdata/Full_test_suite_files/* ^docs/ ^README\.Rmd$ ^README\.html$ -^Rplots.pdf +^Rplots\.pdf$ diff --git a/R/boxGrobs_boxGrob.R b/R/boxGrobs_boxGrob.R index bd1c201..b8ca480 100644 --- a/R/boxGrobs_boxGrob.R +++ b/R/boxGrobs_boxGrob.R @@ -73,9 +73,19 @@ boxGrob <- function(label, checkNumeric(label), is.language(label) ) - if (!is.list(box_fn_args)) { + if (!is.list(box_fn_args) || + is.null(names(box_fn_args)) || + any(!nzchar(names(box_fn_args)))) { stop("`box_fn_args` must be a named list.", call. = FALSE) } + reserved_box_fn_args <- intersect(names(box_fn_args), c("x", "y", "gp")) + if (length(reserved_box_fn_args) > 0) { + stop( + "`box_fn_args` cannot include reserved arguments: ", + paste(reserved_box_fn_args, collapse = ", "), + call. = FALSE + ) + } assert_unit(y) assert_unit(x) assert_unit(width) diff --git a/R/boxGrobs_connect_pr_single_boxes.R b/R/boxGrobs_connect_pr_single_boxes.R index e8a5e3b..5278a24 100644 --- a/R/boxGrobs_connect_pr_single_boxes.R +++ b/R/boxGrobs_connect_pr_single_boxes.R @@ -206,7 +206,7 @@ prConnect1 <- function( line$x <- unit.c(axis_x, target_x) line$y <- unit.c(edges$start_edge, edges$target_edge) } else if (type == "side") { - # Horizontal-first exit: leave from a selected start side, travel vertically + # 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. end_is_right <- prConvertWidthToMm(getX4elmnt(end, "x")) > prConvertWidthToMm(start$x) exit_x <- if (side == "right" || (side == "auto" && end_is_right)) { diff --git a/tests/testthat/test-boxGrob-corner-radius.R b/tests/testthat/test-boxGrob-corner-radius.R index 8bade48..53dbf80 100644 --- a/tests/testthat/test-boxGrob-corner-radius.R +++ b/tests/testthat/test-boxGrob-corner-radius.R @@ -35,3 +35,27 @@ test_that("boxGrob rejects non-list box_fn_args", { "`box_fn_args` must be a named list" ) }) + +test_that("boxGrob rejects unnamed box_fn_args", { + expect_error( + boxGrob("Test", box_fn_args = list(unit(5, "mm"))), + "`box_fn_args` must be a named list" + ) + expect_error( + boxGrob("Test", box_fn_args = list(r = unit(5, "mm"), unit(3, "mm"))), + "`box_fn_args` must be a named list" + ) +}) + +test_that("boxGrob rejects reserved box_fn_args", { + expect_error( + boxGrob("Test", box_fn_args = list(gp = gpar(fill = "red"))), + "`box_fn_args` cannot include reserved arguments: gp", + fixed = TRUE + ) + expect_error( + boxGrob("Test", box_fn_args = list(x = .2, y = .3)), + "`box_fn_args` cannot include reserved arguments: x, y", + fixed = TRUE + ) +})