allow numeric colour

Author: teunbrand

R/properties.R

@@ -58,7 +58,7 @@ property_fontface <- function(allow_null = TRUE, default = NULL) {
   S7::new_property(
     class = class,
     validator = validator,
-    default = NULL
+    default = default
   )
 }
 
@@ -68,3 +68,34 @@ property_nullable <- function(class = S7::class_any, ...) {
     ...
   )
 }
+
+property_colour <- function(
+  allow_null = TRUE,
+  pattern = FALSE,
+  default = NULL
+) {
+  # TODO: remove numeric option for editioning
+  class <- S7::new_union(
+    S7::class_character, # Hex codes and colour names, e.g. #FF000 or "red"
+    S7::class_logical,   # For allowing NA, which means 'transparent'
+    S7::class_numeric    # For `grDevices::palette()` indexing
+  )
+  if (isTRUE(pattern)) {
+    class <- S7::new_union(class, S7::new_S3_class("GridPattern"))
+  }
+  if (isTRUE(allow_null)) {
+    class <- S7::new_union(class, NULL)
+  }
+  validator <- function(value) {
+    if (is.numeric(value) && !is_integerish(value)) {
+      return("cannot be a decimal number, but could be an integer.")
+    }
+    character()
+  }
+  S7::new_property(
+    class = class,
+    validator = validator,
+    default = default
+  )
+}
+

R/theme-elements.R

@@ -103,8 +103,8 @@ element_blank <- S7::new_class(
 #' @include properties.R
 #' @include margins.R
 element_props <- list(
-  fill       = property_nullable(S7::class_character | S7::new_S3_class("GridPattern") | S7::class_logical),
-  colour     = property_nullable(S7::class_character | S7::class_logical),
+  fill       = property_colour(pattern = TRUE),
+  colour     = property_colour(pattern = FALSE),
   family     = property_nullable(S7::class_character),
   hjust      = property_nullable(S7::class_numeric),
   vjust      = property_nullable(S7::class_numeric),
@@ -119,7 +119,7 @@ element_props <- list(
   linejoin   = property_choice(c("round", "mitre", "bevel"), allow_null = TRUE),
   shape      = property_nullable(S7::class_numeric | S7::class_character),
   arrow      = property_nullable(S7::new_S3_class("arrow") | S7::class_logical),
-  arrow.fill = property_nullable(S7::class_character | S7::class_logical),
+  arrow.fill = property_colour(pattern = FALSE),
   debug      = property_boolean(allow_null = TRUE, default = NULL),
   inherit.blank = property_boolean(default = FALSE),
   # These are reserved for future use

tests/testthat/_snaps/theme.md

@@ -106,6 +106,15 @@
       Error in `as_margin()`:
       ! `margin` must be a <margin> class, not a number.
 
+---
+
+    Code
+      element_text(colour = sqrt(2))
+    Condition
+      Error:
+      ! <ggplot2::element_text> object properties are invalid:
+      - @colour cannot be a decimal number, but could be an integer.
+
 # Theme validation behaves as expected
 
     The `aspect.ratio` theme element must be a <numeric/integer> object.

tests/testthat/test-theme.R

@@ -561,6 +561,10 @@ test_that("element_text throws appropriate conditions", {
     element_text(margin = 5),
     error = TRUE
   )
+  expect_snapshot(
+    element_text(colour = sqrt(2)),
+    error = TRUE
+  )
 })
 
 test_that("Theme validation behaves as expected", {