diff --git a/NAMESPACE b/NAMESPACE
index 0474b2b1..4f6c5d81 100644
--- a/NAMESPACE
+++ b/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)
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/R/subsetByClassHelper1.R b/R/subsetByClassHelper1.R
new file mode 100644
index 00000000..7c288da3
--- /dev/null
+++ b/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)
+}
diff --git a/R/subsetByClassHelper2.R b/R/subsetByClassHelper2.R
new file mode 100644
index 00000000..f59cc907
--- /dev/null
+++ b/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))
+}
\ No newline at end of file
diff --git a/R/subsetByClassHelper3.R b/R/subsetByClassHelper3.R
new file mode 100644
index 00000000..de401f62
--- /dev/null
+++ b/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))
+}
\ No newline at end of file
diff --git a/_pkgdown.yml b/_pkgdown.yml
index 4c98f6e5..4dc66bb0 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -1,3 +1,4 @@
template:
+ bootstrap: 5
params:
bootswatch: simplex
diff --git a/docs/404.html b/docs/404.html
index 0e809232..16dd3edd 100644
--- a/docs/404.html
+++ b/docs/404.html
@@ -4,90 +4,70 @@
-
+
Page not found (404) • dsBase
-
-
-
-
-
-
-
+
+
+
+
+
-
-
-
-