From c2b7e0ca6cd8f762493d03dfc8ad76ce9f946f55 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Sun, 24 Jan 2016 22:08:25 +0100 Subject: [PATCH 01/16] Resolve data upon extraction within ggplot_build --- R/plot-build.r | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/R/plot-build.r b/R/plot-build.r index d4ef2a2fda..c8b3bfa724 100644 --- a/R/plot-build.r +++ b/R/plot-build.r @@ -22,7 +22,13 @@ ggplot_build <- function(plot) { } layers <- plot$layers - layer_data <- lapply(layers, function(y) y$data) + layer_data <- lapply(layers, function(y) { + if (is.function(y$data)) { + fortify(y$data(plot$data)) + } else { + y$data + } + }) scales <- plot$scales # Apply function to layer and matching data From d10d2e86e3cac737f92d9168e99ba516f8fc7366 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Thu, 25 Oct 2018 15:45:34 +0200 Subject: [PATCH 02/16] Memoize calls to descentDetails() --- R/margins.R | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/R/margins.R b/R/margins.R index 300e6a6bde..17b85c6c9c 100644 --- a/R/margins.R +++ b/R/margins.R @@ -63,8 +63,7 @@ title_spec <- function(label, x, y, hjust, vjust, angle, gp = gpar(), # has the common letters with descenders. This guarantees that the grob always has # the same height regardless of whether the text actually contains letters with # descenders or not. The same happens automatically with ascenders already. - temp <- editGrob(text_grob, label = "gjpqyQ") - descent <- descentDetails(temp) + descent <- font_descent(gp$fontfamily, gp$fontface, gp$fontsize, gp$cex) # Use trigonometry to calculate grobheight and width for rotated grobs. This is only # exactly correct when vjust = 1. We need to take the absolute value so we don't make @@ -329,3 +328,23 @@ rotate_just <- function(angle, hjust, vjust) { list(hjust = hnew, vjust = vnew) } +descent_cache <- new.env(parent = emptyenv()) +font_descent <- function(family = "", face = "plain", size = 12, cex = 1) { + key <- paste0(family, ':', face, ":", size, ":", cex) + + descent <- descent_cache[[key]] + + if (is.null(descent)) { + descent <- descentDetails(textGrob( + label = "gjpqyQ", + gp = gpar( + fontsize = size, + cex = cex, + fontfamily = family, + fontface = face + ) + )) + descent_cache[[key]] <- descent + } + descent +} From 1476c6f54528545479252f819b084a8c00e3bc22 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Sun, 28 Oct 2018 20:42:57 +0100 Subject: [PATCH 03/16] sub data.frame with new_data_frame in backbone functions --- R/aaa-.r | 26 ++++++++++++++++++++++++++ R/bin.R | 5 ++--- R/facet-.r | 6 +++--- R/facet-wrap.r | 2 +- R/layer.r | 8 ++++---- R/layout.R | 2 +- R/position-.r | 2 +- R/quick-plot.r | 2 +- R/stat-.r | 6 +++--- R/utilities.r | 2 +- 10 files changed, 43 insertions(+), 18 deletions(-) diff --git a/R/aaa-.r b/R/aaa-.r index 3bb6c93110..31af561830 100644 --- a/R/aaa-.r +++ b/R/aaa-.r @@ -12,3 +12,29 @@ NULL #' @keywords internal #' @name ggplot2-ggproto NULL + +# More performant data.frame constructors +new_data_frame <- function(..., .check = FALSE) { + data <- list(...) + list_2_df(data, .check) +} +list_2_df <- function(data, .check = FALSE) { + if (.check) { + n_row <- max(lengths(data)) + for (i in seq_along(data)) { + if (length(data[[i]]) != n_row) data[[i]] <- rep(data[[i]], length.out = n_row) + } + if (is.null(names(data))) { + names(data) <- make.names(seq_along(data)) + } + } else { + n_row <- if (length(data) == 0) 0 else length(data[[1]]) + } + structure(data, class = "data.frame", row.names = c(NA_integer_, -n_row)) +} +mat_2_df <- function(data, .check = FALSE) { + c_names <- colnames(data) + data <- split(data, rep(seq_len(ncol(data))), each = nrow(data)) + names(data) <- c_names + list_2_df(data, .check) +} diff --git a/R/bin.R b/R/bin.R index a7eb5ad8f2..c633064189 100644 --- a/R/bin.R +++ b/R/bin.R @@ -157,7 +157,7 @@ bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0), xmin = x - width / 2, xmax = x + width / 2) { density <- count / width / sum(abs(count)) - data.frame( + new_data_frame( count = count, x = x, xmin = xmin, @@ -165,7 +165,6 @@ bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0), width = width, density = density, ncount = count / max(abs(count)), - ndensity = density / max(abs(density)), - stringsAsFactors = FALSE + ndensity = density / max(abs(density)) ) } diff --git a/R/facet-.r b/R/facet-.r index d4f0c96cb1..733a33fd49 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -443,7 +443,7 @@ eval_facet <- function(facet, data, env = emptyenv()) { layout_null <- function() { # PANEL needs to be a factor to be consistent with other facet types - data.frame(PANEL = factor(1), ROW = 1, COL = 1, SCALE_X = 1, SCALE_Y = 1) + new_data_frame(PANEL = factor(1), ROW = 1, COL = 1, SCALE_X = 1, SCALE_Y = 1) } check_layout <- function(x) { @@ -493,7 +493,7 @@ find_panel <- function(table) { layout <- table$layout panels <- layout[grepl("^panel", layout$name), , drop = FALSE] - data.frame( + new_data_frame( t = min(panels$t), r = max(panels$r), b = max(panels$b), @@ -526,7 +526,7 @@ panel_rows <- function(table) { #' @keywords internal #' @export combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) { - if (length(vars) == 0) return(data.frame()) + if (length(vars) == 0) return(new_data_frame()) # For each layer, compute the facet values values <- compact(plyr::llply(data, eval_facets, facets = vars, env = env)) diff --git a/R/facet-wrap.r b/R/facet-wrap.r index 8998b0b001..2bda89d67a 100644 --- a/R/facet-wrap.r +++ b/R/facet-wrap.r @@ -149,7 +149,7 @@ FacetWrap <- ggproto("FacetWrap", Facet, n <- attr(id, "n") dims <- wrap_dims(n, params$nrow, params$ncol) - layout <- data.frame(PANEL = factor(id, levels = seq_len(n))) + layout <- new_data_frame(PANEL = factor(id, levels = seq_len(n))) if (params$as.table) { layout$ROW <- as.integer((id - 1L) %/% dims[2] + 1L) diff --git a/R/layer.r b/R/layer.r index c4bdc89b15..72739c65d5 100644 --- a/R/layer.r +++ b/R/layer.r @@ -246,7 +246,7 @@ Layer <- ggproto("Layer", NULL, compute_statistic = function(self, data, layout) { if (empty(data)) - return(data.frame()) + return(new_data_frame()) params <- self$stat$setup_params(data, self$stat_params) data <- self$stat$setup_data(data, params) @@ -254,7 +254,7 @@ Layer <- ggproto("Layer", NULL, }, map_statistic = function(self, data, plot) { - if (empty(data)) return(data.frame()) + if (empty(data)) return(new_data_frame()) # Assemble aesthetics from layer, plot and stat mappings aesthetics <- self$mapping @@ -286,7 +286,7 @@ Layer <- ggproto("Layer", NULL, }, compute_geom_1 = function(self, data) { - if (empty(data)) return(data.frame()) + if (empty(data)) return(new_data_frame()) check_required_aesthetics( self$geom$required_aes, @@ -298,7 +298,7 @@ Layer <- ggproto("Layer", NULL, }, compute_position = function(self, data, layout) { - if (empty(data)) return(data.frame()) + if (empty(data)) return(new_data_frame()) params <- self$position$setup_params(data) data <- self$position$setup_data(data, params) diff --git a/R/layout.R b/R/layout.R index aa832047f8..c37cee60ff 100644 --- a/R/layout.R +++ b/R/layout.R @@ -30,7 +30,7 @@ Layout <- ggproto("Layout", NULL, panel_scales_y = NULL, panel_params = NULL, - setup = function(self, data, plot_data = data.frame(), plot_env = emptyenv()) { + setup = function(self, data, plot_data = new_data_frame(), plot_env = emptyenv()) { data <- c(list(plot_data), data) # Setup facets diff --git a/R/position-.r b/R/position-.r index f9a8dbf87e..4b3ec981f4 100644 --- a/R/position-.r +++ b/R/position-.r @@ -55,7 +55,7 @@ Position <- ggproto("Position", compute_layer = function(self, data, params, layout) { plyr::ddply(data, "PANEL", function(data) { - if (empty(data)) return(data.frame()) + if (empty(data)) return(new_data_frame()) scales <- layout$get_scales(data$PANEL[1]) self$compute_panel(data = data, params = params, scales = scales) diff --git a/R/quick-plot.r b/R/quick-plot.r index d3aef44357..378cb89c8e 100644 --- a/R/quick-plot.r +++ b/R/quick-plot.r @@ -100,7 +100,7 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, if (missing(data)) { # If data not explicitly specified, will be pulled from workspace - data <- data.frame() + data <- new_data_frame() # Faceting variables must be in a data frame, so pull those out facetvars <- all.vars(facets) diff --git a/R/stat-.r b/R/stat-.r index 5216b39cc5..d6d02d0599 100644 --- a/R/stat-.r +++ b/R/stat-.r @@ -91,13 +91,13 @@ Stat <- ggproto("Stat", tryCatch(do.call(self$compute_panel, args), error = function(e) { warning("Computation failed in `", snake_class(self), "()`:\n", e$message, call. = FALSE) - data.frame() + new_data_frame() }) }) }, compute_panel = function(self, data, scales, ...) { - if (empty(data)) return(data.frame()) + if (empty(data)) return(new_data_frame()) groups <- split(data, data$group) stats <- lapply(groups, function(group) { @@ -105,7 +105,7 @@ Stat <- ggproto("Stat", }) stats <- mapply(function(new, old) { - if (empty(new)) return(data.frame()) + if (empty(new)) return(new_data_frame()) unique <- uniquecols(old) missing <- !(names(unique) %in% names(new)) cbind( diff --git a/R/utilities.r b/R/utilities.r index 955e2d8ff9..e88c384165 100644 --- a/R/utilities.r +++ b/R/utilities.r @@ -393,7 +393,7 @@ find_args <- function(...) { # Used in annotations to ensure printed even when no # global data -dummy_data <- function() data.frame(x = NA) +dummy_data <- function() new_data_frame(x = NA) with_seed_null <- function(seed, code) { if (is.null(seed)) { From 4af7f83fe6819df67df20ba2724d88f8f5e56dbc Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Wed, 7 Nov 2018 11:50:34 +0100 Subject: [PATCH 04/16] Update constructor API --- R/aaa-.r | 43 +++++++++++++++++++++---------------------- R/bin.R | 4 ++-- R/facet-.r | 6 +++--- R/facet-wrap.r | 2 +- R/utilities.r | 2 +- 5 files changed, 28 insertions(+), 29 deletions(-) diff --git a/R/aaa-.r b/R/aaa-.r index 31af561830..9cd10a044b 100644 --- a/R/aaa-.r +++ b/R/aaa-.r @@ -13,28 +13,27 @@ NULL #' @name ggplot2-ggproto NULL -# More performant data.frame constructors -new_data_frame <- function(..., .check = FALSE) { - data <- list(...) - list_2_df(data, .check) -} -list_2_df <- function(data, .check = FALSE) { - if (.check) { - n_row <- max(lengths(data)) - for (i in seq_along(data)) { - if (length(data[[i]]) != n_row) data[[i]] <- rep(data[[i]], length.out = n_row) - } - if (is.null(names(data))) { - names(data) <- make.names(seq_along(data)) - } - } else { - n_row <- if (length(data) == 0) 0 else length(data[[1]]) +# Fast data.frame constructor +# No checking, recycling etc. unless asked for +new_data_frame <- function(x = list(), n = NULL) { + if (is.null(n)) { + n <- if (length(x) == 0) 0 else length(x[[1]]) } - structure(data, class = "data.frame", row.names = c(NA_integer_, -n_row)) + + class(x) <- "data.frame" + + attr(x, "row.names") <- .set_row_names(n) + x } -mat_2_df <- function(data, .check = FALSE) { - c_names <- colnames(data) - data <- split(data, rep(seq_len(ncol(data))), each = nrow(data)) - names(data) <- c_names - list_2_df(data, .check) + +validate_data_frame <- function(x) { + if (length(unique(lengths(x))) != 1) stop('All elements in a data.frame must be of equal length', call. = FALSE) + if (is.null(names(x))) stop('Columns must be named', call. = FALSE) +} + +mat_2_df <- function(x, .check = FALSE) { + c_names <- colnames(x) + x <- split(x, rep(seq_len(ncol(x))), each = nrow(x)) + names(x) <- c_names + new_data_frame(x) } diff --git a/R/bin.R b/R/bin.R index c633064189..16b20bc815 100644 --- a/R/bin.R +++ b/R/bin.R @@ -157,7 +157,7 @@ bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0), xmin = x - width / 2, xmax = x + width / 2) { density <- count / width / sum(abs(count)) - new_data_frame( + new_data_frame(list( count = count, x = x, xmin = xmin, @@ -166,5 +166,5 @@ bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0), density = density, ncount = count / max(abs(count)), ndensity = density / max(abs(density)) - ) + )) } diff --git a/R/facet-.r b/R/facet-.r index 733a33fd49..41a780d971 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -443,7 +443,7 @@ eval_facet <- function(facet, data, env = emptyenv()) { layout_null <- function() { # PANEL needs to be a factor to be consistent with other facet types - new_data_frame(PANEL = factor(1), ROW = 1, COL = 1, SCALE_X = 1, SCALE_Y = 1) + new_data_frame(list(PANEL = factor(1), ROW = 1, COL = 1, SCALE_X = 1, SCALE_Y = 1)) } check_layout <- function(x) { @@ -493,12 +493,12 @@ find_panel <- function(table) { layout <- table$layout panels <- layout[grepl("^panel", layout$name), , drop = FALSE] - new_data_frame( + new_data_frame(list( t = min(panels$t), r = max(panels$r), b = max(panels$b), l = min(panels$l) - ) + )) } #' @rdname find_panel #' @export diff --git a/R/facet-wrap.r b/R/facet-wrap.r index 2bda89d67a..0771dd1054 100644 --- a/R/facet-wrap.r +++ b/R/facet-wrap.r @@ -149,7 +149,7 @@ FacetWrap <- ggproto("FacetWrap", Facet, n <- attr(id, "n") dims <- wrap_dims(n, params$nrow, params$ncol) - layout <- new_data_frame(PANEL = factor(id, levels = seq_len(n))) + layout <- new_data_frame(list(PANEL = factor(id, levels = seq_len(n)))) if (params$as.table) { layout$ROW <- as.integer((id - 1L) %/% dims[2] + 1L) diff --git a/R/utilities.r b/R/utilities.r index e88c384165..6086310d33 100644 --- a/R/utilities.r +++ b/R/utilities.r @@ -393,7 +393,7 @@ find_args <- function(...) { # Used in annotations to ensure printed even when no # global data -dummy_data <- function() new_data_frame(x = NA) +dummy_data <- function() new_data_frame(list(x = NA)) with_seed_null <- function(seed, code) { if (is.null(seed)) { From 5a92b7a03f0a96bbe13a6f34d9e1efbe7d267dbb Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Thu, 8 Nov 2018 12:43:36 +0100 Subject: [PATCH 05/16] Remove data.frame calls in favour of new_data_frame --- R/aaa-.r | 8 ++++- R/annotation-custom.r | 2 +- R/annotation-raster.r | 2 +- R/annotation.r | 2 +- R/coord-map.r | 12 +++---- R/coord-munch.r | 6 ++-- R/facet-.r | 8 ++--- R/fortify-map.r | 10 +++--- R/geom-abline.r | 6 +++- R/geom-boxplot.r | 73 +++++++++++++++++++++-------------------- R/geom-crossbar.r | 33 +++++++++---------- R/geom-errorbar.r | 4 +-- R/geom-errorbarh.r | 5 ++- R/geom-path.r | 14 ++++---- R/geom-vline.r | 2 +- R/guide-colorbar.r | 4 +-- R/hexbin.R | 2 +- R/limits.r | 5 ++- R/stat-bindot.r | 9 +++-- R/stat-boxplot.r | 2 +- R/stat-contour.r | 6 ++-- R/stat-density-2d.r | 3 +- R/stat-density.r | 10 +++--- R/stat-ecdf.r | 2 +- R/stat-ellipse.R | 3 +- R/stat-qq.r | 2 +- R/stat-quantile.r | 2 +- R/stat-smooth-methods.r | 2 +- R/stat-smooth.r | 2 +- R/stat-summary-bin.R | 4 +-- R/stat-summary.r | 4 +-- R/stat-ydensity.r | 2 +- R/utilities.r | 2 +- 33 files changed, 137 insertions(+), 116 deletions(-) diff --git a/R/aaa-.r b/R/aaa-.r index 9cd10a044b..c07a085694 100644 --- a/R/aaa-.r +++ b/R/aaa-.r @@ -13,7 +13,7 @@ NULL #' @name ggplot2-ggproto NULL -# Fast data.frame constructor +# Fast data.frame constructor and indexing # No checking, recycling etc. unless asked for new_data_frame <- function(x = list(), n = NULL) { if (is.null(n)) { @@ -37,3 +37,9 @@ mat_2_df <- function(x, .check = FALSE) { names(x) <- c_names new_data_frame(x) } + +df_col <- .subset2 + +df_rows <- function(x, i) { + new_data_frame(lapply(x, `[`, i = i)) +} diff --git a/R/annotation-custom.r b/R/annotation-custom.r index df89f884db..506bb15cde 100644 --- a/R/annotation-custom.r +++ b/R/annotation-custom.r @@ -74,7 +74,7 @@ GeomCustomAnn <- ggproto("GeomCustomAnn", Geom, stop("annotation_custom only works with Cartesian coordinates", call. = FALSE) } - corners <- data.frame(x = c(xmin, xmax), y = c(ymin, ymax)) + corners <- new_data_frame(list(x = c(xmin, xmax), y = c(ymin, ymax))) data <- coord$transform(corners, panel_params) x_rng <- range(data$x, na.rm = TRUE) diff --git a/R/annotation-raster.r b/R/annotation-raster.r index 0ea3bfd4c4..e279d34a1b 100644 --- a/R/annotation-raster.r +++ b/R/annotation-raster.r @@ -76,7 +76,7 @@ GeomRasterAnn <- ggproto("GeomRasterAnn", Geom, stop("annotation_raster only works with Cartesian coordinates", call. = FALSE) } - corners <- data.frame(x = c(xmin, xmax), y = c(ymin, ymax)) + corners <- new_data_frame(list(x = c(xmin, xmax), y = c(ymin, ymax))) data <- coord$transform(corners, panel_params) x_rng <- range(data$x, na.rm = TRUE) diff --git a/R/annotation.r b/R/annotation.r index a98439ed1b..e03368ba32 100644 --- a/R/annotation.r +++ b/R/annotation.r @@ -54,7 +54,7 @@ annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL, stop("Unequal parameter lengths: ", details, call. = FALSE) } - data <- data.frame(position) + data <- new_data_frame(lapply(position, rep, length.out = max(lengths))) layer( geom = geom, params = list( diff --git a/R/coord-map.r b/R/coord-map.r index 69ca8d7593..30e6ec1964 100644 --- a/R/coord-map.r +++ b/R/coord-map.r @@ -248,10 +248,10 @@ CoordMap <- ggproto("CoordMap", Coord, )) } - x_intercept <- with(panel_params, data.frame( + x_intercept <- with(panel_params, new_data_frame(list( x = x.major, - y = y.range[1] - )) + y = rep(y.range[1], length(x.major)) + ))) pos <- self$transform(x_intercept, panel_params) axes <- list( @@ -272,10 +272,10 @@ CoordMap <- ggproto("CoordMap", Coord, )) } - x_intercept <- with(panel_params, data.frame( - x = x.range[1], + x_intercept <- with(panel_params, new_data_frame(list( + x = rep(x.range[1], length(y.major)), y = y.major - )) + ))) pos <- self$transform(x_intercept, panel_params) axes <- list( diff --git a/R/coord-munch.r b/R/coord-munch.r index c968bea6e2..d93be2cac6 100644 --- a/R/coord-munch.r +++ b/R/coord-munch.r @@ -60,7 +60,7 @@ munch_data <- function(data, dist = NULL, segment_length = 0.01) { id <- c(rep(seq_len(nrow(data) - 1), extra), nrow(data)) aes_df <- data[id, setdiff(names(data), c("x", "y")), drop = FALSE] - plyr::unrowname(data.frame(x = x, y = y, aes_df)) + new_data_frame(c(list(x = x, y = y), unclass(aes_df))) } # Interpolate. @@ -171,9 +171,9 @@ find_line_formula <- function(x, y) { slope <- diff(y) / diff(x) yintercept <- y[-1] - (slope * x[-1]) xintercept <- x[-1] - (y[-1] / slope) - data.frame(x1 = x[-length(x)], y1 = y[-length(y)], + new_data_frame(list(x1 = x[-length(x)], y1 = y[-length(y)], x2 = x[-1], y2 = y[-1], - slope = slope, yintercept = yintercept, xintercept = xintercept) + slope = slope, yintercept = yintercept, xintercept = xintercept)) } # Spiral arc length diff --git a/R/facet-.r b/R/facet-.r index 41a780d971..eb3abaa13a 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -494,10 +494,10 @@ find_panel <- function(table) { panels <- layout[grepl("^panel", layout$name), , drop = FALSE] new_data_frame(list( - t = min(panels$t), - r = max(panels$r), - b = max(panels$b), - l = min(panels$l) + t = min(.subset2(panels, "t")), + r = max(.subset2(panels, "r")), + b = max(.subset2(panels, "b")), + l = min(.subset2(panels, "l")) )) } #' @rdname find_panel diff --git a/R/fortify-map.r b/R/fortify-map.r index 8c53b0a396..a7e2f9a938 100644 --- a/R/fortify-map.r +++ b/R/fortify-map.r @@ -22,10 +22,12 @@ #' geom_polygon(aes(group = group), colour = "white") #' } fortify.map <- function(model, data, ...) { - df <- as.data.frame(model[c("x", "y")]) - names(df) <- c("long", "lat") - df$group <- cumsum(is.na(df$long) & is.na(df$lat)) + 1 - df$order <- 1:nrow(df) + df <- new_data_frame(list( + long = model$x, + lat = model$y, + group = cumsum(is.na(model$x) & is.na(model$y)) + 1, + order = seq_along(model$x) + )) names <- do.call("rbind", lapply(strsplit(model$names, "[:,]"), "[", 1:2)) df$region <- names[df$group, 1] diff --git a/R/geom-abline.r b/R/geom-abline.r index 1d5b88fc63..382a060065 100644 --- a/R/geom-abline.r +++ b/R/geom-abline.r @@ -84,8 +84,12 @@ geom_abline <- function(mapping = NULL, data = NULL, if (!missing(slope) || !missing(intercept)) { if (missing(slope)) slope <- 1 if (missing(intercept)) intercept <- 0 + n_slopes <- max(length(slope), length(intercept)) - data <- data.frame(intercept = intercept, slope = slope) + data <- new_data_frame(list( + intercept = rep(intercept, length.out = n_slopes), + slope = rep(slope, length.out = n_slopes) + )) mapping <- aes(intercept = intercept, slope = slope) show.legend <- FALSE } diff --git a/R/geom-boxplot.r b/R/geom-boxplot.r index c32d236739..25cd87369f 100644 --- a/R/geom-boxplot.r +++ b/R/geom-boxplot.r @@ -200,52 +200,53 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, outlier.alpha = NULL, notch = FALSE, notchwidth = 0.5, varwidth = FALSE) { - common <- data.frame( + common <- list( colour = data$colour, size = data$size, linetype = data$linetype, fill = alpha(data$fill, data$alpha), - group = data$group, - stringsAsFactors = FALSE + group = data$group ) - whiskers <- data.frame( - x = data$x, - xend = data$x, - y = c(data$upper, data$lower), - yend = c(data$ymax, data$ymin), - alpha = NA, - common, - stringsAsFactors = FALSE - ) + whiskers <- new_data_frame(c( + list( + x = c(data$x, data$x), + xend = c(data$x, data$x), + y = c(data$upper, data$lower), + yend = c(data$ymax, data$ymin), + alpha = c(NA_real_, NA_real_) + ), + lapply(common, rep, 2) + )) - box <- data.frame( - xmin = data$xmin, - xmax = data$xmax, - ymin = data$lower, - y = data$middle, - ymax = data$upper, - ynotchlower = ifelse(notch, data$notchlower, NA), - ynotchupper = ifelse(notch, data$notchupper, NA), - notchwidth = notchwidth, - alpha = data$alpha, - common, - stringsAsFactors = FALSE - ) + box <- new_data_frame(c( + list( + xmin = data$xmin, + xmax = data$xmax, + ymin = data$lower, + y = data$middle, + ymax = data$upper, + ynotchlower = ifelse(notch, data$notchlower, NA), + ynotchupper = ifelse(notch, data$notchupper, NA), + notchwidth = notchwidth, + alpha = data$alpha + ), + common + )) if (!is.null(data$outliers) && length(data$outliers[[1]] >= 1)) { - outliers <- data.frame( + n_out <- length(data$outliers[[1]]) + outliers <- new_data_frame(list( y = data$outliers[[1]], - x = data$x[1], - colour = outlier.colour %||% data$colour[1], - fill = outlier.fill %||% data$fill[1], - shape = outlier.shape %||% data$shape[1], - size = outlier.size %||% data$size[1], - stroke = outlier.stroke %||% data$stroke[1], - fill = NA, - alpha = outlier.alpha %||% data$alpha[1], - stringsAsFactors = FALSE - ) + x = rep(data$x[1], n_out), + colour = rep(outlier.colour %||% data$colour[1], n_out), + fill = rep(outlier.fill %||% data$fill[1], n_out), + shape = rep(outlier.shape %||% data$shape[1], n_out), + size = rep(outlier.size %||% data$size[1], n_out), + stroke = rep(outlier.stroke %||% data$stroke[1], n_out), + fill = rep(NA, n_out), + alpha = rep(outlier.alpha %||% data$alpha[1], n_out) + )) outliers_grob <- GeomPoint$draw_panel(outliers, panel_params, coord) } else { outliers_grob <- NULL diff --git a/R/geom-crossbar.r b/R/geom-crossbar.r index c7ae1863eb..0a901133d7 100644 --- a/R/geom-crossbar.r +++ b/R/geom-crossbar.r @@ -54,7 +54,7 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, middle$x <- middle$x + notchindent middle$xend <- middle$xend - notchindent - box <- data.frame( + box <- new_data_frame(list( x = c( data$xmin, data$xmin, data$xmin + notchindent, data$xmin, data$xmin, data$xmax, data$xmax, data$xmax - notchindent, data$xmax, data$xmax, @@ -65,26 +65,25 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, data$ymin, data$ynotchlower, data$y, data$ynotchupper, data$ymax, data$ymax ), - alpha = data$alpha, - colour = data$colour, - size = data$size, - linetype = data$linetype, fill = data$fill, - group = seq_len(nrow(data)), - stringsAsFactors = FALSE - ) + alpha = rep(data$alpha, 11), + colour = rep(data$colour, 11), + size = rep(data$size, 11), + linetype = rep(data$linetype, 11), + fill = rep(data$fill, 11), + group = rep(seq_len(nrow(data)), 11) + )) } else { # No notch - box <- data.frame( + box <- new_data_frame(list( x = c(data$xmin, data$xmin, data$xmax, data$xmax, data$xmin), y = c(data$ymax, data$ymin, data$ymin, data$ymax, data$ymax), - alpha = data$alpha, - colour = data$colour, - size = data$size, - linetype = data$linetype, - fill = data$fill, - group = seq_len(nrow(data)), # each bar forms it's own group - stringsAsFactors = FALSE - ) + alpha = rep(data$alpha, 5), + colour = rep(data$colour, 5), + size = rep(data$size, 5), + linetype = rep(data$linetype, 5), + fill = rep(data$fill, 5), + group = rep(seq_len(nrow(data)), 5) # each bar forms it's own group + )) } ggname("geom_crossbar", gTree(children = gList( diff --git a/R/geom-errorbar.r b/R/geom-errorbar.r index f6cfb76cc4..d6d41e2e10 100644 --- a/R/geom-errorbar.r +++ b/R/geom-errorbar.r @@ -43,7 +43,7 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, }, draw_panel = function(data, panel_params, coord, width = NULL) { - GeomPath$draw_panel(data.frame( + GeomPath$draw_panel(new_data_frame(list( x = as.vector(rbind(data$xmin, data$xmax, NA, data$x, data$x, NA, data$xmin, data$xmax)), y = as.vector(rbind(data$ymax, data$ymax, NA, data$ymax, data$ymin, NA, data$ymin, data$ymin)), colour = rep(data$colour, each = 8), @@ -53,6 +53,6 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, group = rep(1:(nrow(data)), each = 8), stringsAsFactors = FALSE, row.names = 1:(nrow(data) * 8) - ), panel_params, coord) + )), panel_params, coord) } ) diff --git a/R/geom-errorbarh.r b/R/geom-errorbarh.r index 40ed876579..e23898d12e 100644 --- a/R/geom-errorbarh.r +++ b/R/geom-errorbarh.r @@ -65,7 +65,7 @@ GeomErrorbarh <- ggproto("GeomErrorbarh", Geom, }, draw_panel = function(data, panel_params, coord, height = NULL) { - GeomPath$draw_panel(data.frame( + GeomPath$draw_panel(new_data_frame(list( x = as.vector(rbind(data$xmax, data$xmax, NA, data$xmax, data$xmin, NA, data$xmin, data$xmin)), y = as.vector(rbind(data$ymin, data$ymax, NA, data$y, data$y, NA, data$ymin, data$ymax)), colour = rep(data$colour, each = 8), @@ -73,8 +73,7 @@ GeomErrorbarh <- ggproto("GeomErrorbarh", Geom, size = rep(data$size, each = 8), linetype = rep(data$linetype, each = 8), group = rep(1:(nrow(data)), each = 8), - stringsAsFactors = FALSE, row.names = 1:(nrow(data) * 8) - ), panel_params, coord) + )), panel_params, coord) } ) diff --git a/R/geom-path.r b/R/geom-path.r index 51a56256bb..c424dbe737 100644 --- a/R/geom-path.r +++ b/R/geom-path.r @@ -162,10 +162,10 @@ GeomPath <- ggproto("GeomPath", Geom, # Work out whether we should use lines or segments attr <- plyr::ddply(munched, "group", function(df) { linetype <- unique(df$linetype) - data.frame( + new_data_Frame(list( solid = identical(linetype, 1) || identical(linetype, "solid"), constant = nrow(unique(df[, c("alpha", "colour","size", "linetype")])) == 1 - ) + )) }) solid_lines <- all(attr$solid) constant <- all(attr$constant) @@ -321,9 +321,11 @@ stairstep <- function(data, direction="hv") { xs <- c(1, rep(2:n, each = 2)) } - data.frame( - x = data$x[xs], - y = data$y[ys], + new_data_frame(c( + list( + x = data$x[xs], + y = data$y[ys] + ), data[xs, setdiff(names(data), c("x", "y"))] - ) + )) } diff --git a/R/geom-vline.r b/R/geom-vline.r index 1b6668976d..3bfd2704c1 100644 --- a/R/geom-vline.r +++ b/R/geom-vline.r @@ -11,7 +11,7 @@ geom_vline <- function(mapping = NULL, data = NULL, # Act like an annotation if (!missing(xintercept)) { - data <- data.frame(xintercept = xintercept) + data <- new_data_frame(list(xintercept = xintercept)) mapping <- aes(xintercept = xintercept) show.legend <- FALSE } diff --git a/R/guide-colorbar.r b/R/guide-colorbar.r index d57e3342c9..1234e7924f 100644 --- a/R/guide-colorbar.r +++ b/R/guide-colorbar.r @@ -210,7 +210,7 @@ guide_train.colorbar <- function(guide, scale, aesthetic = NULL) { if (length(breaks) == 0 || all(is.na(breaks))) return() - ticks <- as.data.frame(setNames(list(scale$map(breaks)), aesthetic %||% scale$aesthetics[1])) + ticks <- new_data_frame(setNames(list(scale$map(breaks)), aesthetic %||% scale$aesthetics[1])) ticks$.value <- breaks ticks$.label <- scale$get_labels(breaks) @@ -222,7 +222,7 @@ guide_train.colorbar <- function(guide, scale, aesthetic = NULL) { if (length(.bar) == 0) { .bar = unique(.limits) } - guide$bar <- data.frame(colour = scale$map(.bar), value = .bar, stringsAsFactors = FALSE) + guide$bar <- new_data_frame(list(colour = scale$map(.bar), value = .bar)) if (guide$reverse) { guide$key <- guide$key[nrow(guide$key):1, ] guide$bar <- guide$bar[nrow(guide$bar):1, ] diff --git a/R/hexbin.R b/R/hexbin.R index d92b9b6c57..daf359b037 100644 --- a/R/hexbin.R +++ b/R/hexbin.R @@ -34,7 +34,7 @@ hexBinSummarise <- function(x, y, z, binwidth, fun = mean, fun.args = list(), dr value <- do.call(tapply, c(list(quote(z), quote(hb@cID), quote(fun)), fun.args)) # Convert to data frame - out <- as.data.frame(hexbin::hcell2xy(hb)) + out <- new_data_frame(hexbin::hcell2xy(hb)) out$value <- as.vector(value) if (drop) out <- stats::na.omit(out) diff --git a/R/limits.r b/R/limits.r index 64422bda93..0bc5427960 100644 --- a/R/limits.r +++ b/R/limits.r @@ -143,7 +143,10 @@ limits.POSIXlt <- function(lims, var) { #' geom_point(aes(colour = factor(cyl))) + #' expand_limits(colour = factor(seq(2, 10, by = 2))) expand_limits <- function(...) { - data <- data.frame(..., stringsAsFactors = FALSE) + data <- list(...) + n_rows <- max(lengths(data)) + data <- lapply(data, rep, length.out = n_rows) + data <- new_data_frame(data) geom_blank(aes_all(names(data)), data, inherit.aes = FALSE) } diff --git a/R/stat-bindot.r b/R/stat-bindot.r index e4b5ae43f8..31c6913ab8 100644 --- a/R/stat-bindot.r +++ b/R/stat-bindot.r @@ -136,7 +136,7 @@ StatBindot <- ggproto("StatBindot", Stat, # It returns a data frame with the original data (x), weights, bin #, and the bin centers. densitybin <- function(x, weight = NULL, binwidth = NULL, method = method, range = NULL) { - if (length(stats::na.omit(x)) == 0) return(data.frame()) + if (length(stats::na.omit(x)) == 0) return(new_data_frame()) if (is.null(weight)) weight <- rep(1, length(x)) weight[is.na(weight)] <- 0 @@ -162,7 +162,12 @@ densitybin <- function(x, weight = NULL, binwidth = NULL, method = method, range bin[i] <- cbin } - results <- data.frame(x, bin, binwidth, weight) + results <- new_data_frame(list( + x = x, + bin = bin, + binwidth = rep(binwidth, length(x)), + weight = weight + )) results <- plyr::ddply(results, "bin", function(df) { df$bincenter = (min(df$x) + max(df$x)) / 2 return(df) diff --git a/R/stat-boxplot.r b/R/stat-boxplot.r index 3f30cc15e0..618d57e99c 100644 --- a/R/stat-boxplot.r +++ b/R/stat-boxplot.r @@ -87,7 +87,7 @@ StatBoxplot <- ggproto("StatBoxplot", Stat, if (length(unique(data$x)) > 1) width <- diff(range(data$x)) * 0.9 - df <- as.data.frame(as.list(stats)) + df <- new_data_frame(as.list(stats)) df$outliers <- list(data$y[outliers]) if (is.null(data$weight)) { diff --git a/R/stat-contour.r b/R/stat-contour.r index 1d6d36728b..9bd15eb785 100644 --- a/R/stat-contour.r +++ b/R/stat-contour.r @@ -79,7 +79,7 @@ contour_lines <- function(data, breaks, complete = FALSE) { if (length(cl) == 0) { warning("Not possible to generate contour data", call. = FALSE) - return(data.frame()) + return(new_data_frame()) } # Convert list of lists into single data frame @@ -91,14 +91,14 @@ contour_lines <- function(data, breaks, complete = FALSE) { # Add leading zeros so that groups can be properly sorted later groups <- paste(data$group[1], sprintf("%03d", pieces), sep = "-") - data.frame( + new_data_frame(list( level = rep(levels, lengths), nlevel = rep(levels, lengths) / max(rep(levels, lengths), na.rm = TRUE), x = xs, y = ys, piece = pieces, group = groups - ) + )) } # 1 = clockwise, -1 = counterclockwise, 0 = 0 area diff --git a/R/stat-density-2d.r b/R/stat-density-2d.r index 8737c128af..2bd736833a 100644 --- a/R/stat-density-2d.r +++ b/R/stat-density-2d.r @@ -65,7 +65,8 @@ StatDensity2d <- ggproto("StatDensity2d", Stat, data$x, data$y, h = h, n = n, lims = c(scales$x$dimension(), scales$y$dimension()) ) - df <- data.frame(expand.grid(x = dens$x, y = dens$y), z = as.vector(dens$z)) + df <- expand.grid(x = dens$x, y = dens$y) + df$z <- as.vector(dens$z) df$group <- data$group[1] if (contour) { diff --git a/R/stat-density.r b/R/stat-density.r index 8f92ebdeec..aa5f105804 100644 --- a/R/stat-density.r +++ b/R/stat-density.r @@ -90,25 +90,25 @@ compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, # if less than 2 points return data frame of NAs and a warning if (nx < 2) { warning("Groups with fewer than two data points have been dropped.", call. = FALSE) - return(data.frame( + return(new_data_frame(list( x = NA_real_, density = NA_real_, scaled = NA_real_, ndensity = NA_real_, count = NA_real_, n = NA_integer_ - )) + ))) } dens <- stats::density(x, weights = w, bw = bw, adjust = adjust, kernel = kernel, n = n, from = from, to = to) - data.frame( + new_data_frame(list( x = dens$x, density = dens$y, scaled = dens$y / max(dens$y, na.rm = TRUE), ndensity = dens$y / max(dens$y, na.rm = TRUE), count = dens$y * nx, - n = nx - ) + n = rep(nx, length(dens$x)) + )) } diff --git a/R/stat-ecdf.r b/R/stat-ecdf.r index 71b3d40f2d..aff3853842 100644 --- a/R/stat-ecdf.r +++ b/R/stat-ecdf.r @@ -77,7 +77,7 @@ StatEcdf <- ggproto("StatEcdf", Stat, } y <- ecdf(data$x)(x) - data.frame(x = x, y = y) + new_data_frame(list(x = x, y = y)) }, default_aes = aes(y = stat(y)), diff --git a/R/stat-ellipse.R b/R/stat-ellipse.R index 1b36f32208..0102a593a5 100644 --- a/R/stat-ellipse.R +++ b/R/stat-ellipse.R @@ -113,7 +113,6 @@ calculate_ellipse <- function(data, vars, type, level, segments){ ellipse <- t(center + radius * t(unit.circle %*% chol_decomp)) } - ellipse <- as.data.frame(ellipse) colnames(ellipse) <- vars - ellipse + mat_2_df(ellipse) } diff --git a/R/stat-qq.r b/R/stat-qq.r index 2ef52635ba..ef30ba550f 100644 --- a/R/stat-qq.r +++ b/R/stat-qq.r @@ -99,6 +99,6 @@ StatQq <- ggproto("StatQq", Stat, theoretical <- do.call(distribution, c(list(p = quote(quantiles)), dparams)) - data.frame(sample, theoretical) + new_data_frame(list(sample = sample, theoretical = theoretical)) } ) diff --git a/R/stat-quantile.r b/R/stat-quantile.r index a68f816633..93389d5d5e 100644 --- a/R/stat-quantile.r +++ b/R/stat-quantile.r @@ -71,7 +71,7 @@ StatQuantile <- ggproto("StatQuantile", Stat, xmax <- max(data$x, na.rm = TRUE) xseq <- seq(xmin, xmax, length.out = 100) } - grid <- data.frame(x = xseq) + grid <- new_data_frame(list(x = xseq)) method <- match.fun(method) diff --git a/R/stat-smooth-methods.r b/R/stat-smooth-methods.r index 43ebf62947..acf48eec54 100644 --- a/R/stat-smooth-methods.r +++ b/R/stat-smooth-methods.r @@ -10,7 +10,7 @@ predictdf <- function(model, xseq, se, level) UseMethod("predictdf") #' @export predictdf.default <- function(model, xseq, se, level) { - pred <- stats::predict(model, newdata = data.frame(x = xseq), se.fit = se, + pred <- stats::predict(model, newdata = new_data_frame(list(x = xseq)), se.fit = se, level = level, interval = if (se) "confidence" else "none") if (se) { diff --git a/R/stat-smooth.r b/R/stat-smooth.r index 06e20fc9a2..fecc2842e1 100644 --- a/R/stat-smooth.r +++ b/R/stat-smooth.r @@ -106,7 +106,7 @@ StatSmooth <- ggproto("StatSmooth", Stat, na.rm = FALSE) { if (length(unique(data$x)) < 2) { # Not enough data to perform fit - return(data.frame()) + return(new_data_frame()) } if (is.null(data$weight)) data$weight <- 1 diff --git a/R/stat-summary-bin.R b/R/stat-summary-bin.R index 201f16d9f6..77ef6a86f5 100644 --- a/R/stat-summary-bin.R +++ b/R/stat-summary-bin.R @@ -86,11 +86,11 @@ make_summary_fun <- function(fun.data, fun.y, fun.ymax, fun.ymin, fun.args) { } function(df, ...) { - data.frame( + new_data_frame(list( ymin = call_f(fun.ymin, df$y), y = call_f(fun.y, df$y), ymax = call_f(fun.ymax, df$y) - ) + )) } } else { message("No summary function supplied, defaulting to `mean_se()") diff --git a/R/stat-summary.r b/R/stat-summary.r index b20f6138d8..0e9b108bce 100644 --- a/R/stat-summary.r +++ b/R/stat-summary.r @@ -202,7 +202,7 @@ wrap_hmisc <- function(fun) { result <- do.call(fun, list(x = quote(x), ...)) plyr::rename( - data.frame(t(result)), + new_data_frame(as.list(result)), c(Median = "y", Mean = "y", Lower = "ymin", Upper = "ymax"), warn_missing = FALSE ) @@ -236,5 +236,5 @@ mean_se <- function(x, mult = 1) { x <- stats::na.omit(x) se <- mult * sqrt(stats::var(x) / length(x)) mean <- mean(x) - data.frame(y = mean, ymin = mean - se, ymax = mean + se) + new_data_frame(list(y = mean, ymin = mean - se, ymax = mean + se)) } diff --git a/R/stat-ydensity.r b/R/stat-ydensity.r index bc1d7305e9..6f3769c61e 100644 --- a/R/stat-ydensity.r +++ b/R/stat-ydensity.r @@ -62,7 +62,7 @@ StatYdensity <- ggproto("StatYdensity", Stat, compute_group = function(data, scales, width = NULL, bw = "nrd0", adjust = 1, kernel = "gaussian", trim = TRUE, na.rm = FALSE) { - if (nrow(data) < 3) return(data.frame()) + if (nrow(data) < 3) return(new_data_frame()) range <- range(data$y, na.rm = TRUE) modifier <- if (trim) 0 else 3 bw <- calc_bw(data$y, bw) diff --git a/R/utilities.r b/R/utilities.r index 6086310d33..e7fe15253f 100644 --- a/R/utilities.r +++ b/R/utilities.r @@ -418,7 +418,7 @@ NULL # Check inputs with tibble but allow column vectors (see #2609 and #2374) as_gg_data_frame <- function(x) { x <- lapply(x, validate_column_vec) - as.data.frame(tibble::as_tibble(x)) + new_data_frame(tibble::as_tibble(x)) } validate_column_vec <- function(x) { if (is_column_vec(x)) { From 05d04840bc1c0700a027dd49125b7714d12247ec Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Fri, 9 Nov 2018 11:14:49 +0100 Subject: [PATCH 06/16] Last effort to squash data.frame() --- R/aaa-.r | 8 ++++---- R/annotation-logticks.r | 2 +- R/axis-secondary.R | 2 +- R/facet-grid-.r | 7 +++---- R/geom-hline.r | 2 +- R/geom-path.r | 2 +- R/geom-rect.r | 4 ++-- R/geom-violin.r | 4 ++-- R/guide-legend.r | 7 +++---- R/limits.r | 2 ++ R/stat-count.r | 6 +++--- R/stat-function.r | 4 ++-- R/stat-qq-line.R | 2 +- man/ggplot2-package.Rd | 1 + 14 files changed, 27 insertions(+), 26 deletions(-) diff --git a/R/aaa-.r b/R/aaa-.r index c07a085694..5375164cc1 100644 --- a/R/aaa-.r +++ b/R/aaa-.r @@ -31,10 +31,10 @@ validate_data_frame <- function(x) { if (is.null(names(x))) stop('Columns must be named', call. = FALSE) } -mat_2_df <- function(x, .check = FALSE) { - c_names <- colnames(x) - x <- split(x, rep(seq_len(ncol(x))), each = nrow(x)) - names(x) <- c_names +mat_2_df <- function(x, col_names = NULL, .check = FALSE) { + if (is.null(col_names)) col_names <- colnames(x) + x <- split(x, rep(seq_len(ncol(x)), each = nrow(x))) + if (!is.null(col_names)) names(x) <- col_names new_data_frame(x) } diff --git a/R/annotation-logticks.r b/R/annotation-logticks.r index e4980649c8..caf5cc06b6 100644 --- a/R/annotation-logticks.r +++ b/R/annotation-logticks.r @@ -238,7 +238,7 @@ calc_logticks <- function(base = 10, ticks_per_base = base - 1, longtick_after_base <- floor(ticks_per_base/2) tickend[ cycleIdx == longtick_after_base ] <- midend - tickdf <- data.frame(value = ticks, start = start, end = tickend) + tickdf <- new_data_frame(list(value = ticks, start = rep(start, length(ticks)), end = tickend)) return(tickdf) } diff --git a/R/axis-secondary.R b/R/axis-secondary.R index ebd7e58da1..e81d0eebd6 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -140,7 +140,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, }, transform_range = function(self, range) { - range <- structure(data.frame(range), names = '.') + range <- new_data_frame(list("." = range)) rlang::eval_tidy( rlang::f_rhs(self$trans), data = range, diff --git a/R/facet-grid-.r b/R/facet-grid-.r index 75d71b27ab..98fff5e346 100644 --- a/R/facet-grid-.r +++ b/R/facet-grid-.r @@ -232,11 +232,10 @@ FacetGrid <- ggproto("FacetGrid", Facet, panel <- plyr::id(base, drop = TRUE) panel <- factor(panel, levels = seq_len(attr(panel, "n"))) - rows <- if (!length(names(rows))) 1L else plyr::id(base[names(rows)], drop = TRUE) - cols <- if (!length(names(cols))) 1L else plyr::id(base[names(cols)], drop = TRUE) + rows <- if (!length(names(rows))) rep(1L, length(panel)) else plyr::id(base[names(rows)], drop = TRUE) + cols <- if (!length(names(cols))) rep(1L, length(panel)) else plyr::id(base[names(cols)], drop = TRUE) - panels <- data.frame(PANEL = panel, ROW = rows, COL = cols, base, - check.names = FALSE, stringsAsFactors = FALSE) + panels <- new_data_frame(c(list(PANEL = panel, ROW = rows, COL = cols), base)) panels <- panels[order(panels$PANEL), , drop = FALSE] rownames(panels) <- NULL diff --git a/R/geom-hline.r b/R/geom-hline.r index a067c5b77c..85bba6e67a 100644 --- a/R/geom-hline.r +++ b/R/geom-hline.r @@ -11,7 +11,7 @@ geom_hline <- function(mapping = NULL, data = NULL, # Act like an annotation if (!missing(yintercept)) { - data <- data.frame(yintercept = yintercept) + data <- new_data_frame(list(yintercept = yintercept)) mapping <- aes(yintercept = yintercept) show.legend <- FALSE } diff --git a/R/geom-path.r b/R/geom-path.r index c424dbe737..72886e3e13 100644 --- a/R/geom-path.r +++ b/R/geom-path.r @@ -162,7 +162,7 @@ GeomPath <- ggproto("GeomPath", Geom, # Work out whether we should use lines or segments attr <- plyr::ddply(munched, "group", function(df) { linetype <- unique(df$linetype) - new_data_Frame(list( + new_data_frame(list( solid = identical(linetype, 1) || identical(linetype, "solid"), constant = nrow(unique(df[, c("alpha", "colour","size", "linetype")])) == 1 )) diff --git a/R/geom-rect.r b/R/geom-rect.r index 1d132d4215..155f365425 100644 --- a/R/geom-rect.r +++ b/R/geom-rect.r @@ -74,8 +74,8 @@ GeomRect <- ggproto("GeomRect", Geom, # # @keyword internal rect_to_poly <- function(xmin, xmax, ymin, ymax) { - data.frame( + new_data_frame(list( y = c(ymax, ymax, ymin, ymin, ymax), x = c(xmin, xmax, xmax, xmin, xmin) - ) + )) } diff --git a/R/geom-violin.r b/R/geom-violin.r index 81a677a504..44e92d9c1f 100644 --- a/R/geom-violin.r +++ b/R/geom-violin.r @@ -171,10 +171,10 @@ create_quantile_segment_frame <- function(data, draw_quantiles) { violin.xmaxvs <- (stats::approxfun(data$y, data$xmaxv))(ys) # We have two rows per segment drawn. Each segment gets its own group. - data.frame( + new_data_frame(list( x = interleave(violin.xminvs, violin.xmaxvs), y = rep(ys, each = 2), group = rep(ys, each = 2) - ) + )) } diff --git a/R/guide-legend.r b/R/guide-legend.r index a507b886c6..64a2d15895 100644 --- a/R/guide-legend.r +++ b/R/guide-legend.r @@ -443,13 +443,12 @@ guide_gengrob.legend <- function(guide, theme) { ) if (guide$byrow) { - vps <- data.frame( + vps <- new_data_frame(list( R = ceiling(seq(nbreak) / legend.ncol), C = (seq(nbreak) - 1) %% legend.ncol + 1 - ) + )) } else { - vps <- as.data.frame(arrayInd(seq(nbreak), dim(key_sizes))) - names(vps) <- c("R", "C") + vps <- mat_2_df(arrayInd(seq(nbreak), dim(key_sizes)), c("R", "C")) } # layout of key-label depends on the direction of the guide diff --git a/R/limits.r b/R/limits.r index 0bc5427960..71d970dfad 100644 --- a/R/limits.r +++ b/R/limits.r @@ -144,6 +144,8 @@ limits.POSIXlt <- function(lims, var) { #' expand_limits(colour = factor(seq(2, 10, by = 2))) expand_limits <- function(...) { data <- list(...) + data_dfs <- vapply(data, is.data.frame, logical(1)) + data <- do.call(c, c(list(data[!data_dfs]), data[data_dfs])) n_rows <- max(lengths(data)) data <- lapply(data, rep, length.out = n_rows) data <- new_data_frame(data) diff --git a/R/stat-count.r b/R/stat-count.r index 48b16b772f..fcf16ce40e 100644 --- a/R/stat-count.r +++ b/R/stat-count.r @@ -64,11 +64,11 @@ StatCount <- ggproto("StatCount", Stat, count <- as.numeric(tapply(weight, x, sum, na.rm = TRUE)) count[is.na(count)] <- 0 - data.frame( + new_data_frame(list( count = count, prop = count / sum(abs(count)), x = sort(unique(x)), - width = width - ) + width = rep(width, length.out = length(count)) + )) } ) diff --git a/R/stat-function.r b/R/stat-function.r index 756f49fad1..15df7e166e 100644 --- a/R/stat-function.r +++ b/R/stat-function.r @@ -97,9 +97,9 @@ StatFunction <- ggproto("StatFunction", Stat, x_trans <- scales$x$trans$inverse(xseq) } - data.frame( + new_data_frame(list( x = xseq, y = do.call(fun, c(list(quote(x_trans)), args)) - ) + )) } ) diff --git a/R/stat-qq-line.R b/R/stat-qq-line.R index 10a7b21f6a..b577fb96eb 100644 --- a/R/stat-qq-line.R +++ b/R/stat-qq-line.R @@ -90,6 +90,6 @@ StatQqLine <- ggproto("StatQqLine", Stat, x <- range(theoretical) } - data.frame(x = x, y = slope * x + intercept) + new_data_frame(list(x = x, y = slope * x + intercept)) } ) diff --git a/man/ggplot2-package.Rd b/man/ggplot2-package.Rd index fa4b8c429e..8f94867dcc 100644 --- a/man/ggplot2-package.Rd +++ b/man/ggplot2-package.Rd @@ -33,6 +33,7 @@ Authors: \item Kohske Takahashi \item Claus Wilke \item Kara Woo + \item Hiroaki Yutani } Other contributors: From 47ef11da8af97c248949653ce163051952ecbff0 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Fri, 9 Nov 2018 11:45:51 +0100 Subject: [PATCH 07/16] memoise by the current device as well --- R/margins.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/margins.R b/R/margins.R index 17b85c6c9c..676685c6a5 100644 --- a/R/margins.R +++ b/R/margins.R @@ -330,7 +330,8 @@ rotate_just <- function(angle, hjust, vjust) { } descent_cache <- new.env(parent = emptyenv()) font_descent <- function(family = "", face = "plain", size = 12, cex = 1) { - key <- paste0(family, ':', face, ":", size, ":", cex) + cur_dev <- names(dev.cur()) + key <- paste0(cur_dev, ':', family, ':', face, ":", size, ":", cex) descent <- descent_cache[[key]] From 72c351f5e7efde7b8f72ed2d5d26fc5a5cb17ac6 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Fri, 9 Nov 2018 13:34:31 +0100 Subject: [PATCH 08/16] import dev.cur --- DESCRIPTION | 3 ++- R/margins.R | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 48df3a3a5f..9f0ab172dd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,7 +31,8 @@ Imports: stats, tibble, viridisLite, - withr (>= 2.0.0) + withr (>= 2.0.0), + grDevices Suggests: covr, dplyr, diff --git a/R/margins.R b/R/margins.R index 676685c6a5..4ddfe6135a 100644 --- a/R/margins.R +++ b/R/margins.R @@ -330,7 +330,7 @@ rotate_just <- function(angle, hjust, vjust) { } descent_cache <- new.env(parent = emptyenv()) font_descent <- function(family = "", face = "plain", size = 12, cex = 1) { - cur_dev <- names(dev.cur()) + cur_dev <- names(grDevices::dev.cur()) key <- paste0(cur_dev, ':', family, ':', face, ":", size, ":", cex) descent <- descent_cache[[key]] From a3bee4d734a16e1e85957cd1f2318430c41c7354 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Fri, 9 Nov 2018 13:49:09 +0100 Subject: [PATCH 09/16] Remove tibble() where relevant --- R/facet-null.r | 4 ++-- R/guide-legend.r | 3 +-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/R/facet-null.r b/R/facet-null.r index 04abc3e9fd..21ac598791 100644 --- a/R/facet-null.r +++ b/R/facet-null.r @@ -30,10 +30,10 @@ FacetNull <- ggproto("FacetNull", Facet, # Need the is.waive check for special case where no data, but aesthetics # are mapped to vectors if (is.waive(data)) - return(tibble(PANEL = factor())) + return(new_data_frame(list(PANEL = factor()))) if (empty(data)) - return(cbind(data, PANEL = factor())) + return(new_data_frame(c(data, list(PANEL = factor())))) # Needs to be a factor to be consistent with other facet types data$PANEL <- factor(1) diff --git a/R/guide-legend.r b/R/guide-legend.r index 64a2d15895..8596fbb592 100644 --- a/R/guide-legend.r +++ b/R/guide-legend.r @@ -206,8 +206,7 @@ guide_train.legend <- function(guide, scale, aesthetic = NULL) { # argument to this function or, as a fall back, the first in the vector # of possible aesthetics handled by the scale aes_column_name <- aesthetic %||% scale$aesthetics[1] - # need to make a tibble here in case the scale returns a list column - key <- tibble(!!aes_column_name := scale$map(breaks)) + key <- new_data_frame(setNames(list(scale$map(breaks)), aes_column_name)) key$.label <- scale$get_labels(breaks) # Drop out-of-range values for continuous scale From 50d1a7d90ffaebe030922e2caa0756799a1c9c21 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Mon, 12 Nov 2018 15:19:27 +0100 Subject: [PATCH 10/16] Add description to vignette --- vignettes/profiling.Rmd | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/vignettes/profiling.Rmd b/vignettes/profiling.Rmd index 4e2a31b79c..e05afcc813 100644 --- a/vignettes/profiling.Rmd +++ b/vignettes/profiling.Rmd @@ -61,3 +61,9 @@ are summarised below: `grid::descentDetails()` to ensure that they are aligned across plots, but this is quite heavy. These calls are now cached so they only have to be calculated once per font setting. +- **Use a performant `data.frame` constructor throughout the codebase** The + `data.frame()` function carries a lot of overhead in order to sanitize and + check the input. This is generally not needed if you are sure about the input + 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. From 8606fff1050f436f72ac65cadf5ee41599a040a7 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Tue, 13 Nov 2018 11:12:28 +0100 Subject: [PATCH 11/16] Change data.frame constructor to do automatic recycling. Add data_frame version and guard data.frame --- R/aaa-.r | 15 +++++++++++++-- R/annotation-custom.r | 2 +- R/annotation-logticks.r | 2 +- R/annotation-raster.r | 2 +- R/annotation.r | 4 ++-- R/axis-secondary.R | 2 +- R/bench.r | 2 +- R/bin.R | 2 +- R/coord-map.r | 8 ++++---- R/facet-.r | 2 +- R/fortify-map.r | 2 +- R/fortify-multcomp.r | 8 ++++---- R/geom-abline.r | 6 +++--- R/geom-boxplot.r | 23 +++++++++++------------ R/geom-path.r | 2 +- R/guide-colorbar.r | 2 +- R/stat-bindot.r | 4 ++-- R/stat-contour.r | 2 +- R/stat-count.r | 4 ++-- R/stat-density.r | 6 +++--- R/stat-ecdf.r | 2 +- R/stat-smooth-methods.r | 22 +++++++++++----------- R/stat-summary.r | 2 +- R/utilities.r | 2 +- 24 files changed, 69 insertions(+), 59 deletions(-) diff --git a/R/aaa-.r b/R/aaa-.r index 5375164cc1..30b1490ca8 100644 --- a/R/aaa-.r +++ b/R/aaa-.r @@ -17,7 +17,10 @@ NULL # No checking, recycling etc. unless asked for new_data_frame <- function(x = list(), n = NULL) { if (is.null(n)) { - n <- if (length(x) == 0) 0 else length(x[[1]]) + n <- if (length(x) == 0) 0 else max(lengths(x)) + } + for (i in seq_along(x)) { + if (length(x[[i]]) != n) x[[i]] <- rep(x[[i]], length.out = n) } class(x) <- "data.frame" @@ -26,6 +29,14 @@ new_data_frame <- function(x = list(), n = NULL) { 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) +} + validate_data_frame <- function(x) { if (length(unique(lengths(x))) != 1) stop('All elements in a data.frame must be of equal length', call. = FALSE) if (is.null(names(x))) stop('Columns must be named', call. = FALSE) @@ -38,7 +49,7 @@ mat_2_df <- function(x, col_names = NULL, .check = FALSE) { new_data_frame(x) } -df_col <- .subset2 +df_col <- function(x, name) .subset2(x, name) df_rows <- function(x, i) { new_data_frame(lapply(x, `[`, i = i)) diff --git a/R/annotation-custom.r b/R/annotation-custom.r index 506bb15cde..c27f7c7d61 100644 --- a/R/annotation-custom.r +++ b/R/annotation-custom.r @@ -74,7 +74,7 @@ GeomCustomAnn <- ggproto("GeomCustomAnn", Geom, stop("annotation_custom only works with Cartesian coordinates", call. = FALSE) } - corners <- new_data_frame(list(x = c(xmin, xmax), y = c(ymin, ymax))) + corners <- new_data_frame(list(x = c(xmin, xmax), y = c(ymin, ymax)), n = 2) data <- coord$transform(corners, panel_params) x_rng <- range(data$x, na.rm = TRUE) diff --git a/R/annotation-logticks.r b/R/annotation-logticks.r index caf5cc06b6..a8e39ab109 100644 --- a/R/annotation-logticks.r +++ b/R/annotation-logticks.r @@ -238,7 +238,7 @@ calc_logticks <- function(base = 10, ticks_per_base = base - 1, longtick_after_base <- floor(ticks_per_base/2) tickend[ cycleIdx == longtick_after_base ] <- midend - tickdf <- new_data_frame(list(value = ticks, start = rep(start, length(ticks)), end = tickend)) + tickdf <- new_data_frame(list(value = ticks, start = rep(start, length(ticks)), end = tickend), n = length(ticks)) return(tickdf) } diff --git a/R/annotation-raster.r b/R/annotation-raster.r index e279d34a1b..1851831299 100644 --- a/R/annotation-raster.r +++ b/R/annotation-raster.r @@ -76,7 +76,7 @@ GeomRasterAnn <- ggproto("GeomRasterAnn", Geom, stop("annotation_raster only works with Cartesian coordinates", call. = FALSE) } - corners <- new_data_frame(list(x = c(xmin, xmax), y = c(ymin, ymax))) + corners <- new_data_frame(list(x = c(xmin, xmax), y = c(ymin, ymax)), n = 2) data <- coord$transform(corners, panel_params) x_rng <- range(data$x, na.rm = TRUE) diff --git a/R/annotation.r b/R/annotation.r index e03368ba32..e136ab8da2 100644 --- a/R/annotation.r +++ b/R/annotation.r @@ -45,7 +45,7 @@ annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL, aesthetics <- c(position, list(...)) # Check that all aesthetic have compatible lengths - lengths <- vapply(aesthetics, length, integer(1)) + lengths <- lengths(aesthetics) unequal <- length(unique(setdiff(lengths, 1L))) > 1L if (unequal) { bad <- lengths != 1L @@ -54,7 +54,7 @@ annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL, stop("Unequal parameter lengths: ", details, call. = FALSE) } - data <- new_data_frame(lapply(position, rep, length.out = max(lengths))) + data <- new_data_frame(position, n = max(lengths)) layer( geom = geom, params = list( diff --git a/R/axis-secondary.R b/R/axis-secondary.R index e81d0eebd6..28d5dccd0c 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -140,7 +140,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, }, transform_range = function(self, range) { - range <- new_data_frame(list("." = range)) + range <- new_data_frame(list(. = range)) rlang::eval_tidy( rlang::f_rhs(self$trans), data = range, diff --git a/R/bench.r b/R/bench.r index feca505844..48c8c0286f 100644 --- a/R/bench.r +++ b/R/bench.r @@ -23,7 +23,7 @@ benchplot <- function(x) { times <- rbind(construct, build, render, draw)[, 1:3] - plyr::unrowname(data.frame( + plyr::unrowname(base::data.frame( step = c("construct", "build", "render", "draw", "TOTAL"), rbind(times, colSums(times)))) } diff --git a/R/bin.R b/R/bin.R index 16b20bc815..654a01f98e 100644 --- a/R/bin.R +++ b/R/bin.R @@ -166,5 +166,5 @@ bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0), density = density, ncount = count / max(abs(count)), ndensity = density / max(abs(density)) - )) + ), n = length(count)) } diff --git a/R/coord-map.r b/R/coord-map.r index 30e6ec1964..fa507198b5 100644 --- a/R/coord-map.r +++ b/R/coord-map.r @@ -250,8 +250,8 @@ CoordMap <- ggproto("CoordMap", Coord, x_intercept <- with(panel_params, new_data_frame(list( x = x.major, - y = rep(y.range[1], length(x.major)) - ))) + y = y.range[1] + ), n = length(x.major))) pos <- self$transform(x_intercept, panel_params) axes <- list( @@ -273,9 +273,9 @@ CoordMap <- ggproto("CoordMap", Coord, } x_intercept <- with(panel_params, new_data_frame(list( - x = rep(x.range[1], length(y.major)), + x = x.range[1], y = y.major - ))) + ), n = length(y.major))) pos <- self$transform(x_intercept, panel_params) axes <- list( diff --git a/R/facet-.r b/R/facet-.r index eb3abaa13a..ba06f4b235 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -498,7 +498,7 @@ find_panel <- function(table) { r = max(.subset2(panels, "r")), b = max(.subset2(panels, "b")), l = min(.subset2(panels, "l")) - )) + ), n = 1) } #' @rdname find_panel #' @export diff --git a/R/fortify-map.r b/R/fortify-map.r index a7e2f9a938..e27331c233 100644 --- a/R/fortify-map.r +++ b/R/fortify-map.r @@ -27,7 +27,7 @@ fortify.map <- function(model, data, ...) { lat = model$y, group = cumsum(is.na(model$x) & is.na(model$y)) + 1, order = seq_along(model$x) - )) + ), n = length(model$x)) names <- do.call("rbind", lapply(strsplit(model$names, "[:,]"), "[", 1:2)) df$region <- names[df$group, 1] diff --git a/R/fortify-multcomp.r b/R/fortify-multcomp.r index b80f9b7762..ff054c0e72 100644 --- a/R/fortify-multcomp.r +++ b/R/fortify-multcomp.r @@ -33,7 +33,7 @@ NULL #' @rdname fortify-multcomp #' @export fortify.glht <- function(model, data, ...) { - plyr::unrowname(data.frame( + plyr::unrowname(base::data.frame( lhs = rownames(model$linfct), rhs = model$rhs, estimate = stats::coef(model), @@ -48,7 +48,7 @@ fortify.confint.glht <- function(model, data, ...) { coef <- model$confint colnames(coef) <- tolower(colnames(coef)) - plyr::unrowname(data.frame( + plyr::unrowname(base::data.frame( lhs = rownames(coef), rhs = model$rhs, coef, @@ -64,7 +64,7 @@ fortify.summary.glht <- function(model, data, ...) { model$test[c("coefficients", "sigma", "tstat", "pvalues")]) names(coef) <- c("estimate", "se", "t", "p") - plyr::unrowname(data.frame( + plyr::unrowname(base::data.frame( lhs = rownames(coef), rhs = model$rhs, coef, @@ -77,7 +77,7 @@ fortify.summary.glht <- function(model, data, ...) { #' @rdname fortify-multcomp #' @export fortify.cld <- function(model, data, ...) { - plyr::unrowname(data.frame( + plyr::unrowname(base::data.frame( lhs = names(model$mcletters$Letters), letters = model$mcletters$Letters, check.names = FALSE, diff --git a/R/geom-abline.r b/R/geom-abline.r index 382a060065..fc3b1250f1 100644 --- a/R/geom-abline.r +++ b/R/geom-abline.r @@ -87,9 +87,9 @@ geom_abline <- function(mapping = NULL, data = NULL, n_slopes <- max(length(slope), length(intercept)) data <- new_data_frame(list( - intercept = rep(intercept, length.out = n_slopes), - slope = rep(slope, length.out = n_slopes) - )) + intercept = intercept, + slope = slope + ), n = n_slopes) mapping <- aes(intercept = intercept, slope = slope) show.legend <- FALSE } diff --git a/R/geom-boxplot.r b/R/geom-boxplot.r index 25cd87369f..93e85a5710 100644 --- a/R/geom-boxplot.r +++ b/R/geom-boxplot.r @@ -216,8 +216,8 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, yend = c(data$ymax, data$ymin), alpha = c(NA_real_, NA_real_) ), - lapply(common, rep, 2) - )) + common + ), n = 2) box <- new_data_frame(c( list( @@ -235,18 +235,17 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, )) if (!is.null(data$outliers) && length(data$outliers[[1]] >= 1)) { - n_out <- length(data$outliers[[1]]) outliers <- new_data_frame(list( y = data$outliers[[1]], - x = rep(data$x[1], n_out), - colour = rep(outlier.colour %||% data$colour[1], n_out), - fill = rep(outlier.fill %||% data$fill[1], n_out), - shape = rep(outlier.shape %||% data$shape[1], n_out), - size = rep(outlier.size %||% data$size[1], n_out), - stroke = rep(outlier.stroke %||% data$stroke[1], n_out), - fill = rep(NA, n_out), - alpha = rep(outlier.alpha %||% data$alpha[1], n_out) - )) + x = data$x[1], + colour = outlier.colour %||% data$colour[1], + fill = outlier.fill %||% data$fill[1], + shape = outlier.shape %||% data$shape[1], + size = outlier.size %||% data$size[1], + stroke = outlier.stroke %||% data$stroke[1], + fill = NA, + alpha = outlier.alpha %||% data$alpha[1] + ), n = length(data$outliers[[1]])) outliers_grob <- GeomPoint$draw_panel(outliers, panel_params, coord) } else { outliers_grob <- NULL diff --git a/R/geom-path.r b/R/geom-path.r index 72886e3e13..1a222f5e76 100644 --- a/R/geom-path.r +++ b/R/geom-path.r @@ -165,7 +165,7 @@ GeomPath <- ggproto("GeomPath", Geom, new_data_frame(list( solid = identical(linetype, 1) || identical(linetype, "solid"), constant = nrow(unique(df[, c("alpha", "colour","size", "linetype")])) == 1 - )) + ), n = 1) }) solid_lines <- all(attr$solid) constant <- all(attr$constant) diff --git a/R/guide-colorbar.r b/R/guide-colorbar.r index 1234e7924f..bb5035e97b 100644 --- a/R/guide-colorbar.r +++ b/R/guide-colorbar.r @@ -222,7 +222,7 @@ guide_train.colorbar <- function(guide, scale, aesthetic = NULL) { if (length(.bar) == 0) { .bar = unique(.limits) } - guide$bar <- new_data_frame(list(colour = scale$map(.bar), value = .bar)) + guide$bar <- new_data_frame(list(colour = scale$map(.bar), value = .bar), n = length(.bar)) if (guide$reverse) { guide$key <- guide$key[nrow(guide$key):1, ] guide$bar <- guide$bar[nrow(guide$bar):1, ] diff --git a/R/stat-bindot.r b/R/stat-bindot.r index 31c6913ab8..23bfae1f37 100644 --- a/R/stat-bindot.r +++ b/R/stat-bindot.r @@ -165,9 +165,9 @@ densitybin <- function(x, weight = NULL, binwidth = NULL, method = method, range results <- new_data_frame(list( x = x, bin = bin, - binwidth = rep(binwidth, length(x)), + binwidth = binwidth, weight = weight - )) + ), n = length(x)) results <- plyr::ddply(results, "bin", function(df) { df$bincenter = (min(df$x) + max(df$x)) / 2 return(df) diff --git a/R/stat-contour.r b/R/stat-contour.r index 9bd15eb785..f23bc4681d 100644 --- a/R/stat-contour.r +++ b/R/stat-contour.r @@ -98,7 +98,7 @@ contour_lines <- function(data, breaks, complete = FALSE) { y = ys, piece = pieces, group = groups - )) + ), n = length(xs)) } # 1 = clockwise, -1 = counterclockwise, 0 = 0 area diff --git a/R/stat-count.r b/R/stat-count.r index fcf16ce40e..c08381d8c7 100644 --- a/R/stat-count.r +++ b/R/stat-count.r @@ -68,7 +68,7 @@ StatCount <- ggproto("StatCount", Stat, count = count, prop = count / sum(abs(count)), x = sort(unique(x)), - width = rep(width, length.out = length(count)) - )) + width = width + ), n = length(count)) } ) diff --git a/R/stat-density.r b/R/stat-density.r index aa5f105804..0fbd706c17 100644 --- a/R/stat-density.r +++ b/R/stat-density.r @@ -97,7 +97,7 @@ compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, ndensity = NA_real_, count = NA_real_, n = NA_integer_ - ))) + ), n = 1)) } dens <- stats::density(x, weights = w, bw = bw, adjust = adjust, @@ -109,6 +109,6 @@ compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, scaled = dens$y / max(dens$y, na.rm = TRUE), ndensity = dens$y / max(dens$y, na.rm = TRUE), count = dens$y * nx, - n = rep(nx, length(dens$x)) - )) + n = nx + ), n = length(dens$x)) } diff --git a/R/stat-ecdf.r b/R/stat-ecdf.r index aff3853842..274f96e47b 100644 --- a/R/stat-ecdf.r +++ b/R/stat-ecdf.r @@ -77,7 +77,7 @@ StatEcdf <- ggproto("StatEcdf", Stat, } y <- ecdf(data$x)(x) - new_data_frame(list(x = x, y = y)) + new_data_frame(list(x = x, y = y), n = length(x)) }, default_aes = aes(y = stat(y)), diff --git a/R/stat-smooth-methods.r b/R/stat-smooth-methods.r index acf48eec54..311958e16d 100644 --- a/R/stat-smooth-methods.r +++ b/R/stat-smooth-methods.r @@ -16,20 +16,20 @@ predictdf.default <- function(model, xseq, se, level) { if (se) { fit <- as.data.frame(pred$fit) names(fit) <- c("y", "ymin", "ymax") - data.frame(x = xseq, fit, se = pred$se.fit) + base::data.frame(x = xseq, fit, se = pred$se.fit) } else { - data.frame(x = xseq, y = as.vector(pred)) + base::data.frame(x = xseq, y = as.vector(pred)) } } #' @export predictdf.glm <- function(model, xseq, se, level) { - pred <- stats::predict(model, newdata = data.frame(x = xseq), se.fit = se, + pred <- stats::predict(model, newdata = data_frame(x = xseq), se.fit = se, type = "link") if (se) { std <- stats::qnorm(level / 2 + 0.5) - data.frame( + base::data.frame( x = xseq, y = model$family$linkinv(as.vector(pred$fit)), ymin = model$family$linkinv(as.vector(pred$fit - std * pred$se.fit)), @@ -37,35 +37,35 @@ predictdf.glm <- function(model, xseq, se, level) { se = as.vector(pred$se.fit) ) } else { - data.frame(x = xseq, y = model$family$linkinv(as.vector(pred))) + base::data.frame(x = xseq, y = model$family$linkinv(as.vector(pred))) } } #' @export predictdf.loess <- function(model, xseq, se, level) { - pred <- stats::predict(model, newdata = data.frame(x = xseq), se = se) + pred <- stats::predict(model, newdata = data_frame(x = xseq), se = se) if (se) { y = pred$fit ci <- pred$se.fit * stats::qt(level / 2 + .5, pred$df) ymin = y - ci ymax = y + ci - data.frame(x = xseq, y, ymin, ymax, se = pred$se.fit) + base::data.frame(x = xseq, y, ymin, ymax, se = pred$se.fit) } else { - data.frame(x = xseq, y = as.vector(pred)) + base::data.frame(x = xseq, y = as.vector(pred)) } } #' @export predictdf.locfit <- function(model, xseq, se, level) { - pred <- stats::predict(model, newdata = data.frame(x = xseq), se.fit = se) + pred <- stats::predict(model, newdata = data_frame(x = xseq), se.fit = se) if (se) { y = pred$fit ymin = y - pred$se.fit ymax = y + pred$se.fit - data.frame(x = xseq, y, ymin, ymax, se = pred$se.fit) + base::data.frame(x = xseq, y, ymin, ymax, se = pred$se.fit) } else { - data.frame(x = xseq, y = as.vector(pred)) + base::data.frame(x = xseq, y = as.vector(pred)) } } diff --git a/R/stat-summary.r b/R/stat-summary.r index 0e9b108bce..02f570fa0d 100644 --- a/R/stat-summary.r +++ b/R/stat-summary.r @@ -236,5 +236,5 @@ mean_se <- function(x, mult = 1) { x <- stats::na.omit(x) se <- mult * sqrt(stats::var(x) / length(x)) mean <- mean(x) - new_data_frame(list(y = mean, ymin = mean - se, ymax = mean + se)) + new_data_frame(list(y = mean, ymin = mean - se, ymax = mean + se), n = 1) } diff --git a/R/utilities.r b/R/utilities.r index e7fe15253f..1e2d687c93 100644 --- a/R/utilities.r +++ b/R/utilities.r @@ -393,7 +393,7 @@ find_args <- function(...) { # Used in annotations to ensure printed even when no # global data -dummy_data <- function() new_data_frame(list(x = NA)) +dummy_data <- function() new_data_frame(list(x = NA), n = 1) with_seed_null <- function(seed, code) { if (is.null(seed)) { From d3ccd4ce4e16d350d86a044ea03cfdad7eedc6d4 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Tue, 13 Nov 2018 11:12:49 +0100 Subject: [PATCH 12/16] Update tests to use data_frame instead of data.frame --- tests/testthat/test-aes-grouping.r | 2 +- tests/testthat/test-aes-setting.r | 6 +-- tests/testthat/test-aes.r | 4 +- tests/testthat/test-annotate.r | 2 +- tests/testthat/test-build.r | 4 +- tests/testthat/test-coord-.r | 2 +- tests/testthat/test-coord-cartesian.R | 4 +- tests/testthat/test-coord-polar.r | 8 ++-- tests/testthat/test-coord-transform.R | 4 +- tests/testthat/test-data.r | 4 +- tests/testthat/test-empty-data.r | 12 +++--- tests/testthat/test-facet-.r | 6 +-- tests/testthat/test-facet-labels.r | 2 +- tests/testthat/test-facet-layout.r | 14 +++---- tests/testthat/test-facet-map.r | 16 ++++---- tests/testthat/test-facet-strips.r | 4 +- tests/testthat/test-fortify.r | 2 +- tests/testthat/test-geom-bar.R | 2 +- tests/testthat/test-geom-boxplot.R | 6 +-- tests/testthat/test-geom-col.R | 2 +- tests/testthat/test-geom-dotplot.R | 8 ++-- tests/testthat/test-geom-freqpoly.R | 2 +- tests/testthat/test-geom-hex.R | 4 +- tests/testthat/test-geom-hline-vline-abline.R | 2 +- tests/testthat/test-geom-path.R | 4 +- tests/testthat/test-geom-raster.R | 6 +-- tests/testthat/test-geom-ribbon.R | 2 +- tests/testthat/test-geom-rug.R | 2 +- tests/testthat/test-geom-rule.R | 2 +- tests/testthat/test-geom-smooth.R | 12 +++--- tests/testthat/test-geom-tile.R | 4 +- tests/testthat/test-geom-violin.R | 12 +++--- tests/testthat/test-guides.R | 18 ++++----- tests/testthat/test-labels.r | 2 +- tests/testthat/test-layer.r | 4 +- tests/testthat/test-munch.r | 2 +- tests/testthat/test-position-dodge2.R | 10 ++--- tests/testthat/test-position-nudge.R | 4 +- tests/testthat/test-position-stack.R | 8 ++-- tests/testthat/test-position_dodge.R | 2 +- tests/testthat/test-qplot.r | 2 +- tests/testthat/test-scale-date.R | 2 +- tests/testthat/test-scale-discrete.R | 4 +- tests/testthat/test-scale-gradient.R | 2 +- tests/testthat/test-scale-manual.r | 8 ++-- tests/testthat/test-scale_date.R | 2 +- tests/testthat/test-scales-breaks-labels.r | 10 ++--- tests/testthat/test-scales.r | 40 +++++++++---------- tests/testthat/test-sec-axis.R | 6 +-- tests/testthat/test-stat-bin.R | 24 +++++------ tests/testthat/test-stat-bin2d.R | 6 +-- tests/testthat/test-stat-hex.R | 2 +- tests/testthat/test-stat-sf-coordinates.R | 12 +++--- tests/testthat/test-stats-function.r | 4 +- tests/testthat/test-stats.r | 2 +- tests/testthat/test-theme.r | 10 ++--- tests/testthat/test-utilities.r | 28 ++++++------- tests/testthat/test-viridis.R | 4 +- 58 files changed, 192 insertions(+), 192 deletions(-) diff --git a/tests/testthat/test-aes-grouping.r b/tests/testthat/test-aes-grouping.r index e407b74d8b..7d8a790248 100644 --- a/tests/testthat/test-aes-grouping.r +++ b/tests/testthat/test-aes-grouping.r @@ -1,6 +1,6 @@ context("Aesthetics (grouping)") -df <- data.frame( +df <- data_frame( x = 1:4, a = c("a", "a", "b", "b"), b = c("a", "b", "a", "b") diff --git a/tests/testthat/test-aes-setting.r b/tests/testthat/test-aes-setting.r index bbb3fe01c8..cae65767e3 100644 --- a/tests/testthat/test-aes-setting.r +++ b/tests/testthat/test-aes-setting.r @@ -1,7 +1,7 @@ context("Aes - setting values") test_that("aesthetic parameters match length of data", { - df <- data.frame(x = 1:5, y = 1:5) + df <- data_frame(x = 1:5, y = 1:5) p <- ggplot(df, aes(x, y)) set_colours <- function(colours) { @@ -16,7 +16,7 @@ test_that("aesthetic parameters match length of data", { }) test_that("legend filters out aesthetics not of length 1", { - df <- data.frame(x = 1:5, y = 1:5) + df <- data_frame(x = 1:5, y = 1:5) p <- ggplot(df, aes(x, y, colour = factor(x))) + geom_point(alpha = seq(0, 1, length = 5)) @@ -26,7 +26,7 @@ test_that("legend filters out aesthetics not of length 1", { }) test_that("alpha affects only fill colour of solid geoms", { - df <- data.frame(x = 1:2, y = 1) + df <- data_frame(x = 1:2, y = 1) poly <- ggplot(df, aes(x = x, y)) + geom_polygon(fill = "red", colour = "red", alpha = 0.5) diff --git a/tests/testthat/test-aes.r b/tests/testthat/test-aes.r index 0ce7c2e43e..a4be4bf1de 100644 --- a/tests/testthat/test-aes.r +++ b/tests/testthat/test-aes.r @@ -41,7 +41,7 @@ test_that("aes_all() converts strings into mappings", { }) test_that("aes evaluated in environment where plot created", { - df <- data.frame(x = 1, y = 1) + df <- data_frame(x = 1, y = 1) p <- ggplot(df, aes(foo, y)) + geom_point() # Accessing an undefined variable should result in error @@ -115,7 +115,7 @@ test_that("aes standardises aesthetic names", { # Visual tests ------------------------------------------------------------ test_that("aesthetics are drawn correctly", { - dat <- data.frame(xvar = letters[1:3], yvar = 7:9) + dat <- data_frame(xvar = letters[1:3], yvar = 7:9) expect_doppelganger("stat='identity'", ggplot(dat, aes(x = xvar, y = yvar)) + geom_bar(stat = "identity") diff --git a/tests/testthat/test-annotate.r b/tests/testthat/test-annotate.r index dd26c52682..b510c3ced2 100644 --- a/tests/testthat/test-annotate.r +++ b/tests/testthat/test-annotate.r @@ -20,7 +20,7 @@ test_that("dates in segment annotation work", { test_that("segment annotations transform with scales", { # Line should match data points - df <- data.frame(x = c(1, 10), y = c(10, 1)) + df <- data_frame(x = c(1, 10), y = c(10, 1)) plot <- ggplot(df, aes(x, y)) + geom_point() + annotate("segment", x = 1, y = 10, xend = 10, yend = 1, colour = "red") + diff --git a/tests/testthat/test-build.r b/tests/testthat/test-build.r index ac8d2c0122..4cd1e50878 100644 --- a/tests/testthat/test-build.r +++ b/tests/testthat/test-build.r @@ -1,7 +1,7 @@ # Test the complete path from plot specification to rendered data context("Plot building") -df <- data.frame(x = 1:3, y = 3:1, z = letters[1:3]) +df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) test_that("there is one data frame for each layer", { nlayers <- function(x) length(ggplot_build(x)$data) @@ -48,7 +48,7 @@ test_that("non-position aesthetics are mapped", { }) test_that("strings are not converted to factors", { - df <- data.frame(x = 1:2, y = 2:1, label = c("alpha", "beta"), stringsAsFactors = FALSE) + df <- data_frame(x = 1:2, y = 2:1, label = c("alpha", "beta"), stringsAsFactors = FALSE) p <- ggplot(df, aes(x, y)) + geom_text(aes(label = label), parse = TRUE) diff --git a/tests/testthat/test-coord-.r b/tests/testthat/test-coord-.r index 95d11ce657..f54d8749ff 100644 --- a/tests/testthat/test-coord-.r +++ b/tests/testthat/test-coord-.r @@ -8,7 +8,7 @@ test_that("clipping is on by default", { test_that("message when replacing non-default coordinate system", { - df <- data.frame(x = 1, y = 2) + df <- data_frame(x = 1, y = 2) gg <- ggplot(df, aes(x, y)) expect_message(gg + coord_cartesian(), NA) diff --git a/tests/testthat/test-coord-cartesian.R b/tests/testthat/test-coord-cartesian.R index 83a3b133ba..c81dbff143 100644 --- a/tests/testthat/test-coord-cartesian.R +++ b/tests/testthat/test-coord-cartesian.R @@ -31,14 +31,14 @@ test_that("cartesian coords draws correctly with limits", { }) test_that("cartesian coords draws correctly with clipping on or off", { - df.in <- data.frame(label = c("inside", "inside", "inside", "inside"), + df.in <- data_frame(label = c("inside", "inside", "inside", "inside"), x = c(0, 1, 0.5, 0.5), y = c(0.5, 0.5, 0, 1), angle = c(90, 270, 0, 0), hjust = c(0.5, 0.5, 0.5, 0.5), vjust = c(1.1, 1.1, -0.1, 1.1)) - df.out <- data.frame(label = c("outside", "outside", "outside", "outside"), + df.out <- data_frame(label = c("outside", "outside", "outside", "outside"), x = c(0, 1, 0.5, 0.5), y = c(0.5, 0.5, 0, 1), angle = c(90, 270, 0, 0), diff --git a/tests/testthat/test-coord-polar.r b/tests/testthat/test-coord-polar.r index c31b381d81..e800f0a206 100644 --- a/tests/testthat/test-coord-polar.r +++ b/tests/testthat/test-coord-polar.r @@ -1,7 +1,7 @@ context("coord_polar") test_that("polar distance is calculated correctly", { - dat <- data.frame( + dat <- data_frame( theta = c(0, 2*pi, 2, 6, 6, 1, 1, 0), r = c(0, 0, 0.5, 0.5, 1, 1, 0.75, .5)) @@ -75,7 +75,7 @@ test_that("polar coordinates draw correctly", { axis.title = element_blank(), panel.grid.major = element_line(colour = "grey90") ) - dat <- data.frame(x = 0:1, y = rep(c(1, 10, 40, 80), each = 2)) + dat <- data_frame(x = 0:1, y = rep(c(1, 10, 40, 80), each = 2)) expect_doppelganger("three-concentric-circles", ggplot(dat, aes(x, y, group = factor(y))) + @@ -84,7 +84,7 @@ test_that("polar coordinates draw correctly", { theme ) - dat <- data.frame( + dat <- data_frame( theta = c(0, 2*pi, 2, 6, 6, 1, 1, 0), r = c(0, 0, 0.5, 0.5, 1, 1, 0.75, .5), g = 1:8 @@ -97,7 +97,7 @@ test_that("polar coordinates draw correctly", { theme ) - dat <- data.frame(x = LETTERS[1:3], y = 1:3) + dat <- data_frame(x = LETTERS[1:3], y = 1:3) expect_doppelganger("rose plot with has equal spacing", ggplot(dat, aes(x, y)) + geom_bar(stat = "identity") + diff --git a/tests/testthat/test-coord-transform.R b/tests/testthat/test-coord-transform.R index 92044a52e2..5e089bc154 100644 --- a/tests/testthat/test-coord-transform.R +++ b/tests/testthat/test-coord-transform.R @@ -5,7 +5,7 @@ test_that("warnings are generated when cord_trans() results in new infinite valu geom_bar(aes(x = cut)) + coord_trans(y = "log10") - p2 <- ggplot(data.frame(a = c(1, 2, 0), b = c(10, 6, 4)), aes(a, b)) + + p2 <- ggplot(data_frame(a = c(1, 2, 0), b = c(10, 6, 4)), aes(a, b)) + geom_point() + coord_trans(x = "log") @@ -14,7 +14,7 @@ test_that("warnings are generated when cord_trans() results in new infinite valu }) test_that("no warnings are generated when original data has Inf values, but no new Inf values created from the transformation", { - p <- ggplot(data.frame(x = c(-Inf, 2, 0), y = c(Inf, 6, 4)), aes(x, y)) + + p <- ggplot(data_frame(x = c(-Inf, 2, 0), y = c(Inf, 6, 4)), aes(x, y)) + geom_point() + coord_trans(x = 'identity') diff --git a/tests/testthat/test-data.r b/tests/testthat/test-data.r index bf4635e2c8..83733e60e1 100644 --- a/tests/testthat/test-data.r +++ b/tests/testthat/test-data.r @@ -4,8 +4,8 @@ test_that("stringsAsFactors doesn't affect results", { old <- getOption("stringsAsFactors") on.exit(options(stringsAsFactors = old), add = TRUE) - dat.character <- data.frame(x = letters[5:1], y = 1:5, stringsAsFactors = FALSE) - dat.factor <- data.frame(x = letters[5:1], y = 1:5, stringsAsFactors = TRUE) + dat.character <- data_frame(x = letters[5:1], y = 1:5, stringsAsFactors = FALSE) + dat.factor <- data_frame(x = letters[5:1], y = 1:5, stringsAsFactors = TRUE) base <- ggplot(mapping = aes(x, y)) + geom_point() xlabels <- function(x) x$layout$panel_params[[1]]$x.labels diff --git a/tests/testthat/test-empty-data.r b/tests/testthat/test-empty-data.r index 6732cfd974..f465357268 100644 --- a/tests/testthat/test-empty-data.r +++ b/tests/testthat/test-empty-data.r @@ -1,6 +1,6 @@ context('Empty data') -df0 <- data.frame(mpg = numeric(0), wt = numeric(0), am = numeric(0), cyl = numeric(0)) +df0 <- data_frame(mpg = numeric(0), wt = numeric(0), am = numeric(0), cyl = numeric(0)) test_that("layers with empty data are silently omitted", { # Empty data (no visible points) @@ -24,7 +24,7 @@ test_that("plots with empty data and vectors for aesthetics work", { d <- ggplot(NULL, aes(1:5, 1:5)) + geom_point() expect_equal(nrow(layer_data(d)), 5) - d <- ggplot(data.frame(), aes(1:5, 1:5)) + geom_point() + d <- ggplot(data_frame(), aes(1:5, 1:5)) + geom_point() expect_equal(nrow(layer_data(d)), 5) d <- ggplot() + geom_point(aes(1:5, 1:5)) @@ -58,13 +58,13 @@ test_that("empty data overrides plot defaults", { # Should error when totally empty data frame because there's no x and y d <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + - geom_point(data = data.frame()) + geom_point(data = data_frame()) expect_error(layer_data(d), "not found") # No extra points when x and y vars don't exist but are set d <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + - geom_point(data = data.frame(), x = 20, y = 3) + geom_point(data = data_frame(), x = 20, y = 3) expect_equal(nrow(layer_data(d, 1)), nrow(mtcars)) expect_equal(nrow(layer_data(d, 2)), 0) @@ -83,7 +83,7 @@ test_that("layer inherits data from plot when data = NULL", { }) test_that("empty layers still generate one grob per panel", { - df <- data.frame(x = 1:3, y = c("a", "b", "c")) + df <- data_frame(x = 1:3, y = c("a", "b", "c")) d <- ggplot(df, aes(x, y)) + geom_point(data = df[0, ]) + @@ -94,7 +94,7 @@ test_that("empty layers still generate one grob per panel", { }) test_that("missing layers generate one grob per panel", { - df <- data.frame(x = 1:4, y = 1:2, g = 1:2) + df <- data_frame(x = 1:4, y = 1:2, g = 1:2) base <- ggplot(df, aes(x, y)) + geom_point(shape = NA, na.rm = TRUE) expect_equal(length(layer_grob(base)), 1) diff --git a/tests/testthat/test-facet-.r b/tests/testthat/test-facet-.r index 8a7d0ab79c..ed57f2e0b5 100644 --- a/tests/testthat/test-facet-.r +++ b/tests/testthat/test-facet-.r @@ -48,7 +48,7 @@ test_that("as_facets_list() coerces quosure lists", { }) -df <- data.frame(x = 1:3, y = 3:1, z = letters[1:3]) +df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) test_that("facets split up the data", { l1 <- ggplot(df, aes(x, y)) + geom_point() + facet_wrap(~z) @@ -154,7 +154,7 @@ test_that("facet variables", { }) test_that("facet gives clear error if ", { - df <- data.frame(x = 1) + df <- data_frame(x = 1) expect_error( print(ggplot(df, aes(x)) + facet_grid(x ~ x)), "row or cols, not both" @@ -166,7 +166,7 @@ test_that("facet gives clear error if ", { test_that("facet labels respect both justification and margin arguments", { - df <- data.frame( + df <- data_frame( x = 1:2, y = 1:2, z = c("a", "aaaaaaabc"), diff --git a/tests/testthat/test-facet-labels.r b/tests/testthat/test-facet-labels.r index 6a522465e0..ba87713197 100644 --- a/tests/testthat/test-facet-labels.r +++ b/tests/testthat/test-facet-labels.r @@ -150,7 +150,7 @@ test_that("old school labellers still work", { # Visual test ------------------------------------------------------------- test_that("parsed labels are rendered correctly", { - df <- data.frame(x = 1, y = 1, f = "alpha ^ beta") + df <- data_frame(x = 1, y = 1, f = "alpha ^ beta") expect_doppelganger( "parsed facet labels", diff --git a/tests/testthat/test-facet-layout.r b/tests/testthat/test-facet-layout.r index dc0b0dfb6e..c3cc9d139f 100644 --- a/tests/testthat/test-facet-layout.r +++ b/tests/testthat/test-facet-layout.r @@ -1,9 +1,9 @@ context("Facetting (layout)") -a <- data.frame(a = c(1, 1, 2, 2), b = c(1, 2, 1, 1)) -b <- data.frame(a = 3) -c <- data.frame(b = 3) -empty <- data.frame() +a <- data_frame(a = c(1, 1, 2, 2), b = c(1, 2, 1, 1)) +b <- data_frame(a = 3) +c <- data_frame(b = 3) +empty <- data_frame() panel_layout <- function(facet, data) { layout <- create_layout(facet) @@ -28,7 +28,7 @@ test_that("grid: single row and single col are equivalent", { }) test_that("grid: includes all combinations", { - d <- data.frame(a = c(1, 2), b = c(2, 1)) + d <- data_frame(a = c(1, 2), b = c(2, 1)) all <- panel_layout(facet_grid(a~b), list(d)) expect_equal(nrow(all), 4) @@ -92,7 +92,7 @@ test_that("grid: as.table reverses rows", { # Drop behaviour ------------------------------------------------------------- -a2 <- data.frame( +a2 <- data_frame( a = factor(1:3, levels = 1:4), b = factor(1:3, levels = 4:1) ) @@ -124,7 +124,7 @@ test_that("grid: drop = FALSE preserves unused levels", { # Missing behaviour ---------------------------------------------------------- -a3 <- data.frame( +a3 <- data_frame( a = c(1:3, NA), b = factor(c(1:3, NA)), c = factor(c(1:3, NA), exclude = NULL) diff --git a/tests/testthat/test-facet-map.r b/tests/testthat/test-facet-map.r index 045b1c4781..d7a99b79b8 100644 --- a/tests/testthat/test-facet-map.r +++ b/tests/testthat/test-facet-map.r @@ -3,7 +3,7 @@ context("Facetting (mapping)") df <- expand.grid(a = 1:2, b = 1:2) df_a <- unique(df["a"]) df_b <- unique(df["b"]) -df_c <- unique(data.frame(c = 1)) +df_c <- unique(data_frame(c = 1)) panel_map_one <- function(facet, data, plot_data = data) { layout <- create_layout(facet) @@ -61,7 +61,7 @@ test_that("wrap: missing facet columns are duplicated", { # Missing behaviour ---------------------------------------------------------- -a3 <- data.frame( +a3 <- data_frame( # a = c(1:3, NA), Not currently supported b = factor(c(1:3, NA)), c = factor(c(1:3, NA), exclude = NULL) @@ -69,21 +69,21 @@ a3 <- data.frame( test_that("wrap: missing values are located correctly", { facet <- facet_wrap(~b, ncol = 1) - loc_b <- panel_map_one(facet, data.frame(b = NA), plot_data = a3) + loc_b <- panel_map_one(facet, data_frame(b = NA), plot_data = a3) expect_equal(as.character(loc_b$PANEL), "4") facet <- facet_wrap(~c, ncol = 1) - loc_c <- panel_map_one(facet, data.frame(c = NA), plot_data = a3) + loc_c <- panel_map_one(facet, data_frame(c = NA), plot_data = a3) expect_equal(as.character(loc_c$PANEL), "4") }) test_that("grid: missing values are located correctly", { facet <- facet_grid(b~.) - loc_b <- panel_map_one(facet, data.frame(b = NA), plot_data = a3) + loc_b <- panel_map_one(facet, data_frame(b = NA), plot_data = a3) expect_equal(as.character(loc_b$PANEL), "4") facet <- facet_grid(c~.) - loc_c <- panel_map_one(facet, data.frame(c = NA), plot_data = a3) + loc_c <- panel_map_one(facet, data_frame(c = NA), plot_data = a3) expect_equal(as.character(loc_c$PANEL), "4") }) @@ -92,12 +92,12 @@ test_that("grid: missing values are located correctly", { get_layout <- function(p) ggplot_build(p)$layout$layout # Data with factor f with levels CBA -d <- data.frame(x = 1:9, y = 1:9, +d <- data_frame(x = 1:9, y = 1:9, fx = factor(rep(letters[1:3], each = 3), levels = letters[3:1]), fy = factor(rep(LETTERS[1:3], each = 3), levels = LETTERS[3:1])) # Data with factor f with only level B -d2 <- data.frame(x = 1:9, y = 2:10, fx = "a", fy = "B") +d2 <- data_frame(x = 1:9, y = 2:10, fx = factor("a"), fy = factor("B")) test_that("grid: facet order follows default data frame order", { diff --git a/tests/testthat/test-facet-strips.r b/tests/testthat/test-facet-strips.r index 3882b8fe29..a9747f9f30 100644 --- a/tests/testthat/test-facet-strips.r +++ b/tests/testthat/test-facet-strips.r @@ -123,7 +123,7 @@ test_that("facet_grid() switches to both 'x' and 'y'", { }) test_that("strips can be removed", { - dat <- data.frame(a = rep(LETTERS[1:10], 10), x = rnorm(100), y = rnorm(100)) + dat <- data_frame(a = rep(LETTERS[1:10], 10), x = rnorm(100), y = rnorm(100)) g <- ggplot(dat, aes(x = x, y = y)) + geom_point() + facet_wrap(~a) + @@ -135,6 +135,6 @@ test_that("strips can be removed", { test_that("y strip labels are rotated when strips are switched", { switched <- p + facet_grid(am ~ cyl, switch = "both") - + expect_doppelganger("switched facet strips", switched) }) diff --git a/tests/testthat/test-fortify.r b/tests/testthat/test-fortify.r index f184aa56f5..b7370b284d 100644 --- a/tests/testthat/test-fortify.r +++ b/tests/testthat/test-fortify.r @@ -16,7 +16,7 @@ test_that("spatial polygons have correct ordering", { p } - fake_data <- data.frame(ids = 1:5, region = c(1,1,2,3,4)) + fake_data <- data_frame(ids = 1:5, region = c(1,1,2,3,4)) rownames(fake_data) <- 1:5 polys <- list(sp::Polygons(list(make_square(), make_hole()), 1), sp::Polygons(list(make_square(1,0), make_square(2, 0)), 2), diff --git a/tests/testthat/test-geom-bar.R b/tests/testthat/test-geom-bar.R index 38a27b5f67..b71febb4e4 100644 --- a/tests/testthat/test-geom-bar.R +++ b/tests/testthat/test-geom-bar.R @@ -1,7 +1,7 @@ context("geom_bar") test_that("geom_bar removes bars with parts outside the plot limits", { - dat <- data.frame(x = c("a", "b", "b", "c", "c", "c")) + dat <- data_frame(x = c("a", "b", "b", "c", "c", "c")) p <- ggplot(dat, aes(x)) + geom_bar() diff --git a/tests/testthat/test-geom-boxplot.R b/tests/testthat/test-geom-boxplot.R index 9fbee21214..32367558dd 100644 --- a/tests/testthat/test-geom-boxplot.R +++ b/tests/testthat/test-geom-boxplot.R @@ -2,7 +2,7 @@ context("geom_boxplot") # thanks wch for providing the test code test_that("geom_boxplot range includes all outliers", { - dat <- data.frame(x = 1, y = c(-(1:20) ^ 3, (1:20) ^ 3) ) + dat <- data_frame(x = 1, y = c(-(1:20) ^ 3, (1:20) ^ 3) ) p <- ggplot_build(ggplot(dat, aes(x,y)) + geom_boxplot()) miny <- p$layout$panel_params[[1]]$y.range[1] @@ -31,7 +31,7 @@ test_that("geom_boxplot for continuous x gives warning if more than one x (#992) }) test_that("can use US spelling of colour", { - df <- data.frame(x = 1, y = c(1:5, 100)) + df <- data_frame(x = 1, y = c(1:5, 100)) plot <- ggplot(df, aes(x, y)) + geom_boxplot(outlier.color = "red") gpar <- layer_grob(plot)[[1]]$children[[1]]$children[[1]]$gp @@ -43,7 +43,7 @@ test_that("boxes with variable widths do not overlap", { geom_boxplot(aes(colour = Sepal.Width < 3.2), varwidth = TRUE) d <- layer_data(p)[c("xmin", "xmax")] xid <- find_x_overlaps(d) - + expect_false(any(duplicated(xid))) }) diff --git a/tests/testthat/test-geom-col.R b/tests/testthat/test-geom-col.R index 84c00a3f7a..ed10be1883 100644 --- a/tests/testthat/test-geom-col.R +++ b/tests/testthat/test-geom-col.R @@ -1,7 +1,7 @@ context("geom_col") test_that("geom_col removes columns with parts outside the plot limits", { - dat <- data.frame(x = c(1, 2, 3)) + dat <- data_frame(x = c(1, 2, 3)) p <- ggplot(dat, aes(x, x)) + geom_col() diff --git a/tests/testthat/test-geom-dotplot.R b/tests/testthat/test-geom-dotplot.R index 11b1b304c2..d0080a4c43 100644 --- a/tests/testthat/test-geom-dotplot.R +++ b/tests/testthat/test-geom-dotplot.R @@ -1,7 +1,7 @@ context("geom_dotplot") set.seed(111) -dat <- data.frame(x = LETTERS[1:2], y = rnorm(30), g = LETTERS[3:5]) +dat <- data_frame(x = LETTERS[1:2], y = rnorm(30), g = LETTERS[3:5]) test_that("dodging works", { p <- ggplot(dat, aes(x = x, y = y, fill = g)) + @@ -54,7 +54,7 @@ test_that("binning works", { test_that("NA's result in warning from stat_bindot", { set.seed(122) - dat <- data.frame(x = rnorm(20)) + dat <- data_frame(x = rnorm(20)) dat$x[c(2,10)] <- NA # Need to assign it to a var here so that it doesn't automatically print @@ -81,7 +81,7 @@ test_that("when binning on y-axis, limits depend on the panel", { test_that("geom_dotplot draws correctly", { set.seed(112) - dat <- data.frame(x = rnorm(20), g = LETTERS[1:2]) + dat <- data_frame(x = rnorm(20), g = LETTERS[1:2]) # Basic dotplot with binning along x axis expect_doppelganger("basic dotplot with dot-density binning, binwidth = .4", @@ -145,7 +145,7 @@ test_that("geom_dotplot draws correctly", { ) # Binning along y, with multiple grouping factors - dat2 <- data.frame(x = LETTERS[1:3], y = rnorm(90), g = LETTERS[1:2]) + dat2 <- data_frame(x = factor(LETTERS[1:3]), y = rnorm(90), g = factor(LETTERS[1:2])) expect_doppelganger("bin y, three x groups, stack centerwhole", ggplot(dat2, aes(x, y)) + geom_dotplot(binwidth = .25, binaxis = "y", stackdir = "centerwhole") diff --git a/tests/testthat/test-geom-freqpoly.R b/tests/testthat/test-geom-freqpoly.R index 080fa862ce..97353b7d03 100644 --- a/tests/testthat/test-geom-freqpoly.R +++ b/tests/testthat/test-geom-freqpoly.R @@ -1,7 +1,7 @@ context("geom_freqpoly") test_that("can do frequency polygon with categorical x", { - df <- data.frame(x = rep(letters[1:3], 3:1)) + df <- data_frame(x = rep(letters[1:3], 3:1)) p <- ggplot(df, aes(x)) + geom_freqpoly(stat = "count") d <- layer_data(p) diff --git a/tests/testthat/test-geom-hex.R b/tests/testthat/test-geom-hex.R index 81e3fd5611..d815955792 100644 --- a/tests/testthat/test-geom-hex.R +++ b/tests/testthat/test-geom-hex.R @@ -1,7 +1,7 @@ context("geom_hex") test_that("density and value summaries are available", { - df <- data.frame(x = c(1, 1, 1, 2), y = c(1, 1, 1, 2)) + df <- data_frame(x = c(1, 1, 1, 2), y = c(1, 1, 1, 2)) base <- ggplot(df, aes(x, y)) + geom_hex() @@ -12,7 +12,7 @@ test_that("density and value summaries are available", { }) test_that("size and linetype are applied", { - df <- data.frame(x = c(1, 1, 1, 2), y = c(1, 1, 1, 2)) + df <- data_frame(x = c(1, 1, 1, 2), y = c(1, 1, 1, 2)) plot <- ggplot(df, aes(x, y)) + geom_hex(color = "red", size = 4, linetype = 2) diff --git a/tests/testthat/test-geom-hline-vline-abline.R b/tests/testthat/test-geom-hline-vline-abline.R index f7b94930cb..58239e8863 100644 --- a/tests/testthat/test-geom-hline-vline-abline.R +++ b/tests/testthat/test-geom-hline-vline-abline.R @@ -4,7 +4,7 @@ context("geom-hline-vline-abline") # Visual tests ------------------------------------------------------------ test_that("check h/v/abline transformed on basic projections", { - dat <- data.frame(x = LETTERS[1:5], y = 1:5) + dat <- data_frame(x = LETTERS[1:5], y = 1:5) plot <- ggplot(dat, aes(x, y)) + geom_col(width = 1) + geom_point() + diff --git a/tests/testthat/test-geom-path.R b/tests/testthat/test-geom-path.R index 9516502d6c..a99dd114f2 100644 --- a/tests/testthat/test-geom-path.R +++ b/tests/testthat/test-geom-path.R @@ -15,7 +15,7 @@ test_that("geom_path draws correctly", { nCategory <- 5 nItem <- 6 - df <- data.frame(category = rep(LETTERS[1:nCategory], 1, each = nItem), + df <- data_frame(category = rep(LETTERS[1:nCategory], 1, each = nItem), item = paste("Item#", rep(1:nItem, nCategory, each = 1), sep = ''), value = rep(1:nItem, nCategory, each = 1) + runif(nCategory * nItem) * 0.8) @@ -36,7 +36,7 @@ test_that("geom_path draws correctly", { }) test_that("NA linetype is dropped with warning", { - df <- data.frame(x = 1:2, y = 1:2, z = "a") + df <- data_frame(x = 1:2, y = 1:2, z = "a") # Somehow the warning does not slip through on ggplot_build() if (enable_vdiffr) { diff --git a/tests/testthat/test-geom-raster.R b/tests/testthat/test-geom-raster.R index 9485dc1c79..890ef96692 100644 --- a/tests/testthat/test-geom-raster.R +++ b/tests/testthat/test-geom-raster.R @@ -7,7 +7,7 @@ test_that("geom_raster draws correctly", { set.seed(1) # 3 x 2 ---------------------------------------------------------------------- - df <- data.frame(x = rep(c(-1, 1), each = 3), y = rep(-1:1, 2), z = 1:6) + df <- data_frame(x = rep(c(-1, 1), each = 3), y = rep(-1:1, 2), z = 1:6) expect_doppelganger("3 x 2", ggplot(df, aes(x, y, fill = z)) + geom_raster() + geom_point(colour = "red") @@ -22,7 +22,7 @@ test_that("geom_raster draws correctly", { ) # 1 x 3 ---------------------------------------------------------------------- - df <- data.frame(x = -1:1, y = 0, z = 1:3) + df <- data_frame(x = -1:1, y = 0, z = 1:3) expect_doppelganger("1 x 3", ggplot(df, aes(x, y, fill = z)) + geom_raster() + geom_point(colour = "red") @@ -38,7 +38,7 @@ test_that("geom_raster draws correctly", { # 3 x 1 ---------------------------------------------------------------------- - df <- data.frame(x = 0, y = -1:1, z = 1:3) + df <- data_frame(x = 0, y = -1:1, z = 1:3) expect_doppelganger("3 x 1", ggplot(df, aes(x, y, fill = z)) + geom_raster() + geom_point(colour = "red") ) diff --git a/tests/testthat/test-geom-ribbon.R b/tests/testthat/test-geom-ribbon.R index 13dade7939..ecd0f9a40c 100644 --- a/tests/testthat/test-geom-ribbon.R +++ b/tests/testthat/test-geom-ribbon.R @@ -1,7 +1,7 @@ context("geom_ribbon") test_that("NAs are not dropped from the data", { - df <- data.frame(x = 1:5, y = c(1, 1, NA, 1, 1)) + df <- data_frame(x = 1:5, y = c(1, 1, NA, 1, 1)) p <- ggplot(df, aes(x))+ geom_ribbon(aes(ymin = y - 1, ymax = y + 1)) diff --git a/tests/testthat/test-geom-rug.R b/tests/testthat/test-geom-rug.R index 5440108536..a093d65413 100644 --- a/tests/testthat/test-geom-rug.R +++ b/tests/testthat/test-geom-rug.R @@ -1,7 +1,7 @@ context("geom_rug") n = 10 -df <- data.frame(x = 1:n, y = (1:n)^3) +df <- data_frame(x = 1:n, y = (1:n)^3) p <- ggplot(df, aes(x, y)) + geom_point() + geom_rug(sides = 'l') test_that("coord_flip flips the rugs", { diff --git a/tests/testthat/test-geom-rule.R b/tests/testthat/test-geom-rule.R index 109916fb53..542957232d 100644 --- a/tests/testthat/test-geom-rule.R +++ b/tests/testthat/test-geom-rule.R @@ -1,7 +1,7 @@ context("geom_rule") # tests for geom_vline, geom_hline & geom_abline -df <- data.frame(x = 1:3, y = 3:1) +df <- data_frame(x = 1:3, y = 3:1) p <- ggplot(df, aes(x, y)) + geom_point() p_col <- ggplot(df, aes(x, y, colour = factor(x))) + geom_point() diff --git a/tests/testthat/test-geom-smooth.R b/tests/testthat/test-geom-smooth.R index e4386cbd53..f7bce014f9 100644 --- a/tests/testthat/test-geom-smooth.R +++ b/tests/testthat/test-geom-smooth.R @@ -1,7 +1,7 @@ context("geom_smooth") test_that("data is ordered by x", { - df <- data.frame(x = c(1, 5, 2, 3, 4), y = 1:5) + df <- data_frame(x = c(1, 5, 2, 3, 4), y = 1:5) ps <- ggplot(df, aes(x, y))+ geom_smooth(stat = "identity", se = FALSE) @@ -13,7 +13,7 @@ test_that("default smoothing methods for small and large data sets work", { # test small data set set.seed(6531) x <- rnorm(10) - df <- data.frame( + df <- data_frame( x = x, y = x^2 + 0.5 * rnorm(10) ) @@ -21,7 +21,7 @@ test_that("default smoothing methods for small and large data sets work", { m <- loess(y ~ x, data = df, span = 0.75) range <- range(df$x, na.rm = TRUE) xseq <- seq(range[1], range[2], length.out = 80) - out <- predict(m, data.frame(x = xseq)) + out <- predict(m, data_frame(x = xseq)) p <- ggplot(df, aes(x, y)) + geom_smooth() expect_message( @@ -32,7 +32,7 @@ test_that("default smoothing methods for small and large data sets work", { # test large data set x <- rnorm(1001) # 1000 is the cutoff point for gam - df <- data.frame( + df <- data_frame( x = x, y = x^2 + 0.5 * rnorm(1001) ) @@ -40,7 +40,7 @@ test_that("default smoothing methods for small and large data sets work", { m <- mgcv::gam(y ~ s(x, bs = "cs"), data = df) range <- range(df$x, na.rm = TRUE) xseq <- seq(range[1], range[2], length.out = 80) - out <- predict(m, data.frame(x = xseq)) + out <- predict(m, data_frame(x = xseq)) p <- ggplot(df, aes(x, y)) + geom_smooth() expect_message( @@ -54,7 +54,7 @@ test_that("default smoothing methods for small and large data sets work", { # Visual tests ------------------------------------------------------------ test_that("geom_smooth() works with alternative stats", { - df <- data.frame(x = c(1, 1, 2, 2, 1, 1, 2, 2), + df <- data_frame(x = c(1, 1, 2, 2, 1, 1, 2, 2), y = c(1, 2, 2, 3, 2, 3, 1, 2), fill = c(rep("A", 4), rep("B", 4))) diff --git a/tests/testthat/test-geom-tile.R b/tests/testthat/test-geom-tile.R index 476e1ca0fd..46ee3094e9 100644 --- a/tests/testthat/test-geom-tile.R +++ b/tests/testthat/test-geom-tile.R @@ -1,7 +1,7 @@ context("geom_tile") test_that("accepts width and height params", { - df <- data.frame(x = c("a", "b"), y = c("a", "b")) + df <- data_frame(x = c("a", "b"), y = c("a", "b")) out1 <- layer_data(ggplot(df, aes(x, y)) + geom_tile()) expect_equal(out1$xmin, c(0.5, 1.5)) @@ -13,7 +13,7 @@ test_that("accepts width and height params", { }) test_that("accepts width and height aesthetics", { - df <- data.frame(x = 0, y = 0, width = c(2, 4), height = c(2, 4)) + df <- data_frame(x = 0, y = 0, width = c(2, 4), height = c(2, 4)) p <- ggplot(df, aes(x, y, width = width, height = height)) + geom_tile(fill = NA, colour = "black", size = 1) diff --git a/tests/testthat/test-geom-violin.R b/tests/testthat/test-geom-violin.R index 1b9ff4e694..1be2221168 100644 --- a/tests/testthat/test-geom-violin.R +++ b/tests/testthat/test-geom-violin.R @@ -2,8 +2,8 @@ context("geom_violin") test_that("range is expanded", { df <- rbind( - data.frame(x = "a", y = c(0, runif(10), 1)), - data.frame(x = "b", y = c(0, runif(10), 2)) + data_frame(x = "a", y = c(0, runif(10), 1)), + data_frame(x = "b", y = c(0, runif(10), 2)) ) p <- ggplot(df, aes(1, y)) + @@ -19,7 +19,7 @@ test_that("range is expanded", { # create_quantile_segment_frame ------------------------------------------------- test_that("create_quantile_segment_frame functions for 3 quantiles", { - density.data <- data.frame(y = (1:256)/256, density = 1/256) # uniform density + density.data <- data_frame(y = (1:256)/256, density = 1/256) # uniform density qs <- c(0.25, 0.5, 0.75) # 3 quantiles expect_equal(create_quantile_segment_frame(density.data, qs)$y, @@ -27,7 +27,7 @@ test_that("create_quantile_segment_frame functions for 3 quantiles", { }) test_that("quantiles do not fail on zero-range data", { - zero.range.data <- data.frame(y = rep(1,3)) + zero.range.data <- data_frame(y = rep(1,3)) p <- ggplot(zero.range.data) + geom_violin(aes(1, y), draw_quantiles = 0.5) # This should return without error and have length one @@ -39,7 +39,7 @@ test_that("quantiles do not fail on zero-range data", { test_that("geom_violin draws correctly", { set.seed(111) - dat <- data.frame(x = LETTERS[1:3], y = rnorm(90)) + dat <- data_frame(x = factor(LETTERS[1:3]), y = rnorm(90)) dat <- dat[dat$x != "C" | c(T, F),] # Keep half the C's expect_doppelganger("basic", @@ -79,7 +79,7 @@ test_that("geom_violin draws correctly", { ggplot(dat, aes(x=x, y=y)) + geom_violin(draw_quantiles=c(0.25,0.5,0.75)) ) - dat2 <- data.frame(x = LETTERS[1:3], y = rnorm(90), g = letters[5:6]) + dat2 <- data_frame(x = factor(LETTERS[1:3]), y = rnorm(90), g = factor(letters[5:6])) expect_doppelganger("grouping on x and fill", ggplot(dat2, aes(x = x, y = y, fill = g)) + geom_violin() ) diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index b1002431cd..af404d7a7a 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -9,7 +9,7 @@ test_that("colourbar trains without labels", { }) test_that("Colorbar respects show.legend in layer", { - df <- data.frame(x = 1:3, y = 1) + df <- data_frame(x = 1:3, y = 1) p <- ggplot(df, aes(x = x, y = y, color = x)) + geom_point(size = 20, shape = 21, show.legend = FALSE) expect_false("guide-box" %in% ggplotGrob(p)$layout$name) @@ -30,7 +30,7 @@ test_that("show.legend handles named vectors", { n } - df <- data.frame(x = 1:3, y = 20:22) + df <- data_frame(x = 1:3, y = 20:22) p <- ggplot(df, aes(x = x, y = y, color = x, shape = factor(y))) + geom_point(size = 20) expect_equal(n_legends(p), 2) @@ -68,7 +68,7 @@ test_that("axis guides are drawn correctly", { }) test_that("guides are positioned correctly", { - df <- data.frame(x = 1, y = 1, z = factor("a")) + df <- data_frame(x = 1, y = 1, z = factor("a")) p1 <- ggplot(df, aes(x, y, colour = z)) + geom_point() + @@ -120,7 +120,7 @@ test_that("guides are positioned correctly", { ) # padding - dat <- data.frame(x = LETTERS[1:3], y = 1) + dat <- data_frame(x = LETTERS[1:3], y = 1) p2 <- ggplot(dat, aes(x, y, fill = x, colour = 1:3)) + geom_bar(stat = "identity") + guides(color = "colorbar") + @@ -145,7 +145,7 @@ test_that("guides are positioned correctly", { }) test_that("guides title and text are positioned correctly", { - df <- data.frame(x = 1:3, y = 1:3) + df <- data_frame(x = 1:3, y = 1:3) p <- ggplot(df, aes(x, y, color = factor(x), fill = y)) + geom_point(shape = 21) + # setting the order explicitly removes the risk for failed doppelgangers @@ -167,7 +167,7 @@ test_that("guides title and text are positioned correctly", { ) # now test label positioning, alignment, etc - df <- data.frame(x = c(1, 10, 100)) + df <- data_frame(x = c(1, 10, 100)) p <- ggplot(df, aes(x, x, color = x, size = x)) + geom_point() + # setting the order explicitly removes the risk for failed doppelgangers @@ -184,7 +184,7 @@ test_that("guides title and text are positioned correctly", { ) # title and label rotation - df <- data.frame(x = c(5, 10, 15)) + df <- data_frame(x = c(5, 10, 15)) p <- ggplot(df, aes(x, x, color = x, fill = 15 - x)) + geom_point(shape = 21, size = 5, stroke = 3) + scale_colour_continuous( @@ -214,7 +214,7 @@ test_that("guides title and text are positioned correctly", { }) test_that("colorbar can be styled", { - df <- data.frame(x <- c(0, 1, 2)) + df <- data_frame(x <- c(0, 1, 2)) p <- ggplot(df, aes(x, x, color = x)) + geom_point() expect_doppelganger("white-to-red gradient colorbar, white tick marks, no frame", @@ -235,7 +235,7 @@ test_that("colorbar can be styled", { }) test_that("guides can handle multiple aesthetics for one scale", { - df <- data.frame(x = c(1, 2, 3), + df <- data_frame(x = c(1, 2, 3), y = c(6, 5, 7)) p <- ggplot(df, aes(x, y, color = x, fill = y)) + diff --git a/tests/testthat/test-labels.r b/tests/testthat/test-labels.r index a813f36845..dd13f07f78 100644 --- a/tests/testthat/test-labels.r +++ b/tests/testthat/test-labels.r @@ -54,7 +54,7 @@ test_that("setting guide labels works", { # Visual tests ------------------------------------------------------------ test_that("tags are drawn correctly", { - dat <- data.frame(x = 1:10, y = 10:1) + dat <- data_frame(x = 1:10, y = 10:1) p <- ggplot(dat, aes(x = x, y = y)) + geom_point() + labs(tag = "Fig. A)") expect_doppelganger("defaults", p) diff --git a/tests/testthat/test-layer.r b/tests/testthat/test-layer.r index db44baf1e6..f9572e65d9 100644 --- a/tests/testthat/test-layer.r +++ b/tests/testthat/test-layer.r @@ -20,14 +20,14 @@ test_that("unknown NULL asthetic doesn't create warning (#1909)", { }) test_that("column vectors are allowed (#2609)", { - df <- data.frame(x = 1:10) + df <- data_frame(x = 1:10) df$y <- scale(1:10) # Returns a column vector p <- ggplot(df, aes(x, y)) expect_is(layer_data(p), "data.frame") }) test_that("missing aesthetics trigger informative error", { - df <- data.frame(x = 1:10) + df <- data_frame(x = 1:10) expect_error( ggplot_build(ggplot(df) + geom_line()), "requires the following missing aesthetics:" diff --git a/tests/testthat/test-munch.r b/tests/testthat/test-munch.r index a765b69cf6..8fcbb20103 100644 --- a/tests/testthat/test-munch.r +++ b/tests/testthat/test-munch.r @@ -26,7 +26,7 @@ test_that("munch_data works", { expect_equal(nrow(merge(md, dat)), nrow(dat)) expect_true(nrow(md) >= nrow(dat)) } - dat <- data.frame(x = c(0, 60, 30, 20, 40, 45), + dat <- data_frame(x = c(0, 60, 30, 20, 40, 45), y = c(1, 1, 2, 2, 2, 2), group = c(1L, 1L, 1L, 2L, 2L, 2L)) dist <- dist_euclidean(dat$x, dat$y) diff --git a/tests/testthat/test-position-dodge2.R b/tests/testthat/test-position-dodge2.R index ee97fd7163..39188b1dc8 100644 --- a/tests/testthat/test-position-dodge2.R +++ b/tests/testthat/test-position-dodge2.R @@ -2,12 +2,12 @@ context("position_dodge2") test_that("find_x_overlaps identifies overlapping groups", { - df1 <- data.frame( + df1 <- data_frame( xmin = c(1, 3, 6, 11, 13), xmax = c(5, 7, 9, 15, 16) ) - df2 <- data.frame( + df2 <- data_frame( xmin = c(0.85, 0.80, 1.90, 1.90, 2.80), xmax = c(1.15, 1.20, 2.10, 2.05, 3.20) ) @@ -17,13 +17,13 @@ test_that("find_x_overlaps identifies overlapping groups", { }) test_that("single element is rescaled based on n", { - df <- data.frame(xmin = 1, xmax = 2) + df <- data_frame(xmin = 1, xmax = 2) out <- pos_dodge2(df, n = 2) expect_equal(out$xmax - out$xmin, 0.5) }) test_that("rectangles are dodged", { - df <- data.frame( + df <- data_frame( xmin = c(1, 3, 6, 11, 13), xmax = c(5, 7, 9, 15, 16), ymin = c(1, 1, 5, 2, 2), @@ -38,7 +38,7 @@ test_that("rectangles are dodged", { }) test_that("cols at the same x position are dodged", { - df <- data.frame( + df <- data_frame( x = c("a", "a", "b"), n = c(1, 5, 10), stringsAsFactors = FALSE diff --git a/tests/testthat/test-position-nudge.R b/tests/testthat/test-position-nudge.R index 6c03a05472..0ca8342dd3 100644 --- a/tests/testthat/test-position-nudge.R +++ b/tests/testthat/test-position-nudge.R @@ -1,7 +1,7 @@ context("position_nudge") test_that("nudging works in both dimensions simultaneously", { - df <- data.frame(x = 1:3) + df <- data_frame(x = 1:3) p <- ggplot(df, aes(x, x, xmax = x, xmin = x, ymax = x, ymin = x)) + geom_point(position = position_nudge(x = 1, y = 2)) @@ -17,7 +17,7 @@ test_that("nudging works in both dimensions simultaneously", { }) test_that("nudging works in individual dimensions", { - df <- data.frame(x = 1:3) + df <- data_frame(x = 1:3) # nudging in x # use an empty layer so can test individual aesthetics diff --git a/tests/testthat/test-position-stack.R b/tests/testthat/test-position-stack.R index ac0d9350d8..313dae16a5 100644 --- a/tests/testthat/test-position-stack.R +++ b/tests/testthat/test-position-stack.R @@ -1,7 +1,7 @@ context("position_stack") test_that("data is sorted prior to stacking", { - df <- data.frame( + df <- data_frame( x = rep(c(1:10), 3), var = rep(c("a", "b", "c"), 10), y = round(runif(30, 1, 5)) @@ -13,7 +13,7 @@ test_that("data is sorted prior to stacking", { }) test_that("negative and positive values are handled separately", { - df <- data.frame( + df <- data_frame( x = c(1,1,1,2,2), g = c(1,2,3,1,2), y = c(1,-1,1,2,-3) @@ -29,7 +29,7 @@ test_that("negative and positive values are handled separately", { }) test_that("can request reverse stacking", { - df <- data.frame( + df <- data_frame( y = c(-2, 2, -1, 1), g = c("a", "a", "b", "b") ) @@ -40,7 +40,7 @@ test_that("can request reverse stacking", { }) test_that("data with no extent is stacked correctly", { - df = data.frame( + df <- data_frame( x = c(1, 1), y = c(-40, -75), group = letters[1:2] diff --git a/tests/testthat/test-position_dodge.R b/tests/testthat/test-position_dodge.R index 7c1aaf6778..521e23ce6e 100644 --- a/tests/testthat/test-position_dodge.R +++ b/tests/testthat/test-position_dodge.R @@ -1,7 +1,7 @@ context("position_dodge") test_that("can control whether to preserve total or individual width", { - df <- data.frame(x = c("a", "b", "b"), y = c("a", "a", "b")) + df <- data_frame(x = c("a", "b", "b"), y = c("a", "a", "b")) p_total <- ggplot(df, aes(x, fill = y)) + geom_bar(position = position_dodge(preserve = "total"), width = 1) diff --git a/tests/testthat/test-qplot.r b/tests/testthat/test-qplot.r index dd4df6757d..db56fd05d0 100644 --- a/tests/testthat/test-qplot.r +++ b/tests/testthat/test-qplot.r @@ -1,7 +1,7 @@ context("qplot") test_that("qplot works with variables in data frame and parent env", { - df <- data.frame(x = 1:10, a = 1:10) + df <- data_frame(x = 1:10, a = 1:10) y <- 1:10 b <- 1:10 diff --git a/tests/testthat/test-scale-date.R b/tests/testthat/test-scale-date.R index 8aff4cc5c8..dc08925bc7 100644 --- a/tests/testthat/test-scale-date.R +++ b/tests/testthat/test-scale-date.R @@ -4,7 +4,7 @@ base_time <- function(tz = "") { as.POSIXct(strptime("2015-06-01", "%Y-%m-%d", tz = tz)) } -df <- data.frame( +df <- data_frame( time1 = base_time("") + 0:6 * 3600, time2 = base_time("UTC") + 0:6 * 3600, time3 = base_time("Australia/Lord_Howe") + (0:6 + 13) * 3600, # has half hour offset diff --git a/tests/testthat/test-scale-discrete.R b/tests/testthat/test-scale-discrete.R index 500c6a2235..094d97ce84 100644 --- a/tests/testthat/test-scale-discrete.R +++ b/tests/testthat/test-scale-discrete.R @@ -49,7 +49,7 @@ test_that("NAs are translated/preserved for non-position scales", { # Ranges ------------------------------------------------------------------ test_that("discrete ranges also encompass continuous values", { - df <- data.frame(x1 = c("a", "b", "c"), x2 = c(0, 2, 4), y = 1:3) + df <- data_frame(x1 = c("a", "b", "c"), x2 = c(0, 2, 4), y = 1:3) base <- ggplot(df, aes(y = y)) + scale_x_discrete() @@ -63,7 +63,7 @@ test_that("discrete ranges also encompass continuous values", { }) test_that("discrete scale shrinks to range when setting limits", { - df <- data.frame(x = letters[1:10], y = 1:10) + df <- data_frame(x = letters[1:10], y = 1:10) p <- ggplot(df, aes(x, y)) + geom_point() + scale_x_discrete(limits = c("a", "b")) diff --git a/tests/testthat/test-scale-gradient.R b/tests/testthat/test-scale-gradient.R index 3666f197c3..c1f6542829 100644 --- a/tests/testthat/test-scale-gradient.R +++ b/tests/testthat/test-scale-gradient.R @@ -3,7 +3,7 @@ context("scale_gradient") # Limits ------------------------------------------------------------------ test_that("points outside the limits are plotted as NA", { - df <- data.frame(x = c(0, 1, 2)) + df <- data_frame(x = c(0, 1, 2)) p <- ggplot(df, aes(x, 1, fill = x)) + geom_col() + scale_fill_gradient2(limits = c(-1, 1), midpoint = 2, na.value = "orange") diff --git a/tests/testthat/test-scale-manual.r b/tests/testthat/test-scale-manual.r index 03b06f282c..d03c232b80 100644 --- a/tests/testthat/test-scale-manual.r +++ b/tests/testthat/test-scale-manual.r @@ -7,7 +7,7 @@ test_that("names of values used in manual scales", { }) -dat <- data.frame(g = c("B","A","A")) +dat <- data_frame(g = c("B","A","A")) p <- ggplot(dat, aes(g, fill = g)) + geom_bar() col <- c("A" = "red", "B" = "green", "C" = "blue") @@ -27,7 +27,7 @@ test_that("named values work regardless of order", { }) test_that("missing values are replaced with na.value", { - df <- data.frame(x = 1, y = 1:3, z = factor(c(1:2, NA), exclude = NULL)) + df <- data_frame(x = 1, y = 1:3, z = factor(c(1:2, NA), exclude = NULL)) p <- ggplot(df, aes(x, y, colour = z)) + geom_point() + scale_colour_manual(values = c("black", "black"), na.value = "red") @@ -36,7 +36,7 @@ test_that("missing values are replaced with na.value", { }) test_that("insufficient values raise an error", { - df <- data.frame(x = 1, y = 1:3, z = factor(c(1:2, NA), exclude = NULL)) + df <- data_frame(x = 1, y = 1:3, z = factor(c(1:2, NA), exclude = NULL)) p <- qplot(x, y, data = df, colour = z) expect_error(ggplot_build(p + scale_colour_manual(values = "black")), @@ -54,7 +54,7 @@ test_that("values are matched when scale contains more unique values than are in }) test_that("generic scale can be used in place of aesthetic-specific scales", { - df <- data.frame(x = letters[1:3], y = LETTERS[1:3], z = factor(c(1, 2, 3))) + df <- data_frame(x = letters[1:3], y = LETTERS[1:3], z = factor(c(1, 2, 3))) p1 <- ggplot(df, aes(z, z, shape = x, color = y, alpha = z)) + scale_shape_manual(values = 1:3) + scale_colour_manual(values = c("red", "green", "blue")) + diff --git a/tests/testthat/test-scale_date.R b/tests/testthat/test-scale_date.R index ead4a9507e..ceccb90955 100644 --- a/tests/testthat/test-scale_date.R +++ b/tests/testthat/test-scale_date.R @@ -5,7 +5,7 @@ context("scale_date") test_that("date scale draws correctly", { set.seed(321) - df <- data.frame( + df <- data_frame( dx = seq(as.Date("2012-02-29"), length.out = 100, by = "1 day")[sample(100, 50)], price = runif(50) ) diff --git a/tests/testthat/test-scales-breaks-labels.r b/tests/testthat/test-scales-breaks-labels.r index 35aa8fe9bb..7f7e42f253 100644 --- a/tests/testthat/test-scales-breaks-labels.r +++ b/tests/testthat/test-scales-breaks-labels.r @@ -56,7 +56,7 @@ test_that("out-of-range breaks are dropped", { # limits aren't specified, automatic labels # limits are set by the data sc <- scale_x_continuous(breaks = 1:5) - sc$train_df(data.frame(x = 2:4)) + sc$train_df(data_frame(x = 2:4)) bi <- sc$break_info() expect_equal(bi$labels, as.character(2:4)) expect_equal(bi$major_source, 2:4) @@ -64,7 +64,7 @@ test_that("out-of-range breaks are dropped", { # Limits and labels are specified sc <- scale_x_continuous(breaks = 1:5, labels = letters[1:5]) - sc$train_df(data.frame(x = 2:4)) + sc$train_df(data_frame(x = 2:4)) bi <- sc$break_info() expect_equal(bi$labels, letters[2:4]) expect_equal(bi$major_source, 2:4) @@ -72,7 +72,7 @@ test_that("out-of-range breaks are dropped", { # Limits aren't specified, and all breaks are out of range of data sc <- scale_x_continuous(breaks = c(1,5), labels = letters[c(1,5)]) - sc$train_df(data.frame(x = 2:4)) + sc$train_df(data_frame(x = 2:4)) bi <- sc$break_info() expect_equal(length(bi$labels), 0) expect_equal(length(bi$major), 0) @@ -245,7 +245,7 @@ test_that("minor breaks are transformed by scales", { # Visual tests ------------------------------------------------------------ test_that("minor breaks draw correctly", { - df <- data.frame( + df <- data_frame( x_num = c(1, 3), x_chr = c("a", "b"), x_date = as.Date("2012-2-29") + c(0, 100), @@ -303,7 +303,7 @@ test_that("minor breaks draw correctly", { }) test_that("scale breaks can be removed", { - dat <- data.frame(x = 1:3, y = 1:3) + dat <- data_frame(x = 1:3, y = 1:3) expect_doppelganger("no x breaks", ggplot(dat, aes(x = x, y = y)) + geom_point() + scale_x_continuous(breaks = NULL) diff --git a/tests/testthat/test-scales.r b/tests/testthat/test-scales.r index fb45f7e148..c666fb2c1b 100644 --- a/tests/testthat/test-scales.r +++ b/tests/testthat/test-scales.r @@ -1,7 +1,7 @@ context("Scales") test_that("building a plot does not affect its scales", { - dat <- data.frame(x = rnorm(20), y = rnorm(20)) + dat <- data_frame(x = rnorm(20), y = rnorm(20)) p <- ggplot(dat, aes(x, y)) + geom_point() expect_equal(length(p$scales$scales), 0) @@ -13,37 +13,37 @@ test_that("building a plot does not affect its scales", { test_that("ranges update only for variables listed in aesthetics", { sc <- scale_alpha() - sc$train_df(data.frame(alpha = 1:10)) + sc$train_df(data_frame(alpha = 1:10)) expect_equal(sc$range$range, c(1, 10)) - sc$train_df(data.frame(alpha = 50)) + sc$train_df(data_frame(alpha = 50)) expect_equal(sc$range$range, c(1, 50)) - sc$train_df(data.frame(beta = 100)) + sc$train_df(data_frame(beta = 100)) expect_equal(sc$range$range, c(1, 50)) - sc$train_df(data.frame()) + sc$train_df(data_frame()) expect_equal(sc$range$range, c(1, 50)) }) test_that("mapping works", { sc <- scale_alpha(range = c(0, 1), na.value = 0) - sc$train_df(data.frame(alpha = 1:10)) + sc$train_df(data_frame(alpha = 1:10)) expect_equal( - sc$map_df(data.frame(alpha = 1:10))[[1]], + sc$map_df(data_frame(alpha = 1:10))[[1]], seq(0, 1, length.out = 10) ) - expect_equal(sc$map_df(data.frame(alpha = NA))[[1]], 0) + expect_equal(sc$map_df(data_frame(alpha = NA))[[1]], 0) expect_equal( - sc$map_df(data.frame(alpha = c(-10, 11)))[[1]], + sc$map_df(data_frame(alpha = c(-10, 11)))[[1]], c(0, 0)) }) test_that("identity scale preserves input values", { - df <- data.frame(x = 1:3, z = letters[1:3]) + df <- data_frame(x = 1:3, z = factor(letters[1:3])) # aesthetic-specific scales p1 <- ggplot(df, @@ -74,7 +74,7 @@ test_that("identity scale preserves input values", { }) test_that("position scales are updated by all position aesthetics", { - df <- data.frame(x = 1:3, y = 1:3) + df <- data_frame(x = 1:3, y = 1:3) aesthetics <- list( aes(xend = x, yend = x), @@ -94,7 +94,7 @@ test_that("position scales are updated by all position aesthetics", { }) test_that("position scales generate after stats", { - df <- data.frame(x = factor(c(1, 1, 1))) + df <- data_frame(x = factor(c(1, 1, 1))) plot <- ggplot(df, aes(x)) + geom_bar() ranges <- pranges(plot) @@ -103,7 +103,7 @@ test_that("position scales generate after stats", { }) test_that("oob affects position values", { - dat <- data.frame(x = c("a", "b", "c"), y = c(1, 5, 10)) + dat <- data_frame(x = c("a", "b", "c"), y = c(1, 5, 10)) base <- ggplot(dat, aes(x, y)) + geom_col() + annotate("point", x = "a", y = c(-Inf, Inf)) @@ -175,7 +175,7 @@ test_that("find_global searches in the right places", { }) test_that("scales warn when transforms introduces non-finite values", { - df <- data.frame(x = c(1e1, 1e5), y = c(0, 100)) + df <- data_frame(x = c(1e1, 1e5), y = c(0, 100)) p <- ggplot(df, aes(x, y)) + geom_point(size = 5) + @@ -185,7 +185,7 @@ test_that("scales warn when transforms introduces non-finite values", { }) test_that("scales get their correct titles through layout", { - df <- data.frame(x = c(1e1, 1e5), y = c(0, 100)) + df <- data_frame(x = c(1e1, 1e5), y = c(0, 100)) p <- ggplot(df, aes(x, y)) + geom_point(size = 5) @@ -196,7 +196,7 @@ test_that("scales get their correct titles through layout", { }) test_that("size and alpha scales throw appropriate warnings for factors", { - df <- data.frame( + df <- data_frame( x = 1:3, y = 1:3, d = LETTERS[1:3], @@ -219,7 +219,7 @@ test_that("size and alpha scales throw appropriate warnings for factors", { }) test_that("shape scale throws appropriate warnings for factors", { - df <- data.frame( + df <- data_frame( x = 1:3, y = 1:3, d = LETTERS[1:3], @@ -238,7 +238,7 @@ test_that("shape scale throws appropriate warnings for factors", { }) test_that("aesthetics can be set independently of scale name", { - df <- data.frame( + df <- data_frame( x = LETTERS[1:3], y = LETTERS[4:6] ) @@ -249,7 +249,7 @@ test_that("aesthetics can be set independently of scale name", { }) test_that("multiple aesthetics can be set with one function call", { - df <- data.frame( + df <- data_frame( x = LETTERS[1:3], y = LETTERS[4:6] ) @@ -263,7 +263,7 @@ test_that("multiple aesthetics can be set with one function call", { expect_equal(layer_data(p)$fill, c("red", "green", "blue")) # color order is determined by data order, and breaks are combined where possible - df <- data.frame( + df <- data_frame( x = LETTERS[1:3], y = LETTERS[2:4] ) diff --git a/tests/testthat/test-sec-axis.R b/tests/testthat/test-sec-axis.R index c143bbc2da..d272d6eaf8 100644 --- a/tests/testthat/test-sec-axis.R +++ b/tests/testthat/test-sec-axis.R @@ -1,7 +1,7 @@ context("sec-axis") x <- exp(seq(log(0.001), log(1000), length.out = 100)) -foo <- data.frame( +foo <- data_frame( x = x, y = x / (1 + x) ) @@ -21,7 +21,7 @@ test_that("dup_axis() works", { }) test_that("sec_axis() breaks work for log-transformed scales", { - df <- data.frame( + df <- data_frame( x = c("A", "B", "C"), y = c(10, 100, 1000) ) @@ -121,7 +121,7 @@ test_that("sec axis works with tidy eval", { }) test_that("sec_axis works with date/time/datetime scales", { - df <- data.frame( + df <- data_frame( dx = seq(as.POSIXct("2012-02-29 12:00:00", tz = "UTC", format = "%Y-%m-%d %H:%M:%S" diff --git a/tests/testthat/test-stat-bin.R b/tests/testthat/test-stat-bin.R index 74da1939a0..8dc0b6f9c6 100644 --- a/tests/testthat/test-stat-bin.R +++ b/tests/testthat/test-stat-bin.R @@ -1,7 +1,7 @@ context("stat_bin/stat_count") test_that("stat_bin throws error when y aesthetic is present", { - dat <- data.frame(x = c("a", "b", "c"), y = c(1, 5, 10)) + dat <- data_frame(x = c("a", "b", "c"), y = c(1, 5, 10)) expect_error(ggplot_build(ggplot(dat, aes(x, y)) + stat_bin()), "must not be used with a y aesthetic.") @@ -13,7 +13,7 @@ test_that("stat_bin throws error when y aesthetic is present", { }) test_that("bins specifies the number of bins", { - df <- data.frame(x = 1:10) + df <- data_frame(x = 1:10) out <- function(x, ...) { layer_data(ggplot(df, aes(x)) + geom_histogram(...)) } @@ -23,35 +23,35 @@ test_that("bins specifies the number of bins", { }) test_that("binwidth computes widths for function input", { - df <- data.frame(x = 1:100) + df <- data_frame(x = 1:100) out <- layer_data(ggplot(df, aes(x)) + geom_histogram(binwidth = function(x) 5)) expect_equal(nrow(out), 21) }) test_that("geom_histogram defaults to pad = FALSE", { - df <- data.frame(x = 1:3) + df <- data_frame(x = 1:3) out <- layer_data(ggplot(df, aes(x)) + geom_histogram(binwidth = 1)) expect_equal(out$count, c(1, 1, 1)) }) test_that("geom_freqpoly defaults to pad = TRUE", { - df <- data.frame(x = 1:3) + df <- data_frame(x = 1:3) out <- layer_data(ggplot(df, aes(x)) + geom_freqpoly(binwidth = 1)) expect_equal(out$count, c(0, 1, 1, 1, 0)) }) test_that("can use breaks argument", { - df <- data.frame(x = 1:3) + df <- data_frame(x = 1:3) out <- layer_data(ggplot(df, aes(x)) + geom_histogram(breaks = c(0, 1.5, 5))) expect_equal(out$count, c(1, 2)) }) test_that("fuzzy breaks are used when cutting", { - df <- data.frame(x = c(-1, -0.5, -0.4, 0)) + df <- data_frame(x = c(-1, -0.5, -0.4, 0)) p <- ggplot(df, aes(x)) + geom_histogram(binwidth = 0.1, boundary = 0.1, closed = "left") @@ -60,7 +60,7 @@ test_that("fuzzy breaks are used when cutting", { }) test_that("breaks are transformed by the scale", { - df <- data.frame(x = rep(1:4, 1:4)) + df <- data_frame(x = rep(1:4, 1:4)) base <- ggplot(df, aes(x)) + geom_histogram(breaks = c(1, 2.5, 4)) out1 <- layer_data(base) @@ -77,7 +77,7 @@ comp_bin <- function(df, ...) { } test_that("closed left or right", { - dat <- data.frame(x = c(0, 10)) + dat <- data_frame(x = c(0, 10)) res <- comp_bin(dat, binwidth = 10, pad = FALSE) expect_identical(res$count, c(1, 1)) @@ -100,7 +100,7 @@ test_that("closed left or right", { test_that("setting boundary and center", { # numeric - df <- data.frame(x = c(0, 30)) + df <- data_frame(x = c(0, 30)) # Error if both boundary and center are specified expect_error(comp_bin(df, boundary = 5, center = 0), "one of `boundary` and `center`") @@ -117,7 +117,7 @@ test_that("setting boundary and center", { }) test_that("weights are added", { - df <- data.frame(x = 1:10, y = 1:10) + df <- data_frame(x = 1:10, y = 1:10) p <- ggplot(df, aes(x = x, weight = y)) + geom_histogram(binwidth = 1) out <- layer_data(p) @@ -127,7 +127,7 @@ test_that("weights are added", { # stat_count -------------------------------------------------------------- test_that("stat_count throws error when y aesthetic present", { - dat <- data.frame(x = c("a", "b", "c"), y = c(1, 5, 10)) + dat <- data_frame(x = c("a", "b", "c"), y = c(1, 5, 10)) expect_error( ggplot_build(ggplot(dat, aes(x, y)) + stat_count()), diff --git a/tests/testthat/test-stat-bin2d.R b/tests/testthat/test-stat-bin2d.R index 74cfac992c..309136b8be 100644 --- a/tests/testthat/test-stat-bin2d.R +++ b/tests/testthat/test-stat-bin2d.R @@ -1,7 +1,7 @@ context("stat_bin2d") test_that("binwidth is respected", { - df <- data.frame(x = c(1, 1, 1, 2), y = c(1, 1, 1, 2)) + df <- data_frame(x = c(1, 1, 1, 2), y = c(1, 1, 1, 2)) base <- ggplot(df, aes(x, y)) + stat_bin2d(geom = "tile", binwidth = 0.25) @@ -18,7 +18,7 @@ test_that("breaks override binwidth", { integer_breaks <- (0:4) - 0.5 # Will use for x half_breaks <- seq(0, 3.5, 0.5) # Will test against this for y - df <- data.frame(x = 0:3, y = 0:3) + df <- data_frame(x = 0:3, y = 0:3) base <- ggplot(df, aes(x, y)) + stat_bin2d( breaks = list(x = integer_breaks, y = NULL), @@ -31,7 +31,7 @@ test_that("breaks override binwidth", { }) test_that("breaks are transformed by the scale", { - df <- data.frame(x = c(1, 10, 100, 1000), y = 0:3) + df <- data_frame(x = c(1, 10, 100, 1000), y = 0:3) base <- ggplot(df, aes(x, y)) + stat_bin_2d( breaks = list(x = c(5, 50, 500), y = c(0.5, 1.5, 2.5))) diff --git a/tests/testthat/test-stat-hex.R b/tests/testthat/test-stat-hex.R index 231f64a47a..1ae9a5fc63 100644 --- a/tests/testthat/test-stat-hex.R +++ b/tests/testthat/test-stat-hex.R @@ -1,7 +1,7 @@ context("stat_hex") test_that("can use length 1 binwidth", { - df <- data.frame(x = c(1, 1, 2), y = c(1, 1, 2)) + df <- data_frame(x = c(1, 1, 2), y = c(1, 1, 2)) p <- ggplot(df, aes(x, y)) + stat_binhex(binwidth = 1) expect_equal(nrow(layer_data(p)), 2) diff --git a/tests/testthat/test-stat-sf-coordinates.R b/tests/testthat/test-stat-sf-coordinates.R index 6c56c213b7..f328af194e 100644 --- a/tests/testthat/test-stat-sf-coordinates.R +++ b/tests/testthat/test-stat-sf-coordinates.R @@ -10,7 +10,7 @@ test_that("stat_sf_coordinates() retrieves coordinates from sf objects", { # point df_point <- sf::st_sf(geometry = sf::st_sfc(sf::st_point(c(0, 0)))) - expect_identical(comp_sf_coord(df_point)[, c("x", "y")], data.frame(x = 0, y = 0)) + expect_identical(comp_sf_coord(df_point)[, c("x", "y")], data_frame(x = 0, y = 0)) # line c_line <- rbind(c(-1, -1), c(1, 1)) @@ -19,19 +19,19 @@ test_that("stat_sf_coordinates() retrieves coordinates from sf objects", { # Note that st_point_on_surface() does not return the centroid for # `df_line`, which may be a bit confusing. So, use st_centroid() here. comp_sf_coord(df_line, fun.geometry = sf::st_centroid)[, c("x", "y")], - data.frame(x = 0, y = 0) + data_frame(x = 0, y = 0) ) # polygon c_polygon <- list(rbind(c(-1, -1), c(-1, 1), c(1, 1), c(1, -1), c(-1, -1))) df_polygon <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(c_polygon))) - expect_identical(comp_sf_coord(df_point)[, c("x", "y")], data.frame(x = 0, y = 0)) - + expect_identical(comp_sf_coord(df_point)[, c("x", "y")], data_frame(x = 0, y = 0)) + # computed variables (x and y) df_point <- sf::st_sf(geometry = sf::st_sfc(sf::st_point(c(1, 2)))) expect_identical( comp_sf_coord(df_point, aes(x = stat(x) + 10, y = stat(y) * 10))[, c("x", "y")], - data.frame(x = 11, y = 20) + data_frame(x = 11, y = 20) ) }) @@ -43,5 +43,5 @@ test_that("stat_sf_coordinates() ignores Z and M coordinates", { df_xym <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(c_polygon, dim = "XYM"))) # Note that st_centroid() and st_point_on_surface() cannot handle M dimension since # GEOS does not support it. The default fun.geometry should drop M. - expect_identical(comp_sf_coord(df_xym)[, c("x", "y")], data.frame(x = 0, y = 0)) + expect_identical(comp_sf_coord(df_xym)[, c("x", "y")], data_frame(x = 0, y = 0)) }) diff --git a/tests/testthat/test-stats-function.r b/tests/testthat/test-stats-function.r index a97f94fb01..6ef761718d 100644 --- a/tests/testthat/test-stats-function.r +++ b/tests/testthat/test-stats-function.r @@ -1,7 +1,7 @@ context("stat_function") test_that("uses scale limits, not data limits", { - dat <- data.frame(x = c(0.1, 1:100)) + dat <- data_frame(x = c(0.1, 1:100)) dat$y <- dexp(dat$x) base <- ggplot(dat, aes(x, y)) + @@ -25,7 +25,7 @@ test_that("uses scale limits, not data limits", { }) test_that("works with discrete x", { - dat <- data.frame(x = c("a", "b")) + dat <- data_frame(x = c("a", "b")) base <- ggplot(dat, aes(x, group = 1)) + stat_function(fun = as.numeric, geom = "point", n = 2) diff --git a/tests/testthat/test-stats.r b/tests/testthat/test-stats.r index a5d26e59e0..2374b9ee57 100644 --- a/tests/testthat/test-stats.r +++ b/tests/testthat/test-stats.r @@ -1,7 +1,7 @@ context("Stats") test_that("plot succeeds even if some computation fails", { - df <- data.frame(x = 1:2, y = 1) + df <- data_frame(x = 1:2, y = 1) p1 <- ggplot(df, aes(x, y)) + geom_point() b1 <- ggplot_build(p1) diff --git a/tests/testthat/test-theme.r b/tests/testthat/test-theme.r index 63cc5a04c3..4130bd03e4 100644 --- a/tests/testthat/test-theme.r +++ b/tests/testthat/test-theme.r @@ -265,7 +265,7 @@ test_that("titleGrob() and margins() work correctly", { # Visual tests ------------------------------------------------------------ test_that("aspect ratio is honored", { - df <- data.frame(x = 1:8, y = 1:8, f = gl(2,4), expand.grid(f1 = 1:2, f2 = 1:2, rep = 1:2)) + df <- cbind(data_frame(x = 1:8, y = 1:8, f = gl(2,4)), expand.grid(f1 = 1:2, f2 = 1:2, rep = 1:2)) p <- ggplot(df, aes(x, y)) + geom_point() + theme_test() + @@ -297,7 +297,7 @@ test_that("aspect ratio is honored", { }) test_that("themes don't change without acknowledgement", { - df <- data.frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) + df <- data_frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) plot <- ggplot(df, aes(x, y, colour = z)) + geom_point() + facet_wrap(~ a) @@ -313,7 +313,7 @@ test_that("themes don't change without acknowledgement", { }) test_that("themes look decent at larger base sizes", { - df <- data.frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) + df <- data_frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) plot <- ggplot(df, aes(x, y, colour = z)) + geom_point() + facet_wrap(~ a) @@ -355,7 +355,7 @@ test_that("axes can be styled independently", { }) test_that("strips can be styled independently", { - df <- data.frame(x = 1:2, y = 1:2) + df <- data_frame(x = 1:2, y = 1:2) plot <- ggplot(df, aes(x, y)) + facet_grid(x ~ y) + theme( @@ -366,7 +366,7 @@ test_that("strips can be styled independently", { }) test_that("rotated axis tick labels work", { - df <- data.frame( + df <- data_frame( y = c(1, 2, 3), label = c("short", "medium size", "very long label") ) diff --git a/tests/testthat/test-utilities.r b/tests/testthat/test-utilities.r index 7ac5b32e3b..28832e7b91 100644 --- a/tests/testthat/test-utilities.r +++ b/tests/testthat/test-utilities.r @@ -4,27 +4,27 @@ test_that("finite_cases.data.frame", { finite_cases <- function(x) cases(x, is_finite) # All finite -------------------------------------------------------------- - expect_identical(finite_cases(data.frame(x = 4)), TRUE) # 1x1 - expect_identical(finite_cases(data.frame(x = 4, y = 11)), TRUE) # 1x2 - expect_identical(finite_cases(data.frame(x = 4:5)), c(TRUE, TRUE)) # 2x1 - expect_identical(finite_cases(data.frame(x = 4:5, y = 11:12)), c(TRUE, TRUE)) # 2x2 + expect_identical(finite_cases(data_frame(x = 4)), TRUE) # 1x1 + expect_identical(finite_cases(data_frame(x = 4, y = 11)), TRUE) # 1x2 + expect_identical(finite_cases(data_frame(x = 4:5)), c(TRUE, TRUE)) # 2x1 + expect_identical(finite_cases(data_frame(x = 4:5, y = 11:12)), c(TRUE, TRUE)) # 2x2 # Has one NA -------------------------------------------------------------- - expect_identical(finite_cases(data.frame(x = NA)), FALSE) # 1x1 - expect_identical(finite_cases(data.frame(x = 4, y = NA)), FALSE) # 1x2 - expect_identical(finite_cases(data.frame(x = c(4, NA))), c(TRUE, FALSE)) # 2x1 - expect_identical(finite_cases(data.frame(x = c(4, NA), y = c(11, NA))), c(TRUE, FALSE)) # 2x2 - expect_identical(finite_cases(data.frame(x = c(4, NA), y = c(NA, 12))), c(FALSE, FALSE)) # 2x2 - expect_identical(finite_cases(data.frame(x = c(4, 5), y = c(NA, 12))), c(FALSE, TRUE)) # 2x2 + expect_identical(finite_cases(data_frame(x = NA)), FALSE) # 1x1 + expect_identical(finite_cases(data_frame(x = 4, y = NA)), FALSE) # 1x2 + expect_identical(finite_cases(data_frame(x = c(4, NA))), c(TRUE, FALSE)) # 2x1 + expect_identical(finite_cases(data_frame(x = c(4, NA), y = c(11, NA))), c(TRUE, FALSE)) # 2x2 + expect_identical(finite_cases(data_frame(x = c(4, NA), y = c(NA, 12))), c(FALSE, FALSE)) # 2x2 + expect_identical(finite_cases(data_frame(x = c(4, 5), y = c(NA, 12))), c(FALSE, TRUE)) # 2x2 # Testing NaN and Inf, using miscellaneous data shapes -------------------- - expect_identical(finite_cases(data.frame(x = c(4, NaN))), c(TRUE, FALSE)) - expect_identical(finite_cases(data.frame(x = Inf)), FALSE) - expect_identical(finite_cases(data.frame(x = c(4, 5), y = c(-Inf, 12))), c(FALSE, TRUE)) + expect_identical(finite_cases(data_frame(x = c(4, NaN))), c(TRUE, FALSE)) + expect_identical(finite_cases(data_frame(x = Inf)), FALSE) + expect_identical(finite_cases(data_frame(x = c(4, 5), y = c(-Inf, 12))), c(FALSE, TRUE)) }) test_that("add_group", { - data <- data.frame(f=letters[7:9], x=1:3, y=4:6, group=c(1, -1, 1)) + data <- data_frame(f=letters[7:9], x=1:3, y=4:6, group=c(1, -1, 1)) expect_true(has_groups(add_group(data[2:4]))) # explicit group column expect_true(has_groups(add_group(data[1:3]))) # discrete column expect_false(has_groups(add_group(data[2:3]))) # no group or discrete column diff --git a/tests/testthat/test-viridis.R b/tests/testthat/test-viridis.R index 3f5ecb0ed9..8b4fb1e758 100644 --- a/tests/testthat/test-viridis.R +++ b/tests/testthat/test-viridis.R @@ -1,6 +1,6 @@ context("Viridis") -df <- data.frame(x = 1, y = 1, z = "a", tier = factor("low", ordered = TRUE)) +df <- data_frame(x = 1, y = 1, z = "a", tier = factor("low", ordered = TRUE)) test_that("viridis scale changes point color", { p1 <- ggplot(df, aes(x, y, colour = z)) + @@ -13,6 +13,6 @@ test_that("viridis scale changes point color", { test_that("viridis scale is used by default for ordered factors", { p <- ggplot(df, aes(x, y, colour = tier)) + geom_point() - + expect_equal(layer_data(p)$colour, "#440154FF") }) From dae8d4cadc2a50060415bde29c9d32705c48d3eb Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Tue, 13 Nov 2018 15:26:07 +0100 Subject: [PATCH 13/16] More strict recycling. Check for named input --- R/aaa-.r | 13 ++++++------- R/annotation.r | 2 +- R/limits.r | 2 +- tests/testthat/test-coord-polar.r | 2 +- tests/testthat/test-empty-data.r | 2 +- tests/testthat/test-geom-dotplot.R | 6 +++--- tests/testthat/test-geom-violin.R | 4 ++-- tests/testthat/test-guides.R | 2 +- 8 files changed, 16 insertions(+), 17 deletions(-) diff --git a/R/aaa-.r b/R/aaa-.r index 30b1490ca8..4c69b19b31 100644 --- a/R/aaa-.r +++ b/R/aaa-.r @@ -16,11 +16,15 @@ 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(x)) + n <- if (length(x) == 0) 0 else max(lengths) } for (i in seq_along(x)) { - if (length(x[[i]]) != n) x[[i]] <- rep(x[[i]], length.out = n) + 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" @@ -37,11 +41,6 @@ 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) } -validate_data_frame <- function(x) { - if (length(unique(lengths(x))) != 1) stop('All elements in a data.frame must be of equal length', call. = FALSE) - if (is.null(names(x))) stop('Columns must be named', call. = FALSE) -} - mat_2_df <- function(x, col_names = NULL, .check = FALSE) { if (is.null(col_names)) col_names <- colnames(x) x <- split(x, rep(seq_len(ncol(x)), each = nrow(x))) diff --git a/R/annotation.r b/R/annotation.r index e136ab8da2..04b1bdb1fa 100644 --- a/R/annotation.r +++ b/R/annotation.r @@ -45,7 +45,7 @@ annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL, aesthetics <- c(position, list(...)) # Check that all aesthetic have compatible lengths - lengths <- lengths(aesthetics) + lengths <- vapply(aesthetics, length, integer(1)) unequal <- length(unique(setdiff(lengths, 1L))) > 1L if (unequal) { bad <- lengths != 1L diff --git a/R/limits.r b/R/limits.r index 71d970dfad..6fa2dae289 100644 --- a/R/limits.r +++ b/R/limits.r @@ -146,7 +146,7 @@ expand_limits <- function(...) { data <- list(...) data_dfs <- vapply(data, is.data.frame, logical(1)) data <- do.call(c, c(list(data[!data_dfs]), data[data_dfs])) - n_rows <- max(lengths(data)) + n_rows <- max(vapply(data, length, integer(1))) data <- lapply(data, rep, length.out = n_rows) data <- new_data_frame(data) diff --git a/tests/testthat/test-coord-polar.r b/tests/testthat/test-coord-polar.r index e800f0a206..4e6057a0f5 100644 --- a/tests/testthat/test-coord-polar.r +++ b/tests/testthat/test-coord-polar.r @@ -75,7 +75,7 @@ test_that("polar coordinates draw correctly", { axis.title = element_blank(), panel.grid.major = element_line(colour = "grey90") ) - dat <- data_frame(x = 0:1, y = rep(c(1, 10, 40, 80), each = 2)) + dat <- data_frame(x = rep(0:1, 4), y = rep(c(1, 10, 40, 80), each = 2)) expect_doppelganger("three-concentric-circles", ggplot(dat, aes(x, y, group = factor(y))) + diff --git a/tests/testthat/test-empty-data.r b/tests/testthat/test-empty-data.r index f465357268..26c0cb8bcc 100644 --- a/tests/testthat/test-empty-data.r +++ b/tests/testthat/test-empty-data.r @@ -94,7 +94,7 @@ test_that("empty layers still generate one grob per panel", { }) test_that("missing layers generate one grob per panel", { - df <- data_frame(x = 1:4, y = 1:2, g = 1:2) + df <- data_frame(x = 1:4, y = rep(1:2, 2), g = rep(1:2, 2)) base <- ggplot(df, aes(x, y)) + geom_point(shape = NA, na.rm = TRUE) expect_equal(length(layer_grob(base)), 1) diff --git a/tests/testthat/test-geom-dotplot.R b/tests/testthat/test-geom-dotplot.R index d0080a4c43..b394d76cc4 100644 --- a/tests/testthat/test-geom-dotplot.R +++ b/tests/testthat/test-geom-dotplot.R @@ -1,7 +1,7 @@ context("geom_dotplot") set.seed(111) -dat <- data_frame(x = LETTERS[1:2], y = rnorm(30), g = LETTERS[3:5]) +dat <- data_frame(x = rep(LETTERS[1:2], 15), y = rnorm(30), g = rep(LETTERS[3:5], 10)) test_that("dodging works", { p <- ggplot(dat, aes(x = x, y = y, fill = g)) + @@ -81,7 +81,7 @@ test_that("when binning on y-axis, limits depend on the panel", { test_that("geom_dotplot draws correctly", { set.seed(112) - dat <- data_frame(x = rnorm(20), g = LETTERS[1:2]) + dat <- data_frame(x = rnorm(20), g = rep(LETTERS[1:2], 10)) # Basic dotplot with binning along x axis expect_doppelganger("basic dotplot with dot-density binning, binwidth = .4", @@ -145,7 +145,7 @@ test_that("geom_dotplot draws correctly", { ) # Binning along y, with multiple grouping factors - dat2 <- data_frame(x = factor(LETTERS[1:3]), y = rnorm(90), g = factor(LETTERS[1:2])) + dat2 <- data_frame(x = rep(factor(LETTERS[1:3]), 30), y = rnorm(90), g = rep(factor(LETTERS[1:2]), 45)) expect_doppelganger("bin y, three x groups, stack centerwhole", ggplot(dat2, aes(x, y)) + geom_dotplot(binwidth = .25, binaxis = "y", stackdir = "centerwhole") diff --git a/tests/testthat/test-geom-violin.R b/tests/testthat/test-geom-violin.R index 1be2221168..4c4a3d10ff 100644 --- a/tests/testthat/test-geom-violin.R +++ b/tests/testthat/test-geom-violin.R @@ -39,7 +39,7 @@ test_that("quantiles do not fail on zero-range data", { test_that("geom_violin draws correctly", { set.seed(111) - dat <- data_frame(x = factor(LETTERS[1:3]), y = rnorm(90)) + dat <- data_frame(x = rep(factor(LETTERS[1:3]), 30), y = rnorm(90)) dat <- dat[dat$x != "C" | c(T, F),] # Keep half the C's expect_doppelganger("basic", @@ -79,7 +79,7 @@ test_that("geom_violin draws correctly", { ggplot(dat, aes(x=x, y=y)) + geom_violin(draw_quantiles=c(0.25,0.5,0.75)) ) - dat2 <- data_frame(x = factor(LETTERS[1:3]), y = rnorm(90), g = factor(letters[5:6])) + dat2 <- data_frame(x = rep(factor(LETTERS[1:3]), 30), y = rnorm(90), g = rep(factor(letters[5:6]), 45)) expect_doppelganger("grouping on x and fill", ggplot(dat2, aes(x = x, y = y, fill = g)) + geom_violin() ) diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index af404d7a7a..b7f1c963e7 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -214,7 +214,7 @@ test_that("guides title and text are positioned correctly", { }) test_that("colorbar can be styled", { - df <- data_frame(x <- c(0, 1, 2)) + df <- data_frame(x = c(0, 1, 2)) p <- ggplot(df, aes(x, x, color = x)) + geom_point() expect_doppelganger("white-to-red gradient colorbar, white tick marks, no frame", From 57ffd8e7a3eef99bbadc84feb3bae0796f0d9f3d Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Thu, 15 Nov 2018 20:56:27 +0100 Subject: [PATCH 14/16] cleaner mat_2_col implementation --- R/aaa-.r | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/aaa-.r b/R/aaa-.r index 4c69b19b31..b763b6a5c0 100644 --- a/R/aaa-.r +++ b/R/aaa-.r @@ -41,9 +41,8 @@ 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 = NULL, .check = FALSE) { - if (is.null(col_names)) col_names <- colnames(x) - x <- split(x, rep(seq_len(ncol(x)), each = nrow(x))) +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) } From eb82d19e2517ccd96c437c66fed430aee7022915 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Thu, 15 Nov 2018 21:05:08 +0100 Subject: [PATCH 15/16] Removed unnessecary rep() --- R/annotation-logticks.r | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/annotation-logticks.r b/R/annotation-logticks.r index a8e39ab109..909c01684c 100644 --- a/R/annotation-logticks.r +++ b/R/annotation-logticks.r @@ -238,7 +238,7 @@ calc_logticks <- function(base = 10, ticks_per_base = base - 1, longtick_after_base <- floor(ticks_per_base/2) tickend[ cycleIdx == longtick_after_base ] <- midend - tickdf <- new_data_frame(list(value = ticks, start = rep(start, length(ticks)), end = tickend), n = length(ticks)) + tickdf <- new_data_frame(list(value = ticks, start = start, end = tickend), n = length(ticks)) return(tickdf) } From 9efcffbd67b987251924b99c66d85ab1df9053bf Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Thu, 15 Nov 2018 21:05:23 +0100 Subject: [PATCH 16/16] Remove stray stringAsFactors --- R/geom-errorbar.r | 1 - 1 file changed, 1 deletion(-) diff --git a/R/geom-errorbar.r b/R/geom-errorbar.r index d6d41e2e10..9c0a4361c2 100644 --- a/R/geom-errorbar.r +++ b/R/geom-errorbar.r @@ -51,7 +51,6 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, size = rep(data$size, each = 8), linetype = rep(data$linetype, each = 8), group = rep(1:(nrow(data)), each = 8), - stringsAsFactors = FALSE, row.names = 1:(nrow(data) * 8) )), panel_params, coord) }