diff --git a/DESCRIPTION b/DESCRIPTION index 65b2410..4dfdf34 100644 --- a/DESCRIPTION +++ b/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' diff --git a/R/ggp2-margins.R b/R/ggp2-margins.R index 89e74e0..884b9f8 100644 --- a/R/ggp2-margins.R +++ b/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. diff --git a/tests/testthat/Rplots.pdf b/tests/testthat/Rplots.pdf index 4b24c9d..30343a5 100644 Binary files a/tests/testthat/Rplots.pdf and b/tests/testthat/Rplots.pdf differ diff --git a/tests/testthat/test-draw-key-label-s.R b/tests/testthat/test-draw-key-label-s.R new file mode 100644 index 0000000..20d5962 --- /dev/null +++ b/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")) + + + +}) + diff --git a/tests/testthat/test-draw-key-text-s.R b/tests/testthat/test-draw-key-text-s.R new file mode 100644 index 0000000..1c2e11c --- /dev/null +++ b/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")) + +}) + diff --git a/tests/testthat/testthat-problems.rds b/tests/testthat/testthat-problems.rds deleted file mode 100644 index da45d1f..0000000 Binary files a/tests/testthat/testthat-problems.rds and /dev/null differ