Implement modify_list and substitute modifyList calls with it (tidyverse#3005)

Author: thomasp85

DESCRIPTION

@@ -164,6 +164,7 @@ Collate:
     'layout.R'
     'limits.r'
     'margins.R'
+    'performance.R'
     'plot-build.r'
     'plot-construction.r'
     'plot-last.r'
@@ -243,6 +244,6 @@ Collate:
     'zxx.r'
     'zzz.r'
 VignetteBuilder: knitr
-RoxygenNote: 6.1.0
+RoxygenNote: 6.1.1
 Roxygen: list(markdown = TRUE)
 Encoding: UTF-8

R/aaa-.r

@@ -12,43 +12,3 @@ NULL
 #' @keywords internal
 #' @name ggplot2-ggproto
 NULL
-
-# Fast data.frame constructor and indexing
-# No checking, recycling etc. unless asked for
-new_data_frame <- function(x = list(), n = NULL) {
-  if (length(x) != 0 && is.null(names(x))) stop("Elements must be named", call. = FALSE)
-  lengths <- vapply(x, length, integer(1))
-  if (is.null(n)) {
-    n <- if (length(x) == 0) 0 else max(lengths)
-  }
-  for (i in seq_along(x)) {
-    if (lengths[i] == n) next
-    if (lengths[i] != 1) stop("Elements must equal the number of rows or 1", call. = FALSE)
-    x[[i]] <- rep(x[[i]], n)
-  }
-
-  class(x) <- "data.frame"
-
-  attr(x, "row.names") <- .set_row_names(n)
-  x
-}
-
-data_frame <- function(...) {
-  new_data_frame(list(...))
-}
-
-data.frame <- function(...) {
-  stop('Please use `data_frame()` or `new_data_frame()` instead of `data.frame()` for better performance. See the vignette "ggplot2 internal programming guidelines" for details.', call. = FALSE)
-}
-
-mat_2_df <- function(x, col_names = colnames(x), .check = FALSE) {
-  x <- lapply(seq_len(ncol(x)), function(i) x[, i])
-  if (!is.null(col_names)) names(x) <- col_names
-  new_data_frame(x)
-}
-
-df_col <- function(x, name) .subset2(x, name)
-
-df_rows <- function(x, i) {
-  new_data_frame(lapply(x, `[`, i = i))
-}

R/guide-legend.r

@@ -280,7 +280,7 @@ guide_geom.legend <- function(guide, layers, default_mapping) {
     }
 
     # override.aes in guide_legend manually changes the geom
-    data <- utils::modifyList(data, guide$override.aes)
+    data <- modify_list(data, guide$override.aes)
 
     list(
       draw_key = layer$geom$draw_key,

R/performance.R

@@ -0,0 +1,48 @@
+# Fast data.frame constructor and indexing
+# No checking, recycling etc. unless asked for
+new_data_frame <- function(x = list(), n = NULL) {
+  if (length(x) != 0 && is.null(names(x))) stop("Elements must be named", call. = FALSE)
+  lengths <- vapply(x, length, integer(1))
+  if (is.null(n)) {
+    n <- if (length(x) == 0) 0 else max(lengths)
+  }
+  for (i in seq_along(x)) {
+    if (lengths[i] == n) next
+    if (lengths[i] != 1) stop("Elements must equal the number of rows or 1", call. = FALSE)
+    x[[i]] <- rep(x[[i]], n)
+  }
+
+  class(x) <- "data.frame"
+
+  attr(x, "row.names") <- .set_row_names(n)
+  x
+}
+
+data_frame <- function(...) {
+  new_data_frame(list(...))
+}
+
+data.frame <- function(...) {
+  stop('Please use `data_frame()` or `new_data_frame()` instead of `data.frame()` for better performance. See the vignette "ggplot2 internal programming guidelines" for details.', call. = FALSE)
+}
+
+mat_2_df <- function(x, col_names = colnames(x), .check = FALSE) {
+  x <- lapply(seq_len(ncol(x)), function(i) x[, i])
+  if (!is.null(col_names)) names(x) <- col_names
+  new_data_frame(x)
+}
+
+df_col <- function(x, name) .subset2(x, name)
+
+df_rows <- function(x, i) {
+  new_data_frame(lapply(x, `[`, i = i))
+}
+
+# More performant modifyList without recursion
+modify_list <- function(old, new) {
+  for (i in names(new)) old[[i]] <- new[[i]]
+  old
+}
+modifyList <- function(...) {
+  stop('Please use `modify_list()` instead of `modifyList()` for better performance. See the vignette "ggplot2 internal programming guidelines" for details.', call. = FALSE)
+}

R/sf.R

@@ -204,7 +204,7 @@ GeomSf <- ggproto("GeomSf", Geom,
   },
 
   draw_key = function(data, params, size) {
-    data <- utils::modifyList(default_aesthetics(params$legend), data)
+    data <- modify_list(default_aesthetics(params$legend), data)
     if (params$legend == "point") {
       draw_key_point(data, params, size)
     } else if (params$legend == "line") {
@@ -221,7 +221,7 @@ default_aesthetics <- function(type) {
   } else if (type == "line") {
     GeomLine$default_aes
   } else  {
-    utils::modifyList(GeomPolygon$default_aes, list(fill = "grey90", colour = "grey35"))
+    modify_list(GeomPolygon$default_aes, list(fill = "grey90", colour = "grey35"))
   }
 }
 
@@ -230,7 +230,7 @@ sf_grob <- function(row, lineend = "butt", linejoin = "round", linemitre = 10) {
   geometry <- row$geometry[[1]]
 
   if (inherits(geometry, c("POINT", "MULTIPOINT"))) {
-    row <- utils::modifyList(default_aesthetics("point"), row)
+    row <- modify_list(default_aesthetics("point"), row)
     gp <- gpar(
       col = alpha(row$colour, row$alpha),
       fill = alpha(row$fill, row$alpha),
@@ -240,7 +240,7 @@ sf_grob <- function(row, lineend = "butt", linejoin = "round", linemitre = 10) {
     )
     sf::st_as_grob(geometry, gp = gp, pch = row$shape)
   } else {
-    row <- utils::modifyList(default_aesthetics("poly"), row)
+    row <- modify_list(default_aesthetics("poly"), row)
     gp <- gpar(
       col = row$colour,
       fill = alpha(row$fill, row$alpha),

R/theme-elements.r

@@ -186,7 +186,7 @@ element_grob.element_rect <- function(element, x = 0.5, y = 0.5,
   element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour,
     fill = element$fill, lty = element$linetype)
 
-  rectGrob(x, y, width, height, gp = utils::modifyList(element_gp, gp), ...)
+  rectGrob(x, y, width, height, gp = modify_list(element_gp, gp), ...)
 }
 
 
@@ -214,7 +214,7 @@ element_grob.element_text <- function(element, label = "", x = NULL, y = NULL,
     lineheight = element$lineheight)
 
   titleGrob(label, x, y, hjust = hj, vjust = vj, angle = angle,
-    gp = utils::modifyList(element_gp, gp), margin = margin,
+    gp = modify_list(element_gp, gp), margin = margin,
     margin_x = margin_x, margin_y = margin_y, debug = element$debug)
 }
 
@@ -242,7 +242,7 @@ element_grob.element_line <- function(element, x = 0:1, y = 0:1,
   }
   polylineGrob(
     x, y, default.units = default.units,
-    gp = utils::modifyList(element_gp, gp),
+    gp = modify_list(element_gp, gp),
     id.lengths = id.lengths, arrow = arrow, ...
   )
 }

R/utilities.r

@@ -388,7 +388,7 @@ find_args <- function(...) {
   vals <- mget(args, envir = env)
   vals <- vals[!vapply(vals, is_missing_arg, logical(1))]
 
-  utils::modifyList(vals, list(..., `...` = NULL))
+  modify_list(vals, list(..., `...` = NULL))
 }
 
 # Used in annotations to ensure printed even when no

tests/testthat/test-performance.R

@@ -0,0 +1,34 @@
+context("Performance related alternatives")
+
+testlist <- list(
+  a = 5.5,
+  b = "x",
+  c = 1:10
+)
+testappend <- list(
+  b = "y",
+  c = NULL,
+  d = FALSE
+)
+
+test_that("modifyList is masked", {
+  expect_error(modifyList(testlist, testappend))
+})
+
+test_that("modify_list retains unreferenced elements", {
+  res <- modify_list(testlist, testappend)
+  expect_equal(testlist$a, res$a)
+})
+test_that("modify_list overwrites existing values", {
+  res <- modify_list(testlist, testappend)
+  expect_equal(res$b, testappend$b)
+})
+test_that("modify_list adds new values", {
+  res <- modify_list(testlist, testappend)
+  expect_equal(res$d, testappend$d)
+})
+test_that("modify_list erases null elements", {
+  res <- modify_list(testlist, testappend)
+  expect_null(res$c)
+  expect_named(res, c('a', 'b', 'd'))
+})

vignettes/profiling.Rmd

@@ -67,6 +67,10 @@ are summarised below:
   and will just lead to slower code. The `data.frame()` call is now only used
   when dealing with output from other packages where the extra safety is a 
   benefit.
+- **Use a performant alternative to `utils::modifyList`** `modifyList()` is a 
+  nice convenience function but carries a lot of overhead. It was mainly used
+  in the plot element constructions where it slowed down the application of 
+  theme settings. A more performant version has been added and used throughout.
 - **Speed up position transformation** The `transform_position` helper was 
   unreasonably slow due to the slowness of getting and assigning columns in 
   data.frame. The input is now treated as a list during transformation.