replace merge_element by S7

Author: teunbrand

NAMESPACE

@@ -87,10 +87,6 @@ S3method(limits,character)
 S3method(limits,factor)
 S3method(limits,numeric)
 S3method(makeContext,dotstackGrob)
-S3method(merge_element,default)
-S3method(merge_element,element)
-S3method(merge_element,element_blank)
-S3method(merge_element,margin)
 S3method(pattern_alpha,GridPattern)
 S3method(pattern_alpha,GridTilingPattern)
 S3method(pattern_alpha,default)

R/theme.R

@@ -797,69 +797,63 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE,
 #' # Adopt size but ignore colour
 #' merge_element(new, old)
 #'
-merge_element <- function(new, old) {
-  UseMethod("merge_element")
-}
+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 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) ||
+               is.logical(new)) {
+      # If new is NULL, or a string, numeric vector, unit, or logical, just return it
+      return(new)
+    }
 
-#' @rdname merge_element
-#' @export
-merge_element.default <- function(new, old) {
-  if (is.null(old) || inherits(old, "element_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) ||
-             is.logical(new)) {
-    # If new is NULL, or a string, numeric vector, unit, or logical, just return it
-    return(new)
+    # otherwise we can't merge
+    cli::cli_abort("No method for merging {.cls {class(new)[1]}} into {.cls {class(old)[1]}}.")
   }
 
-  # otherwise we can't merge
-  cli::cli_abort("No method for merging {.cls {class(new)[1]}} into {.cls {class(old)[1]}}.")
-}
-
-#' @rdname merge_element
-#' @export
-merge_element.element_blank <- function(new, old) {
-  # If new is element_blank, just return it
-  new
-}
-
-#' @rdname merge_element
-#' @export
-merge_element.element <- function(new, old) {
-  if (is.null(old) || inherits(old, "element_blank")) {
-    # If old is NULL or element_blank, then just return new
-    return(new)
+S7::method(merge_element, list(element_blank, S7::class_any)) <-
+  function(new, old, ...) {
+    # If new is element_blank, just return it
+    new
   }
 
-  # actual merging can only happen if classes match
-  if (!inherits(new, class(old)[1])) {
-    cli::cli_abort("Only elements of the same class can be merged.")
-  }
+S7::method(merge_element, list(element, S7::class_any)) <-
+  function(new, old, ...) {
+    if (is.null(old) || S7::S7_inherits(old, element_blank)) {
+      # If old is NULL or element_blank, then just return new
+      return(new)
+    }
 
-  # Override NULL properties of new with the values in old
-  # Get logical vector of NULL properties in new
-  idx <- vapply(new, is.null, logical(1))
-  # Get the names of TRUE items
-  idx <- names(idx[idx])
+    # actual merging can only happen if classes match
+    if (!inherits(new, class(old)[1])) {
+      cli::cli_abort("Only elements of the same class can be merged.")
+    }
 
-  # Update non-NULL items
-  new[idx] <- old[idx]
+    # Override NULL properties of new with the values in old
+    # Get logical vector of NULL properties in new
+    idx <- lengths(S7::props(new)) == 0
+    # Get the names of TRUE items
+    idx <- names(idx[idx])
 
-  new
+    # Update non-NULL items
+    S7::props(new)[idx] <- S7::props(old, idx)
+
+    new
 }
 
-#' @rdname merge_element
-#' @export
-merge_element.margin <- function(new, old) {
-  if (is.null(old) || inherits(old, "element_blank")) {
-    return(new)
-  }
-  if (anyNA(new)) {
-    new[is.na(new)] <- old[is.na(new)]
+S7::method(merge_element, list(S7::new_S3_class("margin"), S7::class_any)) <-
+  function(new, old, ...) {
+    if (is.null(old) || S7::S7_inherits(old, element_blank)) {
+      return(new)
+    }
+    if (anyNA(new)) {
+      new[is.na(new)] <- old[is.na(new)]
+    }
+    new
   }
-  new
-}
 
 #' Combine the properties of two elements
 #'
@@ -871,7 +865,7 @@ merge_element.margin <- function(new, old) {
 combine_elements <- function(e1, e2) {
 
   # If e2 is NULL, nothing to inherit
-  if (is.null(e2) || inherits(e1, "element_blank")) {
+  if (is.null(e2) || S7::S7_inherits(e1, element_blank)) {
     return(e1)
   }
 
@@ -904,44 +898,44 @@ combine_elements <- function(e1, e2) {
   }
 
   # If neither of e1 or e2 are element_* objects, return e1
-  if (!inherits(e1, "element") && !inherits(e2, "element")) {
+  if (!S7::S7_inherits(e1, element) && !S7::S7_inherits(e2, element)) {
     return(e1)
   }
 
   # If e2 is element_blank, and e1 inherits blank inherit everything from e2,
   # otherwise ignore e2
-  if (inherits(e2, "element_blank")) {
-    if (e1$inherit.blank) {
+  if (S7::S7_inherits(e2, element_blank)) {
+    if (S7::prop_exists(e1, "inherit.blank") && e1@inherit.blank) {
       return(e2)
     } else {
       return(e1)
     }
   }
 
   # If e1 has any NULL properties, inherit them from e2
-  n <- names(e1)[vapply(e1, is.null, logical(1))]
-  e1[n] <- e2[n]
+  n <- S7::prop_names(e1)[lengths(S7::props(e1)) == 0]
+  S7::props(e1)[n] <- S7::props(e2)[n]
 
   # Calculate relative sizes
-  if (is.rel(e1$size)) {
-    e1$size <- e2$size * unclass(e1$size)
+  if (S7::prop_exists(e1, "size") && is.rel(e1@size)) {
+    e1@size <- e2@size * unclass(e1@size)
   }
 
   # Calculate relative linewidth
-  if (is.rel(e1$linewidth)) {
-    e1$linewidth <- e2$linewidth * unclass(e1$linewidth)
+  if (S7::prop_exists(e1, "linewidth") && is.rel(e1@linewidth)) {
+    e1@linewidth <- e2@linewidth * unclass(e1@linewidth)
   }
 
   if (inherits(e1, "element_text")) {
-    e1$margin <- combine_elements(e1$margin, e2$margin)
+    e1@margin <- combine_elements(e1@margin, e2@margin)
   }
 
   # If e2 is 'richer' than e1, fill e2 with e1 parameters
   is_subclass <- !any(inherits(e2, class(e1), which = TRUE) == 0)
   is_subclass <- is_subclass && length(setdiff(class(e2), class(e1)) > 0)
   if (is_subclass) {
-    new <- defaults(e1, e2)
-    e2[names(new)] <- new
+    new <- defaults(S7::props(e1), S7::props(e2))
+    S7::props(e2)[names(new)] <- new
     return(e2)
   }