Use vctrs internally (#4868)

Author: thomasp85

DESCRIPTION

@@ -43,6 +43,7 @@ Imports:
     scales (>= 1.2.0),
     stats,
     tibble,
+    vctrs (>= 0.4.1),
     withr (>= 2.0.0)
 Suggests:
     covr,
@@ -79,7 +80,7 @@ Config/testthat/edition: 3
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.0
+RoxygenNote: 7.2.0.9000
 Collate: 
     'ggproto.r'
     'ggplot-global.R'

NAMESPACE

@@ -4,23 +4,20 @@ S3method("$",ggproto)
 S3method("$",ggproto_parent)
 S3method("$<-",uneval)
 S3method("+",gg)
-S3method("[",mapped_discrete)
 S3method("[",uneval)
-S3method("[<-",mapped_discrete)
 S3method("[<-",uneval)
 S3method("[[",ggproto)
 S3method("[[<-",uneval)
 S3method(.DollarNames,ggproto)
-S3method(as.data.frame,mapped_discrete)
 S3method(as.list,ggproto)
 S3method(autolayer,default)
 S3method(autoplot,default)
-S3method(c,mapped_discrete)
 S3method(drawDetails,zeroGrob)
 S3method(element_grob,element_blank)
 S3method(element_grob,element_line)
 S3method(element_grob,element_rect)
 S3method(element_grob,element_text)
+S3method(format,ggplot2_mapped_discrete)
 S3method(format,ggproto)
 S3method(format,ggproto_method)
 S3method(fortify,"NULL")
@@ -142,6 +139,30 @@ S3method(scale_type,sfc)
 S3method(single_value,default)
 S3method(single_value,factor)
 S3method(summary,ggplot)
+S3method(vec_arith,ggplot2_mapped_discrete)
+S3method(vec_arith.ggplot2_mapped_discrete,MISSING)
+S3method(vec_arith.ggplot2_mapped_discrete,default)
+S3method(vec_arith.ggplot2_mapped_discrete,ggplot2_mapped_discrete)
+S3method(vec_arith.ggplot2_mapped_discrete,numeric)
+S3method(vec_arith.numeric,ggplot2_mapped_discrete)
+S3method(vec_cast,character.ggplot2_mapped_discrete)
+S3method(vec_cast,double.ggplot2_mapped_discrete)
+S3method(vec_cast,factor.ggplot2_mapped_discrete)
+S3method(vec_cast,ggplot2_mapped_discrete.double)
+S3method(vec_cast,ggplot2_mapped_discrete.factor)
+S3method(vec_cast,ggplot2_mapped_discrete.ggplot2_mapped_discrete)
+S3method(vec_cast,ggplot2_mapped_discrete.integer)
+S3method(vec_cast,integer.ggplot2_mapped_discrete)
+S3method(vec_math,ggplot2_mapped_discrete)
+S3method(vec_ptype2,character.ggplot2_mapped_discrete)
+S3method(vec_ptype2,double.ggplot2_mapped_discrete)
+S3method(vec_ptype2,factor.ggplot2_mapped_discrete)
+S3method(vec_ptype2,ggplot2_mapped_discrete.character)
+S3method(vec_ptype2,ggplot2_mapped_discrete.double)
+S3method(vec_ptype2,ggplot2_mapped_discrete.factor)
+S3method(vec_ptype2,ggplot2_mapped_discrete.ggplot2_mapped_discrete)
+S3method(vec_ptype2,ggplot2_mapped_discrete.integer)
+S3method(vec_ptype2,integer.ggplot2_mapped_discrete)
 S3method(widthDetails,titleGrob)
 S3method(widthDetails,zeroGrob)
 export("%+%")
@@ -668,6 +689,7 @@ export(update_geom_defaults)
 export(update_labels)
 export(update_stat_defaults)
 export(vars)
+export(vec_arith.ggplot2_mapped_discrete)
 export(waiver)
 export(wrap_dims)
 export(xlab)
@@ -679,6 +701,7 @@ import(grid)
 import(gtable)
 import(rlang)
 import(scales)
+import(vctrs)
 importFrom(glue,glue)
 importFrom(glue,glue_collapse)
 importFrom(lifecycle,deprecated)

R/aes.r

@@ -179,7 +179,7 @@ rename_aes <- function(x) {
   names(x) <- standardise_aes_names(names(x))
   duplicated_names <- names(x)[duplicated(names(x))]
   if (length(duplicated_names) > 0L) {
-    cli::cli_warn("Duplicated aesthetics after name standardisation: {.field {unique(duplicated_names)}}")
+    cli::cli_warn("Duplicated aesthetics after name standardisation: {.field {unique0(duplicated_names)}}")
   }
   x
 }

R/annotation-custom.r

@@ -73,7 +73,11 @@ GeomCustomAnn <- ggproto("GeomCustomAnn", Geom,
     if (!inherits(coord, "CoordCartesian")) {
       cli::cli_abort("{.fn annotation_custom} only works with {.fn coord_cartesian}")
     }
-    corners <- new_data_frame(list(x = c(xmin, xmax), y = c(ymin, ymax)), n = 2)
+    corners <- data_frame0(
+      x = c(xmin, xmax),
+      y = c(ymin, ymax),
+      .size = 2
+    )
     data <- coord$transform(corners, panel_params)
 
     x_rng <- range(data$x, na.rm = TRUE)

R/annotation-logticks.r

@@ -213,7 +213,7 @@ GeomLogticks <- ggproto("GeomLogticks", Geom,
       }
     }
 
-    gTree(children = do.call("gList", ticks))
+    gTree(children = inject(gList(!!!ticks)))
   },
 
   default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = 1)
