diff --git a/inst/include/dplyr/symbols.h b/inst/include/dplyr/symbols.h index 4aa06f1586..867dbd5982 100644 --- a/inst/include/dplyr/symbols.h +++ b/inst/include/dplyr/symbols.h @@ -53,6 +53,7 @@ struct symbols { static SEXP inspect; static SEXP dot; static SEXP dot_x; + static SEXP drop; }; } diff --git a/inst/include/dplyr/visitors/subset/column_subset.h b/inst/include/dplyr/visitors/subset/column_subset.h index a3d8048dfc..2aa5809f62 100644 --- a/inst/include/dplyr/visitors/subset/column_subset.h +++ b/inst/include/dplyr/visitors/subset/column_subset.h @@ -6,9 +6,16 @@ #include #include #include +#include SEXP ns_methods(); +namespace base { +SEXP bracket_one(); +SEXP bracket_two(); +} + + namespace dplyr { namespace traits { @@ -111,19 +118,23 @@ template SEXP r_column_subset(SEXP x, const Index& index, SEXP frame) { Shield one_based_index(index); if (Rf_isMatrix(x)) { - return Language("[", x, one_based_index, R_MissingArg, _["drop"] = false).eval(frame); + Shield 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 call(Rf_lang3(base::bracket_one(), x, one_based_index)); + return Rcpp::Rcpp_eval(call, frame); } } template <> inline SEXP r_column_subset(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 call(Rf_lang4(base::bracket_one(), x, index, R_MissingArg)); + return Rcpp::Rcpp_eval(call, frame); } else { - return Language("[[", x, index).eval(frame); + Shield call(Rf_lang3(base::bracket_two(), x, index)); + return Rcpp::Rcpp_eval(call, frame); } } diff --git a/src/hybrid.cpp b/src/hybrid.cpp index 335fbdcad4..6b82330b12 100644 --- a/src/hybrid.cpp +++ b/src/hybrid.cpp @@ -3,6 +3,18 @@ #include #include +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]] diff --git a/src/init.cpp b/src/init.cpp index 9aac52bafc..8a2cd53114 100644 --- a/src/init.cpp +++ b/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"); } diff --git a/tests/testthat/test-summarise.r b/tests/testthat/test-summarise.r index 257dad73a8..0786198c1f 100644 --- a/tests/testthat/test-summarise.r +++ b/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]) +})