Merge pull request #25 from teunbrand/guide_compat

Guide compatability with ggplot2 >3.4.2

DESCRIPTION

@@ -18,7 +18,7 @@ BugReports: https://github.com/csdaw/ggprism/issues
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.1
+RoxygenNote: 7.3.1
 Depends: 
     R (>= 3.2)
 Imports: 

NAMESPACE

@@ -4,8 +4,12 @@ S3method(guide_gengrob,prism_bracket)
 S3method(guide_gengrob,prism_minor)
 S3method(guide_gengrob,prism_offset)
 S3method(guide_gengrob,prism_offset_minor)
+S3method(guide_geom,prism_axis)
+S3method(guide_merge,prism_axis)
+S3method(guide_train,prism_axis)
 S3method(guide_train,prism_minor)
 S3method(guide_train,prism_offset_minor)
+S3method(guide_transform,prism_axis)
 export(GeomBracket)
 export(GeomTicks)
 export(StatBracket)
@@ -27,6 +31,10 @@ export(scale_shape_prism)
 export(theme_prism)
 import(ggplot2)
 importFrom(digest,digest)
+importFrom(ggplot2,guide_geom)
+importFrom(ggplot2,guide_merge)
+importFrom(ggplot2,guide_train)
+importFrom(ggplot2,guide_transform)
 importFrom(glue,glue)
 importFrom(glue,glue_collapse)
 importFrom(glue,glue_data)

R/annotation_ticks.R

@@ -22,7 +22,7 @@
 #' of major ticks.
 #' @param minor.length a \code{\link[grid]{unit}} object specifying the length
 #' of minor ticks.
-#' @param size `numeric`. Linewidth of ticks.
+#' @param linewidth `numeric`. Linewidth of ticks.
 #' @param colour,color `string`. Colour of ticks.
 #' @param linetype `string` or `numeric`. Linetype of tick marks.
 #' @param lineend `string`. Lineend of ticks. One of `"square"`
