|
| 1 | +#' Reference a flowchart box position |
| 2 | +#' |
| 3 | +#' Creates a position reference that can be used anywhere a `move()`/`moveBox()` |
| 4 | +#' coordinate accepts a `grid::unit()`. When `reference` is a path, the position |
| 5 | +#' is resolved against the current box list at move time. |
| 6 | +#' |
| 7 | +#' @param reference A box, a `coords()` object, a list of boxes, or a path into |
| 8 | +#' a flowchart list such as `"groups"` or `c("groups", 1)`. |
| 9 | +#' @param position Which position to extract. For `type = "x"` use `"center"`, |
| 10 | +#' `"left"`, or `"right"`. For `type = "y"` use `"center"`, `"top"`, or |
| 11 | +#' `"bottom"`. |
| 12 | +#' @param type Axis to extract: `"x"` or `"y"`. |
| 13 | +#' |
| 14 | +#' @return A `grid::unit()` when `reference` is already a box/coords object, or |
| 15 | +#' a deferred position reference when `reference` is a flowchart path. |
| 16 | +#' @export |
| 17 | +#' @family flowchart components |
| 18 | +#' @examples |
| 19 | +#' fc <- flowchart(groups = list("A", "B"), ex = list("X", "Y")) |> |
| 20 | +#' spread(axis = "x", subelement = "groups") |
| 21 | +#' |
| 22 | +#' fc |> |
| 23 | +#' move(subelement = c("ex", 1), |
| 24 | +#' x = position(c("groups", 1), position = "center", type = "x") + |
| 25 | +#' grid::unit(5, "mm")) |
| 26 | +position <- function(reference, position = "center", type = c("x", "y")) { |
| 27 | + UseMethod("position") |
| 28 | +} |
| 29 | + |
| 30 | +#' @export |
| 31 | +#' @rdname position |
| 32 | +position.default <- function(reference, position = "center", type = c("x", "y")) { |
| 33 | + type <- match.arg(type) |
| 34 | + position <- match.arg(position, c("center", "left", "right", "top", "bottom")) |
| 35 | + prValidatePositionAxis(position = position, type = type) |
| 36 | + |
| 37 | + if (is.list(reference) && !is.null(reference) && length(reference) > 0 && |
| 38 | + all(vapply(reference, function(x) inherits(x, "box") || inherits(x, "coords") || is.list(x), logical(1)))) { |
| 39 | + return(prSelectPosition(prConvert2Coords(reference), position = position, type = type)) |
| 40 | + } |
| 41 | + |
| 42 | + ref <- structure( |
| 43 | + list(reference = reference, position = position, type = type), |
| 44 | + class = "Gmisc_position_ref" |
| 45 | + ) |
| 46 | + structure(list(list(0, ref, 0L)), class = c("unit", "unit_v2")) |
| 47 | +} |
| 48 | + |
| 49 | +#' @export |
| 50 | +#' @rdname position |
| 51 | +position.box <- function(reference, position = "center", type = c("x", "y")) { |
| 52 | + type <- match.arg(type) |
| 53 | + position <- match.arg(position, c("center", "left", "right", "top", "bottom")) |
| 54 | + prValidatePositionAxis(position = position, type = type) |
| 55 | + prSelectPosition(coords(reference), position = position, type = type) |
| 56 | +} |
| 57 | + |
| 58 | +#' @export |
| 59 | +#' @rdname position |
| 60 | +position.coords <- function(reference, position = "center", type = c("x", "y")) { |
| 61 | + type <- match.arg(type) |
| 62 | + position <- match.arg(position, c("center", "left", "right", "top", "bottom")) |
| 63 | + prValidatePositionAxis(position = position, type = type) |
| 64 | + prSelectPosition(reference, position = position, type = type) |
| 65 | +} |
| 66 | + |
| 67 | +prValidatePositionAxis <- function(position, type) { |
| 68 | + if (type == "x" && !position %in% c("center", "left", "right")) { |
| 69 | + stop("For type = 'x', `position` must be 'center', 'left', or 'right'.", call. = FALSE) |
| 70 | + } |
| 71 | + if (type == "y" && !position %in% c("center", "top", "bottom")) { |
| 72 | + stop("For type = 'y', `position` must be 'center', 'top', or 'bottom'.", call. = FALSE) |
| 73 | + } |
| 74 | +} |
| 75 | + |
| 76 | +prSelectPosition <- function(coords, position, type) { |
| 77 | + if (position == "center") { |
| 78 | + return(coords[[type]]) |
| 79 | + } |
| 80 | + coords[[position]] |
| 81 | +} |
| 82 | + |
| 83 | +prUnitAsExpressionPart <- function(unit_value) { |
| 84 | + raw <- unclass(unit_value) |
| 85 | + if (is.list(raw)) { |
| 86 | + if (length(raw) != 1) { |
| 87 | + stop("Expected a length-1 unit value for position reference resolution.", call. = FALSE) |
| 88 | + } |
| 89 | + return(raw[[1]]) |
| 90 | + } |
| 91 | + list(as.numeric(raw), NULL, as.integer(attr(raw, "unit"))) |
| 92 | +} |
| 93 | + |
| 94 | +prResolvePositionValue <- function(value, element) { |
| 95 | + if (!inherits(value, "unit")) { |
| 96 | + return(value) |
| 97 | + } |
| 98 | + |
| 99 | + resolve_ref <- function(ref) { |
| 100 | + target <- if (inherits(ref$reference, "box") || inherits(ref$reference, "coords")) { |
| 101 | + ref$reference |
| 102 | + } else { |
| 103 | + get_list_element_by_path(element, ref$reference) |
| 104 | + } |
| 105 | + |
| 106 | + if (is.null(target)) { |
| 107 | + stop( |
| 108 | + "The position reference '", |
| 109 | + paste(ref$reference, collapse = " -> "), |
| 110 | + "' was not found in the provided boxes.", |
| 111 | + call. = FALSE |
| 112 | + ) |
| 113 | + } |
| 114 | + |
| 115 | + prSelectPosition(prConvert2Coords(target), position = ref$position, type = ref$type) |
| 116 | + } |
| 117 | + |
| 118 | + resolve_unit <- function(u) { |
| 119 | + if (!inherits(u, "unit_v2")) { |
| 120 | + return(u) |
| 121 | + } |
| 122 | + |
| 123 | + parts <- unclass(u) |
| 124 | + if (!is.list(parts)) { |
| 125 | + return(u) |
| 126 | + } |
| 127 | + changed <- FALSE |
| 128 | + |
| 129 | + parts <- lapply(parts, function(part) { |
| 130 | + data <- part[[2]] |
| 131 | + if (inherits(data, "Gmisc_position_ref")) { |
| 132 | + changed <<- TRUE |
| 133 | + return(prUnitAsExpressionPart(resolve_ref(data))) |
| 134 | + } |
| 135 | + if (inherits(data, "unit")) { |
| 136 | + part[[2]] <- resolve_unit(data) |
| 137 | + changed <<- TRUE |
| 138 | + } |
| 139 | + part |
| 140 | + }) |
| 141 | + |
| 142 | + if (!changed) { |
| 143 | + return(u) |
| 144 | + } |
| 145 | + structure(parts, class = c("unit", "unit_v2")) |
| 146 | + } |
| 147 | + |
| 148 | + resolve_unit(value) |
| 149 | +} |
0 commit comments