Use new select implementation everywhere.

Closes #232. Closes #192. Closes #172. Closes #158

NAMESPACE

@@ -308,7 +308,6 @@ export(regroup)
 export(row_number)
 export(same_src)
 export(select)
-export(select_eval)
 export(select_vars)
 export(semi_join)
 export(setdiff)
@@ -346,8 +345,6 @@ export(trunc_mat)
 export(type_sum)
 export(ungroup)
 export(union)
-export(var_eval)
-export(var_index)
 export(with_order)
 exportClasses(Query)
 import(assertthat)

R/manip-cube.r

@@ -1,7 +1,7 @@
 #' @export
 select.tbl_cube <- function(.data, ...) {
-  idx <- var_index(dots(...), .data$mets, parent.frame())
-  .data$mets <- .data$mets[idx]
+  vars <- select_vars(names(.data$mets), ..., env = parent.frame())
+  .data$mets <- .data$mets[vars]
   .data
 }
 

R/manip-df.r

@@ -43,18 +43,22 @@ summarise.tbl_df <- .data_dots(summarise_impl, named_dots)
 #' @rdname manip_df
 #' @export
 select.tbl_df <- function(.data, ...) {
-  tbl_df(select.data.frame(.data, ...))
+  vars <- select_vars(names(.data), ..., env = parent.frame())
+  select_impl(.data, vars)
 }
 
 #' @export
 select.grouped_df <- function(.data, ...) {
-  input <- var_eval(dots(...), .data, parent.frame())
-  input_vars <- vapply(input, as.character, character(1))
-  gps <- as.character(groups(.data))
-  if(length(diff <- setdiff(gps, input_vars))){
-    stop(sprintf("selection doesn't include grouping variables: %s", paste(diff, collapse = ",")))
+  vars <- select_vars(names(.data), ..., env = parent.frame())
+
+  # Don't remove grouping vars!
+  missing <- setdiff(as.character(groups(.data)), vars)
+  if (length(missing) > 0) {
+    stop("selection doesn't include grouping variables: ",
+      paste0(missing, collapse = ","), call. = FALSE)
   }
-  grouped_df(.data[, input_vars, drop = FALSE], groups(.data))
+
+  select_impl(.data, vars)
 }
 
 # Other methods that currently don't have a better home -----------------------

R/manip-dt.r

@@ -122,10 +122,8 @@ arrange.tbl_dt <- function(.data, ...) {
 #' @rdname manip_dt
 #' @export
 select.data.table <- function(.data, ...) {
-  input <- var_eval(dots(...), .data, parent.frame())
-  input_vars <- vapply(input, as.character, character(1))
-
-  .data[, input_vars, drop = FALSE, with = FALSE]
+  vars <- select_vars(names(.data), ..., env = parent.frame())
+  .data[, vars, drop = FALSE, with = FALSE]
 }
 
 #' @export

R/manip-grouped-dt.r

@@ -139,9 +139,8 @@ arrange.grouped_dt <- function(.data, ...) {
 #' @rdname manip_grouped_dt
 #' @export
 select.grouped_dt <- function(.data, ...) {
-  input <- var_eval(dots(...), .data, parent.frame())
-  input_vars <- vapply(input, as.character, character(1))
-  out <- .data[, input_vars, drop = FALSE, with = FALSE]
+  vars <- select_vars(names(.data), ..., env = parent.frame())
+  out <- .data[, vars, drop = FALSE, with = FALSE]
 
   grouped_dt(
     data = out,

R/manip-sql.r

@@ -12,8 +12,9 @@ arrange.tbl_sql <- function(.data, ...) {
 
 #' @export
 select.tbl_sql <- function(.data, ...) {
-  input <- select_eval(dots(...), .data$select, parent.frame())
-  update(.data, select = input)
+  vars <- select_vars(tbl_vars(.data), ..., env = parent.frame())
+  idx <- match(vars, tbl_vars(.data))
+  update(.data, select = .data$select[idx])
 }
 
 #' @export
@@ -32,7 +33,7 @@ summarise.tbl_sql <- function(.data, ..., .collapse_result = TRUE) {
 
   .data$summarise <- TRUE
   .data <- update(.data, select = c(.data$group_by, input))
-  
+
   if (!.collapse_result) return(.data)
   # Technically, don't always need to collapse result because summarise + filter
   # could be expressed in SQL using HAVING, but that's the only dplyr operation
@@ -48,20 +49,20 @@ regroup.tbl_sql <- function(x, value) {
   if (!all_apply(value, is.name)) {
     stop("May only group by variable names, not expressions", call. = FALSE)
   }
-  
+
   # Effect of group_by on previous operations:
   # * select: none
   # * filter: changes frame of window functions
   # * mutate: changes frame of window functions
   # * arrange: if present, groups inserted as first ordering
-  needed <- (x$mutate && uses_window_fun(x$select, x)) || 
+  needed <- (x$mutate && uses_window_fun(x$select, x)) ||
     uses_window_fun(x$filter, x)
   if (!is.null(x$order_by)) {
     arrange <- c(x$group_by, x$order_by)
   } else {
     arrange <- NULL
   }
-  
+
   if (needed) {
     x <- collapse(update(x, order_by = NULL))
   }
@@ -73,7 +74,7 @@ regroup.tbl_sql <- function(x, value) {
 mutate.tbl_sql <- function(.data, ...) {
   input <- partial_eval(dots(...), .data, parent.frame())
   input <- auto_name(input)
-  
+
   .data$mutate <- TRUE
   update(.data, select = c(.data$select, input))
 }

R/partial-eval.r

@@ -81,48 +81,3 @@ partial_eval <- function(call, tbl = NULL, env = parent.frame()) {
   }
 }
 
-#' Evaluate variable names in the context of a tbl.
-#'
-#' @param exprs a list of unevaluated expressions
-#' @param tbl,select a tbl or a select language list
-#' @param parent the parent frame in which to evaluate variables/functions
-#'   not found in \code{tbl}
-#' @export
-#' @examples
-#' var_eval(list(quote(mpg:wt)), mtcars)
-#'
-#' select <- lapply(names(mtcars), as.name)
-#' select_eval(list(quote(mpg:wt)), select)
-#'
-#' mutate <- c(select, cyl2 = quote(cyl * 2))
-#' select_eval(list(quote(gear:cyl2)), mutate)
-var_eval <- function(exprs, tbl, parent = parent.frame()) {
-  nm <- tbl_vars(tbl)
-
-  nms_list <- as.list(setNames(seq_along(nm), nm))
-
-  idx <- lapply(exprs, eval, nms_list, parent)
-  symbols <- lapply(nm, as.symbol)
-
-  symbols[unlist(idx)]
-}
-
-#' @rdname var_eval
-#' @export
-select_eval <- function(exprs, select, parent = parent.frame()) {
-  nms_list <- as.list(setNames(seq_along(select), auto_names(select)))
-
-  idx <- lapply(exprs, eval, nms_list, parent)
-
-  select[unlist(idx)]
-}
-
-#' @rdname var_eval
-#' @export
-var_index <- function(exprs, tbl, parent = parent.frame()) {
-  nm <- names(tbl)
-  nms_list <- as.list(setNames(seq_along(nm), nm))
-
-  unlist(lapply(exprs, eval, nms_list, parent))
-}
-

R/tbl-cube.r

@@ -71,6 +71,7 @@
 #'
 #' # select() operates only on measures: it doesn't affect dimensions in any way
 #' select(nasa, cloudhigh:cloudmid)
+#' select(nasa, matches("temp"))
 #'
 #' # filter() operates only on dimensions
 #' filter(nasa, lat > 0, year == 2000)

R/tbl-data-frame.R

@@ -36,10 +36,8 @@ arrange.data.frame <- function(.data, ...) {
 }
 #' @export
 select.data.frame <- function(.data, ...) {
-  input <- var_eval(dots(...), .data, parent.frame())
-  input_vars <- vapply(input, as.character, character(1))
-
-  .data[, input_vars, drop = FALSE]
+  vars <- select_vars(names(.data), ..., env = parent.frame())
+  select_impl(.data, vars)
 }
 #' @export
 do.data.frame <- function(.data, .f, ...) {

inst/tests/test-copying.R

@@ -22,3 +22,10 @@ test_that("mutate doesn't copy vars", {
 
   expect_equal(location(mtcars3)$vars[1:11], location(mtcars2)$vars)
 })
+
+test_that("select doesn't copy vars", {
+  mtcars2 <- tbl_df(mtcars)
+  mtcars3 <- select(mtcars2, carb:mpg)
+
+  expect_equal(location(mtcars3)$vars[11:1], location(mtcars2)$vars)
+})

inst/tests/test-select.r

@@ -10,10 +10,10 @@ test_that("two selects equivalent to one", {
     ref = select(df, n:o))
 })
 
-test_that("select does not loose grouping (#147)", {
+test_that("select does not lose grouping (#147)", {
   df <- tbl_df(data.frame(a = rep(1:4, 2), b = rep(1:4, each = 2), x = runif(8)))
   grouped <- df %.% group_by(a) %.% select(a, b, x)
-  
+
   expect_equal(groups(grouped), list(quote(a)))
 })
 

man/tbl_cube.Rd

@@ -82,6 +82,7 @@ as.tbl_cube(esoph, dim_names = 1:3)
 
 # select() operates only on measures: it doesn't affect dimensions in any way
 select(nasa, cloudhigh:cloudmid)
+select(nasa, matches("temp"))
 
 # filter() operates only on dimensions
 filter(nasa, lat > 0, year == 2000)