From 952cde668d1e17459a4c6158ee63544f8253fa76 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Jul 2026 12:41:50 +0200 Subject: [PATCH] fix: revert to correct version of functions and tests --- R/standardiseDfDS.R | 49 ++++++++++++++++++++++- tests/testthat/test-smk-standardiseDfDS.R | 16 ++++++-- 2 files changed, 59 insertions(+), 6 deletions(-) diff --git a/R/standardiseDfDS.R b/R/standardiseDfDS.R index 35e15e6e..24e3eecf 100644 --- a/R/standardiseDfDS.R +++ b/R/standardiseDfDS.R @@ -6,6 +6,8 @@ #' @importFrom purrr map #' @export getClassAllColsDS <- function(df.name){ + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) + df.name <- eval(parse(text = df.name), envir = parent.frame()) all_classes <- map(df.name, class) %>% as_tibble() return(all_classes) @@ -21,6 +23,8 @@ getClassAllColsDS <- function(df.name){ #' @importFrom tidyselect all_of #' @export fixClassDS <- function(df.name, target_vars, target_class) { + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) + df <- eval(parse(text = df.name), envir = parent.frame()) df_transformed <- df %>% mutate( @@ -54,6 +58,8 @@ fixClassDS <- function(df.name, target_vars, target_class) { #' @importFrom purrr set_names #' @export fixColsDS <- function(.data, cols) { + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) + .data <- eval(parse(text = .data), envir = parent.frame()) missing <- setdiff(cols, colnames(.data)) out <- .data %>% @@ -67,13 +73,50 @@ fixColsDS <- function(.data, cols) { #' @param factor_vars A character vector specifying the factor columns. #' @return A list of factor levels for the specified columns. #' @importFrom tidyselect all_of -#' @importFrom purrr map +#' @importFrom purrr map imap #' @export getAllLevelsDS <- function(df.name, factor_vars) { + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) + df <- eval(parse(text = df.name), envir = parent.frame()) - return(df %>% dplyr::select(all_of(factor_vars)) %>% map(levels)) + factor_vars_split <- strsplit(factor_vars, ",\\s*")[[1]] + levels <- purrr::map(df[factor_vars_split], base::levels) + + disclosure_check <- imap(levels, function(lvls, var) { + .checkLevelsDisclosure(df = df, var = var, levels = lvls) + }) + + failed_vars <- names(disclosure_check)[unlist(disclosure_check)] + + if(length(failed_vars) > 0) { + stop("Based on the value of nfilter.levels.density, these factor variables", " {", failed_vars, "} ", "have too many levels compared to the length of the variable. Please reduce the numnber of levels or change the variable type and try again") + } else { + return(levels) + } } +#' Check variable levels against disclosure thresholds +#' +#' Internal helper function to verify whether the number of levels in a variable +#' exceeds the allowed density threshold defined by `dsBase::listDisclosureSettingsDS()`. +#' +#' @param df A data frame containing the variable. +#' @param var Character string. Name of the variable to check. +#' @param levels Character vector. Levels of the variable. +#' +#' @return Logical. `TRUE` if the check fails (i.e., disclosure threshold is violated), +#' otherwise `FALSE`. +#' +#' @keywords internal +#' @noRd +.checkLevelsDisclosure <- function(df, var, levels) { + thr <- dsBase::listDisclosureSettingsDS() + nfilter.levels.density <- as.numeric(thr$nfilter.levels.density) + n_levels <- length(levels) + length_var <- length(df[[var]]) + fail <- (length_var * nfilter.levels.density) < n_levels + return(fail) +} #' Set Factor Levels for Specific Columns in a Data Frame #' @param df.name A string representing the name of the data frame to modify. @@ -82,6 +125,8 @@ getAllLevelsDS <- function(df.name, factor_vars) { #' @return A modified data frame with the specified columns converted to factors with the provided levels. #' @export fixLevelsDS <- function(df.name, vars, levels) { + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) + df.name <- eval(parse(text = df.name), envir = parent.frame()) out <- df.name %>% mutate(across(all_of(vars), ~factor(., levels = levels[[dplyr::cur_column()]]))) diff --git a/tests/testthat/test-smk-standardiseDfDS.R b/tests/testthat/test-smk-standardiseDfDS.R index 1bfd6720..4397fe65 100644 --- a/tests/testthat/test-smk-standardiseDfDS.R +++ b/tests/testthat/test-smk-standardiseDfDS.R @@ -49,7 +49,7 @@ test_that("fixClassDS sets classes correctly", { ) expect_equal( - classes_changed_df %>% tidytable::map_chr(class) %>% unname(), + classes_changed_df %>% purrr::map_chr(class) %>% unname(), c("factor", "factor", "numeric", "factor", "factor", "factor", "factor", "integer", "factor", "factor", "factor", "factor", "character", "logical", "factor", "integer", "integer", "numeric", "logical", "integer", "character", "numeric", "numeric", "character", "numeric", @@ -89,9 +89,7 @@ test_that("fixColsDS correctly adds missing columns", { test_that("getAllLevelsDS correctly retrieves the levels of specified factor columns", { - factor_vars <- c("fac_col1", "fac_col2", "fac_col3", "fac_col4", "fac_col5", "fac_col6", "fac_col7", - "fac_col8", "fac_col9", "fac_col10", "fac_col11", "fac_col12", "fac_col14", - "fac_col15", "col27") + factor_vars <- "fac_col1, fac_col2, fac_col3, fac_col4, fac_col5, fac_col6, fac_col7, fac_col8, fac_col9, fac_col10, fac_col11, fac_col12, fac_col14, fac_col15, col27" observed <- getAllLevelsDS("df_3", factor_vars) @@ -154,6 +152,16 @@ test_that("fixLevelsDS throws an error for invalid input", { expect_error(fixLevelsDS("example_df", c("col1", "non_existent_col"), levels)) }) +test_that("getAllLevelsDS stops when a variable exceeds disclosure threshold", { + + mtcars_bad_group <- mtcars %>% mutate(qsec = as.factor(qsec)) + + expect_error( + getAllLevelsDS("mtcars_bad_group", "qsec"), + regexp = "Based on the value of nfilter.levels.density" + ) +}) + # # Done #