Consolidated updates from v6.3.6-dev

NAMESPACE

@@ -155,6 +155,7 @@ importFrom(dplyr,mutate)
 importFrom(dplyr,select)
 importFrom(gamlss.dist,pST3)
 importFrom(gamlss.dist,qST3)
+importFrom(purrr,imap)
 importFrom(purrr,map)
 importFrom(purrr,set_names)
 importFrom(tibble,as_tibble)

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

R/subsetByClassHelper1.R

@@ -0,0 +1,41 @@
+#' 
+#' @title generates subsets vectors from a factor vector
+#' @description This is an internal function called by the function 'subsetByClassDS'.
+#' @details The function generates subsets if the input of 'subsetByClassDS' is a factor vector.
+#' @param xvect a vector of type factor.
+#' @param xname the name of the vector.
+#' @param filter the minimum number observation (i.e. rows) that are allowed.
+#' @return a list which contains the subsets.
+#' @keywords internal
+#' @noRd
+#' @author Gaye, A.
+#'
+subsetByClassHelper1 <- function(xvect=NULL, xname=NULL, filter=NULL){
+  vectname <- xname
+  subsets <- list()
+  names.of.subsets <- c()
+  categories <- levels(xvect)
+  for(i in 1:length(categories)){
+    indices <- which(xvect == as.numeric(categories[i]))    
+    if(!(length(indices) < filter)){
+      subsets[[i]] <- xvect[indices]
+      name.of.subD <- paste(vectname,".level_", categories[i], sep="")
+      names.of.subsets <- append(names.of.subsets, name.of.subD)
+    }else{
+      # if any one category has between 0 and 'filter' observation turn subset content into missing values
+      if(length(indices) == 0){
+        subsets[[i]] <-  xvect[-c(1:length(xvect))]
+        name.of.subD <- paste(vectname,".level_", categories[i], "_EMPTY", sep="")
+      }else{
+        temp1 <- xvect[indices]
+        temp1[1:length(temp1)] <- NA
+        subsets[[i]] <- temp1
+        name.of.subD <- paste(vectname,".level_", categories[i], "_INVALID", sep="")
+      }
+      names.of.subsets <- append(names.of.subsets, name.of.subD)
+    }
+    names(subsets) <- names.of.subsets
+    output <- subsets
+  }
+  return(output)
+}

R/subsetByClassHelper2.R

@@ -0,0 +1,64 @@
+#' 
+#' @title generates subset tables from a data frame
+#' @description This is an internal function called by the function 'subsetByClassDS'
+#' @details The function generates subsets if the input of 'subsetByClassDS' is a data frame 
+#' and if the number variables(columns) to subset by are greater than 1; i.e. this 
+#' function is called if the user specified more than one variable or no variable to subset by
+#' (if no variables are specified the function 'subsetByClassDS' produces a subset for each category
+#' in each variable).
+#' @param df a data frame.
+#' @param iter the indices of columns to loop trough.
+#' @param filter the minimum number of observations (i.e. rows) that are allowed.
+#' @return a list which contains the subsets, their names and an integer that indicates how many columns were
+#' not factors.
+#' @keywords internal
+#' @noRd
+#' @author Gaye, A.
+#'
+subsetByClassHelper2 <- function(df=NULL, iter=NULL, filter=NULL){
+  # various counters and temporary variables to hold info
+  subsets <- list()
+  names.of.subsets <- c()
+  count <- 0  
+  nonfactorvars <- 0
+  ncols <- length(colnames(df))
+  for(i in iter){
+    var <- df[,i]
+    varname <- colnames(df)[i]
+    if(is.factor(var)){        
+      # get the levels
+      categories <- levels(var)
+      # loop through the levels and generate a dataset for each level
+      # if the number of observations for that level > 0 and < 'filter'
+      for(j in 1:length(categories)){
+        indices <- which(var == as.numeric(categories[j]))
+        if(!(length(indices) < filter)){
+          count <- count+1
+          subD <- df[indices,]
+          subsets[[count]] <- subD
+          name.of.subD <- paste(varname,".level_", categories[j], sep="")
+          names.of.subsets <- append(names.of.subsets, name.of.subD)
+        }else{
+          # if any one category has between 1 and 'filter' number of observation turn subset content into missing values
+          count <- count+1
+          if(length(indices) == 0){
+            subsets[[count]] <- df[-c(1:dim(df)[1]),]
+            name.of.subD <- paste(varname,".level_", categories[j], "_EMPTY",sep="")
+          }else{
+            subD <- df[indices,]
+            subD[] <- NA
+            subsets[[count]] <- subD
+            name.of.subD <- paste(varname,".level_", categories[j], "_INVALID",sep="")
+          }
+          colnames(subsets[[count]]) <- colnames(df)
+          names.of.subsets <- append(names.of.subsets, name.of.subD) 
+        }
+      }
+      names(subsets) <- names.of.subsets
+    }else{
+      # if a variable is not a factor increment the below counter
+      nonfactorvars <- nonfactorvars + 1
+    }
+  }
+  return(list(subsets, nonfactorvars))
+}

