inline [ and [[

inst/include/dplyr/symbols.h

@@ -53,6 +53,7 @@ struct symbols {
   static SEXP inspect;
   static SEXP dot;
   static SEXP dot_x;
+  static SEXP drop;
 };
 
 }

inst/include/dplyr/visitors/subset/column_subset.h

@@ -6,9 +6,16 @@
 #include <tools/bad.h>
 #include <tools/default_value.h>
 #include <tools/SlicingIndex.h>
+#include <dplyr/symbols.h>
 
 SEXP ns_methods();
 
+namespace base {
+SEXP bracket_one();
+SEXP bracket_two();
+}
+
+
 namespace dplyr {
 namespace traits {
 
@@ -111,19 +118,23 @@ template <typename Index>
 SEXP r_column_subset(SEXP x, const Index& index, SEXP frame) {
   Shield<SEXP> one_based_index(index);
   if (Rf_isMatrix(x)) {
-    return Language("[", x, one_based_index, R_MissingArg, _["drop"] = false).eval(frame);
+    Shield<SEXP> call(Rf_lang5(base::bracket_one(), x, one_based_index, R_MissingArg, Rf_ScalarLogical(false)));
+    SET_TAG(CDR(CDDDR(call)), dplyr::symbols::drop);
+    return Rcpp::Rcpp_eval(call, frame);
   } else {
-    return Language("[", x, one_based_index).eval(frame);
+    Shield<SEXP> call(Rf_lang3(base::bracket_one(), x, one_based_index));
+    return Rcpp::Rcpp_eval(call, frame);
   }
 }
 
 template <>
 inline SEXP r_column_subset<RowwiseSlicingIndex>(SEXP x, const RowwiseSlicingIndex& index, SEXP frame) {
   if (Rf_isMatrix(x)) {
-    // TODO: not sure about this
-    return Language("[", x, index, R_MissingArg).eval(frame);
+    Shield<SEXP> call(Rf_lang4(base::bracket_one(), x, index, R_MissingArg));
+    return Rcpp::Rcpp_eval(call, frame);
   } else {
-    return Language("[[", x, index).eval(frame);
+    Shield<SEXP> call(Rf_lang3(base::bracket_two(), x, index));
+    return Rcpp::Rcpp_eval(call, frame);
   }
 }
 

src/hybrid.cpp

@@ -3,6 +3,18 @@
 #include <tools/hash.h>
 #include <dplyr/hybrid/Expression.h>
 
+namespace base {
+static SEXP primitive_bracket_one;
+static SEXP primitive_bracket_two;
+
+SEXP bracket_one() {
+  return primitive_bracket_one;
+}
+SEXP bracket_two() {
+  return primitive_bracket_two;
+}
+}
+
 namespace dplyr {
 namespace hybrid {
 
@@ -76,6 +88,9 @@ void init_hybrid_inline_map(DllInfo* /*dll*/) {
     hybrid_init(stats, symbols::var, symbols::stats, VAR);
     hybrid_init(stats, symbols::sd, symbols::stats, SD);
   }
+
+  ::base::primitive_bracket_one = Rf_eval(R_BracketSymbol, R_BaseEnv);
+  ::base::primitive_bracket_two = Rf_eval(R_Bracket2Symbol, R_BaseEnv);
 }
 
 // [[Rcpp::export]]

src/init.cpp

@@ -88,4 +88,5 @@ SEXP symbols::dot_Internal = Rf_install(".Internal");
 SEXP symbols::inspect = Rf_install("inspect");
 SEXP symbols::dot = Rf_install(".");
 SEXP symbols::dot_x = Rf_install(".x");
+SEXP symbols::drop = Rf_install("drop");
 }

tests/testthat/test-summarise.r

@@ -754,7 +754,6 @@ test_that("lead and lag behave correctly in summarise (#1434)", {
 # .data and .env tests now in test-hybrid-traverse.R
 
 test_that("data.frame columns are supported in summarise (#1425)", {
-  skip("will fix as part of #3630")
   df <- data.frame(x1 = rep(1:3, times = 3), x2 = 1:9)
   df$x3 <- df %>% mutate(x3 = x2)
   res <- df %>% group_by(x1) %>% summarise(nr = nrow(x3))
@@ -1082,3 +1081,25 @@ test_that("the data mask marks subsets as not mutable", {
   expect_true(all(res$shared))
   expect_true(all(maybe_shared_columns(res)))
 })
+
+test_that("column_subset respects S3 local [. method (#3923)", {
+  testS3Class <- function(x, X){
+    structure(x, class = "testS3Class", X = X)
+  }
+  `[.testS3Class` <- function(x, i, ...) {
+    testS3Class(unclass(x)[i, ...], X = attr(x, "X"))
+  }
+  df <- tibble(x = rep(1:2, each = 5), y = testS3Class(1:10, X = 100))
+  res <- df %>%
+    group_by(x) %>%
+    summarise(chunk = list(y))
+  expect_equal(res$chunk[[1]], df$y[df$x == 1])
+  expect_equal(res$chunk[[1]], df$y[df$x == 1])
+
+  df$y <- testS3Class(matrix(1:20, ncol = 2), X = 200)
+  res <- df %>%
+    group_by(x) %>%
+    summarise(chunk = list(y))
+  expect_equal(res$chunk[[1]], df$y[df$x == 1, , drop = FALSE])
+  expect_equal(res$chunk[[1]], df$y[df$x == 1, , drop = FALSE])
+})