Eliminate reshape dependency (#3639)

Author: hadley

DESCRIPTION

@@ -27,7 +27,6 @@ Imports:
     isoband,
     MASS,
     mgcv,
-    reshape2,
     rlang (>= 0.3.0),
     scales (>= 0.5.0),
     stats,
@@ -185,6 +184,7 @@ Collate:
     'position-stack.r'
     'quick-plot.r'
     'range.r'
+    'reshape-add-margins.R'
     'save.r'
     'scale-.r'
     'scale-alpha.r'

NEWS.md

@@ -1,5 +1,8 @@
 # ggplot2 (development version)
 
+* ggplot2 no longer depends on reshape2, which means that it no longer 
+  (recursively) needs plyr, stringr, or stringi packages.
+
 * `geom_sf()` now determines the legend type automatically (@microly, #3646).
 
 * `scale_x_continuous()` and `scale_y_continuous()` gains an `n.breaks` argument

R/aes-group-order.r

@@ -30,12 +30,7 @@
 #' a + geom_bar(aes(fill = factor(vs)))
 #'
 #' # Using linetypes
-#' rescale01 <- function(x) (x - min(x)) / diff(range(x))
-#' ec_scaled <- data.frame(
-#'   date = economics$date,
-#'   lapply(economics[, -(1:2)], rescale01))
-#' ecm <- reshape2::melt(ec_scaled, id.vars = "date")
-#' f <- ggplot(ecm, aes(date, value))
+#' f <- ggplot(economics_long, aes(date, value01))
 #' f + geom_line(aes(linetype = variable))
 #'
 #' # Using facets

R/facet-grid-.r

@@ -32,9 +32,9 @@ NULL
 #'   one with `vars(cyl, am)`. Each output
 #'   column gets displayed as one separate line in the strip
 #'   label. This function should inherit from the "labeller" S3 class
-#'   for compatibility with [labeller()]. You can use different labeling 
-#'   functions for different kind of labels, for example use [label_parsed()] for 
-#'   formatting facet labels. [label_value()] is used by default, 
+#'   for compatibility with [labeller()]. You can use different labeling
+#'   functions for different kind of labels, for example use [label_parsed()] for
+#'   formatting facet labels. [label_value()] is used by default,
 #'   check it for more details and pointers to other options.
 #' @param as.table If `TRUE`, the default, the facets are laid out like
 #'   a table with highest values at the bottom-right. If `FALSE`, the
@@ -215,8 +215,7 @@ FacetGrid <- ggproto("FacetGrid", Facet,
     }
 
     # Add margins
-    base <- reshape2::add_margins(base, list(names(rows), names(cols)), params$margins)
-    # Work around bug in reshape2
+    base <- reshape_add_margins(base, list(names(rows), names(cols)), params$margins)
     base <- unique(base)
 
     # Create panel info dataset
@@ -252,7 +251,7 @@ FacetGrid <- ggproto("FacetGrid", Facet,
     # Compute faceting values and add margins
     margin_vars <- list(intersect(names(rows), names(data)),
       intersect(names(cols), names(data)))
-    data <- reshape2::add_margins(data, margin_vars, params$margins)
+    data <- reshape_add_margins(data, margin_vars, params$margins)
 
     facet_vals <- eval_facets(c(rows, cols), data, params$plot_env)
 

R/geom-histogram.r

@@ -88,8 +88,8 @@
 #' # You can specify a function for calculating binwidth, which is
 #' # particularly useful when faceting along variables with
 #' # different ranges because the function will be called once per facet
-#' mtlong <- reshape2::melt(mtcars)
-#' ggplot(mtlong, aes(value)) + facet_wrap(~variable, scales = 'free_x') +
+#' ggplot(economics_long, aes(value)) +
+#'   facet_wrap(~variable, scales = 'free_x') +
 #'   geom_histogram(binwidth = function(x) 2 * IQR(x) / (length(x)^(1/3)))
 geom_histogram <- function(mapping = NULL, data = NULL,
                            stat = "bin", position = "stack",

R/geom-map.r

@@ -45,16 +45,23 @@ NULL
 #'   expand_limits(positions) + ylim(0, 3)
 #'
 #' # Better example
-#' crimes <- data.frame(state = tolower(rownames(USArrests)), USArrests)
-#' crimesm <- reshape2::melt(crimes, id = 1)
 #' if (require(maps)) {
+#'
+#'   crimes <- data.frame(state = tolower(rownames(USArrests)), USArrests)
+#'
+#'   # Equivalent to crimes %>% tidyr::pivot_longer(Murder:Rape)
+#'   vars <- lapply(names(crimes)[-1], function(j) {
+#'     data.frame(state = crimes$state, variable = j, value = crimes[[j]])
+#'   })
+#'   crimes_long <- do.call("rbind", vars)
+#'
 #'   states_map <- map_data("state")
 #'   ggplot(crimes, aes(map_id = state)) +
 #'     geom_map(aes(fill = Murder), map = states_map) +
 #'     expand_limits(x = states_map$long, y = states_map$lat)
 #'
 #'   last_plot() + coord_map()
-#'   ggplot(crimesm, aes(map_id = state)) +
+#'   ggplot(crimes_long, aes(map_id = state)) +
 #'     geom_map(aes(fill = value), map = states_map) +
 #'     expand_limits(x = states_map$long, y = states_map$lat) +
 #'     facet_wrap( ~ variable)

R/guide-colorbar.r

@@ -51,7 +51,8 @@
 #' @export
 #' @family guides
 #' @examples
-#' df <- reshape2::melt(outer(1:4, 1:4), varnames = c("X1", "X2"))
+#' df <- expand.grid(X1 = 1:10, X2 = 1:10)
+#' df$value <- df$X1 * df$X2
 #'
 #' p1 <- ggplot(df, aes(X1, X2)) + geom_tile(aes(fill = value))
 #' p2 <- p1 + geom_point(aes(size = value))

R/guide-colorsteps.R

@@ -17,7 +17,8 @@
 #'
 #' @family guides
 #' @examples
-#' df <- reshape2::melt(outer(1:10, 1:10), varnames = c("X1", "X2"))
+#' df <- expand.grid(X1 = 1:10, X2 = 1:10)
+#' df$value <- df$X1 * df$X2
 #'
 #' p <- ggplot(df, aes(X1, X2)) + geom_tile(aes(fill = value))
 #'

R/guide-legend.r

@@ -61,7 +61,8 @@
 #' @family guides
 #' @examples
 #' \donttest{
-#' df <- reshape2::melt(outer(1:4, 1:4), varnames = c("X1", "X2"))
+#' df <- expand.grid(X1 = 1:10, X2 = 1:10)
+#' df$value <- df$X1 * df$X2
 #'
 #' p1 <- ggplot(df, aes(X1, X2)) + geom_tile(aes(fill = value))
 #' p2 <- p1 + geom_point(aes(size = value))

R/reshape-add-margins.R

@@ -0,0 +1,60 @@
+# Inlined from reshape2
+reshape_add_margins <- function(df, vars, margins = TRUE) {
+  margin_vars <- reshape_margins(vars, margins)
+
+  # Return data frame if no margining necessary
+  if (length(margin_vars) == 0) return(df)
+
+  # Prepare data frame for addition of margins
+  addAll <- function(x) {
+    x <- addNA(x, TRUE)
+    factor(x, levels = c(levels(x), "(all)"), exclude = NULL)
+  }
+  vars <- unique(unlist(margin_vars))
+  df[vars] <- lapply(df[vars], addAll)
+
+  rownames(df) <- NULL
+
+  # Loop through all combinations of margin variables, setting
+  # those variables to (all)
+  margin_dfs <- lapply(margin_vars, function(vars) {
+    df[vars] <- rep(list(factor("(all)")), length(vars))
+    df
+  })
+
+  do.call("rbind", margin_dfs)
+}
+
+reshape_margins <- function(vars, margins = NULL) {
+  if (is.null(margins) || identical(margins, FALSE)) return(NULL)
+
+  all_vars <- unlist(vars)
+  if (isTRUE(margins)) {
+    margins <- all_vars
+  }
+
+  # Start by grouping margins by dimension
+  dims <- lapply(vars, intersect, margins)
+
+  # Next, ensure high-level margins include lower-levels
+  dims <- mapply(function(vars, margin) {
+    lapply(margin, downto, vars)
+  }, vars, dims, SIMPLIFY = FALSE, USE.NAMES = FALSE)
+
+  # Finally, find intersections across all dimensions
+  seq_0 <- function(x) c(0, seq_along(x))
+  indices <- expand.grid(lapply(dims, seq_0), KEEP.OUT.ATTRS = FALSE)
+  # indices <- indices[rowSums(indices) > 0, ]
+
+  lapply(seq_len(nrow(indices)), function(i){
+    unlist(mapply("[", dims, indices[i, ], SIMPLIFY = FALSE))
+  })
+}
+
+
+upto <- function(a, b) {
+  b[seq_len(match(a, b, nomatch = 0))]
+}
+downto <- function(a, b) {
+  rev(upto(a, rev(b)))
+}