@@ -43,7 +43,7 @@ annotation_ticks <- function(sides = "b",
                              outside = FALSE,
                              tick.length = unit(4.8, "pt"),
                              minor.length = unit(2.4, "pt"),
-                             size = 0.6,
+                             linewidth = 0.6,
                              colour = "black",
                              color = NULL,
                              linetype = 1,
@@ -89,7 +89,7 @@ annotation_ticks <- function(sides = "b",
       type = type,
       tick.length = tick.length,
       minor.length = minor.length,
-      size = size,
+      linewidth = linewidth,
       colour = colour,
       linetype = linetype,
       lineend = lineend,
@@ -148,7 +148,7 @@ GeomTicks <- ggproto("GeomTicks", Geom, extra_params = "",
                                  gp = gpar(
                                    col = alpha(colour, alpha),
                                    lty = linetype,
-                                   lwd = size * .pt,
+                                   lwd = linewidth * .pt,
                                    lineend = lineend
                                  )
                                )
@@ -165,7 +165,7 @@ GeomTicks <- ggproto("GeomTicks", Geom, extra_params = "",
                                  gp = gpar(
                                    col = alpha(colour, alpha),
                                    lty = linetype,
-                                   lwd = size * .pt,
+                                   lwd = linewidth * .pt,
                                    lineend = lineend
                                  )
                                )
@@ -202,7 +202,7 @@ GeomTicks <- ggproto("GeomTicks", Geom, extra_params = "",
                                  gp = gpar(
                                    col = alpha(colour, alpha),
                                    lty = linetype,
-                                   lwd = size * .pt,
+                                   lwd = linewidth * .pt,
                                    lineend = lineend
                                  )
                                )
@@ -219,7 +219,7 @@ GeomTicks <- ggproto("GeomTicks", Geom, extra_params = "",
                                  gp = gpar(
                                    col = alpha(colour, alpha),
                                    lty = linetype,
-                                   lwd = size * .pt,
+                                   lwd = linewidth * .pt,
                                    lineend = lineend
                                  )
                                )
@@ -229,6 +229,6 @@ GeomTicks <- ggproto("GeomTicks", Geom, extra_params = "",
                        }
                        gTree(children = do.call("gList", ticks))
                      },
-                     default_aes = aes(colour = "black", size = 0.6,
+                     default_aes = aes(colour = "black", linewidth = 0.6,
                                        linetype = 1, lineend = "butt", alpha = 1)
 )

R/guide_methods.R

@@ -0,0 +1,106 @@
+
+#' @export
+#' @importFrom ggplot2 guide_train
+guide_train.prism_axis <- function(guide, scale, aesthetic = NULL) {
+
+  aesthetic <- aesthetic %||% scale$aesthetics[1]
+  breaks <- scale$get_breaks()
+
+  empty_ticks <- base::data.frame(
+    aesthetic = numeric(0),
+    .value    = numeric(0),
+    .label    = character(0)
+  )
+  names(empty_ticks) <- c(aesthetic, ".value", ".label")
+
+  if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) {
+    warn(glue(
+      "axis guide needs appropriate scales: ",
+      glue_collapse(guide$available_aes, ", ", last = " or ")
+    ))
+    guide$key <- empty_ticks
+  } else if (length(breaks) == 0) {
+    guide$key <- empty_ticks
+  } else {
+    mapped_breaks <- if (scale$is_discrete()) scale$map(breaks) else breaks
+    ticks <- base::data.frame(setNames(list(mapped_breaks), aesthetic))
+    ticks$.value <- breaks
+    ticks$.label <- scale$get_labels(breaks)
+
+    guide$key <- ticks[is.finite(ticks[[aesthetic]]), ]
+  }
+
+  guide$name <- paste0(guide$name, "_", aesthetic)
+  guide$hash <- digest(list(guide$title, guide$key$.value,
+                            guide$key$.label, guide$name, guide$is_major))
+  guide
+}
+
+#' @export
+#' @importFrom ggplot2 guide_transform
+guide_transform.prism_axis <- function(guide, coord, panel_params) {
+
+  if (is.null(guide$position) || nrow(guide$key) == 0) {
+    return(guide)
+  }
+
+  aesthetics <- names(guide$key)[!grepl("^\\.", names(guide$key))]
+
+  if (all(c("x", "y") %in% aesthetics)) {
+    guide$key <- coord$transform(guide$key, panel_params)
+  } else {
+    other_aesthetic <- setdiff(c("x", "y"), aesthetics)
+    override_value  <- if(guide$position %in% c("bottom", "left")) -Inf else Inf
+    guide$key[[other_aesthetic]] <- override_value
+
+    guide$key <- coord$transform(guide$key, panel_params)
+
+    warn_for_guide_position(guide)
+  }
+  guide
+}
+
+warn_for_guide_position <- function(guide) {
+  # This is trying to catch when a user specifies a position perpendicular
+  # to the direction of the axis (e.g., a "y" axis on "top").
+  # The strategy is to check that two or more unique breaks are mapped
+  # to the same value along the axis.
+  breaks_are_unique <- !duplicated(guide$key$.value)
+  empty <- is.null(guide$key) || prod(dim(guide$key)) == 0 ||
+    inherits(guide$key, "waiver")
+  if (empty || sum(breaks_are_unique) == 1) {
+    return()
+  }
+
+  if (guide$position %in% c("top", "bottom")) {
+    position_aes <- "x"
+  } else if(guide$position %in% c("left", "right")) {
+    position_aes <- "y"
+  } else {
+    return()
+  }
+
+  if (length(unique(guide$key[[position_aes]][breaks_are_unique])) == 1) {
+    warn(c(
+      "Position guide is perpendicular to the intended axis",
+      "i" = "Did you mean to specify a different guide `position`?"
+    ))
+  }
+}
+
+#' @export
+#' @importFrom ggplot2 guide_geom
+guide_geom.prism_axis <- function(guide, layers, ...) {
+  guide
+}
+
+#' @export
+#' @importFrom ggplot2 guide_merge
+guide_merge.prism_axis <- function(guide, new_guide) {
+  if (!inherits(new_guide, c("guide_none", "GuideNone"))) {
+    warn(c(
+      "Discarding guide on merge",
+      "i" = "Do you have more than one guide with the same position?"
+    ))
+  }
+}

R/guide_prism_bracket.R

@@ -47,7 +47,7 @@ guide_prism_bracket <- function(title = waiver(), check.overlap = FALSE,
 
       name = "axis"
     ),
-    class = c("guide", "prism_bracket", "axis")
+    class = c("guide", "prism_bracket", "prism_axis", "axis")
   )
 }
 

R/guide_prism_minor.R

@@ -42,7 +42,7 @@ guide_prism_minor <- function(title = waiver(), check.overlap = FALSE,
 
       name = "axis"
     ),
-    class = c("guide", "prism_minor", "axis")
+    class = c("guide", "prism_minor", "prism_axis", "axis")
   )
 }
 

R/guide_prism_offset.R

@@ -38,7 +38,7 @@ guide_prism_offset <- function(title = waiver(), check.overlap = FALSE,
 
       name = "axis"
     ),
-    class = c("guide", "prism_offset", "axis")
+    class = c("guide", "prism_offset", "prism_axis", "axis")
   )
 }
 

R/guide_prism_offset_minor.R

@@ -45,7 +45,7 @@ guide_prism_offset_minor <- function(title = waiver(), check.overlap = FALSE,
 
       name = "axis"
     ),
-    class = c("guide", "prism_offset_minor", "axis")
+    class = c("guide", "prism_offset_minor", "prism_axis", "axis")
   )
 }
 

R/theme_prism.R

@@ -169,6 +169,12 @@ theme_prism <- function(palette = "black_and_white", base_size = 14,
     complete = TRUE
   )
 
