Merge pull request tidyverse#3573 from tidyverse/feature-341-filter-p…

…reserve

.preserve argument in `filter()` to control group preservation

NEWS.md

@@ -7,6 +7,7 @@
 - Add documentation example for moving variable to back in `?select` (#3051).
 - `group_by()` does not trigger the additional `mutate()` on simple uses of the `.data` pronoun (#3533). 
 - `group_by()` respects levels of factors and keeps empty groups (#341). 
+- `filter`  gains a `.preserve` argument to control which groups it should keep. 
 
 # dplyr 0.7.5.9001
 

R/colwise-filter.R

@@ -8,6 +8,8 @@
 #' @inheritParams scoped
 #' @param .vars_predicate A quoted predicate expression as returned by
 #'   [all_vars()] or [any_vars()].
+#' @param .preserve when `TRUE` (the default), the grouping structure
+#'   is preserved, otherwise it is recalculated based on the resulting data.
 #' @export
 #' @examples
 #' # While filter() accepts expressions with specific variables, the
@@ -31,24 +33,24 @@
 #'
 #' # And filter_if() selects variables with a predicate function:
 #' filter_if(mtcars, ~ all(floor(.) == .), all_vars(. != 0))
-filter_all <- function(.tbl, .vars_predicate) {
+filter_all <- function(.tbl, .vars_predicate, .preserve = TRUE) {
   syms <- syms(tbl_vars(.tbl))
   pred <- apply_filter_syms(.vars_predicate, syms, .tbl)
-  filter(.tbl, !!pred)
+  filter(.tbl, !!pred, .preserve = .preserve)
 }
 #' @rdname filter_all
 #' @export
-filter_if <- function(.tbl, .predicate, .vars_predicate) {
+filter_if <- function(.tbl, .predicate, .vars_predicate, .preserve = TRUE) {
   syms <- tbl_if_syms(.tbl, .predicate, .include_group_vars = TRUE)
   pred <- apply_filter_syms(.vars_predicate, syms, .tbl)
-  filter(.tbl, !!pred)
+  filter(.tbl, !!pred, .preserve = .preserve)
 }
 #' @rdname filter_all
 #' @export
-filter_at <- function(.tbl, .vars, .vars_predicate) {
+filter_at <- function(.tbl, .vars, .vars_predicate, .preserve = TRUE) {
   syms <- tbl_at_syms(.tbl, .vars, .include_group_vars = TRUE)
   pred <- apply_filter_syms(.vars_predicate, syms, .tbl)
-  filter(.tbl, !!pred)
+  filter(.tbl, !!pred, .preserve = .preserve)
 }
 
 apply_filter_syms <- function(pred, syms, tbl) {

R/dataframe.R

@@ -57,13 +57,13 @@ n_groups.data.frame <- function(x) 1L
 # is just a convenience layer, I didn't bother. They should still be fast.
 
 #' @export
-filter.data.frame <- function(.data, ...) {
-  as.data.frame(filter(tbl_df(.data), ...))
+filter.data.frame <- function(.data, ..., .preserve = TRUE) {
+  as.data.frame(filter(tbl_df(.data), ..., .preserve = .preserve))
 }
 #' @export
-filter_.data.frame <- function(.data, ..., .dots = list()) {
+filter_.data.frame <- function(.data, ..., .dots = list(), .preserve = TRUE) {
   dots <- compat_lazy_dots(.dots, caller_env(), ...)
-  filter(.data, !!!dots)
+  filter(.data, !!!dots, .preserve = .preserve)
 }
 
 #' @export

R/manip.r

@@ -36,6 +36,8 @@
 #'   frame. They support [unquoting][rlang::quasiquotation] and
 #'   splicing. See `vignette("programming")` for an introduction to
 #'   these concepts.
+#' @param .preserve when `TRUE` (the default), the grouping structure
+#'   is preserved, otherwise it is recalculated based on the resulting data.
 #' @return An object of the same class as `.data`.
 #' @seealso [filter_all()], [filter_if()] and [filter_at()].
 #' @export
@@ -49,16 +51,16 @@
 #'
 #' # Multiple arguments are equivalent to and
 #' filter(starwars, hair_color == "none", eye_color == "black")
-filter <- function(.data, ...) {
+filter <- function(.data, ..., .preserve = TRUE) {
   UseMethod("filter")
 }
 #' @export
-filter.default <- function(.data, ...) {
-  filter_(.data, .dots = compat_as_lazy_dots(...))
+filter.default <- function(.data, ..., .preserve = TRUE) {
+  filter_(.data, .dots = compat_as_lazy_dots(...), .preserve = .preserve)
 }
 #' @export
 #' @rdname se-deprecated
-filter_ <- function(.data, ..., .dots = list()) {
+filter_ <- function(.data, ..., .dots = list(), .preserve = TRUE) {
   UseMethod("filter_")
 }
 

R/tbl-df.r

@@ -52,7 +52,7 @@ arrange_.tbl_df <- function(.data, ..., .dots = list(), .by_group = FALSE) {
 }
 
 #' @export
-filter.tbl_df <- function(.data, ...) {
+filter.tbl_df <- function(.data, ..., .preserve = TRUE) {
   dots <- quos(...)
   if (any(have_name(dots))) {
     bad <- dots[have_name(dots)]
@@ -62,12 +62,16 @@ filter.tbl_df <- function(.data, ...) {
   }
 
   quo <- all_exprs(!!!dots, .vectorised = TRUE)
-  filter_impl(.data, quo)
+  out <- filter_impl(.data, quo)
+  if (!.preserve) {
+    out <- group_by(out, add = TRUE)
+  }
+  out
 }
 #' @export
-filter_.tbl_df <- function(.data, ..., .dots = list()) {
+filter_.tbl_df <- function(.data, ..., .dots = list(), .preserve = TRUE) {
   dots <- compat_lazy_dots(.dots, caller_env(), ...)
-  filter(.data, !!!dots)
+  filter(.data, !!!dots, .preserve = .preserve)
 }
 
 #' @export