Unit tests for draw_key functions

Also track one change in äggplot2' 3.5.1

DESCRIPTION

@@ -32,6 +32,7 @@ Imports:
     grid,
     grDevices,
     rlang (>= 1.0.6),
+    vctrs (>= 0.6.0),
     magrittr (>= 2.0.1),
     glue (>= 1.6.0),
     gridExtra (>= 2.3),
@@ -100,3 +101,4 @@ Collate:
     'stat-quadrant-counts.R'
     'try-data-frame.R'
     'weather-data.R'
+    'wrap-labels.R'

R/ggp2-margins.R

@@ -216,6 +216,7 @@ justify_grobs <- function(grobs, x = NULL, y = NULL, hjust = 0.5, vjust = 0.5,
 }
 
 #' Rotate justification parameters counter-clockwise
+#' from 'ggplot2' 3.5.1
 #'
 #' @param angle angle of rotation, in degrees
 #' @param hjust horizontal justification
@@ -240,22 +241,44 @@ rotate_just <- function(angle, hjust, vjust) {
   #vnew <- sin(rad) * hjust + cos(rad) * vjust + (1 - cos(rad) - sin(rad)) / 2
 
   angle <- (angle %||% 0) %% 360
-  if (0 <= angle & angle < 90) {
-    hnew <- hjust
-    vnew <- vjust
-  } else if (90 <= angle & angle < 180) {
-    hnew <- 1 - vjust
-    vnew <- hjust
-  } else if (180 <= angle & angle < 270) {
-    hnew <- 1 - hjust
-    vnew <- 1 - vjust
-  } else if (270 <= angle & angle < 360) {
-    hnew <- vjust
-    vnew <- 1 - hjust
+
+  if (is.character(hjust)) {
+    hjust <- match(hjust, c("left", "right")) - 1
+    hjust[is.na(hjust)] <- 0.5
+  }
+  if (is.character(vjust)) {
+    vjust <- match(vjust, c("bottom", "top")) - 1
+    vjust[is.na(vjust)] <- 0.5
   }
 
+  # Apply recycle rules
+  size  <- vctrs::vec_size_common(angle, hjust, vjust)
+  angle <- vctrs::vec_recycle(angle, size)
+  hjust <- vctrs::vec_recycle(hjust, size)
+  vjust <- vctrs::vec_recycle(vjust, size)
+
+  # Find quadrant on circle
+  case <- findInterval(angle, c(0, 90, 180, 270, 360))
+
+  hnew <- hjust
+  vnew <- vjust
+
+  is_case <- which(case == 2) # 90 <= x < 180
+  hnew[is_case] <- 1 - vjust[is_case]
+  vnew[is_case] <- hjust[is_case]
+
+  is_case <- which(case == 3) # 180 <= x < 270
+  hnew[is_case] <- 1 - hjust[is_case]
+  vnew[is_case] <- 1 - vjust[is_case]
+
+  is_case <- which(case == 4) # 270 <= x < 360
+  hnew[is_case] <- vjust[is_case]
+  vnew[is_case] <- 1 - hjust[is_case]
+
   list(hjust = hnew, vjust = vnew)
 }
+
+
 descent_cache <- new.env(parent = emptyenv())
 # Important: This function is not vectorized. Do not use to look up multiple
 # font descents at once.

tests/testthat/test-draw-key-label-s.R

@@ -0,0 +1,99 @@
+context("draw_key_label_s")
+
+test_that("Returns expected value", {
+
+  test.data <- data.frame(x = 1,
+                          y = 5,
+                          label = "a",
+                          angle = 0,
+                          colour = "red",
+                          fill = "white",
+                          alpha = 0.5,
+                          vjust = 0.5,
+                          hjust = 0.5)
+
+  test.params.01 <- list(colour.target = "all",
+                      alpha.target = "all",
+                      default.colour = "black",
+                      default.alpha = 1
+                      )
+
+  set.seed(1)
+  obj.01 <- draw_key_label_s(data = test.data,
+                             params = test.params.01,
+                             size = 4)
+  # expect_known_value(unname(obj.01),
+  #                    "draw-key-label-s-01")
+  expect_is(obj.01, "gTree")
+  expect_length(obj.01, 5)
+  expect_named(obj.01, c("name", "gp", "vp", "children", "childrenOrder"))
+
+
+  test.params.02 <- list(colour.target = "text",
+                      alpha.target = "none",
+                      default.colour = "grey30",
+                      default.alpha = 1
+  )
+
+  set.seed(1)
+  obj.02 <- draw_key_label_s(data = test.data,
+                             params = test.params.02,
+                             size = 4)
+  # expect_known_value(unname(obj.02),
+  #                    "draw-key-label-s-02")
+  expect_is(obj.02, "gTree")
+  expect_length(obj.02, 5)
+  expect_named(obj.02, c("name", "gp", "vp", "children", "childrenOrder"))
+
+  test.params.03 <- list(colour.target = "text",
+                         alpha.target = "none",
+                         default.colour = "grey30",
+                         default.alpha = 0
+  )
+
+  set.seed(1)
+  obj.03 <- draw_key_label_s(data = test.data,
+                             params = test.params.03,
+                             size = 4)
+  # expect_known_value(unname(obj.03),
+  #                    "draw-key-label-s-03")
+  expect_is(obj.03, "gTree")
+  expect_length(obj.03, 5)
+  expect_named(obj.03, c("name", "gp", "vp", "children", "childrenOrder"))
+
+  test.params.04 <- list(colour.target = "box",
+                         alpha.target = "none",
+                         default.colour = "grey30",
+                         default.alpha = 0
+  )
+
+  set.seed(1)
+  obj.04 <- draw_key_label_s(data = test.data,
+                             params = test.params.04,
+                             size = 4)
+  # expect_known_value(unname(obj.04),
+  #                    "draw-key-label-s-04")
+  expect_is(obj.04, "gTree")
+  expect_length(obj.04, 5)
+  expect_named(obj.04, c("name", "gp", "vp", "children", "childrenOrder"))
+
+  test.params.05 <- list(colour.target = c("segment", "text"),
+                         alpha.target = "none",
+                         default.colour = "grey30",
+                         default.alpha = 1
+  )
+
+  set.seed(1)
+  obj.05 <- draw_key_label_s(data = test.data,
+                             params = test.params.05,
+                             size = 4)
+  # expect_known_value(unname(obj.05),
+  #                    "draw-key-label-s-05")
+  expect_is(obj.05, "gTree")
+  expect_length(obj.05, 5)
+  expect_named(obj.05, c("name", "gp", "vp", "children", "childrenOrder"))
+
+
+
+})
+

tests/testthat/test-draw-key-text-s.R

@@ -0,0 +1,65 @@
+context("draw_key_text_s")
+
+test_that("Returns expected value", {
+
+  test.data <- data.frame(x = 1,
+                          y = 5,
+                          label = "a",
+                          angle = 0,
+                          colour = "red",
+                          alpha = 0.5,
+                          vjust = 0.5,
+                          hjust = 0.5)
+
+  test.params.01 <- list(colour.target = "all",
+                         alpha.target = "all",
+                         default.colour = "black",
+                         default.alpha = 1
+  )
+
+  # names of grob members seem to change randomly from run to run
+  # set.seed() and unname() do not seem to help!
+  set.seed(1)
+  obj.01 <- draw_key_text_s(data = test.data,
+                            params = test.params.01,
+                            size = 4)
+  # expect_known_value(unname(obj.01),
+  #                    "draw-key-text-s-01")
+  expect_is(obj.01, "titleGrob")
+  expect_length(obj.01, 7)
+  expect_named(obj.01, c("widths", "heights", "name", "gp", "vp", "children", "childrenOrder"))
+
+  test.params.02 <- list(colour.target = "text",
+                      alpha.target = "none",
+                      default.colour = "grey30",
+                      default.alpha = 1
+  )
+
+  set.seed(1)
+  obj.02 <- draw_key_text_s(data = test.data,
+                            params = test.params.02,
+                            size = 4)
+  # expect_known_value(unname(obj.02),
+  #                    "draw-key-text-s-02")
+  expect_is(obj.02, "titleGrob")
+  expect_length(obj.02, 7)
+  expect_named(obj.02, c("widths", "heights", "name", "gp", "vp", "children", "childrenOrder"))
+
+  test.params.03 <- list(colour.target = "text",
+                         alpha.target = "none",
+                         default.colour = "grey30",
+                         default.alpha = 0
+  )
+
+  set.seed(1)
+  obj.03 <- draw_key_text_s(data = test.data,
+                            params = test.params.03,
+                            size = 4)
+  # expect_known_value(unname(obj.03),
+  #                    "draw-key-text-s-03")
+  expect_is(obj.03, "titleGrob")
+  expect_length(obj.03, 7)
+  expect_named(obj.03, c("widths", "heights", "name", "gp", "vp", "children", "childrenOrder"))
+
+})
+