develop the acro_summarise() function

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

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)

R/acro_tables.R

@@ -167,6 +167,134 @@ 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 doesn not support different aggreagtion 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.

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) # 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 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)
+  )
+}