Merge pull request #4 from blockr-org/summarize-by

Summarize by

NAMESPACE

@@ -2,8 +2,10 @@
 
 S3method(ui_fields,admiral_dpc_block)
 S3method(ui_fields,filter_expr_block)
+S3method(ui_fields,summarize_expr_block)
 export(admiral_dpc_block)
 export(filter_expr_block)
+export(summarize_expr_block)
 import(blockr)
 importFrom(admiral,derive_param_computed)
 importFrom(dplyr,filter)

R/summarize-expr-block.R

@@ -0,0 +1,109 @@
+# pkgload::load_all(".");
+# stack <- new_stack(data_block, summarize_expr_block);
+# serve_stack(stack)
+
+#' @importFrom admiral derive_param_computed
+#' @importFrom rlang exprs
+#' @import blockr
+new_summarize_expr_block <- function(data,
+                                     new_cols = NULL,
+                                     group_by = NULL,
+                                     ...) {
+
+  # 0. helper functions
+  handle_error <- function(e) {
+    warning(e)
+    expression()
+  }
+
+  parse_one <- function(x) {
+    tryCatch(
+      parse(text = x),
+      error = handle_error
+    )
+  }
+
+  parse_multiple <- function(x) {
+    ans <- try({
+      res <- lapply(x, parse_one)
+      if (length(res)) {
+        res <- do.call(c, res)
+      }
+    })
+    if (inherits(ans, "try-error")) {
+      return(expression())
+    }
+    res
+  }
+
+  parse_cols <- function(new_cols) {
+    parse_multiple(new_cols)
+  }
+
+  parse_grouping <- function(group_by) {
+    res <- parse_multiple(group_by)
+    names(res) <- NULL
+    res
+  }
+
+  # 1. main expression
+  main_expr <- function(new_cols = NULL, group_by = NULL) {
+
+    col_expr <- parse_cols(new_cols)
+    grp_expr <- parse_grouping(group_by)
+
+    bquote(
+      dplyr::summarize(..(col_expr), .by = c(..(grp_expr))),
+      list(col_expr = col_expr, grp_expr = grp_expr),
+      splice = TRUE
+    )
+  }
+
+  # 2. functions for derived inputs
+  data_cols <- function(data) {
+    colnames(data)
+  }
+
+  # 3. fields
+  fields <- list(
+    new_cols = new_keyvalue_field(
+      value = new_cols,
+      submit = TRUE,
+      title = "Summarise each group down to one row",
+      descr = "Name-value pairs of summary functions. The name will be the name
+               of the variable in the result."
+    ),
+    group_by = new_select_field(
+      value = group_by,
+      choices = data_cols,
+      multiple = TRUE,
+      title = "Grouping variables",
+      descr = "Selection of columns to group by for just this
+              operation, functioning as an alternative to group_by()"
+    ),
+    expression = new_hidden_field(main_expr)
+  )
+
+  # 4. block creation
+  new_block(
+    fields = fields,
+    expr = quote(.(expression)),
+    ...,
+    class = c("summarize_expr_block", "transform_block")
+  )
+}
+
+#' Summarize By Block
+#'
+#' @inheritParams blockr::new_block
+#'
+#' @export
+summarize_expr_block <- function(data, ...) {
+  initialize_block(new_summarize_expr_block(data, ...), data)
+}
+
+
+#' @export
+ui_fields.summarize_expr_block <- function(x, ns, inputs_hidden, ...) {
+  ui_fields_one_column(x = x, ns = ns, inputs_hidden = inputs_hidden)
+}

README.Rmd

@@ -24,6 +24,14 @@ library(bslib)
 [![codecov](https://codecov.io/github/blockr-org/blockr.extra/graph/badge.svg?token=9AO88LK8FJ)](https://codecov.io/github/blockr-org/blockr)
 <!-- badges: end -->
 
+## Content
+
+Provides the following blocks:
+
+- `filter_expr_block`
+- `summarize_expr_block`
+- `admiral_dpc_block`
+
 ## Usage
 
 ```r
@@ -33,7 +41,11 @@ library(blockr.extra)
 options(BLOCKR_DEV = TRUE)
 pkgload::load_all(".")
 
-stack <- new_stack(data_block, filter_expr_block)
+stack <- new_stack(
+  data_block,
+  filter_expr_block,
+  summarize_expr_block
+);
 serve_stack(stack)
 
 # see admiral vingette for how to use admiral_dpc_block

README.md

@@ -9,6 +9,14 @@
 [![codecov](https://codecov.io/github/blockr-org/blockr.extra/graph/badge.svg?token=9AO88LK8FJ)](https://codecov.io/github/blockr-org/blockr)
 <!-- badges: end -->
 
+## Content
+
+Provides the following blocks:
+
+- `filter_expr_block`
+- `summarize_expr_block`
+- `admiral_dpc_block`
+
 ## Usage
 
 ``` r
@@ -18,7 +26,11 @@ library(blockr.extra)
 options(BLOCKR_DEV = TRUE)
 pkgload::load_all(".")
 
-stack <- new_stack(data_block, filter_expr_block)
+stack <- new_stack(
+  data_block,
+  filter_expr_block,
+  summarize_expr_block
+);
 serve_stack(stack)
 
 # see admiral vingette for how to use admiral_dpc_block

tests/testthat/test-filter-expr-block.R

@@ -5,6 +5,8 @@ test_that("filter-expr-block", {
   expect_s3_class(block, "filter_expr_block")
   expect_type(block, "list")
 
+  expect_true(is_initialized(block))
+
   res <- evaluate_block(block, data)
   expect_identical(unique(as.character(res$Species)), "virginica")
 

tests/testthat/test-summarize-expr-block.R

@@ -0,0 +1,19 @@
+test_that("summarize-expr-block", {
+  data <- datasets::iris
+
+  block <- summarize_expr_block(
+    data,
+    group_by = "Species",
+    new_cols = c(
+      Mean.Sepal.Width = "mean(Sepal.Width)"
+    )
+  )
+
+  expect_true(is_initialized(block))
+  expect_s3_class(block, "summarize_expr_block")
+  expect_type(block, "list")
+
+  res <- evaluate_block(block, data)
+  expect_identical(nrow(res), 3L)
+
+})