S7-aware is_theme_element()

Author: teunbrand

R/coord-sf.R

@@ -334,7 +334,7 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
 
     # we don't draw the graticules if the major panel grid is
     # turned off
-    if (S7::S7_inherits(el, element_blank)) {
+    if (is_theme_element(el, "blank")) {
       grobs <- list(element_render(theme, "panel.background"))
     } else {
       line_gp <- gg_par(

R/guide-axis-theta.R

@@ -184,7 +184,7 @@ GuideAxisTheta <- ggproto(
 
   build_labels = function(key, elements, params) {
 
-    if (S7::S7_inherits(elements$text, element_blank)) {
+    if (is_theme_element(elements$text, "blank")) {
       return(zeroGrob())
     }
 
@@ -268,7 +268,7 @@ GuideAxisTheta <- ggproto(
     key <- params$key
     key <- vec_slice(key, !is.na(key$.label) & nzchar(key$.label))
     labels <- validate_labels(key$.label)
-    if (length(labels) == 0 || S7::S7_inherits(elements$text, element_blank)) {
+    if (length(labels) == 0 || is_theme_element(elements$text, "blank")) {
       return(list(offset = offset))
     }
 
@@ -365,7 +365,7 @@ GuideAxisTheta <- ggproto(
 
 theta_tickmarks <- function(key, element, length, offset = NULL) {
   n_breaks <- nrow(key)
-  if (n_breaks < 1 || S7::S7_inherits(element, element_blank)) {
+  if (n_breaks < 1 || is_theme_element(element, "blank")) {
     return(zeroGrob())
   }
 

R/guide-axis.R

@@ -259,10 +259,10 @@ GuideAxis <- ggproto(
   override_elements = function(params, elements, theme) {
     elements$text <-
       label_angle_heuristic(elements$text, params$position, params$angle)
-    if (S7::S7_inherits(elements$ticks, element_blank)) {
+    if (is_theme_element(elements$ticks, "blank")) {
       elements$major_length <- unit(0, "cm")
     }
-    if (S7::S7_inherits(elements$minor, element_blank) || isFALSE(params$minor.ticks)) {
+    if (is_theme_element(elements$minor, "blank") || isFALSE(params$minor.ticks)) {
       elements$minor_length <- unit(0, "cm")
     }
     return(elements)
@@ -379,7 +379,7 @@ GuideAxis <- ggproto(
     # Ticks
     major_cm <- convertUnit(elements$major_length, "cm", valueOnly = TRUE)
     range <- range(0, major_cm)
-    if (params$minor.ticks && !S7::S7_inherits(elements$minor, element_blank)) {
+    if (params$minor.ticks && !is_theme_element(elements$minor, "blank")) {
       minor_cm <- convertUnit(elements$minor_length, "cm", valueOnly = TRUE)
       range <- range(range, minor_cm)
     }
@@ -590,7 +590,7 @@ axis_label_priority_between <- function(x, y) {
 #'   overridden from the user- or theme-supplied element.
 #' @noRd
 label_angle_heuristic <- function(element, position, angle) {
-  if (!S7::S7_inherits(element, element_text)
+  if (!is_theme_element(element, "text")
       || is.null(position)
       || is.null(angle %|W|% NULL)) {
     return(element)

R/plot-build.R

@@ -348,7 +348,7 @@ table_add_tag <- function(table, label, theme) {
     return(table)
   }
   element <- calc_element("plot.tag", theme)
-  if (S7::S7_inherits(element, element_blank)) {
+  if (is_theme_element(element, "blank")) {
     return(table)
   }
 

R/theme-elements.R

@@ -207,25 +207,6 @@ element_text <- S7::new_class(
   }
 )
 
-#' @export
-#' @param type For testing elements: the type of element to expect. One of
-#'   `"blank"`, `"rect"`, `"line"` or `"text"`.
-#' @rdname is_tests
-is_theme_element <- function(x, type = "any") {
-  switch(
-    type %||% "any",
-    any   = inherits(x, "element"),
-    rect  = inherits(x, "element_rect"),
-    line  = inherits(x, "element_line"),
-    text  = inherits(x, "element_text"),
-    blank = inherits(x, "element_blank"),
-    # TODO: ideally we accept more elements from extensions. We need to
-    # consider how this will work with S7 classes, where ggplot2 doesn't know
-    # about the extension's class objects.
-    FALSE
-  )
-}
-
 #' @export
 #' @rdname element
 element_polygon <- S7::new_class(
@@ -322,6 +303,25 @@ element_geom <- S7::new_class(
 #' @export
 print.element <- function(x, ...) utils::str(x)
 
+#' @export
+#' @param type For testing elements: the type of element to expect. One of
+#'   `"blank"`, `"rect"`, `"line"`, `"text"`, `"polygon"`, `"point"` or `"geom"`.
+#' @rdname is_tests
+is_theme_element <- function(x, type = "any") {
+  switch(
+    type %||% "any",
+    any     = S7::S7_inherits(x, element),
+    blank   = S7::S7_inherits(x, element_blank),
+    rect    = S7::S7_inherits(x, element_rect),
+    line    = S7::S7_inherits(x, element_line),
+    text    = S7::S7_inherits(x, element_text),
+    polygon = S7::S7_inherits(x, element_polygon),
+    point   = S7::S7_inherits(x, element_point),
+    geom    = S7::S7_inherits(x, element_geom),
+    FALSE
+  )
+}
+
 #' @param x A single number specifying size relative to parent element.
 #' @rdname element
 #' @export
@@ -890,16 +890,15 @@ check_element <- function(el, elname, element_tree, call = caller_env()) {
   if (is.null(el)) return()
   class <- eldef$class
   if (inherits(class, "S7_class") && S7::S7_inherits(el)) {
-    if (S7::S7_inherits(el, class) ||
-        (S7::S7_inherits(el, element) && S7::S7_inherits(el, element_blank))) {
+    if (S7::S7_inherits(el, class) || is_theme_element(el, "blank")) {
       return()
     }
   }
 
   if (is.character(class) && "margin" %in% class) {
     if (!is.unit(el) && length(el) == 4)
       cli::cli_abort("The {.var {elname}} theme element must be a {.cls unit} vector of length 4.", call = call)
-  } else if (!inherits(el, class) && !S7::S7_inherits(el, element_blank)) {
+  } else if (!inherits(el, class) && !is_theme_element(el, "blank")) {
     if (inherits(class, "S7_class")) {
       class <- class@name
     }

R/theme.R

@@ -751,7 +751,7 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE,
 
   # If result is element_blank, we skip it if `skip_blank` is `TRUE`,
   # and otherwise we don't inherit anything from parents
-  if (S7::S7_inherits(el_out, element_blank)) {
+  if (is_theme_element(el_out, "blank")) {
     if (isTRUE(skip_blank)) {
       el_out <- NULL
     } else {
@@ -786,7 +786,7 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE,
     if (verbose) cli::cli_inform("nothing (top level)")
 
     # Check that all the properties of this element are non-NULL
-    if (inherits(el_out, "ggplot2::element")) {
+    if (is_theme_element(el_out)) {
       nullprops <- lengths(S7::props(el_out)) == 0
     } else {
       nullprops <- vapply(el_out, is.null, logical(1))
@@ -797,12 +797,12 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE,
 
     # if we have null properties, try to fill in from ggplot_global$theme_default
     el_out <- combine_elements(el_out, ggplot_global$theme_default[[element]])
-    if (is.theme_element(el_out)) {
+    if (is_theme_element(el_out)) {
       nullprops <- lengths(S7::props(el_out)) == 0
     } else {
       nullprops <- vapply(el_out, is.null, logical(1))
     }
-    if (S7::S7_inherits(el_out, element_geom)) {
+    if (is_theme_element(el_out, "geom")) {
       # Geom elements are expected to have NULL fill/colour, so allow these
       # to be missing
       nullprops[c("colour", "fill")] <- FALSE
@@ -861,7 +861,7 @@ merge_element <- S7::new_generic("merge_element", c("new", "old"))
 
 S7::method(merge_element, list(S7::class_any, S7::class_any))  <-
   function(new, old, ...) {
-    if (is.null(old) || S7::S7_inherits(old, element_blank)) {
+    if (is.null(old) || is_theme_element(old, "blank")) {
       # If old is NULL or element_blank, then just return new
       return(new)
     } else if (is.null(new) || is.character(new) || is.numeric(new) || is.unit(new) ||
@@ -882,7 +882,7 @@ S7::method(merge_element, list(element_blank, S7::class_any)) <-
 
 S7::method(merge_element, list(element, S7::class_any)) <-
   function(new, old, ...) {
-    if (is.null(old) || S7::S7_inherits(old, element_blank)) {
+    if (is.null(old) || is_theme_element(old, "blank")) {
       # If old is NULL or element_blank, then just return new
       return(new)
     }
@@ -906,7 +906,7 @@ S7::method(merge_element, list(element, S7::class_any)) <-
 
 S7::method(merge_element, list(margin, S7::class_any)) <-
   function(new, old, ...) {
-    if (is.null(old) || S7::S7_inherits(old, element_blank)) {
+    if (is.null(old) || is_theme_element(old, "blank")) {
       return(new)
     }
     if (anyNA(new)) {
@@ -925,7 +925,7 @@ S7::method(merge_element, list(margin, S7::class_any)) <-
 combine_elements <- function(e1, e2) {
 
   # If e2 is NULL, nothing to inherit
-  if (is.null(e2) || S7::S7_inherits(e1, element_blank)) {
+  if (is.null(e2) || is_theme_element(e1, "blank")) {
     return(e1)
   }
 
@@ -948,7 +948,7 @@ combine_elements <- function(e1, e2) {
     return(e1)
   }
 
-  if (is.margin(e1) && is.margin(e2)) {
+  if (is_margin(e1) && is_margin(e2)) {
     if (anyNA(e2)) {
       e2[is.na(e2)] <- unit(0, "pt")
     }
@@ -986,7 +986,7 @@ combine_elements <- function(e1, e2) {
     e1@linewidth <- e2@linewidth * unclass(e1@linewidth)
   }
 
-  if (S7::S7_inherits(e1, element_text)) {
+  if (is_theme_element(e1, "text")) {
     e1@margin <- combine_elements(e1@margin, e2@margin)
   }
 

man/is_tests.Rd

@@ -345,7 +345,7 @@ test_that("element tree can be modified", {
 test_that("all elements in complete themes have inherit.blank=TRUE", {
   inherit_blanks <- function(theme) {
     all(vapply(theme, function(el) {
-      if (is_theme_element(el) && !is_theme_element(el, "blank")) {
+      if (is_theme_element(el) && S7::prop_exists(el, "inherit.blank")) {
         el@inherit.blank
       } else {
         TRUE