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..e960db8 100644 --- a/R/acro_tables.R +++ b/R/acro_tables.R @@ -167,6 +167,132 @@ 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 +#' +#' @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 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) { + # 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"] + } + if (identical(index, "acro_dummy_all")) { + index <- NULL + } + + # 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) + } + + + return(r_output) +} + #' Pivot table #' #' @param data The data to operate on. diff --git a/R/utils.R b/R/utils.R index 855058b..956b4e1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -78,3 +78,41 @@ 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) # nocov + } + + # 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 the values + call_args <- rlang::call_args(expr) + + values <- if (length(call_args) > 0) { + as.character(call_args[[1]]) + } else { + NULL # nocov + } + + list( + values = values, + agg_funcs = py_agg_funcs + ) +} 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/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..ab8afdb --- /dev/null +++ b/tests/testthat/test-acro_summarise.R @@ -0,0 +1,279 @@ +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) + + 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_init() + 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_init() + 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_init() + 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 throws an error when different aggreagtion functions used for different values", { + acro_init() + 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", { + # 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_init() + 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_init() + 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_init() + 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_init() + 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_init() + 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 = 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 %>% + dplyr::group_by(parents, recommend) %>% + dplyr::summarise(mean_children = mean(children), .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") %>% + dplyr::arrange(parents, recommend) + + 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 %>% + 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\\." + ) +}) + +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." + ) +}) + +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 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", { + 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 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", { + 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 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) +})