Simplify transformation of formulas to functions

R/colwise.R

@@ -204,8 +204,12 @@ tbl_if_vars <- function(.tbl, .p, .env, ..., .include_group_vars = FALSE) {
 
   n <- length(tibble_vars)
   selected <- new_logical(n)
+
+  mask <- as_data_mask(.tbl)
+  quo <- quo(.p(.tbl[[tibble_vars[[i]]]], ...))
+
   for (i in seq_len(n)) {
-    selected[[i]] <- .p(.tbl[[tibble_vars[[i]]]], ...)
+    selected[[i]] <- eval_tidy(quo, mask)
   }
 
   tibble_vars[selected]
@@ -222,27 +226,24 @@ tbl_if_syms <- function(.tbl, .p, .env, ..., .include_group_vars = FALSE) {
 # So we need:
 # - Inheritance from closure -> lexical
 # - A maskable quosure
-new_lambda_quosure <- function(call, mask) {
-  if (typeof(call) != "language") {
-    abort("Internal error: Expected call in `new_lambda_quosure()`")
-  }
+as_inlined_function <- function(f, env) {
+  # Process unquote operator at inlining time
+  f <- expr_interp(f)
 
-  fn <- node_car(call)
+  # Transform to a purrr-like lambda
+  fn <- as_function(f, env = .env)
 
-  # Inline all foreign symbols with quasiquotation because the closure
-  # must inherit from the lexical env of the lambda
   body(fn) <- expr({
+    # Force all arguments
+    base::pairlist(...)
+
     # Transform the lambda body into a maskable quosure inheriting
     # from the execution environment
-    `_quo` <- (!!rlang::quo)(!!body(fn))
+    `_quo` <- rlang::quo(!!body(fn))
 
     # Evaluate the quosure in the mask
-    (!!eval_bare)(`_quo`, !!mask)
+    rlang::eval_bare(`_quo`, base::parent.frame())
   })
 
-  call <- rlang::duplicate(call, shallow = TRUE)
-  node_poke_car(call, fn)
-
-  # The caller expects a quosure
-  new_quosure(call, base_env())
+  fn
 }

R/funs.R

@@ -91,10 +91,7 @@ as_fun_list <- function(.funs, .env, ...) {
 
   funs <- map(.funs, function(.x){
     if (is_formula(.x)) {
-      # processing unquote operator at inlining time
-      # for rlang lambdas
-      .x <- expr_interp(.x)
-      .x <- as_function(.x, env = .env)
+      .x <- as_inlined_function(.x, env = .env)
     } else {
       if (is_character(.x)) {
         .x <- get(.x, .env, mode = "function")
@@ -114,7 +111,6 @@ as_fun_list <- function(.funs, .env, ...) {
   funs
 }
 
-
 as_fun <- function(.x, .env, .args) {
   quo <- as_quosure(.x, .env)
 

inst/include/dplyr/symbols.h

@@ -74,7 +74,6 @@ struct symbols {
 
 struct fns {
   static SEXP quote;
-  static SEXP new_lambda_quosure;
 };
 
 struct strings {

inst/include/tools/Quosure.h

@@ -60,17 +60,6 @@ class NamedQuosure {
   SymbolString name_;
 };
 
-inline SEXP make_lambda_quosure(const NamedQuosure& named_quosure, SEXP data_mask) {
-  // Adjust the lambda so its body is rewrapped in a maskable quosure
-  // that inherits from the lambda's environment
-  Rcpp::Shelter<SEXP> local;
-
-  SEXP fn = local(sym_protect(named_quosure.expr()));
-  SEXP call = local(Rf_lang3(fns::new_lambda_quosure, fn, data_mask));
-
-  return Rcpp::Rcpp_fast_eval(call, R_BaseEnv);
-}
-
 } // namespace dplyr
 
 namespace dplyr {

src/init.cpp

@@ -98,8 +98,6 @@ SEXP symbols::ptype = Rf_install("ptype");
 SEXP symbols::names = R_NamesSymbol;
 
 SEXP fns::quote = Rf_eval(Rf_install("quote"), R_BaseEnv);
-SEXP fns::new_lambda_quosure = Rf_eval(Rf_install("new_lambda_quosure"),
-                                       Rcpp::Environment::namespace_env("dplyr"));
 
 SEXP strings::POSIXct = STRING_ELT(get_time_classes(), 0);
 SEXP strings::POSIXt = STRING_ELT(get_time_classes(), 1);

src/mutate.cpp

@@ -455,16 +455,7 @@ Rcpp::DataFrame mutate_grouped(const Rcpp::DataFrame& df, const dplyr::QuosureLi
 
       // NULL columns are not removed if `setup()` is not called here
       mask.setup();
-
-      if (quosure.is_rlang_lambda()) {
-        // need to create a new quosure to put the data mask in scope
-        // of the lambda function
-        Rcpp::Shield<SEXP> new_quosure(make_lambda_quosure(quosure, mask.get_data_mask()));
-        dplyr::NamedQuosure lambda_quosure(new_quosure, quosure.name());
-        variable = dplyr::MutateCallProxy<SlicedTibble>(gdf, mask, lambda_quosure).get();
-      } else {
-        variable = dplyr::MutateCallProxy<SlicedTibble>(gdf, mask, quosure).get();
-      }
+      variable = dplyr::MutateCallProxy<SlicedTibble>(gdf, mask, quosure).get();
     }
 
     if (Rf_isNull(variable)) {

src/summarise.cpp

@@ -152,17 +152,7 @@ Rcpp::DataFrame summarise_grouped(const Rcpp::DataFrame& df, const QuosureList&
       // we can use a GroupedCallReducer which will callback to R.
       if (result == R_UnboundValue) {
         mask.setup();
-
-        if (quosure.is_rlang_lambda()) {
-          // need to create a new quosure to put the data mask in scope
-          // of the lambda function
-          Rcpp::Shield<SEXP> new_quosure(make_lambda_quosure(quosure, mask.get_data_mask()));
-          NamedQuosure lambda_quosure(new_quosure, quosure.name());
-          result = GroupedCallReducer<SlicedTibble>(lambda_quosure, mask).process(gdf);
-        } else {
-          result = GroupedCallReducer<SlicedTibble>(quosure, mask).process(gdf);
-        }
-
+        result = GroupedCallReducer<SlicedTibble>(quosure, mask).process(gdf);
       }
     }
     check_not_null(result, quosure.name());

tests/testthat/test-funs.R

@@ -78,7 +78,7 @@ test_that("can enfun() purrr-style lambdas", {
   my_mean <- as_function(~ mean(.x))
   res <- enfun(~ mean(.x))
   expect_equal(length(res), 1L)
-  expect_equal(res[[1]], my_mean)
+  expect_true(typeof(res[[1]]) == "closure")
 })
 
 test_that("as_fun_list() uses rlang auto-naming", {