@@ -254,7 +254,12 @@ 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 = start, end = tickend), n = length(ticks))
+  tickdf <- data_frame0(
+    value = ticks,
+    start = start,
+    end = tickend,
+    .size = length(ticks)
+  )
 
   return(tickdf)
 }

R/annotation-map.r

@@ -93,7 +93,7 @@ GeomAnnotationMap <- ggproto("GeomAnnotationMap", GeomMap,
     # must be sequential integers
     coords <- coord_munch(coord, map, panel_params)
     coords$group <- coords$group %||% coords$id
-    grob_id <- match(coords$group, unique(coords$group))
+    grob_id <- match(coords$group, unique0(coords$group))
 
     polygonGrob(coords$x, coords$y, default.units = "native",
       id = grob_id,

R/annotation-raster.r

@@ -76,7 +76,11 @@ GeomRasterAnn <- ggproto("GeomRasterAnn", Geom,
     if (!inherits(coord, "CoordCartesian")) {
       cli::cli_abort("{.fn annotation_raster} only works with {.fn coord_cartesian}")
     }
-    corners <- new_data_frame(list(x = c(xmin, xmax), y = c(ymin, ymax)), n = 2)
+    corners <- data_frame0(
+      x = c(xmin, xmax),
+      y = c(ymin, ymax),
+      .size = 2
+    )
     data <- coord$transform(corners, panel_params)
 
     x_rng <- range(data$x, na.rm = TRUE)

R/annotation.r

@@ -57,7 +57,7 @@ annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL,
 
   # Check that all aesthetic have compatible lengths
   lengths <- vapply(aesthetics, length, integer(1))
-  n <- unique(lengths)
+  n <- unique0(lengths)
 
   # if there is more than one unique length, ignore constants
   if (length(n) > 1L) {
@@ -71,7 +71,7 @@ annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL,
     cli::cli_abort("Unequal parameter lengths: {details}")
   }
 
-  data <- new_data_frame(position, n = n)
+  data <- data_frame0(!!!position, .size = n)
   layer(
     geom = geom,
     params = list(

R/axis-secondary.R

@@ -193,7 +193,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL,
     full_range <- self$transform_range(old_range)
 
     # Test for monotonicity
-    if (length(unique(sign(diff(full_range)))) != 1)
+    if (length(unique0(sign(diff(full_range)))) != 1)
       cli::cli_abort("Transformation for secondary axes must be monotonic")
   },
 

R/bench.r

@@ -26,7 +26,7 @@ benchplot <- function(x) {
   times <- rbind(construct, build, render, draw)[, 1:3]
   times <- rbind(times, colSums(times))
 
-  cbind(
+  vec_cbind(
     step = c("construct", "build", "render", "draw", "TOTAL"),
     mat_2_df(times)
   )

R/bin.R

@@ -183,14 +183,15 @@ 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(list(
+  data_frame0(
     count = count,
     x = x,
     xmin = xmin,
     xmax = xmax,
     width = width,
     density = density,
     ncount = count / max(abs(count)),
-    ndensity = density / max(abs(density))
-  ), n = length(count))
+    ndensity = density / max(abs(density)),
+    .size = length(count)
+  )
 }

R/compat-plyr.R

@@ -62,7 +62,7 @@ id_var <- function(x, drop = FALSE) {
     id <- as.integer(x)
     n <- length(levels(x))
   } else {
-    levels <- sort(unique(x), na.last = TRUE)
+    levels <- sort(unique0(x), na.last = TRUE)
     id <- match(x, levels)
     n <- max(id)
   }
@@ -107,12 +107,12 @@ id <- function(.variables, drop = FALSE) {
   ndistinct <- vapply(ids, attr, "n", FUN.VALUE = numeric(1), USE.NAMES = FALSE)
   n <- prod(ndistinct)
   if (n > 2^31) {
-    char_id <- do.call("paste", c(ids, sep = "\r"))
-    res <- match(char_id, unique(char_id))
+    char_id <- inject(paste(!!!ids, sep = "\r"))
+    res <- match(char_id, unique0(char_id))
   }
   else {
     combs <- c(1, cumprod(ndistinct[-p]))
-    mat <- do.call("cbind", ids)
+    mat <- inject(cbind(!!!ids))
     res <- c((mat - 1L) %*% combs + 1L)
   }
   if (drop) {
@@ -153,13 +153,13 @@ count <- function(df, vars = NULL, wt_var = NULL) {
     wt <- .subset2(df, wt_var)
     freq <- vapply(split(wt, id), sum, numeric(1))
   }
-  new_data_frame(c(as.list(labels), list(n = freq)))
+  data_frame0(labels, n = freq)
 }
 # Adapted from plyr::join.keys
 # Create a shared unique id across two data frames such that common variable
 # combinations in the two data frames gets the same id
 join_keys <- function(x, y, by) {
-  joint <- rbind_dfs(list(x[by], y[by]))
+  joint <- vec_rbind(x[by], y[by])
   keys <- id(joint, drop = TRUE)
   n_x <- nrow(x)
   n_y <- nrow(y)
@@ -251,103 +251,6 @@ round_any <- function(x, accuracy, f = round) {
   }
   f(x/accuracy) * accuracy
 }
-#' Bind data frames together by common column names
-#'
-#' This function is akin to `plyr::rbind.fill`, `dplyr::bind_rows`, and
-#' `data.table::rbindlist`. It takes data frames in a list and stacks them on
-#' top of each other, filling out values with `NA` if the column is missing from
-#' a data.frame
-#'
-#' @param dfs A list of data frames
-#'
-#' @return A data.frame with the union of all columns from the data frames given
-#' in `dfs`
-#'
-#' @keywords internal
-#' @noRd
-#'
-rbind_dfs <- function(dfs) {
-  out <- list()
-  columns <- unique(unlist(lapply(dfs, names)))
-  nrows <- vapply(dfs, .row_names_info, integer(1), type = 2L)
-  total <- sum(nrows)
-  if (length(columns) == 0) return(new_data_frame(list(), total))
-  allocated <- rep(FALSE, length(columns))
-  names(allocated) <- columns
-  col_levels <- list()
-  ord_levels <- list()
-  for (df in dfs) {
-    new_columns <- intersect(names(df), columns[!allocated])
-    for (col in new_columns) {
-      if (is.factor(df[[col]])) {
-        all_ordered <- all(vapply(dfs, function(df) {
-          val <- .subset2(df, col)
-          is.null(val) || is.ordered(val)
-        }, logical(1)))
-        all_factors <- all(vapply(dfs, function(df) {
-          val <- .subset2(df, col)
-          is.null(val) || is.factor(val)
-        }, logical(1)))
-        if (all_ordered) {
-          ord_levels[[col]] <- unique(unlist(lapply(dfs, function(df) levels(.subset2(df, col)))))
-        } else if (all_factors) {
-          col_levels[[col]] <- unique(unlist(lapply(dfs, function(df) levels(.subset2(df, col)))))
-        }
-        out[[col]] <- rep(NA_character_, total)
-      } else {
-        out[[col]] <- rep(.subset2(df, col)[1][NA], total)
-      }
-    }
-    allocated[new_columns] <- TRUE
-    if (all(allocated)) break
-  }
-  is_date <- lapply(out, inherits, 'Date')
-  is_time <- lapply(out, inherits, 'POSIXct')
-  pos <- c(cumsum(nrows) - nrows + 1)
-  for (i in seq_along(dfs)) {
-    df <- dfs[[i]]
-    rng <- seq(pos[i], length.out = nrows[i])
-    for (col in names(df)) {
-      date_col <- inherits(df[[col]], 'Date')
-      time_col <- inherits(df[[col]], 'POSIXct')
-      if (is_date[[col]] && !date_col) {
-        out[[col]][rng] <- as.Date(
-          unclass(df[[col]]),
-          origin = ggplot_global$date_origin
-        )
-      } else if (is_time[[col]] && !time_col) {
-        out[[col]][rng] <- as.POSIXct(
-          unclass(df[[col]]),
-          origin = ggplot_global$time_origin
-        )
-      } else if (date_col || time_col || inherits(df[[col]], 'factor')) {
-        out[[col]][rng] <- as.character(df[[col]])
-      } else {
-        out[[col]][rng] <- df[[col]]
-      }
-    }
-  }
-  for (col in names(ord_levels)) {
-    out[[col]] <- ordered(out[[col]], levels = ord_levels[[col]])
-  }
-  for (col in names(col_levels)) {
-    out[[col]] <- factor(out[[col]], levels = col_levels[[col]])
-  }
-  attributes(out) <- list(
-    class = "data.frame",
-    names = names(out),
-    row.names = .set_row_names(total)
-  )
-  out
-}
-
-# Info needed for rbind_dfs date/time handling
-on_load({
-  date <- Sys.Date()
-  ggplot_global$date_origin <- date - unclass(date)
-  time <- Sys.time()
-  ggplot_global$time_origin <- time - unclass(time)
-})
 
 #' Apply function to unique subsets of a data.frame
 #'
@@ -370,17 +273,18 @@ on_load({
 #' @noRd
 dapply <- function(df, by, fun, ..., drop = TRUE) {
   grouping_cols <- .subset(df, by)
-  fallback_order <- unique(c(by, names(df)))
+  fallback_order <- unique0(c(by, names(df)))
   apply_fun <- function(x) {
     res <- fun(x, ...)
     if (is.null(res)) return(res)
-    if (length(res) == 0) return(new_data_frame())
+    if (length(res) == 0) return(data_frame0())
     vars <- lapply(setNames(by, by), function(col) .subset2(x, col)[1])
     if (is.matrix(res)) res <- split_matrix(res)
     if (is.null(names(res))) names(res) <- paste0("V", seq_along(res))
-    if (all(by %in% names(res))) return(new_data_frame(unclass(res)))
+    if (all(by %in% names(res))) return(data_frame0(!!!unclass(res)))
     res <- modify_list(unclass(vars), unclass(res))
-    new_data_frame(res[intersect(c(fallback_order, names(res)), names(res))])
+    res <- res[intersect(c(fallback_order, names(res)), names(res))]
+    data_frame0(!!!res)
   }
 
   # Shortcut when only one group
@@ -390,10 +294,11 @@ dapply <- function(df, by, fun, ..., drop = TRUE) {
 
   ids <- id(grouping_cols, drop = drop)
   group_rows <- split_with_index(seq_len(nrow(df)), ids)
-  rbind_dfs(lapply(seq_along(group_rows), function(i) {
+  result <- lapply(seq_along(group_rows), function(i) {
     cur_data <- df_rows(df, group_rows[[i]])
     apply_fun(cur_data)
-  }))
+  })
+  vec_rbind(!!!result)
 }
 
 single_value <- function(x, ...) {