diff --git a/R/abstract_stat_slabinterval.R b/R/abstract_stat_slabinterval.R index 9fc96bfe..f92b48ec 100644 --- a/R/abstract_stat_slabinterval.R +++ b/R/abstract_stat_slabinterval.R @@ -67,7 +67,7 @@ AbstractStatSlabinterval = ggproto("AbstractStatSlabinterval", AbstractStat, # @param trans the scale transformation object applied to the coordinate space # @param ... other stat parameters created by children of stat_slabinterval compute_limits = function(self, data, trans, ...) { - data.frame(.lower = NA, .upper = NA) + data_frame0(.lower = NA, .upper = NA) }, # Compute the function that defines the slab. That takes a data frame of @@ -81,7 +81,7 @@ AbstractStatSlabinterval = ggproto("AbstractStatSlabinterval", AbstractStat, # @param trans the scale transformation object applied to the coordinate space # @param ... other stat parameters created by children of stat_slabinterval compute_slab = function(self, data, scales, trans, input, ...) { - data.frame() + data_frame0() }, # Compute interval(s). Takes a data frame of aesthetics and a `.width` @@ -99,7 +99,7 @@ AbstractStatSlabinterval = ggproto("AbstractStatSlabinterval", AbstractStat, .width, na.rm, ... ) { - if (is.null(point_interval)) return(data.frame()) + if (is.null(point_interval)) return(data_frame0()) define_orientation_variables(orientation) @@ -128,9 +128,9 @@ AbstractStatSlabinterval = ggproto("AbstractStatSlabinterval", AbstractStat, is_missing = is.na(data$dist) if (any(is_missing)) { data = data[!is_missing, ] - remove_missing(data.frame(dist = ifelse(is_missing, NA_real_, 0)), na.rm, "dist", name = "stat_slabinterval") + remove_missing(data_frame0(dist = ifelse(is_missing, NA_real_, 0)), na.rm, "dist", name = "stat_slabinterval") } - if (nrow(data) == 0) return(data.frame()) + if (nrow(data) == 0) return(data_frame0()) # figure out coordinate transformation @@ -181,7 +181,7 @@ AbstractStatSlabinterval = ggproto("AbstractStatSlabinterval", AbstractStat, ... ) } else { - data.frame(.input = numeric()) + data_frame0(.input = numeric()) } i_data = self$compute_interval(d, trans = trans, diff --git a/R/binning_methods.R b/R/binning_methods.R index be6662e3..1463786a 100644 --- a/R/binning_methods.R +++ b/R/binning_methods.R @@ -75,7 +75,7 @@ bin_dots = function(x, y, binwidth, side = match.arg(side) orientation = match.arg(orientation) - d = data.frame(x = x, y = y) + d = data_frame0(x = x, y = y) # after this point `x` and `y` refer to column names in `d` according # to the orientation diff --git a/R/curve_interval.R b/R/curve_interval.R index fc462ee1..d5c0cfd7 100755 --- a/R/curve_interval.R +++ b/R/curve_interval.R @@ -152,7 +152,7 @@ curve_interval.matrix = function( check_along_is_null(.along) curve_interval( - data.frame(.value = posterior::rvar(.data)), .value, + data_frame0(.value = posterior::rvar(.data)), .value, .width = .width, na.rm = na.rm, .interval = .interval ) @@ -167,7 +167,7 @@ curve_interval.rvar = function( check_along_is_null(.along) curve_interval( - data.frame(.value = .data), .value, + data_frame0(.value = .data), .value, .width = .width, na.rm = na.rm, .interval = .interval ) diff --git a/R/geom_slabinterval.R b/R/geom_slabinterval.R index 63149acd..5152c033 100755 --- a/R/geom_slabinterval.R +++ b/R/geom_slabinterval.R @@ -81,7 +81,7 @@ rescale_slab_thickness = function( s_data = ggplot2::remove_missing(s_data, na.rm, c(height, "justification", "scale"), name = name, finite = TRUE) # side is a character vector, thus need finite = FALSE for it; x/y can be Inf here s_data = ggplot2::remove_missing(s_data, na.rm, c(x, y, "side"), name = name) - if (nrow(s_data) == 0) return(list(data = s_data, subguide_params = data.frame())) + if (nrow(s_data) == 0) return(list(data = s_data, subguide_params = data_frame0())) min_height = min(s_data[[height]]) @@ -100,7 +100,7 @@ rescale_slab_thickness = function( thickness_scale = d$scale[[1]] * min_height - subguide_params = data.frame( + subguide_params = data_frame0( group = d$group[[1]], side = d$size[[1]], justification = d$justification[[1]], diff --git a/R/guide_rampbar.R b/R/guide_rampbar.R index a14100ad..146fe5b1 100755 --- a/R/guide_rampbar.R +++ b/R/guide_rampbar.R @@ -71,7 +71,7 @@ guide_rampbar = function(..., to = "gray65", available_aes = c("fill_ramp", "col if (length(bar) == 0) { bar = unique(limits) } - bar = data_frame( + bar = data_frame0( colour = scale$map(bar), value = bar, .size = length(bar) diff --git a/R/point_interval.R b/R/point_interval.R index f4609773..daf0ca08 100644 --- a/R/point_interval.R +++ b/R/point_interval.R @@ -226,7 +226,7 @@ point_interval.default = function(.data, ..., .width = .95, .point = median, .in map_dfr_(seq_len(nrow(row)), function(j) { # get row of `data` with grouping factors # faster version of row_j = row[j, , drop = FALSE] - row_j = tibble::new_tibble(lapply(row, vctrs::vec_slice, j), nrow = 1) + row_j = new_data_frame(lapply(row, vctrs::vec_slice, j), n = 1L) row.names(row_j) = NULL draws_j = draws[[j]] @@ -322,7 +322,7 @@ point_interval.numeric = function(.data, ..., .width = .95, .point = median, .in result = map_dfr_(.width, function(p) { interval = .interval(data, .width = p, na.rm = na.rm) - data.frame( + data_frame0( y = .point(data, na.rm = na.rm), ymin = interval[, 1], ymax = interval[, 2], diff --git a/R/stat_dotsinterval.R b/R/stat_dotsinterval.R index 4e4c5668..a57e67de 100755 --- a/R/stat_dotsinterval.R +++ b/R/stat_dotsinterval.R @@ -20,7 +20,7 @@ compute_slab_dots = function( dist = data$dist if (distr_is_missing(dist)) { - return(data.frame(.input = NA_real_, f = NA_real_, n = NA_integer_)) + return(data_frame0(.input = NA_real_, f = NA_real_, n = NA_integer_)) } quantiles = quantiles %||% NA @@ -64,7 +64,7 @@ compute_slab_dots = function( se = 0 } - out = data.frame( + out = data_frame0( .input = input, f = 1, n = length(input) diff --git a/R/stat_slabinterval.R b/R/stat_slabinterval.R index 90478c0e..7863768f 100755 --- a/R/stat_slabinterval.R +++ b/R/stat_slabinterval.R @@ -16,19 +16,19 @@ compute_limits_slabinterval = function( ) { dist = check_one_dist(data$dist) if (distr_is_missing(dist)) { - return(data.frame(.lower = NA, .upper = NA)) + return(data_frame0(.lower = NA, .upper = NA)) } if (distr_is_factor_like(dist)) { # limits on factor-like dists are determined by the scale, which will # have been set earlier (in layer_slabinterval()), so we don't have to # do it here - return(data.frame(.lower = NA, .upper = NA)) + return(data_frame0(.lower = NA, .upper = NA)) } if (distr_is_constant(dist)) { .median = distr_quantile(dist)(0.5) - return(data.frame(.lower = .median, .upper = .median)) + return(data_frame0(.lower = .median, .upper = .median)) } if (distr_is_sample(dist)) { @@ -57,7 +57,7 @@ compute_limits_slabinterval = function( lower_limit = min(quantile_fun(p_limits[[1]])) upper_limit = max(quantile_fun(p_limits[[2]])) - data.frame( + data_frame0( .lower = lower_limit, .upper = upper_limit ) @@ -74,7 +74,7 @@ compute_limits_sample = function(x, trans, trim, adjust, ..., density = "bounded # determine limits of data based on the density estimator x = trans$transform(x) x_range = range(density(x, n = 2, range_only = TRUE, trim = trim, adjust = adjust, weights = weights)$x) - data.frame( + data_frame0( .lower = trans$inverse(x_range[[1]]), .upper = trans$inverse(x_range[[2]]) ) @@ -94,7 +94,7 @@ compute_slab_slabinterval = function( dist = data$dist # TODO: add support for multivariate distributions if (distr_is_missing(dist) || distr_is_multivariate(dist)) { - return(data.frame(.input = NA_real_, f = NA_real_, n = NA_integer_)) + return(data_frame0(.input = NA_real_, f = NA_real_, n = NA_integer_)) } # calculate pdf and cdf @@ -167,7 +167,7 @@ compute_slab_slabinterval = function( cdf = cdf_fun(input) } - data.frame( + data_frame0( .input = input, f = get_slab_function(slab_type, list(pdf = pdf, cdf = cdf)), pdf = pdf, @@ -191,7 +191,6 @@ compute_slab_sample = function( ..., weights = NULL ) { - if (is.integer(x) || inherits(x, "mapped_discrete")) { # discrete variables are always displayed as histograms slab_type = "histogram" @@ -207,7 +206,7 @@ compute_slab_sample = function( breaks = breaks, align = align, outline_bars = outline_bars, weights = weights ) - slab_df = data.frame( + slab_df = data_frame0( .input = trans$inverse(d$x), pdf = d$y, cdf = d$cdf %||% weighted_ecdf(x, weights = weights)(d$x) @@ -221,7 +220,7 @@ compute_slab_sample = function( if (expand[[1]]) { input_below_slab = input[input < min(slab_df$.input) - .Machine$double.eps] if (length(input_below_slab) > 0) { - slab_df = rbind(data.frame( + slab_df = rbind(data_frame0( .input = input_below_slab, pdf = 0, cdf = 0 @@ -231,7 +230,7 @@ compute_slab_sample = function( if (expand[[2]]) { input_above_slab = input[input > max(slab_df$.input) + .Machine$double.eps] if (length(input_above_slab) > 0) { - slab_df = rbind(slab_df, data.frame( + slab_df = rbind(slab_df, data_frame0( .input = input_above_slab, pdf = 0, cdf = 1 @@ -255,10 +254,10 @@ compute_interval_slabinterval = function( .width, na.rm, ... ) { - if (is.null(point_interval)) return(data.frame()) + if (is.null(point_interval)) return(data_frame0()) dist = data$dist if (distr_is_missing(dist)) { - return(data.frame(.value = NA_real_, .lower = NA_real_, .upper = NA_real_, .width = .width)) + return(data_frame0(.value = NA_real_, .lower = NA_real_, .upper = NA_real_, .width = .width)) } distr_point_interval(dist, point_interval, trans = trans, .width = .width, na.rm = na.rm) @@ -624,7 +623,7 @@ StatSlabinterval = ggproto("StatSlabinterval", AbstractStatSlabinterval, # dist aesthetic is not provided but x aesthetic is, and x is not a dist # this means we need to wrap it as a weighted dist_sample data = summarise_by(data, c("PANEL", y, "group"), function(d) { - data.frame(dist = .dist_weighted_sample(list(trans$inverse(d[[x]])), list(d[["weight"]]))) + data_frame0(dist = .dist_weighted_sample(list(trans$inverse(d[[x]])), list(d[["weight"]]))) }) data[[x]] = median(data$dist) } diff --git a/R/stat_spike.R b/R/stat_spike.R index 3ed67354..dc853647 100755 --- a/R/stat_spike.R +++ b/R/stat_spike.R @@ -113,15 +113,15 @@ compute_slab_spike = function( # needs to be a vector (e.g. in cases of interval functions # like qi() which return matrices) input = unlist(input_nested, use.names = FALSE, recursive = FALSE) - names(input) = rep(names(at), times = lengths(input_nested)) + input_names = rep(names(at), times = lengths(input_nested)) # evaluate functions pdf = pdf_fun(input) cdf = cdf_fun(input) - data.frame( + data_frame0( .input = input, - at = names(input), + at = input_names, f = if (length(input) > 0) get_slab_function(slab_type, list(pdf = pdf, cdf = cdf)), pdf = pdf, cdf = cdf, diff --git a/R/subguide.R b/R/subguide.R index f9d531bf..8b9a9126 100755 --- a/R/subguide.R +++ b/R/subguide.R @@ -298,12 +298,12 @@ draw_subguide_axis = function( position = axis_position ) params = guide$params - params$key = data_frame( + params$key = data_frame0( !!aes := break_positions, .value = break_positions, .label = break_labels ) - params$decor = data_frame( + params$decor = data_frame0( !!aes := c(0, 1), !!opp := if (axis_position %in% c("top", "right")) 0 else 1 ) diff --git a/R/util.R b/R/util.R index 86ebd86e..c4762ca9 100644 --- a/R/util.R +++ b/R/util.R @@ -136,6 +136,12 @@ check_na = function(x, na.rm) { # data frames ------------------------------------------------------------- +#' fast data frame creation +#' @noRd +data_frame0 = function(...) { + vctrs::data_frame(..., .name_repair = "minimal") +} + #' rename columns using a lookup table #' @param data data frame #' @param new_names lookup table of new column names, where names are @@ -182,7 +188,7 @@ map_dfr_ = function(data, fun, ...) { row_map_dfr_ = function(data, fun, ...) { map_dfr_(seq_len(nrow(data)), function(row_i) { # faster version of row_df = data[row_i, , drop = FALSE] - row_df = tibble::new_tibble(lapply(data, vctrs::vec_slice, row_i), nrow = 1) + row_df = new_data_frame(lapply(data, vctrs::vec_slice, row_i), n = 1L) fun(row_df, ...) }) } @@ -221,7 +227,7 @@ dlply_ = function(data, groups, fun, ...) { lapply(group_is, function(group_i) { # faster version of row_df = data[group_i, , drop = FALSE] - row_df = tibble::new_tibble(lapply(data, vctrs::vec_slice, group_i), nrow = length(group_i)) + row_df = new_data_frame(lapply(data, vctrs::vec_slice, group_i), n = length(group_i)) fun(row_df, ...) }) } else { diff --git a/tests/testthat/test.util.R b/tests/testthat/test.util.R index e24aad30..1ab69708 100755 --- a/tests/testthat/test.util.R +++ b/tests/testthat/test.util.R @@ -3,7 +3,9 @@ # Author: mjskay ############################################################################### -library(dplyr) +suppressPackageStartupMessages(suppressWarnings({ + library(dplyr) +})) test_that("all_names works", { @@ -51,12 +53,21 @@ test_that("fct_rev_ works properly", { # dlply_ ------------------------------------------------------------------ test_that("dlply_ works properly", { - df = tibble( + df = data.frame( x = 1:8, - g = c(rep("a", 2), rep("(Missing)", 2), rep("(Missing)+", 2), rep(NA, 2)) + g = c(rep("a", 2), rep("(Missing)", 2), rep("(Missing)+", 2), rep(NA, 2)), + stringsAsFactors = FALSE ) - expect_equal(dlply_(df, "g", identity), list(df[3:4,], df[5:6,], df[1:2,], df[7:8,])) + expect_equal( + dlply_(df, "g", identity), + list( + new_data_frame(df[3:4,]), + new_data_frame(df[5:6,]), + new_data_frame(df[1:2,]), + new_data_frame(df[7:8,]) + ) + ) expect_equal(dlply_(df, NULL, identity), list(df))