feat: Allow manipulation of list columns

.Rbuildignore

@@ -9,14 +9,14 @@
 ^.*\.sh$
 ^\.github$
 .*.tar.gz
-^.*\.Rcheck$
+.Rcheck$
 ^CRAN-RELEASE$
 ^cran-comments\.md$
 ^Dockerfile$
 ^ci$
 ^\.vscode$
 ^\.Rhistory$
-poorman.code-workspace
+.code-workspace$
 ^_pkgdown\.yml$
 ^docs$
 ^pkgdown$

DESCRIPTION

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

R/bind.R

@@ -116,7 +116,7 @@ squash <- function(lst) {
 #' Move entries within a list up one level
 #' @noRd
 flatten <- function(lst) {
-  nested <- vapply(lst, function(x) inherits(x[1L], "list"), FALSE)
+  nested <- is_nested(lst)
   res <- c(lst[!nested], unlist(lst[nested], recursive = FALSE))
   if (sum(nested)) Recall(res) else return(res)
 }

R/context.R

@@ -7,6 +7,13 @@ context$get_columns <- function(cols) context$.data[, cols, drop = FALSE]
 context$get_nrow <- function() nrow(context$.data)
 context$get_colnames <- function() colnames(context$.data)
 context$is_grouped <- function() has_groups(context$.data)
+context$as_env <- function() {
+  if (any(is_nested(context$.data))) {
+    lapply(as.list(context$.data), function(x) if (is.data.frame(x[[1]])) x[[1]] else x)
+  } else {
+    context$.data
+  }
+}
 context$clean <- function() rm(list = c(".data"), envir = context)
 
 #' Context dependent expressions

R/mutate.R

@@ -38,18 +38,19 @@ mutate.default <- function(.data, ...) {
   on.exit(context$clean(), add = TRUE)
   for (i in seq_along(conditions)) {
     not_named <- (is.null(cond_nms) || cond_nms[i] == "")
-    res <- eval(conditions[[i]], envir = context$.data)
-    if (!is.list(res)) res <- list(res)
+    res <- eval(conditions[[i]], envir = context$as_env())
     res_nms <- names(res)
     if (is.data.frame(res)) {
       if (not_named) {
         context$.data[, res_nms] <- res
       } else {
         context$.data[[cond_nms[i]]] <- res
       }
+    } else if (is.atomic(res)) {
+      context$.data[[names(conditions)[[i]]]] <- res
     } else {
       if (is.null(res_nms)) names(res) <- names(conditions)[[i]]
-      context$.data[, names(res)] <- res
+      context$.data[[names(res)]] <- res
     }
   }
   context$.data

R/utils.R

@@ -87,3 +87,11 @@ build_data_frame <- function(x, nms = NULL) {
   if (!is.null(nms)) colnames(res) <- nms
   res
 }
+
+#' Check whether any elements of a list are nested
+#' @param lst A `list()`
+#' @examples
+#' is_nested(list(a = 1, b = 2, c = 3))
+#' is_nested(list(a = 1, b = list(c = 2, d = 3)))
+#' @noRd
+is_nested <- function(lst) vapply(lst, function(x) inherits(x[1L], "list"), FALSE)

inst/tinytest/test_mutate.R

@@ -173,6 +173,28 @@ res <- df %>% group_by(x) %>% mutate(z = ifelse(y > 1, 1, 2))
 expect_true(is.na(res$z[2]), info = "mutate() coerces results from one group with all NA values: 1")
 expect_true(inherits(res$z, "numeric"), info = "mutate() coerces results from one group with all NA values: 2")
 
+# List columns
+
+df <- structure(list(), class = "data.frame", row.names = c(NA, -3L), .Names = character(0))
+df[["x"]] <- list(1, 2:3, 4:6)
+df[["y"]] <- 1:3
+expect_equal(
+  df %>% mutate(l = length(x)) %>% .[["l"]],
+  c(3, 3, 3),
+  info = "List columns can be mutated: 1"
+)
+expect_equal(
+  df %>% mutate(l = lengths(x)) %>% .[["l"]],
+  c(1, 2, 3),
+  info = "List columns can be mutated: 2"
+)
+models <- mtcars %>% nest_by(cyl) %>% mutate(model = list(lm(mpg ~ wt, data = data)))
+expect_equal(
+  lapply(models$model, class),
+  list(model = "lm", model = "lm", model = "lm"),
+  info = "List columns can be mutated: 3"
+)
+
 # Errors
 
 df <- data.frame(x = 1:2, y = 1:2)