diff --git a/DESCRIPTION b/DESCRIPTION index 89fae1d9b3..0fea684321 100644 --- a/DESCRIPTION +++ b/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 diff --git a/R/aaa-.r b/R/aaa-.r index b763b6a5c0..3bb6c93110 100644 --- a/R/aaa-.r +++ b/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)) -} diff --git a/R/guide-legend.r b/R/guide-legend.r index 8596fbb592..3f90dc26e8 100644 --- a/R/guide-legend.r +++ b/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, diff --git a/R/performance.R b/R/performance.R new file mode 100644 index 0000000000..2bcffed645 --- /dev/null +++ b/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) +} diff --git a/R/sf.R b/R/sf.R index 98d2a3c52c..4d54e4c459 100644 --- a/R/sf.R +++ b/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), diff --git a/R/theme-elements.r b/R/theme-elements.r index 62b9b38f38..b343af54bd 100644 --- a/R/theme-elements.r +++ b/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, ... ) } diff --git a/R/utilities.r b/R/utilities.r index 1e2d687c93..d1f6733441 100644 --- a/R/utilities.r +++ b/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 diff --git a/tests/testthat/test-performance.R b/tests/testthat/test-performance.R new file mode 100644 index 0000000000..6436e731be --- /dev/null +++ b/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')) +}) diff --git a/vignettes/profiling.Rmd b/vignettes/profiling.Rmd index f42f273a26..b83b5a24f1 100644 --- a/vignettes/profiling.Rmd +++ b/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.