WIP: Cleanup legend code

R/guide-.R

@@ -25,13 +25,8 @@ new_guide <- function(..., available_aes = "any", super) {
   params <- intersect(names(args), param_names)
   params <- defaults(args[params], super$params)
 
-  # Set elements
-  elems_names <- names(super$elements)
-  elems  <- intersect(names(args), elems_names)
-  elems  <- defaults(args[elems], super$elements)
-
   # Warn about extra arguments
-  extra_args <- setdiff(names(args), union(param_names, elems_names))
+  extra_args <- setdiff(names(args), param_names)
   if (length(extra_args) > 0) {
     cli::cli_warn(paste0(
       "Ignoring unknown {cli::qty(extra_args)} argument{?s} to ",
@@ -56,8 +51,7 @@ new_guide <- function(..., available_aes = "any", super) {
 
   ggproto(
     NULL, super,
-    params   = params,
-    elements = elems,
+    params = params,
     available_aes = available_aes
   )
 }
@@ -128,6 +122,11 @@ new_guide <- function(..., available_aes = "any", super) {
 #'   It can be used to overrule user-supplied parameters or perform checks on
 #'   the `params` property.
 #'
+#' - `setup_elements()` Used to extract elements from the theme. The base
+#'   `Guide` uses this method to merge a potential `internal_theme` with the
+#'   global theme and to calculate the elements declared in `Guide$elements`.
+#'   For other guides, this is a good place to intervene in theme inheritance.
+#'
 #' - `override_elements()` Take populated theme elements derived from the
 #'   `elements` property and allows overriding these theme settings.
 #'
@@ -274,6 +273,7 @@ Guide <- ggproto(
   # Converts the `elements` field to proper elements to be accepted by
   # `element_grob()`. String-interpolates aesthetic/position dependent elements.
   setup_elements = function(params, elements, theme) {
+    theme <- merge_internal_theme(theme, params$internal_theme)
     is_char  <- vapply(elements, is.character, logical(1))
     elements[is_char] <- lapply(elements[is_char], calc_element, theme = theme)
     elements
@@ -457,3 +457,53 @@ validate_labels <- function(labels) {
     unlist(labels)
   }
 }
+
+# This logic is similar to `add_theme()` with the following exceptions:
+#
+# 1. Elements in `new` that have `inherit.blank = TRUE` and are blank in `old`
+#    will remain blank.
+# 2. `NULL` elements in `new` are ignored.
+# 3. When an `old` element is a subclass of the `new` element, that subclass
+#    is preserved.
+merge_internal_theme <- function(old, new, new_name = caller_arg(new)) {
+  if (length(new) == 0) {
+    return(old)
+  }
+  # Get non empty names of new theme
+  nms <- names(new)[!vapply(new, is.null, logical(1))]
+
+  # Does any of the new theme elements carry over blank elements?
+  inherit_blank <- vapply(
+    new[nms], FUN.VALUE = logical(1),
+    function(x) is.list(x) && isTRUE(x$inherit.blank)
+  )
+  # Are their equivalents in the old theme blank?
+  is_blank <- vapply(old[nms], inherits, logical(1), what = "element_blank")
+
+  # Only merge in elements that shouldn't become blank
+  keep <- nms[!(inherit_blank & is_blank)]
+
+  try_fetch(
+    for (item in keep) {
+      x <- merge_subclass(new[[item]], old[[item]])
+      old[item] <- list(x)
+    },
+    error = function(cnd) {
+      cli::cli_abort(
+        "Problem merging the {.var {item}} theme element.",
+        parent = cnd
+      )
+    }
+  )
+  old
+}
+
+merge_subclass <- function(new, old) {
+  if (!is.subclass(old, new)) {
+    return(merge_element(new, old))
+  }
+  idx <- !vapply(new, is.null, logical(1))
+  idx <- names(new)[idx]
+  old[idx] <- new[idx]
+  old
+}

R/guide-bins.R

@@ -108,16 +108,6 @@ guide_bins <- function(
   show.limits  = NULL,
   ...
 ) {
-
-  if (!(is.null(keywidth) || is.unit(keywidth))) {
-    keywidth <- unit(keywidth, default.unit)
-  }
-  if (!(is.null(keyheight) || is.unit(keyheight))) {
-    keyheight <- unit(keyheight, default.unit)
-  }
-  if (!is.unit(ticks.length)) {
-    ticks.length <- unit(ticks.length, default.unit)
-  }
   if (!is.null(title.position)) {
     title.position <- arg_match0(title.position, .trbl)
   }
@@ -127,13 +117,12 @@ guide_bins <- function(
   if (!is.null(label.position)) {
     label.position <- arg_match0(label.position, .trbl)
   }
-
   if (is.logical(axis)) {
-    axis <- if (axis) element_line() else element_rect()
+    axis <- if (!isFALSE(axis)) element_line() else element_blank()
   }
   if (inherits(axis, "element_line")) {
-    axis$colour    <- axis.colour    %||% axis$colour      %||% "black"
-    axis$linewidth <- axis.linewidth %||% axis$linewidth   %||% (0.5 / .pt)
+    axis$colour    <- axis.colour    %||% axis$colour    %||% "black"
+    axis$linewidth <- axis.linewidth %||% axis$linewidth %||% (0.5 / .pt)
     axis$arrow     <- axis.arrow     %||% axis$arrow
   } else {
     axis <- element_blank()
@@ -144,29 +133,34 @@ guide_bins <- function(
     ticks$arrow <- NULL
   }
 
+  label.theme <- if (!isFALSE(label)) label.theme else element_blank()
+  label.theme <- combine_elements(
+    label.theme,
+    element_text(hjust = label.hjust, vjust = label.vjust, inherit.blank = TRUE)
+  )
+  title.theme <- combine_elements(
+    title.theme,
+    element_text(hjust = title.hjust, vjust = title.vjust, inherit.blank = TRUE)
+  )
+
+  internal_theme <- theme(
+    legend.text       = label.theme,
+    legend.title      = title.theme,
+    legend.key.width  = set_default_unit(keywidth,  default.unit),
+    legend.key.height = set_default_unit(keyheight, default.unit),
+    axis_line         = axis,
+    ticks             = ticks,
+    ticks_length      = set_default_unit(ticks.length, default.unit)
+  )
+
   new_guide(
     # title
     title = title,
     title.position = title.position,
-    title.theme = title.theme,
-    title.hjust = title.hjust,
-    title.vjust = title.vjust,
-
-    # label
-    label = label,
     label.position = label.position,
-    label.theme = label.theme,
-    label.hjust = label.hjust,
-    label.vjust = label.vjust,
 
-    # key
-    keywidth  = keywidth,
-    keyheight = keyheight,
-
-    # ticks
-    line  = axis,
-    ticks = ticks,
-    ticks_length = ticks.length,
+    # theme
+    internal_theme = internal_theme,
 
     # general
     direction = direction,
@@ -193,20 +187,10 @@ GuideBins <- ggproto(
   params = list(
     title = waiver(),
     title.position = NULL,
-    title.theme = NULL,
-    title.hjust = NULL,
-    title.vjust = NULL,
-
-    label = TRUE,
     label.position = NULL,
-    label.theme = NULL,
-    label.hjust = NULL,
-    label.vjust = NULL,
-
-    keywidth  = NULL,
-    keyheight = NULL,
+    internal_theme = NULL,
 
-    direction = NULL,
+    # direction = NULL,
     override.aes = list(),
     reverse = FALSE,
     order = 0,
@@ -221,8 +205,8 @@ GuideBins <- ggproto(
   elements = c(
     GuideLegend$elements,
     list(
-      line  = "line",
-      ticks = "line",
+      axis_line = "line",
+      ticks     = "line",
       ticks_length = unit(0.2, "npc")
     )
   ),
@@ -329,8 +313,9 @@ GuideBins <- ggproto(
   },
 
   override_elements = function(params, elements, theme) {
-    elements$ticks <- combine_elements(elements$ticks, theme$line)
-    elements$line  <- combine_elements(elements$line,  theme$line)
+    itheme <- params$internal_theme
+    elements$ticks <- combine_elements(itheme$ticks, elements$ticks)
+    elements$line  <- combine_elements(itheme$axis_line, elements$axis_line)
     GuideLegend$override_elements(params, elements, theme)
   },
 

R/guide-colorbar.R

@@ -158,16 +158,6 @@ guide_colourbar <- function(
   available_aes = c("colour", "color", "fill"),
   ...
 ) {
-  if (!(is.null(barwidth) || is.unit(barwidth))) {
-    barwidth <- unit(barwidth, default.unit)
-  }
-  if (!(is.null(barheight) || is.unit(barheight))) {
-    barheight <- unit(barheight, default.unit)
-  }
-  if (!is.unit(ticks.length)) {
-    ticks.length <- unit(ticks.length, default.unit)
-  }
-
   if (!is.null(title.position)) {
     title.position <- arg_match0(title.position, .trbl)
   }
@@ -205,6 +195,26 @@ guide_colourbar <- function(
     ticks$linewidth <- ticks.linewidth %||% ticks$linewidth %||% (0.5 / .pt)
   }
 
+  label.theme <- if (!isFALSE(label)) label.theme else element_blank()
+  label.theme <- combine_elements(
+    label.theme,
+    element_text(hjust = label.hjust, vjust = label.vjust)
+  )
+  title.theme <- combine_elements(
+    title.theme,
+    element_text(hjust = title.hjust, vjust = title.vjust)
+  )
+
+  internal_theme <- theme(
+    legend.text       = label.theme,
+    legend.title      = title.theme,
+    legend.key.width  = set_default_unit(barwidth,  default.unit),
+    legend.key.height = set_default_unit(barheight, default.unit),
+    frame             = frame,
+    ticks             = ticks,
+    ticks.length      = set_default_unit(ticks.length, default.unit)
+  )
+
   # Trick to re-use this constructor in `guide_coloursteps()`.
   args  <- list2(...)
   super <- args$super %||% GuideColourbar
@@ -214,29 +224,14 @@ guide_colourbar <- function(
     # title
     title = title,
     title.position = title.position,
-    title.theme = title.theme,
-    title.hjust = title.hjust,
-    title.vjust = title.vjust,
-
-    # label
-    label = label,
     label.position = label.position,
-    label.theme = label.theme,
-    label.hjust = label.hjust,
-    label.vjust = label.vjust,
+
+    # theme
+    internal_theme = internal_theme,
 
     # bar
-    keywidth = barwidth,
-    keyheight = barheight,
     nbin = nbin,
     raster = raster,
-
-    # frame
-    frame = frame,
-
-    # ticks
-    ticks = ticks,
-    ticks_length = ticks.length,
     draw_lim = c(isTRUE(draw.llim), isTRUE(draw.ulim)),
 
     # general
@@ -267,20 +262,10 @@ GuideColourbar <- ggproto(
     # title
     title = waiver(),
     title.position = NULL,
-    title.theme = NULL,
-    title.hjust = NULL,
-    title.vjust = NULL,
-
-    # label
-    label = TRUE,
     label.position = NULL,
-    label.theme = NULL,
-    label.hjust = NULL,
-    label.vjust = NULL,
 
     # bar
-    keywidth  = NULL,
-    keyheight = NULL,
+    internal_theme = NULL,
     nbin = 300,
     raster = TRUE,
 
@@ -311,7 +296,7 @@ GuideColourbar <- ggproto(
     key.height  = "legend.key.height",
     key.width   = "legend.key.width",
     text        = "legend.text",
-    theme.title = "legend.title"
+    title       = "legend.title"
   ),
 
   extract_key = function(scale, aesthetic, ...) {
@@ -392,15 +377,20 @@ GuideColourbar <- ggproto(
     params
   },
 
-  override_elements = function(params, elements, theme) {
-    # These key sizes are the defaults, the GuideLegend method may overrule this
+  setup_elements = function(params, elements, theme) {
+    # Key sizes are already calculated before `Guides$draw()`
     if (params$direction == "horizontal") {
-      elements$key.width <- elements$key.width * 5
+      theme$legend.key.width  <- theme$legend.key.width * 5
     } else {
-      elements$key.height <- elements$key.height * 5
+      theme$legend.key.height <- theme$legend.key.height * 5
     }
-    elements$ticks <- combine_elements(elements$ticks, theme$line)
-    elements$frame <- combine_elements(elements$frame, theme$rect)
+    GuideLegend$setup_elements(params, elements, theme)
+  },
+
+  override_elements = function(params, elements, theme) {
+    itheme <- params$internal_theme
+    elements$ticks <- combine_elements(itheme$ticks, elements$ticks)
+    elements$frame <- combine_elements(itheme$frame, elements$frame)
     GuideLegend$override_elements(params, elements, theme)
   },