ggh4x 0.2.4 (#104)

* Attempt to update pkgdown part 2

* Drop dependency on digest

* Adapt to upcoming ggplot2 #95

* Better message in facetted_pos_scales #91

* try_require() -> check_installed()

* Use {cli} for messages

* Add `inv` option

* Fix #97

* Smarter omission of fixed scales

* Better removal of spurious whitespace

* Add scale_{x/y}_manual

* Polish news

* Mark scale_{x/y}_manual as experimental

* Last polishes

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: ggh4x
 Title: Hacks for 'ggplot2'
-Version: 0.2.3.9000
+Version: 0.2.4
 Authors@R: 
     person(given = "Teun",
            family = "van den Brand",
@@ -18,19 +18,18 @@ URL: https://github.com/teunbrand/ggh4x,
     https://teunbrand.github.io/ggh4x/
 BugReports: https://github.com/teunbrand/ggh4x/issues
 Depends: 
-    ggplot2 (>= 3.4.0)
+    ggplot2 (>= 3.4.2)
 Imports: 
     grid,
     gtable,
     scales,
     vctrs (>= 0.5.0),
-    rlang,
+    rlang (>= 1.1.0),
     lifecycle,
     stats,
     cli
 Suggests: 
     covr,
-    digest,
     fitdistrplus,
     ggdendro,
     vdiffr,
@@ -42,7 +41,7 @@ Suggests:
 VignetteBuilder: 
     knitr
 Encoding: UTF-8
-RoxygenNote: 7.2.1
+RoxygenNote: 7.2.3
 Config/testthat/edition: 3
 Collate:
     'borrowed_ggplot2.R'
@@ -79,6 +78,7 @@ Collate:
     'scale_dendrogram.R'
     'scale_facet.R'
     'scale_listed.R'
+    'scale_manual.R'
     'scale_multi.R'
     'stat_difference.R'
     'stat_funxy.R'

NAMESPACE

@@ -34,6 +34,7 @@ export(FacetNestedWrap)
 export(FacetWrap2)
 export(GeomBox)
 export(GeomPointPath)
+export(GeomPointpath)
 export(GeomPolygonRaster)
 export(GeomRectMargin)
 export(GeomTextAimed)
@@ -89,8 +90,11 @@ export(scale_fill_multi)
 export(scale_listed)
 export(scale_x_dendrogram)
 export(scale_x_facet)
+export(scale_x_manual)
 export(scale_y_dendrogram)
 export(scale_y_facet)
+export(scale_y_manual)
+export(sep_discrete)
 export(stat_centroid)
 export(stat_difference)
 export(stat_funxy)
@@ -106,27 +110,17 @@ export(weave_factors)
 import(ggplot2)
 import(grid)
 import(gtable)
+import(rlang)
 import(scales)
 import(vctrs)
 importFrom(cli,cli_abort)
 importFrom(ggplot2,layer)
 importFrom(lifecycle,deprecated)
-importFrom(rlang,`%||%`)
 importFrom(rlang,`:=`)
-importFrom(rlang,abort)
-importFrom(rlang,arg_match)
-importFrom(rlang,arg_match0)
-importFrom(rlang,as_function)
-importFrom(rlang,as_label)
 importFrom(rlang,as_quosure)
-importFrom(rlang,enquo)
-importFrom(rlang,eval_tidy)
 importFrom(rlang,f_env)
 importFrom(rlang,f_lhs)
 importFrom(rlang,f_rhs)
-importFrom(rlang,is_formula)
-importFrom(rlang,list2)
-importFrom(rlang,warn)
 importFrom(stats,ccf)
 importFrom(stats,coef)
 importFrom(stats,dcauchy)

NEWS.md

@@ -1,5 +1,29 @@
-# ggh4x (development version)
+# ggh4x 0.2.4
 
+This is a small release for compatibility with ggplot2 3.4.2, along with some
+minor improvements and bug fixes.
+
+## New features
+
+* `scale_{x/y}_manual()` is a semi-discrete scale that accepts categorical 
+  input and maps this a continuous output (#94).
+
+## Improvements
+
+* `facet_manual()` can now not only omit axes when panels occupy 1 cell in
+  the axes' direction, but also when all panels in the same rows/columns occupy
+  the same range of cells, when scales are not free.
+* `facet_manual()` now tries to omit white space introduced by axis placement 
+  when scales are not free (#86)
+* Added `inv` option to invert the label order from outer to inner in 
+  `guide_axis_nested()`.
+
+## Bug fixes
+
+* Avoid spurious warning in `guide_axis_nested()` (#97).
+* Compatibility with ggplot2 3.4.2 (#95).
+* Improved error messages (#91).
+* Fixed `annotate(geom = "pointpath")` (#83).
 * Fixed bug in `geom_box()` where `radius` is now properly handed off to the
   grob.
 

R/borrowed_ggplot2.R

@@ -548,4 +548,8 @@ just_dir <- function(x, tol = 0.001) {
   out[x > 0.5 + tol] <- 3L
   out
 }
+
+`%|W|%` <- function(a, b) {
+  if (!inherits(a, "waiver")) a else b
+}
 # nocov end

R/conveniences.R

@@ -162,8 +162,10 @@ weave_factors <- function(..., drop = TRUE, sep = ".", replaceNA = TRUE) {
   }
   lengths <- lengths(args)
   if (!all(lengths %in% c(1L, max(lengths)))) {
-    stop("All inputs to 'weave_factors' should either be the",
-         "same length or length 1", call. = FALSE)
+    cli::cli_abort(paste0(
+      "All inputs to {.fn weave_factors} should have the same length, ",
+      "or length 1."
+    ))
   }
   if (replaceNA) {
     args <- lapply(args, function(x) {

R/facet_grid2.R

@@ -183,8 +183,11 @@ FacetGrid2 <- ggproto(
     cols <- params$cols
     dups <- intersect(names(rows), names(cols))
     if (length(dups) > 0) {
-      abort("Facetting variables can only appear in row or cols, not both.\n",
-            "Problems: ", paste0(dups, collapse = "'"), call. = FALSE)
+      cli::cli_abort(c(
+        paste0("Facetting variables can only appear in {.arg rows} or
+               {.arg cols}, not both."),
+        i = "Duplicated variables: {.val dups}"
+      ))
     }
 
     # Use `self$vars_combine` instead of `combine_vars`
@@ -375,7 +378,7 @@ FacetGrid2 <- ggproto(
     ranges, coord, data, theme, params, self
   ) {
     if ((params$free$x || params$free$y) && !coord$is_free()) {
-      abort(paste0(snake_class(coord), "doesn't support free scales."))
+      cli::cli_abort("{.fn {snake_class(coord)}} doesn't support free scales.")
     }
     strip <- self$strip
     cols <- which(layout$ROW == 1)
@@ -412,27 +415,43 @@ FacetGrid2 <- ggproto(
 .validate_independent <- function(independent, free, space_free, rmlab) {
   if (independent$x) {
     if (!free$x) {
-      abort("Rows cannot be independent if the scales are not free.")
+      cli::cli_abort(
+        "{.field x} cannot be independent if scales are not free."
+      )
     }
     if (space_free$x) {
-      warn("Rows cannot have free space if axes are independent.")
+      cli::cli_warn(c(
+        "{.field x} cannot have free space if axes are independent.",
+        i = "Overriding {.arg space} for {.field x} to {.val FALSE}."
+      ))
       space_free$x <- FALSE
     }
     if (rmlab$x) {
-      warn("x-axes must be labelled if they are independent.")
+      cli::cli_warn(c(
+        "x-axes must be labelled if they are independent.",
+        i = "Overriding {.arg remove_labels} for {.field x} to {.val FALSE}."
+      ))
       rmlab$x <- FALSE
     }
   }
   if (independent$y) {
     if (!free$y) {
-      abort("Columns cannot be independent if the scales are not free.")
+      cli::cli_abort(
+        "{.field y} cannot be independent if scales are not free."
+      )
     }
     if (space_free$y) {
-      warn("Columns cannot have free space if axes are independent.")
+      cli::cli_warn(c(
+        "{.field y} cannot have free space if axes are independent.",
+        i = "Overriding {.arg space} for {.field y} to {.val FALSE}."
+      ))
       space_free$y <- FALSE
     }
     if (rmlab$y) {
-      warn("y-axes must be labelled if they are independent.")
+      cli::cli_warn(c(
+        "y-axes must be labelled if they are independent.",
+        i = "Overriding {.arg remove_labels} for {.field y} to {.val FALSE}."
+      ))
       rmlab$y <- FALSE
     }
   }

R/facet_manual.R

@@ -265,8 +265,8 @@ FacetManual <- ggproto(
     purge_y <- !params$free$y && (params$rmlab$y || !params$axes$y)
 
     # Should we purge in practise?
-    purge_x <- purge_x && all(layout$.LEFT == layout$.RIGHT)
-    purge_y <- purge_y && all(layout$.TOP  == layout$.BOTTOM)
+    purge_x <- purge_x && do_purge(layout$.LEFT, layout$.RIGHT)
+    purge_y <- purge_y && do_purge(layout$.TOP,  layout$.BOTTOM)
 
     if (purge_x) {
       purger <- if (params$rmlab$x) purge_guide_labels else zeroGrob()
@@ -293,7 +293,23 @@ FacetManual <- ggproto(
     )
   },
 
-  attach_axes = function(panels, axes, sizes ) {
+  attach_axes = function(panels, axes, sizes, params, inside = TRUE) {
+    if (!params$free$y && do_purge(panels$layout$t, panels$layout$b)) {
+      if (inside || params$strip.position != "left") {
+        sizes$left[-1] <- unit(0, "cm")
+      }
+      if (inside || params$strip.position != "right") {
+        sizes$right[-length(sizes$right)] <- unit(0, "cm")
+      }
+    }
+    if (!params$free$x && do_purge(panels$layout$l, panels$layout$r)) {
+      if (inside || params$strip.position != "bottom")
+      sizes$bottom[-length(sizes$bottom)] <- unit(0, "cm")
+      if (inside || params$strip.position != "top") {
+        sizes$top[-1] <- unit(0, "cm")
+      }
+    }
+
     # Top axis
     panels <- weave_panel_rows(panels, axes, -1, sizes$top,
                                "axis-t", 3, "off", "t", "axes_top")
@@ -313,8 +329,7 @@ FacetManual <- ggproto(
                          x_scales, y_scales,
                          ranges, coord, data, theme, params) {
     if ((params$free$x || params$free$y) && !coord$is_free()) {
-      stop(snake_class(coord), " doesn't support free scales",
-           call. = FALSE)
+      cli::cli_abort("{.fn {snake_class(coord)}} doesn't support free scales.")
     }
     strip <- self$strip
 
@@ -334,7 +349,10 @@ FacetManual <- ggproto(
       left   = split_widths_cm(axes$axes_left,    split = dims$l),
       right  = split_widths_cm(axes$axes_right,   split = dims$r)
     )
-    panels <- self$attach_axes(panels, axes, sizes)
+    panels <- self$attach_axes(
+      panels, axes, sizes, params,
+      inside = calc_element("strip.placement", theme) == "inside"
+    )
 
     # Deal with strips
     simplify <- switch(
@@ -361,7 +379,9 @@ FacetManual <- ggproto(
 
 validate_design <- function(design = NULL, trim = TRUE) {
   if (is.null(design)) {
-    stop("Cannot interpret design.", call. = FALSE)
+    cli::cli_abort(
+      "The {.arg design} argument cannot be {.obj_type_friendly {design}}."
+    )
   }
   # Inspired by patchwork:::as_areas()
   if (is.character(design)) {
@@ -371,7 +391,9 @@ validate_design <- function(design = NULL, trim = TRUE) {
     x <- strsplit(x, "")
     ncols <- lengths(x)
     if (length(unique(ncols)) != 1) {
-      stop("Design must be rectangular.", call. = FALSE)
+      cli::cli_abort(
+        "The {.arg design} argument must be rectangular."
+      )
     }
     nrow <- length(x)
     x <- unlist(x)
@@ -384,7 +406,9 @@ validate_design <- function(design = NULL, trim = TRUE) {
   if (is.matrix(design)) {
     dim <- dim(design)
     if (length(dim) != 2 || any(dim < 1) || any(is.na(dim))) {
-      stop("The `design` argument has invalid dimensions.")
+      cli::cli_abort(
+        "The {.arg design} argument has invalid dimensions."
+      )
     }
     if (typeof(design) == "character") {
       design[design == "#"] <- NA
@@ -405,7 +429,9 @@ validate_design <- function(design = NULL, trim = TRUE) {
     }
     return(design)
   } else {
-    stop("The `design` argument should be interpretable as a matrix.")
+    cli::cli_abort(
+      "The {.arg design} argument should be interpretable as a {.cls matrix}."
+    )
   }
 }
 
@@ -425,3 +451,10 @@ restrict_axes <- function(axes, position, by, which_fun = min,
   axes
 }
 
+do_purge <- function(a, b) {
+  ab <- data_frame0(a = a, b = b)
+  n  <- vec_unique_count(ab)
+  a  <- vec_unique_count(a)
+  b  <- vec_unique_count(b)
+  n == a && n == b
+}

R/facet_nested.R

@@ -89,8 +89,10 @@ facet_nested <- function(
     nest_line <- element_blank()
   }
   if (!inherits(nest_line, c("element_line", "element_blank"))) {
-    abort(paste0("The `nest_line` argument must be an 'element_blank' or ",
-                 "inherit from an 'element_line'."))
+    cli::cli_abort(paste0(
+      "The {.arg nest_line} argument must be {.cls element_blank} or inherit ",
+      "from {.cls element_line}."
+    ))
   }
 
   params <- list(
@@ -217,8 +219,7 @@ FacetNested <- ggproto(
       base <- rbind(base, df.grid(old, new))
     }
     if (empty(base)) {
-      stop("Facetting variables must have at least one value",
-           call. = FALSE)
+      cli::cli_abort("Facetting variables must have at least one value.")
     }
     base
   },

R/facet_nested_wrap.R

@@ -77,8 +77,10 @@ facet_nested_wrap <- function(
     nest_line <- element_blank()
   }
   if (!inherits(nest_line, c("element_line", "element_blank"))) {
-    abort(paste0("The `nest_line` argument must be an 'element_blank' or ",
-                 "inherit from an 'element_line'."))
+    cli::cli_abort(paste0(
+      "The {.arg nest_line} argument must be {.cls element_blank} or inherit ",
+      "from {.cls element_line}."
+    ))
   }
   params <- list(
     nest_line = nest_line,