Fence primitive (#19)

* rename colour guides (#11)

* abstract range param extraction

* abstract range justification

* draft guide

* abstract checking if in range

* theme customisation

* document

* fixup mistakes

* add test

* integrate into `guide_axis_nested()`

NAMESPACE

@@ -10,10 +10,11 @@ export(GizmoDensity)
 export(GizmoGrob)
 export(GizmoHistogram)
 export(GizmoStepcap)
-export(GuideColourRing)
+export(GuideColring)
 export(GuideSubtitle)
 export(PrimitiveBox)
 export(PrimitiveBracket)
+export(PrimitiveFence)
 export(PrimitiveLabels)
 export(PrimitiveLine)
 export(PrimitiveSpacer)
@@ -42,9 +43,9 @@ export(gizmo_histogram)
 export(gizmo_stepcap)
 export(guide_axis_custom)
 export(guide_axis_nested)
-export(guide_colour_ring)
-export(guide_colourbar_custom)
-export(guide_coloursteps_custom)
+export(guide_colbar)
+export(guide_colring)
+export(guide_colsteps)
 export(guide_subtitle)
 export(key_auto)
 export(key_bins)
@@ -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)

NEWS.md

@@ -18,9 +18,9 @@ Full guides are guides that you can just drop in the `guides()` function or as
 `guide` argument to scales.
 
 * `guide_axis_custom()` as an axis guide.
-* `guide_colourbar_custom()` as a continuous colour/fill guide.
-* `guide_coloursteps_custom()` as a binned colour/fill guide.
-* `guide_colour_ring()` as a continuous colour/fill guide.
+* `guide_colbar_custom()` as a continuous colour/fill guide.
+* `guide_colsteps_custom()` as a binned colour/fill guide.
+* `guide_colring()` as a continuous colour/fill guide.
 * `guide_subtitle()` as a colour/fill guide.
 
 ## Gizmos

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/guide_colourbar_custom.R → R/guide_colbar.R

@@ -42,40 +42,40 @@
 #' # The colourbar shows caps when values are out-of-bounds (oob)
 #' p + scale_colour_viridis_c(
 #'   limits = c(10, NA),
-#'   guide = "colourbar_custom"
+#'   guide = "colbar"
 #' )
 #'
 #' # It also shows how oob values are handled
 #' p + scale_colour_viridis_c(
 #'   limits = c(10, NA), oob = scales::oob_squish,
-#'   guide = "colourbar_custom"
+#'   guide = "colbar"
 #' )
 #'
 #' # Adjusting the type of cap
 #' p + scale_colour_viridis_c(
 #'   limits = c(10, 30), oob = scales::oob_squish,
-#'   guide = guide_colourbar_custom(shape = "round")
+#'   guide = guide_colbar(shape = "round")
 #' )
 #'
 #' # One-sided ticks
 #' p + scale_colour_viridis_c(
-#'   guide = guide_colourbar_custom(second_guide = "none")
+#'   guide = guide_colbar(second_guide = "none")
 #' )
 #'
 #' # Colour bar with minor breaks
 #' p + scale_colour_viridis_c(
 #'   minor_breaks = scales::breaks_width(1),
-#'   guide = guide_colourbar_custom(key = "minor")
+#'   guide = guide_colbar(key = "minor")
 #' )
 #'
 #' # Using log ticks on a colourbar
 #' ggplot(msleep, aes(sleep_total, sleep_rem)) +
 #'   geom_point(aes(colour = bodywt), na.rm = TRUE) +
 #'   scale_colour_viridis_c(
 #'     transform = "log10",
-#'     guide = guide_colourbar_custom(key = "log")
+#'     guide = guide_colbar(key = "log")
 #'   )
-guide_colourbar_custom <- function(
+guide_colbar <- function(
   title = waiver(),
   key = "auto",
   first_guide  = "axis_custom",

R/guide_colour_ring.R → R/guide_colring.R

@@ -46,22 +46,22 @@
 #'   scale_colour_gradientn(colours = my_pal)
 #'
 #' # Standard colour ring
-#' p + guides(colour = "colour_ring")
+#' p + guides(colour = "colring")
 #'
 #' # As an arc
-#' p + guides(colour = guide_colour_ring(
+#' p + guides(colour = guide_colring(
 #'   start = 1.25 * pi, end = 2.75 * pi
 #' ))
 #'
 #' # Removing the inner tick marks
-#' p + guides(colour = guide_colour_ring(inner_guide = "none"))
+#' p + guides(colour = guide_colring(inner_guide = "none"))
 #'
 #' # Include labels on the inner axis
-#' p + guides(colour = guide_colour_ring(show_labels = "both"))
+#' p + guides(colour = guide_colring(show_labels = "both"))
 #'
 #' # Passing an argument to inner/outer guides
-#' p + guides(colour = guide_colour_ring(angle = 0))
-guide_colour_ring <- function(
+#' p + guides(colour = guide_colring(angle = 0))
+guide_colring <- function(
   title = waiver(),
   key = "auto",
   start = 0,
@@ -103,7 +103,7 @@ guide_colour_ring <- function(
     show_labels = show_labels,
     position = position,
     available_aes = available_aes,
-    super = GuideColourRing
+    super = GuideColring
   )
 }
 
@@ -113,8 +113,8 @@ guide_colour_ring <- function(
 #' @rdname gguidance_extensions
 #' @format NULL
 #' @usage NULL
-GuideColourRing <- ggproto(
-  "GuideColourRing", Compose,
+GuideColring <- ggproto(
+  "GuideColring", Compose,
 
   params = new_params(
     guides = list(), guide_params = list(),

R/guide_coloursteps_custom.R → R/guide_colsteps.R

@@ -40,41 +40,41 @@
 #' # The colour steps show caps when values are out-of-bounds
 #' p + scale_colour_viridis_b(
 #'   limits = c(10, NA),
-#'   guide = "coloursteps_custom"
+#'   guide = "colsteps"
 #' )
 #'
 #' # It also shows how oob values are handled
 #' p + scale_colour_viridis_b(
 #'   limits = c(10, 30), oob = scales::oob_censor,
-#'   guide = "coloursteps_custom"
+#'   guide = "colsteps"
 #' )
 #'
 #' # Adjusting the type of cap
 #' p + scale_colour_viridis_b(
 #'   limits = c(10, 30),
-#'   guide = guide_coloursteps_custom(shape = "round")
+#'   guide = guide_colsteps(shape = "round")
 #' )
 #'
 #' # The default is to use the breaks as-is
 #' p + scale_colour_viridis_b(
 #'   limits = c(10, 30), breaks = c(10, 20, 25),
-#'   guide = "coloursteps_custom"
+#'   guide = "colsteps"
 #' )
 #'
 #' # But the display can be set to use evenly spaced steps
 #' p + scale_colour_viridis_b(
 #'   limits = c(10, 30), breaks = c(10, 20, 25),
-#'   guide = guide_coloursteps_custom(key = key_bins(even.steps = TRUE))
+#'   guide = guide_colsteps(key = key_bins(even.steps = TRUE))
 #' )
 #'
 #' # Using tick marks by swapping side guides
 #' p + scale_colour_viridis_b(
-#'   guide = guide_coloursteps_custom(
+#'   guide = guide_colsteps(
 #'     first_guide  = "axis_custom",
 #'     second_guide = "axis_custom"
 #'   )
 #' )
-guide_coloursteps_custom <- function(
+guide_colsteps <- function(
   title = waiver(),
   key = "bins",
   first_guide = "axis_custom",

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)