R/subsetByClassHelper3.R

@@ -0,0 +1,59 @@
+#' 
+#' @title generates subset tables from a data frame
+#' @description This is an internal function called by the function 'subsetByClassDS'
+#' @details The function generates subsets if the input of 'subsetByClassDS' is a data frame 
+#' and if the number of variables (columns) to subset by is 1; i.e. this 
+#' function is called if the user specified one variable to subset by.
+#' @param df a data frame.
+#' @param indx1 the column index of the variable specified by the user.
+#' @param filter the minimum number of observations (i.e. rows) that are allowed.
+#' @return a list which contains the subsets, their names and an integer that indicates if
+#' the variable specified by user is a factor.
+#' @keywords internal
+#' @noRd
+#' @author Gaye, A.
+#'
+subsetByClassHelper3 <- function(df=NULL, indx1=NULL, filter=NULL){
+  # various counters and temporary variables to hold info
+  subsets <- list()
+  names.of.subsets <- c()
+  count <- 0
+  nonfactorvars <- 0
+  ncols <- length(colnames(df))
+  var <- df[,indx1]
+  varname <- colnames(df)[indx1]
+  if(is.factor(var)){
+    # get the levels
+    categories <- levels(var)
+    # loop through the levels and generate a dataset for each level
+    # if the number of observations for that level > 0 and < 'filter'
+    for(j in 1:length(categories)){
+      indices <- which(var == as.numeric(categories[j]))
+      if(!(length(indices) < filter)){
+        count <- count+1
+        subD <- df[indices,]
+        subsets[[count]] <- subD
+        name.of.subD <- paste(varname,".level_", categories[j], sep="")
+        names.of.subsets <- append(names.of.subsets, name.of.subD)
+      }else{
+        # if any one category has between 1 and 'filter' number of observations turn subset content into missing values
+        count <- count+1
+        if(length(indices) == 0){
+          subsets[[count]] <- df[-c(1:dim(df)[1]),]
+          name.of.subD <- paste(varname,".level_", categories[j], "_EMPTY",sep="")
+        }else{
+          subD <- df[indices,]
+          subD[] <- NA
+          subsets[[count]] <- subD
+          name.of.subD <- paste(varname,".level_", categories[j], "_INVALID",sep="")
+        }
+        colnames(subsets[[count]]) <- colnames(df)
+        names.of.subsets <- append(names.of.subsets, name.of.subD)
+      }
+    }
+    names(subsets) <- names.of.subsets
+  }else{
+    nonfactorvars <- 1
+  }
+  return(list(subsets, nonfactorvars))
+}

_pkgdown.yml

@@ -1,3 +1,4 @@
 template:
+  bootstrap: 5
   params:
     bootswatch: simplex