Improve performance for subsetting

R/names.R

@@ -31,8 +31,8 @@ error_column_names_must_be_unique <- function(names, repair = has_tibble_arg(".n
 # Subclassing errors ------------------------------------------------------
 
 subclass_name_repair_errors <- function(expr, name, details = NULL) {
-  tryCatch(
-    force(expr),
+  withCallingHandlers(
+    expr,
 
     # FIXME: use cnd$names with vctrs >= 0.3.0
     vctrs_error_names_cannot_be_empty = function(cnd) {

R/subsetting-matrix.R

@@ -26,7 +26,7 @@ tbl_subassign_matrix <- function(x, j, value, j_arg, value_arg) {
   cells <- matrix_to_cells(j, x, j_arg)
   col_idx <- cells_to_col_idx(cells)
 
-  tryCatch(
+  withCallingHandlers(
     for (j in col_idx) {
       xj <- x[[j]]
       vec_slice(xj, cells[[j]]) <- value

R/subsetting.R

@@ -75,13 +75,11 @@ NULL
 #' @inheritParams base::`[.data.frame`
 #' @export
 `$.tbl_df` <- function(x, name) {
-  j <- match(as_string(name), names2(x))
-  if (is.na(j)) {
+  out <- .subset2(x, name)
+  if (is.null(out)) {
     warn(paste0("Unknown or uninitialised column: ", tick(name), "."))
-    NULL
-  } else {
-    .subset2(x, j)
   }
+  out
 }
 
 
@@ -218,7 +216,23 @@ NULL
   }
 
   # From here on, i, j and drop contain correct values:
-  xo <- tbl_subset_col(x, j = j, j_arg)
+  xo <- x
+
+  if (!is.null(j)) {
+    j <- vectbl_as_col_location(j, length(xo), names(xo), j_arg = j_arg, assign = FALSE)
+
+    if (anyNA(j)) {
+      cnd_signal(error_na_column_index(which(is.na(j))))
+    }
+
+    xo <- .subset(x, j)
+
+    if (anyDuplicated(j)) {
+      xo <- set_repaired_names(xo, .name_repair = "minimal")
+    }
+
+    xo <- set_tibble_class(xo, nrow = fast_nrow(x))
+  }
 
   if (!is.null(i)) {
     xo <- tbl_subset_row(xo, i = i, i_arg)
@@ -293,9 +307,9 @@ vectbl_as_row_index <- function(i, x, i_arg, assign = FALSE) {
 }
 
 fix_oob <- function(i, n, warn = TRUE) {
-  if (all(i >= 0, na.rm = TRUE)) {
+  if (any(i > 0, na.rm = TRUE)) {
     fix_oob_positive(i, n, warn)
-  } else if (all(i <= 0, na.rm = TRUE)) {
+  } else if (any(i < 0, na.rm = TRUE)) {
     fix_oob_negative(i, n, warn)
   } else {
     # Will throw error in vec_as_location()
@@ -305,41 +319,29 @@ fix_oob <- function(i, n, warn = TRUE) {
 
 fix_oob_positive <- function(i, n, warn = TRUE) {
   oob <- which(i > n)
-  if (warn) {
-    warn_oob(oob, n)
+  if (warn && length(oob) > 0) {
+    deprecate_soft("3.0.0", "tibble::`[.tbl_df`(i = 'must lie in [0, rows] if positive,')",
+                   details = "Use `NA_integer_` as row index to obtain a row full of `NA` values.",
+                   env = foreign_caller_env())
   }
 
   i[oob] <- NA_integer_
   i
 }
 
-warn_oob <- function(oob, n) {
-  if (has_length(oob)) {
-    deprecate_soft("3.0.0", "tibble::`[.tbl_df`(i = 'must lie in [0, rows] if positive,')",
-      details = "Use `NA_integer_` as row index to obtain a row full of `NA` values.",
-      env = foreign_caller_env())
-  }
-}
-
 fix_oob_negative <- function(i, n, warn = TRUE) {
   oob <- (i < -n)
-  if (warn) {
-    warn_oob_negative(which(oob), n)
+  if (warn && any(oob, na.rm = TRUE)) {
+    deprecate_soft("3.0.0", "tibble::`[.tbl_df`(i = 'must lie in [-rows, 0] if negative,')",
+                   details = "Use `NA_integer_` as row index to obtain a row full of `NA` values.",
+                   env = foreign_caller_env())
   }
 
   i <- i[!oob]
   if (is_empty(i)) i <- seq_len(n)
   i
 }
 
-warn_oob_negative <- function(oob, n) {
-  if (has_length(oob)) {
-    deprecate_soft("3.0.0", "tibble::`[.tbl_df`(i = 'must lie in [-rows, 0] if negative,')",
-      details = "Use `NA_integer_` as row index to obtain a row full of `NA` values.",
-      env = foreign_caller_env())
-  }
-}
-
 fix_oob_invalid <- function(i, is_na_orig) {
   oob <- which(is.na(i) & !is_na_orig)
 
@@ -353,16 +355,6 @@ fix_oob_invalid <- function(i, is_na_orig) {
   i
 }
 
-vectbl_as_col_index <- function(j, x, j_arg, assign = FALSE) {
-  stopifnot(!is.null(j))
-
-  if (vec_is(j) && anyNA(j)) {
-    cnd_signal(error_na_column_index(which(is.na(j))))
-  }
-
-  vectbl_as_col_location(j, length(x), names(x), j_arg = j_arg, assign = assign)
-}
-
 tbl_subset2 <- function(x, j, j_arg) {
   if (is.matrix(j)) {
     deprecate_soft("3.0.0", "tibble::`[[.tbl_df`(j = 'can\\'t be a matrix",
@@ -392,14 +384,6 @@ tbl_subset2 <- function(x, j, j_arg) {
   .subset2(x, j)
 }
 
-tbl_subset_col <- function(x, j, j_arg) {
-  if (is.null(j)) return(x)
-  j <- vectbl_as_col_index(j, x, j_arg = j_arg)
-  xo <- .subset(x, j)
-  xo <- set_repaired_names(xo, .name_repair = "minimal")
-  set_tibble_class(xo, nrow = fast_nrow(x))
-}
-
 tbl_subset_row <- function(x, i, i_arg) {
   if (is.null(i)) return(x)
   i <- vectbl_as_row_index(i, x, i_arg)
@@ -447,7 +431,7 @@ tbl_subassign <- function(x, i, j, value, i_arg, j_arg, value_arg) {
         x <- tbl_subassign_col(x, j[new], init)
       }
 
-      xj <- tbl_subset_col(x, j, j_arg)
+      xj <- .subset(x, j)
       xj <- tbl_subassign_row(xj, i, value, value_arg)
       xo <- tbl_subassign_col(x, j, unclass(xj))
     }
@@ -532,10 +516,16 @@ vectbl_as_new_col_index <- function(j, x, value, j_arg, value_arg) {
 
     set_names(j, names)
   } else {
-    j <- vectbl_as_col_index(j, x, j_arg, assign = TRUE)
+    j <- vectbl_as_col_location(j, length(x), names(x), j_arg = j_arg, assign = TRUE)
+
+    if (anyNA(j)) {
+      cnd_signal(error_na_column_index(which(is.na(j))))
+    }
+
     if (anyDuplicated(j)) {
       cnd_signal(error_duplicate_column_subscript_for_assignment(j))
     }
+
     j
   }
 }
@@ -554,19 +544,19 @@ vectbl_as_row_location <- function(i, n, i_arg, assign = FALSE) {
     i <- i[, 1]
   }
 
-  subclass_row_index_errors(vec_as_location(i, n, arg = as_label(i_arg)), i_arg = i_arg, assign = assign)
+  subclass_row_index_errors(vec_as_location(i, n), i_arg = i_arg, assign = assign)
 }
 
 vectbl_as_row_location2 <- function(i, n, i_arg, assign = FALSE) {
-  subclass_row_index_errors(vec_as_location2(i, n, arg = as_label(i_arg)), i_arg = i_arg, assign = assign)
+  subclass_row_index_errors(vec_as_location2(i, n), i_arg = i_arg, assign = assign)
 }
 
 vectbl_as_col_location <- function(j, n, names = NULL, j_arg, assign = FALSE) {
-  subclass_col_index_errors(vec_as_location(j, n, names, arg = as_label(j_arg)), j_arg = j_arg, assign = assign)
+  subclass_col_index_errors(vec_as_location(j, n, names), j_arg = j_arg, assign = assign)
 }
 
 vectbl_as_col_location2 <- function(j, n, names = NULL, j_arg, assign = FALSE) {
-  subclass_col_index_errors(vec_as_location2(j, n, names, arg = as_label(j_arg)), j_arg = j_arg, assign = assign)
+  subclass_col_index_errors(vec_as_location2(j, n, names), j_arg = j_arg, assign = assign)
 }
 
 is_tight_sequence_at_end <- function(i_new, n) {
@@ -628,7 +618,7 @@ tbl_subassign_row <- function(x, i, value, value_arg) {
   nrow <- fast_nrow(x)
   x <- unclass(x)
 
-  tryCatch(
+  withCallingHandlers(
     for (j in seq_along(x)) {
       xj <- x[[j]]
       vec_slice(xj, i) <- value[[j]]
@@ -698,7 +688,7 @@ result_vectbl_wrap_rhs <- function(value) {
 }
 
 vectbl_recycle_rhs <- function(value, nrow, ncol, i_arg, value_arg) {
-  tryCatch(
+  withCallingHandlers(
     for (j in seq_along(value)) {
       if (!is.null(value[[j]])) {
         value[[j]] <- vec_recycle(value[[j]], nrow)
@@ -845,8 +835,8 @@ error_assign_incompatible_type <- function(x, value, j, value_arg, message) {
 # Subclassing errors ------------------------------------------------------
 
 subclass_col_index_errors <- function(expr, j_arg, assign) {
-  tryCatch(
-    force(expr),
+  withCallingHandlers(
+    expr,
     vctrs_error_subscript = function(cnd) {
       cnd$subscript_arg <- j_arg
       cnd$subscript_elt <- "column"
@@ -859,8 +849,8 @@ subclass_col_index_errors <- function(expr, j_arg, assign) {
 }
 
 subclass_row_index_errors <- function(expr, i_arg, assign) {
-  tryCatch(
-    force(expr),
+  withCallingHandlers(
+    expr,
     vctrs_error_subscript = function(cnd) {
       cnd$subscript_arg <- i_arg
       cnd$subscript_elt <- "row"

R/tribble.R

@@ -179,7 +179,7 @@ turn_frame_data_into_frame_matrix <- function(names, rest) {
 }
 
 subclass_tribble_c_errors <- function(name, code) {
-  tryCatch(
+  withCallingHandlers(
     code,
 
     vctrs_error = function(cnd) {

bench/bench-subsetting.R

@@ -0,0 +1,89 @@
+library(tibble)
+library(dplyr)
+library(bench)
+
+bm <- function(df) {
+  idx <- c(rep(TRUE, 5), rep(FALSE, 5))
+  bench::mark(
+    df[[1]], df[[1]] <- 1,
+    df[["a"]], df[["a"]] <- 1,
+    df[["aa"]], df[["aa"]] <- 1,
+    df[["aaa"]], df[["aaa"]] <- 1,
+    df[["b"]],
+
+    df$a, df$a <- 1,
+    df$aa, df$aa <- 1,
+    df$aaa, df$aaa <- 1,
+
+    df["a"], df["a"] <- 1,
+    df["aa"], df["aa"] <- 1,
+    df[c("aa", "aaa")], df[c("aa", "aaa")] <- 1,
+    df[1], df[1] <- 1,
+    df[2:3], df[2:3] <- 1,
+    df[TRUE], df[TRUE] <- 1,
+    df[c(TRUE, FALSE, TRUE)], df[c(TRUE, FALSE, TRUE)] <- 1,
+
+    df[, "a"], df[, "a"] <- 1,
+    df[, "aa"], df[, "aa"] <- 1,
+    df[, c("aa", "aaa")], df[, c("aa", "aaa")] <- 1,
+    df[, 1], df[, 1] <- 1,
+    df[, 2:3], df[, 2:3] <- 1,
+    df[, TRUE], df[, TRUE] <- 1,
+    df[, c(TRUE, FALSE, TRUE)], df[, c(TRUE, FALSE, TRUE)] <- 1,
+
+    df[1, ], df[1, ] <- 1,
+    df[3:7, ], df[3:7, ] <- 1,
+    df[TRUE, ], df[TRUE, ] <- 1,
+    df[idx, ], df[idx, ] <- 1,
+
+    df[1, "a"], df[1, "a"] <- 1,
+    df[1, "aa"], df[1, "aa"] <- 1,
+    df[1, c("aa", "aaa")], df[1, c("aa", "aaa")] <- 1,
+    df[1, 1], df[1, 1] <- 1,
+    df[1, 2:3], df[1, 2:3] <- 1,
+    df[1, TRUE], df[1, TRUE] <- 1,
+    df[1, c(TRUE, FALSE, TRUE)], df[1, c(TRUE, FALSE, TRUE)] <- 1,
+
+    df[3:7, "a"], df[3:7, "a"] <- 1,
+    df[3:7, "aa"], df[3:7, "aa"] <- 1,
+    df[3:7, c("aa", "aaa")], df[3:7, c("aa", "aaa")] <- 1,
+    df[3:7, 1], df[3:7, 1] <- 1,
+    df[3:7, 2:3], df[3:7, 2:3] <- 1,
+    df[3:7, TRUE], df[3:7, TRUE] <- 1,
+    df[3:7, c(TRUE, FALSE, TRUE)], df[3:7, c(TRUE, FALSE, TRUE)] <- 1,
+
+    df[TRUE, "a"], df[TRUE, "a"] <- 1,
+    df[TRUE, "aa"], df[TRUE, "aa"] <- 1,
+    df[TRUE, c("aa", "aaa")], df[TRUE, c("aa", "aaa")] <- 1,
+    df[TRUE, 1], df[TRUE, 1] <- 1,
+    df[TRUE, 2:3], df[TRUE, 2:3] <- 1,
+    df[TRUE, TRUE], df[TRUE, TRUE] <- 1,
+    df[TRUE, c(TRUE, FALSE, TRUE)], df[TRUE, c(TRUE, FALSE, TRUE)] <- 1,
+
+    df[idx, "a"], df[idx, "a"] <- 1,
+    df[idx, "aa"], df[idx, "aa"] <- 1,
+    df[idx, c("aa", "aaa")], df[idx, c("aa", "aaa")] <- 1,
+    df[idx, 1], df[idx, 1] <- 1,
+    df[idx, 2:3], df[idx, 2:3] <- 1,
+    df[idx, TRUE], df[idx, TRUE] <- 1,
+    df[idx, c(TRUE, FALSE, TRUE)], df[idx, c(TRUE, FALSE, TRUE)] <- 1,
+
+    check = FALSE,
+    iterations = 10000
+  )
+}
+
+df <- tibble(a = 1:10, aa = 1:10, aaa = 1:10)
+b_tibble <- bm(df)
+
+df <- data.frame(a = 1:10, aa = 1:10, aaa = 1:10)
+b_df <- bm(df)
+
+b_df %>%
+  select(expression, median) %>%
+  left_join(b_tibble %>% select(expression, median), by = "expression") %>%
+  mutate(ratio = as.numeric(median.y / median.x)) %>%
+  arrange(-ratio) %>%
+  view()
+
+b_tibble %>% arrange(desc(median))

tests/testthat/subsetting.txt

@@ -25,7 +25,7 @@ x Subscript `array("x", dim = c(1, 1, 1))` must be a simple vector, not an array
 > foo <- tibble(x = 1:10, y = 1:10, z = 1:10)
 > foo[0.5]
 Error: Must subset columns with a valid subscript vector.
-x Can't convert from `0.5` <double> to <integer> due to loss of precision.
+x Can't convert from <double> to <integer> due to loss of precision.
 
 > foo[1:5]
 Error: Can't subset columns that don't exist.
@@ -43,7 +43,9 @@ x Negative and positive locations can't be mixed.
 i Subscript `c(-1, 1)` has a positive value at location 2.
 
 > foo[c(-1, NA)]
-Error: Can't use NA as column index with `[` at position 2.
+Error: Must subset columns with a valid subscript vector.
+x Negative locations can't have missing values.
+i Subscript `c(-1, NA)` has a missing value at location 2.
 
 > foo[-4]
 Error: Can't negate columns that don't exist.
@@ -81,7 +83,7 @@ i It must be logical, numeric, or character.
 > foo <- tibble(x = 1:3, y = 1:3, z = 1:3)
 > foo[0.5, ]
 Error: Must subset rows with a valid subscript vector.
-x Can't convert from `0.5` <double> to <integer> due to loss of precision.
+x Can't convert from <double> to <integer> due to loss of precision.
 
 > invisible(foo[1:5, ])
 Warning: The `i` argument of ``[.tbl_df`()` must lie in [0, rows] if positive, as of tibble 3.0.0.
@@ -296,7 +298,7 @@ x Subscript `-1` has value -1 but must be a positive location.
 
 > foo[[1.5]]
 Error: Must extract column with a single valid subscript.
-x Can't convert from `1.5` <double> to <integer> due to loss of precision.
+x Can't convert from <double> to <integer> due to loss of precision.
 
 > foo[[3]]
 Error: Can't subset columns that don't exist.
@@ -305,7 +307,7 @@ i There are only 2 columns.
 
 > foo[[Inf]]
 Error: Must extract column with a single valid subscript.
-x Can't convert from `Inf` <double> to <integer> due to loss of precision.
+x Can't convert from <double> to <integer> due to loss of precision.
 
 > foo[[mean]]
 Error: Must extract column with a single valid subscript.