diff --git a/.Rbuildignore b/.Rbuildignore index ce92312..5f0efe0 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -27,3 +27,5 @@ Gmisc/inst/extdata/Full_test_suite_files/* ^.github/ ^docs/ ^README\.Rmd$ +^README\.html$ +^Rplots\.pdf$ 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/NAMESPACE b/NAMESPACE index bc64e3e..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) @@ -84,6 +87,7 @@ export(document_box_fn) export(documents_box_fn) export(docx_document) export(ellipse_box_fn) +export(equalizeHeights) export(equalizeWidths) export(fastDoCall) export(figCapNo) @@ -109,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 67465a2..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. @@ -9,6 +10,11 @@ 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()`. +- 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_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_boxGrob.R b/R/boxGrobs_boxGrob.R index 4b3e233..b8ca480 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,19 @@ boxGrob <- function(label, checkNumeric(label), is.language(label) ) + 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) @@ -83,10 +103,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_connect.R b/R/boxGrobs_connect.R index 2b95c90..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"`). @@ -82,6 +95,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. @@ -104,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")), @@ -114,6 +136,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), @@ -121,9 +146,24 @@ 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) + 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 +256,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_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 7269df8..5278a24 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) @@ -193,21 +198,38 @@ 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 start side, travel horizontally, - # then drop vertically to the end box. + # 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)) { 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 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 d707c17..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", @@ -104,6 +106,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_equalizeWidths.R b/R/boxGrobs_equalizeWidths.R index 5cbc5ec..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) { @@ -165,3 +164,136 @@ 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. `"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. +#' +#' @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)) + } + prResolveSubelementSelector(subelement, obj) + } + + 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/R/boxGrobs_move.R b/R/boxGrobs_move.R index 9b5d270..5b3a52d 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 #' @@ -35,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") } @@ -45,7 +50,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_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/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/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/align.Rd b/man/align.Rd index c5f1e92..770b28a 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,12 +130,14 @@ 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()}}, \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 a0dc326..b14f3e6 100644 --- a/man/append.Rd +++ b/man/append.Rd @@ -36,12 +36,14 @@ 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()}}, \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 5927b83..2cd159e 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,12 +129,14 @@ 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()}}, \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 da260ee..181a4bb 100644 --- a/man/boxHeaderGrob.Rd +++ b/man/boxHeaderGrob.Rd @@ -97,12 +97,14 @@ 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()}}, \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 4ad69ca..42d69f3 100644 --- a/man/boxPropGrob.Rd +++ b/man/boxPropGrob.Rd @@ -93,12 +93,14 @@ 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()}}, \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 d79eb31..0290603 100644 --- a/man/boxShapes.Rd +++ b/man/boxShapes.Rd @@ -226,12 +226,14 @@ 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()}}, \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 8791cb6..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 = @@ -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{ @@ -147,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 @@ -166,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}{ @@ -211,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") |> @@ -243,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() @@ -283,12 +341,14 @@ 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()}}, \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 3f388ff..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: @@ -29,12 +41,14 @@ 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()}}, \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 b7ee148..afd7fac 100644 --- a/man/distance.Rd +++ b/man/distance.Rd @@ -60,12 +60,14 @@ 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()}}, \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 new file mode 100644 index 0000000..c167b87 --- /dev/null +++ b/man/equalizeHeights.Rd @@ -0,0 +1,61 @@ +% 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[=position]{position()}}, +\code{\link[=spread]{spread()}} +} +\concept{flowchart components} diff --git a/man/equalizeWidths.Rd b/man/equalizeWidths.Rd index dbccc3a..2856aa0 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,11 +52,13 @@ 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()}}, \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 bacf0e7..67dd48b 100644 --- a/man/flowchart.Rd +++ b/man/flowchart.Rd @@ -51,11 +51,13 @@ 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()}}, \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 35513bc..5298d67 100644 --- a/man/insert.Rd +++ b/man/insert.Rd @@ -48,11 +48,13 @@ 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()}}, \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 98f642c..9564856 100644 --- a/man/move.Rd +++ b/man/move.Rd @@ -37,11 +37,13 @@ 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()}}, \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 9af878d..228cd18 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,11 +106,13 @@ 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()}}, \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 6dbb38c..979cb54 100644 --- a/man/phaseLabel.Rd +++ b/man/phaseLabel.Rd @@ -81,11 +81,13 @@ 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()}}, \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 7b07d85..ab5c584 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,11 +137,13 @@ 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()}}, \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/_snaps/vdiffr/basic-box.svg b/tests/testthat/_snaps/vdiffr/basic-box.svg index c401fb1..8971129 100644 --- a/tests/testthat/_snaps/vdiffr/basic-box.svg +++ b/tests/testthat/_snaps/vdiffr/basic-box.svg @@ -18,7 +18,7 @@ - + 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..53dbf80 --- /dev/null +++ b/tests/testthat/test-boxGrob-corner-radius.R @@ -0,0 +1,61 @@ +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", { + 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", { + expect_error( + boxGrob("Test", box_fn_args = unit(5, "mm")), + "`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 + ) +}) 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/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/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/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)) +}) 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() diff --git a/vignettes/Grid-based_flowcharts.Rmd b/vignettes/Grid-based_flowcharts.Rmd index 11f9392..373b828 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: @@ -286,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: @@ -338,7 +468,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",