feat: Add with_groups()

Closes #61

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: poorman
 Type: Package
 Title: A Poor Man's Dependency Free Recreation of 'dplyr'
-Version: 0.2.3.16
+Version: 0.2.3.17
 Authors@R: person("Nathan", "Eastwood", "", "nathan.eastwood@icloud.com",
     role = c("aut", "cre"))
 Maintainer: Nathan Eastwood <nathan.eastwood@icloud.com>

NAMESPACE

@@ -126,6 +126,7 @@ export(transmute)
 export(ungroup)
 export(unite)
 export(where)
+export(with_groups)
 importFrom(stats,na.omit)
 importFrom(stats,setNames)
 importFrom(utils,head)

R/group_by.R

@@ -34,6 +34,11 @@ group_by <- function(.data, ..., .add = FALSE) {
 #' @export
 group_by.data.frame <- function(.data, ..., .add = FALSE) {
   vars <- dotdotdot(..., .impute_names = TRUE)
+  if (all(vapply(vars, is.null, FALSE))) {
+    res <- set_groups(.data, NULL)
+    class(res) <- class(res)[!(class(res) %in% "grouped_data")]
+    return(res)
+  }
   new_cols <- add_group_columns(.data, vars)
   res <- new_cols$data
   groups <- new_cols$groups

R/lang.R

@@ -36,3 +36,16 @@ is_named <- function(x) {
 is_empty_list <- function(x) {
   inherits(x, "list") && length(x) == 0L
 }
+
+#' Turn an am atomic vector into a list of symbols
+#'
+#' @return
+#' A `list` of symbols.
+#'
+#' @example
+#' as_symbols(c("am", "cyl"))
+#'
+#' @noRd
+as_symbols <- function(x) {
+  lapply(x, as.symbol)
+}

R/select_positions.R

@@ -30,6 +30,8 @@
 #' @noRd
 select_positions <- function(.data, ..., .group_pos = FALSE) {
   cols <- dotdotdot(...)
+  cols <- cols[!vapply(cols, is.null, FALSE)]
+  if (length(cols) == 0L) return(integer(0))
   select_env$setup(.data = .data, calling_frame = parent.frame(2L))
   on.exit(select_env$clean(), add = TRUE)
   data_names <- select_env$get_colnames()
@@ -94,7 +96,7 @@ eval_expr <- function(x) {
 
 select_char <- function(expr) {
   pos <- match(expr, select_env$get_colnames())
-  if (is.na(pos)) stop("Column `", expr, "` does not exist")
+  if (any(is.na(pos))) stop("The following columns do not exist:\n    ", paste(expr, collapse = "\n    "))
   pos
 }
 

R/with_groups.R

@@ -0,0 +1,38 @@
+#' Perform an operation with temporary groups
+#'
+#' This function allows you to modify the grouping variables for a single operation.
+#'
+#' @param .data A `data.frame`.
+#' @param .groups <[`poor-select`][select_helpers]> One or more variables to group by. Unlike [group_by()], you can
+#' only group by existing variables, and you can use `poor-select` syntax like `c(x, y, z)` to select multiple
+#' variables.
+#'
+#' Use `NULL` to temporarily **un**group.
+#' @param .f A `function` to apply to regrouped data. Supports lamba-style `~` syntax.
+#' @param ... Additional arguments passed on to `.f`.
+#'
+#' @examples
+#' df <- data.frame(g = c(1, 1, 2, 2, 3), x = runif(5))
+#' df %>% with_groups(g, mutate, x_mean = mean(x))
+#' df %>% with_groups(g, ~ mutate(.x, x_mean = mean(x)))
+#'
+#' df %>%
+#'   group_by(g) %>%
+#'   with_groups(NULL, mutate, x_mean = mean(x))
+#'
+#' # NB: grouping can't be restored if you remove the grouping variables
+#' df %>%
+#'   group_by(g) %>%
+#'   with_groups(NULL, mutate, g = NULL)
+#'
+#' @export
+with_groups <- function(.data, .groups, .f, ...) {
+  cur_groups <- get_groups(.data)
+  .groups <- eval_select_pos(.data = .data, .cols = substitute(.groups))
+  val <- as_symbols(names(.data)[.groups])
+  out <- do.call(group_by, c(list(.data = .data), val))
+  .f <- as_function(.f)
+  out <- .f(out, ...)
+  out_groups <- cur_groups[cur_groups %in% colnames(out)]
+  do.call(group_by, c(list(.data = out), as_symbols(out_groups)))
+}

inst/tinytest/test_group_by.R

@@ -42,4 +42,22 @@ expect_equal(
   info = "group_by() can create new columns #2"
 )
 
+# NULL group
+expect_equal(
+  group_by(mtcars, NULL),
+  mtcars,
+  info = "NULL group returns the original data.frame"
+)
+res <- group_by(mtcars, am, cyl)
+expect_equal(
+  class(group_by(res, NULL)),
+  "data.frame",
+  info = "group_by(., NULL) ungroups data #1"
+)
+expect_equal(
+  attr(group_by(res, NULL), "groups", exact = TRUE),
+  NULL,
+  info = "group_by(., NULL) ungroups data #2"
+)
+
 rm(res)

inst/tinytest/test_select_positions.R

@@ -23,12 +23,6 @@ expect_equal(
   info = "Selecting the 0th numeric column returns an empty data.frame"
 )
 
-# Logical
-expect_error(
-  mtcars %>% select(TRUE),
-  info = "Logical selections do not work"
-)
-
 # Character
 expect_equal(
   mtcars %>% select("mpg"),
@@ -219,7 +213,26 @@ expect_equal(
   info = "Test selecting with a mixture of selection options"
 )
 
+# NULL
+expect_equal(
+  select_positions(mtcars, NULL),
+  integer(0),
+  info = "NULL returns zero column positions"
+)
+
+expect_equal(
+  select_positions(mtcars, am, NULL, cyl),
+  c("am" = 9, "cyl" = 2),
+  info = "combinations of NULL and other parameter names ignore the NULLs"
+)
+
+# Errors
 expect_error(
-  mtcars %>% select(100),
+  select_positions(mtcars, 100),
   info = "Out of range columns error"
 )
+
+expect_error(
+  select_positions(mtcars, TRUE),
+  info = "Logical selections do not work"
+)

inst/tinytest/test_with_groups.R

@@ -0,0 +1,15 @@
+df <- data.frame(x = 1:2)
+gf <- group_by(df, x)
+expect_equal(class(with_groups(df, x, mutate)), "data.frame", info = "restores original class #1")
+expect_equal(class(with_groups(gf, x, mutate)), "grouped_df", info = "restores original class #2")
+
+gf <- group_by(data.frame(x = 1:2), x)
+out <- gf %>% with_groups(NULL, mutate, y = mean(x))
+expect_equal(out$y, c(1.5, 1.5), info = ".groups = NULL ungroups")
+
+local_fn <- identity
+expect_identical(
+  with_groups(mtcars, local_fn(2), mutate, disp = disp / sd(disp)),
+  with_groups(mtcars, 2, mutate, disp = disp / sd(disp)),
+  info = ".groups is defused with context"
+)