diff --git a/NAMESPACE b/NAMESPACE index c65ed3f..787b0a2 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/summarize-expr-block.R b/R/summarize-expr-block.R new file mode 100644 index 0000000..08ae5e5 --- /dev/null +++ b/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) +} diff --git a/README.Rmd b/README.Rmd index 8088633..f17ef4f 100644 --- a/README.Rmd +++ b/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) +## 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 diff --git a/README.md b/README.md index f5fe8eb..16615da 100644 --- a/README.md +++ b/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) +## 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 diff --git a/man/summarize_expr_block.Rd b/man/summarize_expr_block.Rd new file mode 100644 index 0000000..2993f12 --- /dev/null +++ b/man/summarize_expr_block.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summarize-expr-block.R +\name{summarize_expr_block} +\alias{summarize_expr_block} +\title{Summarize By Block} +\usage{ +summarize_expr_block(data, ...) +} +\arguments{ +\item{data}{Block input data} + +\item{...}{Any other params. TO DO} +} +\description{ +Summarize By Block +} diff --git a/tests/testthat/test-filter-expr-block.R b/tests/testthat/test-filter-expr-block.R index 6909b89..0642202 100644 --- a/tests/testthat/test-filter-expr-block.R +++ b/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") diff --git a/tests/testthat/test-summarize-expr-block.R b/tests/testthat/test-summarize-expr-block.R new file mode 100644 index 0000000..274b09e --- /dev/null +++ b/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) + +})