From b2925997e27d99cf6854489737baee915cfa44cb Mon Sep 17 00:00:00 2001 From: mahaalbashir Date: Mon, 27 Jul 2026 14:38:57 +0100 Subject: [PATCH 01/11] develop the acro_summarise() function --- DESCRIPTION | 7 +- NAMESPACE | 1 + R/acro_tables.R | 125 +++++++++++++++++++++ R/utils.R | 33 ++++++ man/acro_summarise.Rd | 23 ++++ tests/testthat/test-acro_summarise.R | 162 +++++++++++++++++++++++++++ 6 files changed, 350 insertions(+), 1 deletion(-) create mode 100644 man/acro_summarise.Rd create mode 100644 tests/testthat/test-acro_summarise.R diff --git a/DESCRIPTION b/DESCRIPTION index 0987b36..1e65e64 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -17,7 +17,12 @@ SystemRequirements: Python (>= 3.10) Imports: reticulate, admiraldev, - png + png, + dplyr, + purrr, + rlang, + tibble, + tidyselect Depends: R (>= 2.10) LazyData: true diff --git a/NAMESPACE b/NAMESPACE index 5b92a1e..7ba62a7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,6 +15,7 @@ export(acro_pivot_table) export(acro_print_outputs) export(acro_remove_output) export(acro_rename_output) +export(acro_summarise) export(acro_surv_func) export(acro_table) export(create_factors) diff --git a/R/acro_tables.R b/R/acro_tables.R index a926791..8a71f41 100644 --- a/R/acro_tables.R +++ b/R/acro_tables.R @@ -167,6 +167,131 @@ acro_table <- function(index, columns, dnn = NULL, deparse.level = 0, useNA = "n return(table) } +#' Title +#' +#' @param .data A data frame or a data frame extension +#' @param ... Name-value pairs of summary functions. The name will be the name of the variable in the result +#' @param .groups Grouping structure of the result +#' @param .by Optionally, a selection of columns to group by for just this operation, functioning as an alternative to group_by() +#' +#' @returns Summary of the data +#' @export + +acro_summarise <- function(.data, ..., .groups = NULL, .by = NULL) { + if (is.null(acroEnv$ac)) { + stop("ACRO has not been initialised. Please first call acro_init()") + } + + by_expr <- rlang::enquo(.by) + + if (!is.null(.groups) && !rlang::quo_is_null(by_expr)) { + stop("Can't supply both `.by` and `.groups`.", call. = FALSE) + } + + if (dplyr::is_grouped_df(.data) && !rlang::quo_is_null(by_expr)) { + stop("Can't supply `.by` when `.data` is a grouped data frame.", call. = FALSE) + } + + # Handling the index parameter for the pivot_table + if (!rlang::quo_is_null(by_expr)) { + # Use the .by provided by the user + index <- tidyselect::vars_select(names(.data), {{ .by }}) + } else { + # Use the existing groups from group_by() + index <- dplyr::group_vars(.data) + } + + # Handling the agg_func and the value parameters for the pivot_table + summary_funcs <- rlang::enquos(..., .named = TRUE) + + summary_funcs <- purrr::map(summary_funcs, parse_summary_expression) + + + values <- unname(purrr::map(summary_funcs, "values")) + python_aggfuncs <- purrr::map(summary_funcs, "agg_funcs") + + if (length(unique(values)) > 1 && length(unique(python_aggfuncs)) > 1) { + # Create the dictionary for the agg functions + # Uncomment this when the acro pivot table is accepting dictionaries for the agg_func parameter ie. is handling different agg_funcs with different values + # python_aggfuncs <- stats::setNames(python_aggfuncs, values) + stop("ACRO currently doesn not support different aggreagtion functions for different values.", call. = FALSE) + } else { + python_aggfuncs <- unique(unname(python_aggfuncs)) + } + + if (length(values[[1]]) == 0) { + values <- NULL + } + + # Handling ungrouped data via a dummy grouping column + if (length(index) == 0) { + .data$acro_dummy_all <- "All Data" + index <- "acro_dummy_all" + } + + # Call the python pivot table + pd <- reticulate::import("pandas", convert = FALSE) + py_df <- reticulate::r_to_py(.data) + python_aggfuncs <- reticulate::r_to_py(python_aggfuncs) + + py_result <- acroEnv$ac$pivot_table( + data = py_df, + index = index, + values = unique(values), + aggfunc = python_aggfuncs + ) + + # Clean and rename Columns for the python dataframe + py_result <- py_result$reset_index() + new_col_names <- c(index, names(summary_funcs)) + + # Convert to R dataframe + r_output <- reticulate::py_to_r(py_result) + colnames(r_output) <- new_col_names + + # Remove the dummy column if it exists + if ("acro_dummy_all" %in% names(r_output)) { + r_output <- r_output[, names(r_output) != "acro_dummy_all"] + } + + # Convert to tibble + r_output <- tibble::as_tibble(r_output) + + # Handling the .group parameter + if (is.null(.groups)) { + .groups <- "drop_last" + } + + if (.groups == "drop") { + r_output <- dplyr::ungroup(r_output) + } else if (.groups == "drop_last") { + if (length(index) > 1) { + new_index <- utils::head(index, -1) + r_output <- dplyr::group_by(r_output, dplyr::across(dplyr::all_of(new_index))) + } else { + r_output <- dplyr::ungroup(r_output) + } + } else if (.groups == "keep") { + if (length(index) > 0) { + r_output <- dplyr::group_by(r_output, dplyr::across(dplyr::all_of(index))) + } else { + r_output <- dplyr::ungroup(r_output) + } + } else if (.groups == "rowwise") { + if (length(index) > 0) { + r_output <- dplyr::group_by(r_output, dplyr::across(dplyr::all_of(index))) + } else { + r_output <- dplyr::ungroup(r_output) + } + } else { + stop("`.groups` must be one of 'drop', 'drop_last', 'keep', or 'rowwise'.", call. = FALSE) + r_output <- dplyr::rowwise(r_output) + } + + + return(r_output) +} + #' Pivot table #' #' @param data The data to operate on. diff --git a/R/utils.R b/R/utils.R index 855058b..a4daf6c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -78,3 +78,36 @@ to_pandas_categorical <- function(Values, pd) { ordered = is.ordered(Values) ) } + +parse_summary_expression <- function(quo) { + expr <- rlang::quo_get_expr(quo) + + # Ensure it is a function call (e.g., mean(disp)) + if (!rlang::is_call(expr)) { + return(NULL) + } + + # Get the R function name + r_agg_funcs <- as.character(expr[[1]]) + + mapping <- c(mean = "mean", median = "median", mode = "mode", sd = "std", sum = "sum") + + # Check if the function is supported + if (r_agg_funcs == "n") { + stop(paste("Function", r_agg_funcs, "is not supported, but it will be available soon. Please use: mean, median, mode, sd or sum.")) + } else if (!(r_agg_funcs %in% names(mapping))) { + stop(paste("Function", r_agg_funcs, "is not supported. Please use: mean, median, mode, sd or sum.")) + } + + # Translate to Python agg function + py_agg_funcs <- mapping[r_agg_funcs] + + # Get all arguments + args <- rlang::call_match(expr, get(r_agg_funcs)) + + list( + values = as.character(args$x), + agg_funcs = py_agg_funcs, + na.rm = isTRUE(args$na.rm) + ) +} diff --git a/man/acro_summarise.Rd b/man/acro_summarise.Rd new file mode 100644 index 0000000..1989945 --- /dev/null +++ b/man/acro_summarise.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/acro_tables.R +\name{acro_summarise} +\alias{acro_summarise} +\title{Title} +\usage{ +acro_summarise(.data, ..., .groups = NULL, .by = NULL) +} +\arguments{ +\item{.data}{A data frame or a data frame extension} + +\item{...}{Name-value pairs of summary functions. The name will be the name of the variable in the result} + +\item{.groups}{Grouping structure of the result} + +\item{.by}{Optionally, a selection of columns to group by for just this operation, functioning as an alternative to group_by()} +} +\value{ +Summary of the data +} +\description{ +Title +} diff --git a/tests/testthat/test-acro_summarise.R b/tests/testthat/test-acro_summarise.R new file mode 100644 index 0000000..72f1f50 --- /dev/null +++ b/tests/testthat/test-acro_summarise.R @@ -0,0 +1,162 @@ +test_that("acro_summarise works with one grouping parameter", { + # table produces by summarise function from dplyr package + R_table <- dplyr::summarise(nursery_data, mean_children = mean(children), .by = recommend) |> + dplyr::arrange(recommend) + + # table produces by acro_summarise function + acro_table <- acro_summarise(nursery_data, mean_children = mean(children), .by = recommend) |> + dplyr::arrange(recommend) + + expect_equal(acro_table, R_table, tolerance = 1e-5, ignore_attr = TRUE) +}) + +test_that("acro_summarise works with two grouping parameters", { + # table produces by summarise function from dplyr package + R_table <- dplyr::summarise(nursery_data, mean_children = mean(children), .by = c(parents, recommend)) |> + dplyr::arrange(parents, recommend) + + # table produces by acro_summarise function + acro_table <- acro_summarise(nursery_data, mean_children = mean(children), .by = c(parents, recommend)) |> + dplyr::arrange(parents, recommend) + + expect_equal(acro_table, R_table, tolerance = 1e-5, ignore_attr = TRUE) +}) + +test_that("acro_summarise works with no grouping parameter calculate the summary function for the whole dataset", { + # table produces by summarise function from dplyr package + R_table <- dplyr::summarise(nursery_data, mean_children = mean(children)) + + # table produces by acro_summarise function + acro_table <- acro_summarise(nursery_data, mean_children = mean(children)) + + expect_equal(acro_table, R_table, tolerance = 1e-5, ignore_attr = TRUE) +}) + + +test_that("acro_summarise works with two summary functions for the same variable", { + # table produces by summarise function from dplyr package + R_table <- dplyr::summarise(nursery_data, mean_children = mean(children), sd_children = sd(children), .by = recommend) |> + dplyr::arrange(recommend) + + + # table produces by acro_summarise function + acro_table <- acro_summarise(nursery_data, mean_children = mean(children), sd_children = sd(children), .by = recommend) |> + dplyr::arrange(recommend) + + + expect_equal(acro_table, R_table, tolerance = 1e-5, ignore_attr = TRUE) +}) + +test_that("acro_summarise works with piping", { + # table produces by summarise function from dplyr package + R_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + dplyr::summarise(mean_children = mean(children), sd_children = sd(children)) %>% + dplyr::arrange(parents, recommend) + + # table produces by acro_summarise function + acro_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + acro_summarise(mean_children = mean(children), sd_children = sd(children)) %>% + dplyr::arrange(parents, recommend) + + + expect_equal(acro_table, R_table, tolerance = 1e-5, ignore_attr = TRUE) +}) + +test_that("acro_summarise works with .groups = drop_last", { + # table produces by summarise function from dplyr package + R_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + dplyr::summarise(mean_children = mean(children), .groups = "drop_last") %>% + dplyr::arrange(parents, recommend) + + # table produces by acro_summarise function + acro_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + acro_summarise(mean_children = mean(children), .groups = "drop_last") %>% + dplyr::arrange(parents, recommend) + + expect_equal(dplyr::group_vars(R_table), dplyr::group_vars(acro_table)) +}) + +test_that("acro_summarise works with .groups = drop", { + # table produces by summarise function from dplyr package + R_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + dplyr::summarise(mean_children = mean(children), .groups = "drop") %>% + dplyr::arrange(parents, recommend) + + # table produces by acro_summarise function + acro_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + acro_summarise(mean_children = mean(children), .groups = "drop") %>% + dplyr::arrange(parents, recommend) + + expect_equal(dplyr::group_vars(R_table), dplyr::group_vars(acro_table)) +}) + +test_that("acro_summarise works with .groups = drop", { + # table produces by summarise function from dplyr package + R_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + dplyr::summarise(mean_children = mean(children), .groups = "drop") %>% + dplyr::arrange(parents, recommend) + + # table produces by acro_summarise function + acro_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + acro_summarise(mean_children = mean(children), .groups = "drop") %>% + dplyr::arrange(parents, recommend) + + expect_equal(dplyr::group_vars(R_table), dplyr::group_vars(acro_table)) +}) + +test_that("acro_summarise works with .groups = keep", { + # table produces by summarise function from dplyr package + R_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + dplyr::summarise(mean_children = mean(children), .groups = "keep") %>% + dplyr::arrange(parents, recommend) + + # table produces by acro_summarise function + acro_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + acro_summarise(mean_children = mean(children), .groups = "keep") %>% + dplyr::arrange(parents, recommend) + + expect_equal(dplyr::group_vars(R_table), dplyr::group_vars(acro_table)) +}) + +test_that("acro_summarise works with .groups = rowwise", { + # table produces by summarise function from dplyr package + R_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + dplyr::summarise(mean_children = mean(children), .groups = "rowwise") %>% + dplyr::arrange(parents, recommend) + + # table produces by acro_summarise function + acro_table <- nursery_data %>% + dplyr::group_by(parents, recommend) %>% + acro_summarise(mean_children = mean(children), .groups = "rowwise") %>% + dplyr::arrange(parents, recommend) + + expect_equal(dplyr::group_vars(R_table), dplyr::group_vars(acro_table)) +}) + +test_that("acro_summarise gives error when both .by and .groups are provided", { + expect_error( + nursery_data %>% + acro_summarise(mean_children = mean(children), .by = parents, .groups = "drop"), + "Can't supply both `\\.by` and `\\.groups`\\." + ) +}) + +test_that("acro_summarise gives error when .by is provided on a grouped dataframe", { + expect_error( + nursery_data %>% + dplyr::group_by(recommend) %>% + acro_summarise(mean_children = mean(children), .by = parents), + "Can't supply `\\.by` when `\\.data` is a grouped data frame\\." + ) +}) From 73d10bd4719b6d689785bdd966122e713dcc27bc Mon Sep 17 00:00:00 2001 From: mahaalbashir Date: Mon, 27 Jul 2026 17:08:20 +0100 Subject: [PATCH 02/11] fixing coverage and small changes to the code --- R/acro_tables.R | 13 ++++--- tests/testthat/test-acro_summarise.R | 57 ++++++++++++++++++++++++++++ 2 files changed, 65 insertions(+), 5 deletions(-) diff --git a/R/acro_tables.R b/R/acro_tables.R index 8a71f41..350befa 100644 --- a/R/acro_tables.R +++ b/R/acro_tables.R @@ -167,7 +167,7 @@ acro_table <- function(index, columns, dnn = NULL, deparse.level = 0, useNA = "n return(table) } -#' Title +#' creates a new data frame. It returns one row for each combination of grouping variables; if there are no grouping variables, the output will have a single row summarising all observations in the input #' #' @param .data A data frame or a data frame extension #' @param ... Name-value pairs of summary functions. The name will be the name of the variable in the result @@ -219,9 +219,10 @@ acro_summarise <- function(.data, ..., .groups = NULL, .by = NULL) { python_aggfuncs <- unique(unname(python_aggfuncs)) } - if (length(values[[1]]) == 0) { - values <- NULL - } + # Uncomment this when supporting the count function n() + # if (length(values[[1]]) == 0) { + # values <- NULL + # } # Handling ungrouped data via a dummy grouping column if (length(index) == 0) { @@ -253,6 +254,9 @@ acro_summarise <- function(.data, ..., .groups = NULL, .by = NULL) { if ("acro_dummy_all" %in% names(r_output)) { r_output <- r_output[, names(r_output) != "acro_dummy_all"] } + if (identical(index, "acro_dummy_all")) { + index <- NULL + } # Convert to tibble r_output <- tibble::as_tibble(r_output) @@ -285,7 +289,6 @@ acro_summarise <- function(.data, ..., .groups = NULL, .by = NULL) { } } else { stop("`.groups` must be one of 'drop', 'drop_last', 'keep', or 'rowwise'.", call. = FALSE) - r_output <- dplyr::rowwise(r_output) } diff --git a/tests/testthat/test-acro_summarise.R b/tests/testthat/test-acro_summarise.R index 72f1f50..0e48b31 100644 --- a/tests/testthat/test-acro_summarise.R +++ b/tests/testthat/test-acro_summarise.R @@ -1,9 +1,16 @@ +test_that("acro_summarise throws an error if the ACRO object was not initialised first", { + acroEnv$ac <- NULL + expect_error(acro_summarise(acro_summarise(nursery_data, mean_children = mean(children), .by = recommend)), "ACRO has not been initialised. Please first call acro_init()") +}) + + test_that("acro_summarise works with one grouping parameter", { # table produces by summarise function from dplyr package R_table <- dplyr::summarise(nursery_data, mean_children = mean(children), .by = recommend) |> dplyr::arrange(recommend) # table produces by acro_summarise function + acro_init() acro_table <- acro_summarise(nursery_data, mean_children = mean(children), .by = recommend) |> dplyr::arrange(recommend) @@ -16,6 +23,7 @@ test_that("acro_summarise works with two grouping parameters", { dplyr::arrange(parents, recommend) # table produces by acro_summarise function + acro_init() acro_table <- acro_summarise(nursery_data, mean_children = mean(children), .by = c(parents, recommend)) |> dplyr::arrange(parents, recommend) @@ -27,6 +35,7 @@ test_that("acro_summarise works with no grouping parameter calculate the summary R_table <- dplyr::summarise(nursery_data, mean_children = mean(children)) # table produces by acro_summarise function + acro_init() acro_table <- acro_summarise(nursery_data, mean_children = mean(children)) expect_equal(acro_table, R_table, tolerance = 1e-5, ignore_attr = TRUE) @@ -40,6 +49,7 @@ test_that("acro_summarise works with two summary functions for the same variable # table produces by acro_summarise function + acro_init() acro_table <- acro_summarise(nursery_data, mean_children = mean(children), sd_children = sd(children), .by = recommend) |> dplyr::arrange(recommend) @@ -47,6 +57,11 @@ test_that("acro_summarise works with two summary functions for the same variable expect_equal(acro_table, R_table, tolerance = 1e-5, ignore_attr = TRUE) }) +test_that("acro_summarise throws an error when different aggreagtion functions used for different values", { + acro_init() + expect_error(acro_summarise(nursery_data, mean_children = mean(children), sd_children = sd(parents), .by = recommend), "ACRO currently doesn not support different aggreagtion functions for different values.") +}) + test_that("acro_summarise works with piping", { # table produces by summarise function from dplyr package R_table <- nursery_data %>% @@ -55,6 +70,7 @@ test_that("acro_summarise works with piping", { dplyr::arrange(parents, recommend) # table produces by acro_summarise function + acro_init() acro_table <- nursery_data %>% dplyr::group_by(parents, recommend) %>% acro_summarise(mean_children = mean(children), sd_children = sd(children)) %>% @@ -72,6 +88,7 @@ test_that("acro_summarise works with .groups = drop_last", { dplyr::arrange(parents, recommend) # table produces by acro_summarise function + acro_init() acro_table <- nursery_data %>% dplyr::group_by(parents, recommend) %>% acro_summarise(mean_children = mean(children), .groups = "drop_last") %>% @@ -88,6 +105,7 @@ test_that("acro_summarise works with .groups = drop", { dplyr::arrange(parents, recommend) # table produces by acro_summarise function + acro_init() acro_table <- nursery_data %>% dplyr::group_by(parents, recommend) %>% acro_summarise(mean_children = mean(children), .groups = "drop") %>% @@ -104,6 +122,7 @@ test_that("acro_summarise works with .groups = drop", { dplyr::arrange(parents, recommend) # table produces by acro_summarise function + acro_init() acro_table <- nursery_data %>% dplyr::group_by(parents, recommend) %>% acro_summarise(mean_children = mean(children), .groups = "drop") %>% @@ -120,6 +139,7 @@ test_that("acro_summarise works with .groups = keep", { dplyr::arrange(parents, recommend) # table produces by acro_summarise function + acro_init() acro_table <- nursery_data %>% dplyr::group_by(parents, recommend) %>% acro_summarise(mean_children = mean(children), .groups = "keep") %>% @@ -128,6 +148,32 @@ test_that("acro_summarise works with .groups = keep", { expect_equal(dplyr::group_vars(R_table), dplyr::group_vars(acro_table)) }) +test_that("acro_summarise works with .groups = keep when there is no grouping provided", { + # table produces by summarise function from dplyr package + R_table <- nursery_data %>% + dplyr::summarise(mean_children = mean(children), .groups = "keep") + + # table produces by acro_summarise function + acro_init() + acro_table <- nursery_data %>% + acro_summarise(mean_children = mean(children), .groups = "keep") + + expect_equal(dplyr::group_vars(R_table), dplyr::group_vars(acro_table)) +}) + +test_that("acro_summarise works with .groups = rowwise when there is no grouping provided", { + # table produces by summarise function from dplyr package + R_table <- nursery_data %>% + dplyr::summarise(mean_children = mean(children), .groups = "rowwise") + + # table produces by acro_summarise function + acro_init() + acro_table <- nursery_data %>% + acro_summarise(mean_children = mean(children), .groups = "rowwise") + + expect_equal(dplyr::group_vars(R_table), dplyr::group_vars(acro_table)) +}) + test_that("acro_summarise works with .groups = rowwise", { # table produces by summarise function from dplyr package R_table <- nursery_data %>% @@ -136,6 +182,7 @@ test_that("acro_summarise works with .groups = rowwise", { dplyr::arrange(parents, recommend) # table produces by acro_summarise function + acro_init() acro_table <- nursery_data %>% dplyr::group_by(parents, recommend) %>% acro_summarise(mean_children = mean(children), .groups = "rowwise") %>% @@ -144,6 +191,16 @@ test_that("acro_summarise works with .groups = rowwise", { expect_equal(dplyr::group_vars(R_table), dplyr::group_vars(acro_table)) }) +test_that("acro_summarise throws an error with .groups is assigned to a not valid option", { + acro_init() + expect_error( + nursery_data %>% + dplyr::group_by(parents, recommend) %>% + acro_summarise(mean_children = mean(children), .groups = "columns"), + "`.groups` must be one of 'drop', 'drop_last', 'keep', or 'rowwise'." + ) +}) + test_that("acro_summarise gives error when both .by and .groups are provided", { expect_error( nursery_data %>% From 895842ecd6a49bbcbc1700bbd56fa65c2e8b0cf8 Mon Sep 17 00:00:00 2001 From: mahaalbashir Date: Mon, 27 Jul 2026 19:34:51 +0100 Subject: [PATCH 03/11] fixing the code coverage --- R/acro_tables.R | 8 ++++---- R/utils.R | 2 +- tests/testthat/test-acro_summarise.R | 18 ++++++++++++++++++ 3 files changed, 23 insertions(+), 5 deletions(-) diff --git a/R/acro_tables.R b/R/acro_tables.R index 350befa..9e1cf28 100644 --- a/R/acro_tables.R +++ b/R/acro_tables.R @@ -167,7 +167,7 @@ acro_table <- function(index, columns, dnn = NULL, deparse.level = 0, useNA = "n return(table) } -#' creates a new data frame. It returns one row for each combination of grouping variables; if there are no grouping variables, the output will have a single row summarising all observations in the input +#' Creates a new data frame. It returns one row for each combination of grouping variables; if there are no grouping variables, the output will have a single row summarising all observations in the input #' #' @param .data A data frame or a data frame extension #' @param ... Name-value pairs of summary functions. The name will be the name of the variable in the result @@ -220,9 +220,9 @@ acro_summarise <- function(.data, ..., .groups = NULL, .by = NULL) { } # Uncomment this when supporting the count function n() - # if (length(values[[1]]) == 0) { - # values <- NULL - # } + #if (length(values[[1]]) == 0) { + # values <- NULL + #} # Handling ungrouped data via a dummy grouping column if (length(index) == 0) { diff --git a/R/utils.R b/R/utils.R index a4daf6c..054ac8a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -84,7 +84,7 @@ parse_summary_expression <- function(quo) { # Ensure it is a function call (e.g., mean(disp)) if (!rlang::is_call(expr)) { - return(NULL) + return(NULL) # nocov } # Get the R function name diff --git a/tests/testthat/test-acro_summarise.R b/tests/testthat/test-acro_summarise.R index 0e48b31..356ecb6 100644 --- a/tests/testthat/test-acro_summarise.R +++ b/tests/testthat/test-acro_summarise.R @@ -217,3 +217,21 @@ test_that("acro_summarise gives error when .by is provided on a grouped datafram "Can't supply `\\.by` when `\\.data` is a grouped data frame\\." ) }) + +test_that("acro_summarise gives error when aggregation function is n()", { + expect_error( + nursery_data %>% + dplyr::group_by(recommend) %>% + acro_summarise(count_children = n()), + "Function n is not supported, but it will be available soon. Please use: mean, median, mode, sd or sum." + ) +}) + +test_that("acro_summarise gives error when aggregation function is not provided", { + expect_error( + nursery_data %>% + dplyr::group_by(recommend) %>% + acro_summarise(max_children = max()), + "Function max is not supported. Please use: mean, median, mode, sd or sum." + ) +}) From 6ee7d30750d9e8e843070c39a8f6f10f23d4df5b Mon Sep 17 00:00:00 2001 From: "pre-commit-ci[bot]" <66853113+pre-commit-ci[bot]@users.noreply.github.com> Date: Mon, 27 Jul 2026 18:35:25 +0000 Subject: [PATCH 04/11] [pre-commit.ci] auto fixes from pre-commit.com hooks for more information, see https://pre-commit.ci --- R/acro_tables.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/acro_tables.R b/R/acro_tables.R index 9e1cf28..2b58d9e 100644 --- a/R/acro_tables.R +++ b/R/acro_tables.R @@ -220,9 +220,9 @@ acro_summarise <- function(.data, ..., .groups = NULL, .by = NULL) { } # Uncomment this when supporting the count function n() - #if (length(values[[1]]) == 0) { + # if (length(values[[1]]) == 0) { # values <- NULL - #} + # } # Handling ungrouped data via a dummy grouping column if (length(index) == 0) { From 40a5fd262eb532e47bc1740305588e6848dd2df2 Mon Sep 17 00:00:00 2001 From: mahaalbashir Date: Tue, 28 Jul 2026 11:04:42 +0100 Subject: [PATCH 05/11] Update tests/testthat/test-acro_summarise.R Co-authored-by: Jim-smith Signed-off-by: mahaalbashir --- tests/testthat/test-acro_summarise.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-acro_summarise.R b/tests/testthat/test-acro_summarise.R index 356ecb6..10ec367 100644 --- a/tests/testthat/test-acro_summarise.R +++ b/tests/testthat/test-acro_summarise.R @@ -59,7 +59,7 @@ test_that("acro_summarise works with two summary functions for the same variable test_that("acro_summarise throws an error when different aggreagtion functions used for different values", { acro_init() - expect_error(acro_summarise(nursery_data, mean_children = mean(children), sd_children = sd(parents), .by = recommend), "ACRO currently doesn not support different aggreagtion functions for different values.") + expect_error(acro_summarise(nursery_data, mean_children = mean(children), sd_parents = sd(parents), .by = recommend), "ACRO currently does not support different aggregation functions for different values.") }) test_that("acro_summarise works with piping", { From 3940674652c041928d4eca02ab24b76dd3697c80 Mon Sep 17 00:00:00 2001 From: mahaalbashir Date: Tue, 28 Jul 2026 11:08:41 +0100 Subject: [PATCH 06/11] Correct typo Signed-off-by: mahaalbashir --- R/acro_tables.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/acro_tables.R b/R/acro_tables.R index 2b58d9e..91dcecd 100644 --- a/R/acro_tables.R +++ b/R/acro_tables.R @@ -214,7 +214,7 @@ acro_summarise <- function(.data, ..., .groups = NULL, .by = NULL) { # Create the dictionary for the agg functions # Uncomment this when the acro pivot table is accepting dictionaries for the agg_func parameter ie. is handling different agg_funcs with different values # python_aggfuncs <- stats::setNames(python_aggfuncs, values) - stop("ACRO currently doesn not support different aggreagtion functions for different values.", call. = FALSE) + stop("ACRO currently does not support different aggregation functions for different values.", call. = FALSE) } else { python_aggfuncs <- unique(unname(python_aggfuncs)) } From 23e8fd4537c624ee7b426b5348a63ae25789ab6b Mon Sep 17 00:00:00 2001 From: mahaalbashir Date: Tue, 28 Jul 2026 21:51:28 +0100 Subject: [PATCH 07/11] adding more tests --- R/acro_tables.R | 6 ++-- tests/testthat/test-acro_summarise.R | 42 +++++++++++++++++++++++++++- 2 files changed, 44 insertions(+), 4 deletions(-) diff --git a/R/acro_tables.R b/R/acro_tables.R index 9e1cf28..91dcecd 100644 --- a/R/acro_tables.R +++ b/R/acro_tables.R @@ -214,15 +214,15 @@ acro_summarise <- function(.data, ..., .groups = NULL, .by = NULL) { # Create the dictionary for the agg functions # Uncomment this when the acro pivot table is accepting dictionaries for the agg_func parameter ie. is handling different agg_funcs with different values # python_aggfuncs <- stats::setNames(python_aggfuncs, values) - stop("ACRO currently doesn not support different aggreagtion functions for different values.", call. = FALSE) + stop("ACRO currently does not support different aggregation functions for different values.", call. = FALSE) } else { python_aggfuncs <- unique(unname(python_aggfuncs)) } # Uncomment this when supporting the count function n() - #if (length(values[[1]]) == 0) { + # if (length(values[[1]]) == 0) { # values <- NULL - #} + # } # Handling ungrouped data via a dummy grouping column if (length(index) == 0) { diff --git a/tests/testthat/test-acro_summarise.R b/tests/testthat/test-acro_summarise.R index 356ecb6..a124385 100644 --- a/tests/testthat/test-acro_summarise.R +++ b/tests/testthat/test-acro_summarise.R @@ -59,7 +59,7 @@ test_that("acro_summarise works with two summary functions for the same variable test_that("acro_summarise throws an error when different aggreagtion functions used for different values", { acro_init() - expect_error(acro_summarise(nursery_data, mean_children = mean(children), sd_children = sd(parents), .by = recommend), "ACRO currently doesn not support different aggreagtion functions for different values.") + expect_error(acro_summarise(nursery_data, mean_children = mean(children), sd_parents = sd(parents), .by = recommend), "ACRO currently does not support different aggregation functions for different values.") }) test_that("acro_summarise works with piping", { @@ -235,3 +235,43 @@ test_that("acro_summarise gives error when aggregation function is not provided" "Function max is not supported. Please use: mean, median, mode, sd or sum." ) }) + +test_that("acro_summarise returns the status of the SDC checks as pass when the output is safe", { + acro_init() + acro_table <- acro_summarise(nursery_data, mean_children = mean(children), .by = parents) + + # Access the python results object + py_results <- acro:::acroEnv$ac$results + output <- py_results$get_index(as.integer(0)) + + # Verify summary string matches expected SDC risk assessment + correct_summary <- "pass" + expect_equal(as.character(output$summary), correct_summary) +}) + +test_that("acro_summarise returns the status of the SDC checks as fail when the output is unsafe", { + acro_init() + acro_table <- acro_summarise(nursery_data, mean_children = mean(children), .by = c(parents, recommend)) + + # Access the python results object + py_results <- acro:::acroEnv$ac$results + output <- py_results$get_index(as.integer(0)) + + # Verify summary string matches expected SDC risk assessment + correct_summary <- "fail; threshold: 1 cells may need suppressing; p-ratio: 1 cells may need suppressing; nk-rule: 1 cells may need suppressing; " + expect_equal(as.character(output$summary), correct_summary) +}) + +test_that("acro_summarise returns the summary as review when suppression is enabled", { + acro_init() + acro_enable_suppression() + acro_table <- acro_summarise(nursery_data, mean_children = mean(children), .by = c(parents, recommend)) + + # Access the python results object + py_results <- acro:::acroEnv$ac$results + output <- py_results$get_index(as.integer(0)) + + # Verify summary string matches expected SDC risk assessment + correct_summary <- "review; threshold: 1 cells suppressed; p-ratio: 1 cells suppressed; nk-rule: 1 cells suppressed; " + expect_equal(as.character(output$summary), correct_summary) +}) From 3ab8a68995b03a0d2b2a603a9bd7f365512f7020 Mon Sep 17 00:00:00 2001 From: mahaalbashir Date: Thu, 30 Jul 2026 15:46:10 +0100 Subject: [PATCH 08/11] adding more tests to make sure acro_summarise() suppress the right cells --- R/acro_tables.R | 2 - R/utils.R | 15 +++-- tests/testthat/test-acro_summarise.R | 96 ++++++++++++++++++++++++++++ 3 files changed, 106 insertions(+), 7 deletions(-) diff --git a/R/acro_tables.R b/R/acro_tables.R index 91dcecd..e960db8 100644 --- a/R/acro_tables.R +++ b/R/acro_tables.R @@ -203,10 +203,8 @@ acro_summarise <- function(.data, ..., .groups = NULL, .by = NULL) { # Handling the agg_func and the value parameters for the pivot_table summary_funcs <- rlang::enquos(..., .named = TRUE) - summary_funcs <- purrr::map(summary_funcs, parse_summary_expression) - values <- unname(purrr::map(summary_funcs, "values")) python_aggfuncs <- purrr::map(summary_funcs, "agg_funcs") diff --git a/R/utils.R b/R/utils.R index 054ac8a..d06e7ef 100644 --- a/R/utils.R +++ b/R/utils.R @@ -102,12 +102,17 @@ parse_summary_expression <- function(quo) { # Translate to Python agg function py_agg_funcs <- mapping[r_agg_funcs] - # Get all arguments - args <- rlang::call_match(expr, get(r_agg_funcs)) + # Get the values + call_args <- rlang::call_args(expr) + + values <- if (length(call_args) > 0) { + as.character(call_args[[1]]) + } else { + NULL + } list( - values = as.character(args$x), - agg_funcs = py_agg_funcs, - na.rm = isTRUE(args$na.rm) + values = values, + agg_funcs = py_agg_funcs ) } diff --git a/tests/testthat/test-acro_summarise.R b/tests/testthat/test-acro_summarise.R index a124385..f034362 100644 --- a/tests/testthat/test-acro_summarise.R +++ b/tests/testthat/test-acro_summarise.R @@ -275,3 +275,99 @@ test_that("acro_summarise returns the summary as review when suppression is enab correct_summary <- "review; threshold: 1 cells suppressed; p-ratio: 1 cells suppressed; nk-rule: 1 cells suppressed; " expect_equal(as.character(output$summary), correct_summary) }) + +test_that("acro_summarise() suppression for the threshold matches R summarise() on the dataset filtered for the threshold", { + acro_init() + safe_threshold <- reticulate::py_to_r((acro:::acroEnv$ac$config$safe_threshold)) + + # Run the acro command and then manually exclude the rows that violate the threshold + acro_table <- acro_summarise(mtcars, total_hp = sum(hp), .by = c(cyl, gear)) + + acro_table_filtered <- acro_table %>% + dplyr::filter( + !(cyl == 4) & + !(cyl == 6) & + !(cyl == 8 & gear == 5) + ) %>% + dplyr::arrange(cyl, gear) + + # Manually filter out the specific rows in mtcars that trigger the threshold failure + mtcars_filtered <- mtcars %>% + dplyr::group_by(cyl, gear) %>% + dplyr::filter(dplyr::n() >= safe_threshold) %>% + dplyr::ungroup() + + # Run the R summarise() with the filtered dataset + R_table <- dplyr::summarise(mtcars_filtered, total_hp = sum(hp), .by = c(cyl, gear)) + + # Compare acro's suppressed output against the manually filtered R output + expect_equal(acro_table_filtered, R_table, tolerance = 1e-5, ignore_attr = TRUE) +}) + +test_that("acro_summarise() suppression for the p-ratio rule matches R summarise() on the dataset filtered for the p-ratio", { + acro_init() + safe_pratio_p <- reticulate::py_to_r((acro:::acroEnv$ac$config$safe_pratio_p)) + + # Run the acro command and then manually exclude the rows that violate the p-ratio rule + acro_table <- acro_summarise(mtcars, total_hp = sum(hp), .by = c(cyl, gear)) + acro_table_filtered <- acro_table %>% + dplyr::filter( + !(cyl == 4 & gear %in% c(3, 5)) & + !(cyl == 6 & gear %in% c(3, 5)) & + !(cyl == 8 & gear == 5) + ) %>% + dplyr::arrange(cyl, gear) + print("£££££££££££££££££33") + print(safe_pratio_p) + # Manually filter out the specific dominant rows in mtcars that trigger the p-ratio failure + mtcars_filtered <- mtcars %>% + dplyr::group_by(cyl, gear) %>% + # Keep only groups that pass the specific p-ratio rule + dplyr::filter( + dplyr::n() >= 3, + # Sort then sum the two smallest then divide by the largest and check if the result >= 0.10 + sum(sort(hp)[1:2]) / max(hp) >= safe_pratio_p + ) %>% + dplyr::ungroup() + + # Run the R summarise() with the filtered dataset + R_table <- dplyr::summarise(mtcars_filtered, total_hp = sum(hp), .by = c(cyl, gear)) %>% + dplyr::arrange(cyl, gear) + + # Compare acro's suppressed output against the manually filtered R output + expect_equal(acro_table_filtered, R_table, tolerance = 1e-5, ignore_attr = TRUE) +}) + +test_that("acro_summarise() suppression for the nk-rule matches R summarise() on the dataset filtered for the nk-rule", { + acro_init() + safe_nk_n <- reticulate::py_to_r((acro:::acroEnv$ac$config$safe_nk_n)) + safe_nk_k <- reticulate::py_to_r((acro:::acroEnv$ac$config$safe_nk_k)) + + # Run the acro command and then manually exclude the rows that violate the nk-rule rule + acro_table <- acro_summarise(mtcars, total_hp = sum(hp), .by = c(cyl, gear)) + acro_table_filtered <- acro_table %>% + dplyr::filter( + !(cyl == 4 & gear %in% c(3, 5)) & + !(cyl == 6 & gear %in% c(3, 5)) & + !(cyl == 8 & gear == 5) + ) %>% + dplyr::arrange(cyl, gear) + + # Manually filter out the specific dominant rows in mtcars that trigger the nk-rule failure + mtcars_filtered <- mtcars %>% + dplyr::group_by(cyl, gear) %>% + dplyr::filter( + dplyr::n() >= safe_nk_n, + + # Sort then sum the two largest then divide by the total and check if the result < 0.9 + sum(head(sort(hp, decreasing = TRUE), safe_nk_n)) / sum(hp) < safe_nk_k + ) %>% + dplyr::ungroup() + + # Run the R summarise() with the filtered dataset + R_table <- dplyr::summarise(mtcars_filtered, total_hp = sum(hp), .by = c(cyl, gear)) %>% + dplyr::arrange(cyl, gear) + + # Compare acro's suppressed output against the manually filtered R output + expect_equal(acro_table_filtered, R_table, tolerance = 1e-5, ignore_attr = TRUE) +}) From 7c63c35f5f9e1a5e66688e45e2caa8638210f7d8 Mon Sep 17 00:00:00 2001 From: mahaalbashir Date: Thu, 30 Jul 2026 15:52:23 +0100 Subject: [PATCH 09/11] fixing code coverage --- R/utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index d06e7ef..956b4e1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -108,7 +108,7 @@ parse_summary_expression <- function(quo) { values <- if (length(call_args) > 0) { as.character(call_args[[1]]) } else { - NULL + NULL # nocov } list( From e22c1b3bb01b06ccb0baffd2fcb29b0698f560c7 Mon Sep 17 00:00:00 2001 From: mahaalbashir Date: Sun, 2 Aug 2026 13:39:37 +0100 Subject: [PATCH 10/11] updating the tests --- tests/testthat/test-acro_summarise.R | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/tests/testthat/test-acro_summarise.R b/tests/testthat/test-acro_summarise.R index f034362..7de0bfc 100644 --- a/tests/testthat/test-acro_summarise.R +++ b/tests/testthat/test-acro_summarise.R @@ -244,9 +244,9 @@ test_that("acro_summarise returns the status of the SDC checks as pass when the py_results <- acro:::acroEnv$ac$results output <- py_results$get_index(as.integer(0)) - # Verify summary string matches expected SDC risk assessment - correct_summary <- "pass" - expect_equal(as.character(output$summary), correct_summary) + # Verify status matches expected SDC risk assessment + correct_status <- "pass" + expect_equal(as.character(output$status), correct_status) }) test_that("acro_summarise returns the status of the SDC checks as fail when the output is unsafe", { @@ -257,9 +257,9 @@ test_that("acro_summarise returns the status of the SDC checks as fail when the py_results <- acro:::acroEnv$ac$results output <- py_results$get_index(as.integer(0)) - # Verify summary string matches expected SDC risk assessment - correct_summary <- "fail; threshold: 1 cells may need suppressing; p-ratio: 1 cells may need suppressing; nk-rule: 1 cells may need suppressing; " - expect_equal(as.character(output$summary), correct_summary) + # Verify status matches expected SDC risk assessment + correct_status <- "fail" + expect_equal(as.character(output$status), correct_status) }) test_that("acro_summarise returns the summary as review when suppression is enabled", { @@ -271,9 +271,11 @@ test_that("acro_summarise returns the summary as review when suppression is enab py_results <- acro:::acroEnv$ac$results output <- py_results$get_index(as.integer(0)) - # Verify summary string matches expected SDC risk assessment - correct_summary <- "review; threshold: 1 cells suppressed; p-ratio: 1 cells suppressed; nk-rule: 1 cells suppressed; " - expect_equal(as.character(output$summary), correct_summary) + # Verify status matches expected SDC risk assessment + correct_status <- "review" + correct_exception <- "Suppression automatically applied where needed" + expect_equal(as.character(output$status), correct_status) + expect_equal(as.character(output$exception), correct_exception) }) test_that("acro_summarise() suppression for the threshold matches R summarise() on the dataset filtered for the threshold", { @@ -317,8 +319,6 @@ test_that("acro_summarise() suppression for the p-ratio rule matches R summarise !(cyl == 8 & gear == 5) ) %>% dplyr::arrange(cyl, gear) - print("£££££££££££££££££33") - print(safe_pratio_p) # Manually filter out the specific dominant rows in mtcars that trigger the p-ratio failure mtcars_filtered <- mtcars %>% dplyr::group_by(cyl, gear) %>% From a36c7dc7b9b8b88c5af73ea20bc35788f51ab6e0 Mon Sep 17 00:00:00 2001 From: mahaalbashir Date: Mon, 3 Aug 2026 11:55:30 +0100 Subject: [PATCH 11/11] adding acro in tidyverse example notebook --- inst/notebooks/acro_demo_2026.Rmd | 6 +- inst/notebooks/acro_in_tidyverse_demo.Rmd | 91 ++++++++++++++++++++++ tests/testthat/test-acro_summarise.R | 94 ----------------------- 3 files changed, 96 insertions(+), 95 deletions(-) create mode 100644 inst/notebooks/acro_in_tidyverse_demo.Rmd diff --git a/inst/notebooks/acro_demo_2026.Rmd b/inst/notebooks/acro_demo_2026.Rmd index 20ce367..efd2954 100644 --- a/inst/notebooks/acro_demo_2026.Rmd +++ b/inst/notebooks/acro_demo_2026.Rmd @@ -276,7 +276,7 @@ table <- acro_table(index = rows, columns = columns, deparse.level = 1) table ``` -#### ACRO Crosstab +### ACRO Crosstab According to R's documentation, the \`table' command is typically only used to produce contingency tables - i.e. report on frequencies. @@ -320,6 +320,10 @@ table4 <- acro_crosstab( table4 ``` +### ACRO Summarise + +We also support the summarise() function from the tidy verse. Please see here for a separate example notebook about acro in the tidy verse [acro_in_tidyverse_demo.Rmd file](acro_in_tidyverse_demo.Rmd). + ## D: What other sorts of analysis does ACRO currently support? We are continually adding support for more types of analysis as users prioritise them. diff --git a/inst/notebooks/acro_in_tidyverse_demo.Rmd b/inst/notebooks/acro_in_tidyverse_demo.Rmd new file mode 100644 index 0000000..abfecb5 --- /dev/null +++ b/inst/notebooks/acro_in_tidyverse_demo.Rmd @@ -0,0 +1,91 @@ +--- +title: "acro-in_tidyverse_demo" +output: html_document +--- + +# ACRO in the tidyverse world + +This is a simple notebook to help you understand where acro fits in your tidyverse work flow. + +## Where does acro stand in the tidyverse world? +ACRO is designed to be a seamless addition to your existing tidyverse habits: + +- What stays the same: You will keep using your favorite functions (like filter(), select(), or mutate()) to prep your data exactly as you always have. + +- What ACRO adds: It steps in at the very end of your code pipeline to check your final outputs, ensuring your results meet the statistical disclosure control (SDC) checks + +## Example: +### Step 1: Check if acro is installed and if it is not install it from CRAN + +```{r} +# Check if acro is installed +if (!requireNamespace("acro", quietly = TRUE)) { + # If not installed, install it + install.packages("acro") +} +``` + +### Step 2: Starting an ACRO session +#### Load the acro package + +```{r} +library("acro") +``` + +#### Initiate acro + +```{r} +acro_init() +``` + +### Step 3: Load the data +- The dataset used in this example notebook is the nursery dataset from OpenML. +- The code below reads the data from a folder called data which we assume is located relative to your project directory. +- The path might need to be changed if the data has been downloaded and stored + elsewhere. + +```{r} +library(tidyverse) +library(farff) + +# 1. Read the ARFF file and rename 'class' to 'recommendation' +nursery_data <- readARFF("../../data/nursery.arff") %>% + as_tibble() %>% + rename(recommendation = class) +``` + +### Step 4: Data Preparation & Exploration +In this step we are going to use some tidyverse verses to clean and prep the data. + +- *mutate()* are used to format the children column +- *setcet()* is used to keep only specific column + +You can see that nothing has changed in the syntax or workflow up to this step +```{r} +# Convert children column to integers, replacing 'more' with a random int (4-10) +nursery_data <- nursery_data %>% + mutate( + children = suppressWarnings(as.numeric(as.character(children))), + children = if_else( + is.na(children), + round(runif(n(), min = 4, max = 10), 0), + children + ) + ) %>% + select(parents, children, finance, recommendation) +``` + +### Step 4: Producing outputs +- Now, let us produce a summary table that calculates the mean of the children column for the nursery dataset grouped by parents and recommendation. +- Instead of using the standard tidyverse *summarise()* function, we prefix it with acro_ to make it *acro_summarise()*. That is the primary change to your workflow needed to let ACRO perform disclosure control checks + +```{r} +# Generate a summary table using ACRO +nursery_data %>% + group_by(parents, recommendation) %>% + acro_summarise( + mean_children = mean(children) + ) +``` + +You can see that the output is not just the summary table but also the risk analysis produced by acro. You can then decide what are the steps you are going to make to remove the discolsive cells as discussed in the [acro_demo_2026.Rmd file](acro_demo_2026.Rmd) document. diff --git a/tests/testthat/test-acro_summarise.R b/tests/testthat/test-acro_summarise.R index 7de0bfc..ab8afdb 100644 --- a/tests/testthat/test-acro_summarise.R +++ b/tests/testthat/test-acro_summarise.R @@ -277,97 +277,3 @@ test_that("acro_summarise returns the summary as review when suppression is enab expect_equal(as.character(output$status), correct_status) expect_equal(as.character(output$exception), correct_exception) }) - -test_that("acro_summarise() suppression for the threshold matches R summarise() on the dataset filtered for the threshold", { - acro_init() - safe_threshold <- reticulate::py_to_r((acro:::acroEnv$ac$config$safe_threshold)) - - # Run the acro command and then manually exclude the rows that violate the threshold - acro_table <- acro_summarise(mtcars, total_hp = sum(hp), .by = c(cyl, gear)) - - acro_table_filtered <- acro_table %>% - dplyr::filter( - !(cyl == 4) & - !(cyl == 6) & - !(cyl == 8 & gear == 5) - ) %>% - dplyr::arrange(cyl, gear) - - # Manually filter out the specific rows in mtcars that trigger the threshold failure - mtcars_filtered <- mtcars %>% - dplyr::group_by(cyl, gear) %>% - dplyr::filter(dplyr::n() >= safe_threshold) %>% - dplyr::ungroup() - - # Run the R summarise() with the filtered dataset - R_table <- dplyr::summarise(mtcars_filtered, total_hp = sum(hp), .by = c(cyl, gear)) - - # Compare acro's suppressed output against the manually filtered R output - expect_equal(acro_table_filtered, R_table, tolerance = 1e-5, ignore_attr = TRUE) -}) - -test_that("acro_summarise() suppression for the p-ratio rule matches R summarise() on the dataset filtered for the p-ratio", { - acro_init() - safe_pratio_p <- reticulate::py_to_r((acro:::acroEnv$ac$config$safe_pratio_p)) - - # Run the acro command and then manually exclude the rows that violate the p-ratio rule - acro_table <- acro_summarise(mtcars, total_hp = sum(hp), .by = c(cyl, gear)) - acro_table_filtered <- acro_table %>% - dplyr::filter( - !(cyl == 4 & gear %in% c(3, 5)) & - !(cyl == 6 & gear %in% c(3, 5)) & - !(cyl == 8 & gear == 5) - ) %>% - dplyr::arrange(cyl, gear) - # Manually filter out the specific dominant rows in mtcars that trigger the p-ratio failure - mtcars_filtered <- mtcars %>% - dplyr::group_by(cyl, gear) %>% - # Keep only groups that pass the specific p-ratio rule - dplyr::filter( - dplyr::n() >= 3, - # Sort then sum the two smallest then divide by the largest and check if the result >= 0.10 - sum(sort(hp)[1:2]) / max(hp) >= safe_pratio_p - ) %>% - dplyr::ungroup() - - # Run the R summarise() with the filtered dataset - R_table <- dplyr::summarise(mtcars_filtered, total_hp = sum(hp), .by = c(cyl, gear)) %>% - dplyr::arrange(cyl, gear) - - # Compare acro's suppressed output against the manually filtered R output - expect_equal(acro_table_filtered, R_table, tolerance = 1e-5, ignore_attr = TRUE) -}) - -test_that("acro_summarise() suppression for the nk-rule matches R summarise() on the dataset filtered for the nk-rule", { - acro_init() - safe_nk_n <- reticulate::py_to_r((acro:::acroEnv$ac$config$safe_nk_n)) - safe_nk_k <- reticulate::py_to_r((acro:::acroEnv$ac$config$safe_nk_k)) - - # Run the acro command and then manually exclude the rows that violate the nk-rule rule - acro_table <- acro_summarise(mtcars, total_hp = sum(hp), .by = c(cyl, gear)) - acro_table_filtered <- acro_table %>% - dplyr::filter( - !(cyl == 4 & gear %in% c(3, 5)) & - !(cyl == 6 & gear %in% c(3, 5)) & - !(cyl == 8 & gear == 5) - ) %>% - dplyr::arrange(cyl, gear) - - # Manually filter out the specific dominant rows in mtcars that trigger the nk-rule failure - mtcars_filtered <- mtcars %>% - dplyr::group_by(cyl, gear) %>% - dplyr::filter( - dplyr::n() >= safe_nk_n, - - # Sort then sum the two largest then divide by the total and check if the result < 0.9 - sum(head(sort(hp, decreasing = TRUE), safe_nk_n)) / sum(hp) < safe_nk_k - ) %>% - dplyr::ungroup() - - # Run the R summarise() with the filtered dataset - R_table <- dplyr::summarise(mtcars_filtered, total_hp = sum(hp), .by = c(cyl, gear)) %>% - dplyr::arrange(cyl, gear) - - # Compare acro's suppressed output against the manually filtered R output - expect_equal(acro_table_filtered, R_table, tolerance = 1e-5, ignore_attr = TRUE) -})