Merge pull request #174 from ModelOriented/better-collect

Better collect mechanism

Author: mayer79

NEWS.md

@@ -4,24 +4,29 @@
 
 - `sv_dependence()`: The new arguments `ylim` and `share_y = FALSE` allow to control the y-axis limits.
   They help to assess the importance in multiple dependence plots ([#172](https://github.com/ModelOriented/shapviz/pull/172)).
-  Later, we might change the default to `share_y = TRUE` (as in Python's SHAP dependence plots) ([#171](https://github.com/ModelOriented/shapviz/pull/171).
+  Later, we might change the default to `share_y = TRUE` (as in Python's SHAP dependence plots) ([#171](https://github.com/ModelOriented/shapviz/pull/171)).
 - `sv_interaction()` has received a new visualization: `kind = "bar"` now shows mean absolute SHAP interactions/main effects as a barplot.
-  Its appearance can be modified by the arguments `fill` and `bar_width` [#169](https://github.com/ModelOriented/shapviz/pull/169).
+  Its appearance can be modified by the arguments `fill` and `bar_width` ([#169](https://github.com/ModelOriented/shapviz/pull/169)).
+- We are now (cautiously) collecting axes, axis titles, and color guides via {patchwork} ([#171](https://github.com/ModelOriented/shapviz/pull/171)).
+Currently fails for `sv_force()`.
 
-### User-visible changes
+### Minor user-visible changes
 
-- We are now (cautiously) collecting axes, axis titles, and color guides via {patchwork} [#171](https://github.com/ModelOriented/shapviz/pull/171).
-(Currently fails for `sv_force()`.)
-- The color bars in `sv_dependence2D()` are less wide [#169](https://github.com/ModelOriented/shapviz/pull/169).
+- The color bars in `sv_dependence2D()` are less wide ([#169](https://github.com/ModelOriented/shapviz/pull/169)).
+- Jittering now uses a seed ([#174](https://github.com/ModelOriented/shapviz/pull/174)).
 
 ### Minor API changes
 
 - In `sv_dependence()`, passing the same variable for `v` and `color_var` does not suppress the color axis anymore, 
-except when `interactions = TRUE` ([#171](https://github.com/ModelOriented/shapviz/pull/171).
+except when `interactions = TRUE` ([#171](https://github.com/ModelOriented/shapviz/pull/171)).
+- `sv_dependence()` and `sv_dependence2D()` has received a `seed = 1` argument used for jittering.
+  This does not modify the global seed ([#174](https://github.com/ModelOriented/shapviz/pull/174)).
 
 ### Maintenance
 
-- Update code coverage version [#168](https://github.com/ModelOriented/shapviz/pull/168).
+- Update code coverage version ([#168](https://github.com/ModelOriented/shapviz/pull/168)).
+- More unit tests ([#173](https://github.com/ModelOriented/shapviz/pull/173)).
+- Bump minimal version of {ggplot2} ([#174](https://github.com/ModelOriented/shapviz/pull/174)).
 
 # shapviz 0.9.7
 

R/collect_axes.R

@@ -0,0 +1,56 @@
+# Functions that help to derive collection info for patchwork
+
+# Same logic for axes and axis_titles
+.collect_xy <- function(z) {
+  if (z$x && z$y) {
+    return("collect")
+  }
+  if (z$x) {
+    return("collect_x")
+  }
+  if (z$y) {
+    return("collect_y")
+  }
+  return("keep")
+}
+
+# Takes list of ggplots and determines collection info for patchwork
+.collect <- function(plot_list) {
+  plot_list <- lapply(plot_list, ggplot2::ggplot_build)
+  ll <- lapply(plot_list, ggplot2::get_labs) # Version 3.5.2
+
+  titles_unique <- axes_unique <- list()
+  for (z in c("x", "y", "colour")) {
+    temp <- lapply(plot_list, ggplot2::get_guide_data, aesthetic = z)
+    if (z %in% c("x", "y")) {
+      # we should not test for equality of x when interested in y and vice versa
+      temp <- lapply(temp, `[`, c(z, ".value", ".label"))
+    }
+    axes_unique[[z]] <- .all_identical(temp, ignore_null = TRUE)
+
+    titles_unique[[z]] <- .all_identical(
+      lapply(ll, `[[`, z),
+      ignore_null = (z == "colour")
+    )
+  }
+
+  out <- list(
+    axis_titles = .collect_xy(titles_unique),
+    axes = .collect_xy(axes_unique),
+    guides = if (titles_unique$colour && axes_unique$colour) "collect" else "keep"
+  )
+
+  return(out)
+}
+
+# Check if the elements in z (list or vector) are all identical, ignoring NULLs
+.all_identical <- function(z, ignore_null = TRUE) {
+  if (ignore_null) {
+    z <- z[!vapply(z, is.null, logical(1L))]
+  }
+  n <- length(z)
+  if (n <= 1L) {
+    return(TRUE)
+  }
+  return(all(vapply(z[-1L], FUN = identical, z[[1L]], FUN.VALUE = logical(1L))))
+}