+  parent <- ggprism::ggprism_data$themes[["all_null"]]
+  if (!"legend.text.align" %in% rlang::fn_fmls_names(theme)) {
+    t$legend.text.align  <- parent$legend.text.align <- NULL
+    t$legend.title.align <- parent$legend.title.align <- NULL
+  }
+
   # make sure all elements are set to NULL if not explicitly defined
-  ggprism::ggprism_data$themes[["all_null"]] %+replace% t
+  parent %+replace% t
 }

inst/examples/ex-annotation_ticks.R

@@ -31,7 +31,7 @@ ggplot(mtcars, aes(x = mpg, y = disp)) +
     outside = TRUE,
     tick.length = unit(10, "pt"),
     colour = "red",
-    size = 2,
+    linewidth = 2,
     linetype = "dashed",
     lineend = "round"
   ) +

inst/tinytest/test-guide_prism_bracket.R

@@ -21,8 +21,8 @@ grab_axis <- function(plot, side = "b") {
 g1 <- p + scale_x_discrete(guide = "axis")
 g2 <- p + scale_x_discrete(guide = "prism_bracket")
 
-expect_silent(ggplotGrob(g1))
-expect_silent(ggplotGrob(g2))
+expect_equal(dim(ggplotGrob(g1)), c(16, 13))
+expect_equal(dim(ggplotGrob(g2)), c(16, 13))
 
 control <- grab_axis(g1, side = "b")
 test <- grab_axis(g2, side = "b")
@@ -41,7 +41,11 @@ expect_silent(ggplotGrob(g2))
 control <- grab_axis(g1, side = "l")
 test <- grab_axis(g2, side = "l")
 
-expect_equal(length(test$grobs[[1]]$x), length(control$grobs[[1]]$x) * 2)
+if (!inherits(guide_none(), "Guide")) {
+  expect_equal(length(test$grobs[[1]]$x), length(control$grobs[[1]]$x) * 2)
+} else {
+  expect_equal(length(test$grobs[[1]]$x), length(control$grobs[[2]]$x) * 2)
+}
 
 # test that guide_prism_bracket works with y axis and continuous scale
 g1 <- p + scale_y_continuous(guide = "axis")
@@ -53,7 +57,7 @@ expect_silent(ggplotGrob(g2))
 control <- grab_axis(g1, side = "l")
 test <- grab_axis(g2, side = "l")
 
-p + scale_x_discrete(position = "right", guide = "prism_bracket")
+# p + scale_x_discrete(position = "right", guide = "prism_bracket")
 
 # test that bracket width can be adjusted or left missing
 g1 <- p + scale_x_discrete(guide = "prism_bracket")

inst/tinytest/test-guide_prism_minor.R

@@ -26,7 +26,11 @@ expect_silent(ggplotGrob(g2))
 control <- grab_axis(g1, side = "l")
 test <- grab_axis(g2, side = "l")
 
-expect_equal(length(test$grobs[[2]]$y), (length(control$grobs[[2]]$y) * 2) + 2)
+if (!inherits(guide_none(), "Guide")) {
+  expect_equal(length(test$grobs[[2]]$y), (length(control$grobs[[2]]$y) * 2) + 2)
+} else {
+  expect_equal(length(test$grobs[[2]]$y), (length(control$grobs[[1]]$y) * 2) + 2)
+}
 
 # test that guide_prism_minor works with coord flip
 g1 <- p + scale_y_continuous(guide = "axis") +

inst/tinytest/test-guide_prism_offset.R

@@ -26,7 +26,15 @@ expect_silent(ggplotGrob(g2))
 control <- grab_axis(g1, side = "l")
 test <- grab_axis(g2, side = "l")
 
-expect_equal(length(test$grobs[[2]]$y), length(control$grobs[[2]]$y))
+if (!inherits(guide_none(), "Guide")) {
+  expect_equal(length(test$grobs[[2]]$y), length(control$grobs[[2]]$y))
+} else {
+  expect_equal(
+    length(test$grobs[[2]]$y),
+    length(control$grobs[[1]]$y)
+  )
+}
+
 
 # test that guide_prism_offset defaults work with discrete scale
 g1 <- p + scale_x_discrete(guide = "axis")

inst/tinytest/test-guide_prism_offset_minor.R

@@ -26,7 +26,11 @@ expect_silent(ggplotGrob(g2))
 control <- grab_axis(g1, side = "l")
 test <- grab_axis(g2, side = "l")
 
-expect_equal(length(test$grobs[[2]]$y), (length(control$grobs[[2]]$y) * 2) + 2)
+if (!inherits(guide_none(), "Guide")) {
+  expect_equal(length(test$grobs[[2]]$y), (length(control$grobs[[2]]$y) * 2) + 2)
+} else {
+  expect_equal(length(test$grobs[[2]]$y), (length(control$grobs[[1]]$y) * 2) + 2)
+}
 
 # test that guide_prism_offset_minor works with coord flip
 g1 <- p + scale_y_continuous(guide = "axis") +