Fix/standardise df

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()]])))

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
 #