Merge branch 'main' of https://github.com/teunbrand/gguidance

NAMESPACE

@@ -14,6 +14,7 @@ export(GuideColring)
 export(GuideSubtitle)
 export(PrimitiveBox)
 export(PrimitiveBracket)
+export(PrimitiveFence)
 export(PrimitiveLabels)
 export(PrimitiveLine)
 export(PrimitiveSpacer)
@@ -60,6 +61,7 @@ export(key_sequence)
 export(new_compose)
 export(primitive_box)
 export(primitive_bracket)
+export(primitive_fence)
 export(primitive_labels)
 export(primitive_line)
 export(primitive_spacer)

R/guide_axis_nested.R

@@ -16,14 +16,14 @@
 #' @inheritParams primitive_line
 #' @inheritParams primitive_ticks
 #' @inheritParams primitive_bracket
-#' @param ... Arguments passed on to [`primitive_bracket()`] or
-#'   [`primitive_box()`].
+#' @param ... Arguments passed on to [`primitive_bracket()`],
+#'   [`primitive_box()`] or [`primitive_fence()`].
 #'
 #' @details
 #' Under the hood, this guide is a [stack composition][compose_stack] of a
 #' [line][primitive_line], [ticks][primitive_ticks], optionally
-#' [labels][primitive_labels] and either [bracket][primitive_bracket] or
-#' [box][primitive_box] primitives.
+#' [labels][primitive_labels] and either [bracket][primitive_bracket],
+#' [box][primitive_box] or [fence][primitive_fence] primitives.
 #'
 #' By default, the [`key = "range_auto"`][key_range] will incorporate the 0th
 #' level labels inferred from the scale's labels. These labels will look like
@@ -61,6 +61,13 @@
 #' p + guides(x = guide_axis_nested(type = "box")) +
 #'   theme_guide(box = element_rect("limegreen", "forestgreen"))
 #'
+#' # Using fences instead of brackets + styling of fences
+#' p + guides(x = guide_axis_nested(type = "fence", rail = "inner")) +
+#'   theme_guide(
+#'     fence.post = element_line("tomato"),
+#'     fence.rail = element_line("dodgerblue")
+#'   )
+#'
 #' # Use as annotation of a typical axis
 #' # `regular_key` controls display of typical axis
 #' ggplot(mpg, aes(displ, hwy)) +
@@ -70,32 +77,34 @@
 #'     regular_key = key_manual(c(2, 2.5, 3, 5, 7))
 #'   ))
 guide_axis_nested <- function(
-  key   = "range_auto",
-  regular_key = "auto",
-  type  = "bracket",
-  title = waiver(),
-  theme = NULL,
-  angle = waiver(),
-  cap   = "none",
-  bidi  = FALSE,
-  oob   = "squish",
-  drop_zero = TRUE,
-  pad_discrete = 0.4,
-  levels_text = NULL,
-  ...,
-  order = 0,
-  position = waiver()
+    key   = "range_auto",
+    regular_key = "auto",
+    type  = "bracket",
+    title = waiver(),
+    theme = NULL,
+    angle = waiver(),
+    cap   = "none",
+    bidi  = FALSE,
+    oob   = "squish",
+    drop_zero = TRUE,
+    pad_discrete = NULL,
+    levels_text = NULL,
+    ...,
+    order = 0,
+    position = waiver()
 ) {
 
   theme <- theme %||% theme()
   theme$gguidance.guide.spacing <-
     theme$gguidance.guide.spacing %||% unit(0, "cm")
 
   nesting <- switch(
-    arg_match0(type, c("bracket", "box")),
+    arg_match0(type, c("bracket", "box", "fence")),
     bracket = primitive_bracket,
-    box = primitive_box
+    box = primitive_box,
+    fence = primitive_fence
   )
+  pad_discrete <- pad_discrete %||% switch(type, fence = 0.5, 0.4)
 
   if (identical(key, "range_auto")) {
     labels <- new_guide(

R/key-range.R

@@ -291,6 +291,36 @@ range_from_label <- function(
   df
 }
 
+justify_ranges <- function(key, levels, element, level_elements) {
+
+  if (is_blank(element)) {
+    return(key)
+  }
+
+  ends <- intersect(c("thetaend", "xend", "yend"), names(key))
+  if (length(ends) < 1) {
+    return(key)
+  }
+  starts <- gsub("end$", "", ends[1])
+
+  just_name <- switch(ends[1], yend = "vjust", "hjust")
+  just <- element[[just_name]] %||% 0.5
+
+  if (!is.null(level_elements)) {
+    just <- map_dbl(level_elements, function(x) x[[just_name]] %||% just)
+    just <- just[match(key$.level, levels)]
+  }
+
+  key[[starts]] <- switch(
+    ends[1],
+    thetaend = justify_range(key$theta, key$thetaend, just, theta = TRUE),
+    xend     = justify_range(key$x, key$xend, just),
+    yend     = justify_range(key$y, key$yend, just)
+  )
+
+  key
+}
+
 justify_range <- function(start, end, just, theta = FALSE) {
   if (theta) {
     add <- end < start
@@ -337,6 +367,21 @@ disjoin_ranges <- function(ranges) {
   ranges
 }
 
+extract_range_params <- function(scale, params, ...) {
+  params$position <- params$position %|W|% NULL
+  params$limits   <- scale$get_limits()
+
+  new_names <- c("start", "end")
+  aesthetic <- params$aesthetic
+  if (aesthetic %in% c("x", "y")) {
+    new_names  <- paste0(aesthetic, c("", "end"))
+  } else if (is_theta(params$position)) {
+    new_names <- c("x", "xend")
+  }
+  params$key <- rename(params$key, c("start", "end"), new_names)
+  params
+}
+
 setup_range_params <- function(params) {
   if (params$aesthetic %in% c("x", "y")) {
     # parameters are already transformed

R/primitive-box.R

@@ -117,20 +117,7 @@ PrimitiveBox <- ggproto(
 
   extract_key = range_extract_key,
 
-  extract_params = function(scale, params, ...) {
-    params <- primitive_extract_params(scale, params, ...)
-
-    aesthetic <- params$aesthetic
-
-    if (aesthetic %in% c("x", "y")) {
-      params$key <-
-        rename(params$key, c("start", "end"), paste0(aesthetic, c("", "end")))
-    } else if (is_theta(params$position)) {
-      params$key <-
-        rename(params$key, c("start", "end"), c("x", "xend"))
-    }
-    params
-  },
+  extract_params = extract_range_params,
 
   extract_decor = function(scale, aesthetic, key, ...) {
 
@@ -175,27 +162,11 @@ PrimitiveBox <- ggproto(
     text_levels <- rep0(params$levels_text, length.out = nlevels)
 
     # Justify labels along their ranges
-    if (!is_blank(elements$text)) {
+    key <- justify_ranges(key, levels, elements$text, text_levels)
 
-      hjust <- elements$text$hjust
-      vjust <- elements$text$vjust
-
-      if (!is.null(text_levels)) {
-        hjust <- map_dbl(text_levels, function(x) x$hjust %||% hjust)
-        hjust <- hjust[match(key$.level, levels)]
-        vjust <- map_dbl(text_levels, function(x) x$vjust %||% vjust)
-        vjust <- vjust[match(key$.label, levels)]
-      }
-
-      if (is_theta(position)) {
-        add <- if (position == "theta.sec") pi else 0
-        key$theta <- justify_range(key$theta, key$thetaend, hjust, theta = TRUE)
-        key <- polar_xy(key, key$r, key$theta + add, params$bbox)
-      } else if ("xend" %in% names(key)) {
-        key$x <- justify_range(key$x, key$xend, hjust)
-      } else if ("yend" %in% names(key)) {
-        key$y <- justify_range(key$y, key$yend, vjust)
-      }
+    if (is_theta(position)) {
+      add <- if (position == "theta.sec") pi else 0
+      key <- polar_xy(key, key$r, key$theta + add, params$bbox)
     }
 
     grobs  <- vector("list", nlevels)

R/primitive-bracket.R

@@ -142,18 +142,7 @@ PrimitiveBracket <- ggproto(
 
   extract_key = range_extract_key,
 
-  extract_params = function(scale, params, ...) {
-    params <- primitive_extract_params(scale, params, ...)
-    aesthetic <- params$aesthetic
-    if (aesthetic %in% c("x", "y")) {
-      params$key <-
-        rename(params$key, c("start", "end"), paste0(aesthetic, c("", "end")))
-    } else if (is_theta(params$position)) {
-      params$key <-
-        rename(params$key, c("start", "end"), c("x", "xend"))
-    }
-    params
-  },
+  extract_params = extract_range_params,
 
   extract_decor = function(scale, aesthetic, position, key, bracket, ...) {
     bracket <- resolve_bracket(bracket)
@@ -202,28 +191,11 @@ PrimitiveBracket <- ggproto(
     text_levels    <- rep0(params$levels_text,     length.out = nlevels)
 
     # Justify labels along their ranges
-    if (!is_blank(elements$text)) {
-
-      hjust <- elements$text$hjust
-      vjust <- elements$text$vjust
-
-      # If we have custom elements, take justification from there
-      if (!is.null(text_levels)) {
-        hjust <- map_dbl(text_levels, function(x) x$hjust %||% hjust)
-        hjust <- hjust[match(key$.level, levels)]
-        vjust <- map_dbl(text_levels, function(x) x$vjust %||% vjust)
-        vjust <- vjust[match(key$.level, levels)]
-      }
-
-      if (is_theta(position)) {
-        add <- if (position == "theta.sec") pi else 0
-        key$theta <- justify_range(key$theta, key$thetaend, hjust, theta = TRUE)
-        key <- polar_xy(key, key$r, key$theta + add, params$bbox)
-      } else if ("xend" %in% names(key)) {
-        key$x <- justify_range(key$x, key$xend, hjust)
-      } else if ("yend" %in% names(key)) {
-        key$y <- justify_range(key$y, key$yend, vjust)
-      }
+    key <- justify_ranges(key, levels, elements$text, text_levels)
+
+    if (is_theta(position)) {
+      add <- if (position == "theta.sec") pi else 0
+      key <- polar_xy(key, key$r, key$theta + add, params$bbox)
     }
 
     if (is_blank(elements$line) || is_empty(decor)) {