diff --git a/.gitignore b/.gitignore index 10fe035..ed6314b 100644 --- a/.gitignore +++ b/.gitignore @@ -24,3 +24,4 @@ output/ vignettes/tauargus_files/ vignettes/hrc/ vignettes/example_1/ +bench/ diff --git a/NAMESPACE b/NAMESPACE index c7946eb..a3c5c56 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,29 +3,20 @@ export(analyse_metadata) export(create_edges) export(dataframe_result) +export(explore_reduce_dims) export(format_template) -export(from_4_to_3) -export(from_4_to_3_case_0_hr) -export(from_4_to_3_case_1_hr) -export(from_4_to_3_case_2_hr) -export(from_5_to_3) export(grp_tab_in_cluster) export(grp_tab_names) export(identify_hrc) export(identify_hrc_with_eq) export(import) -export(length_tabs) export(micro_arb) export(micro_asc_rda) export(micro_rtauargus) -export(nb_tab_generated) -export(reduce_dims) export(reset_rtauargus_options) -export(restore_format) export(rtauargus_options) export(rtauargus_plus) export(run_arb) -export(sp_format) export(split_dataframe) export(split_in_clusters) export(summarize_secret) @@ -37,7 +28,6 @@ export(tab_rtauargus2) export(tab_rtauargus4) export(tab_to_treat) export(tabulate_micro_data) -export(var_to_merge) export(write_hrc) export(write_hrc2) import(data.table, except = transpose) diff --git a/R/globals.R b/R/globals.R index 6f53a3c..d9e12f6 100644 --- a/R/globals.R +++ b/R/globals.R @@ -7,5 +7,5 @@ utils::globalVariables( "eq_name","unit","var","n_total","total_alt","group","initial_indicator","spanning_new", "spanning_key","all_sides","side","sides_manquants","table_name_combined","var_mapped", "totcode","all_combinations","covered_sides","VALUE", "status", "nb_cells", - "value",".") + "value",".", "nb_tab", "max_size", "min_size") ) diff --git a/R/multitable.R b/R/multitable.R index a945bd1..53ec001 100644 --- a/R/multitable.R +++ b/R/multitable.R @@ -124,8 +124,7 @@ tab_multi_manager <- function( num_iter_max = 10, summary_secret = FALSE, split_tab = FALSE, - nb_tab_option = "smart", - limit = 14700, + split_limit = NULL, ... ){ start_time <- Sys.time() @@ -143,8 +142,11 @@ tab_multi_manager <- function( params$suppress = suppress params$suppress = suppress params$split_tab = split_tab - params$nb_tab_option = nb_tab_option - params$limit = limit + + params$nb_tab_option = if (!is.null(.dots$nb_tab_option)) .dots$nb_tab_option else "smart" + params$split_limit = split_limit + # Enabled by default for multi-table manager calls + params$compact_verbose <- if (!is.null(.dots[["compact_verbose"]])) .dots[["compact_verbose"]] else TRUE n_tbx = length(list_tables) # nombre de tableaux @@ -368,7 +370,11 @@ tab_multi_manager <- function( num_iter_all <- num_iter_all + 1 num_tableau <- todolist[1] num_iter_par_tab[num_tableau] <- num_iter_par_tab[num_tableau] + 1 - cat("--- Current table to treat: ", num_tableau, "---\n") + + # cat("--- Current table to treat: ", num_tableau, "---\n") + cat(sprintf("\r--- Current table to treat: %s | loop iter : %d --- ", + num_tableau, num_iter_all)) + flush.console() nom_col_identifiante <- paste0("T_", num_tableau) tableau_a_traiter <- which(table_majeure[[nom_col_identifiante]]) @@ -492,6 +498,8 @@ tab_multi_manager <- function( } + cat("\n") + # Reconstruire la liste des tableaux d'entrée liste_tbx_res <- purrr::imap( list_tables, diff --git a/R/sp_from_4_to_3.R b/R/sp_from_4_to_3.R index 3c814a0..45d1a1d 100644 --- a/R/sp_from_4_to_3.R +++ b/R/sp_from_4_to_3.R @@ -1,30 +1,41 @@ -# Small functions for use in from_4_to_3() +# Small helper functions for variable selection in from_4_to_3() -# Returns the hierarchical variable with the fewest nodes (= subtotals) -smallest_hrc <- function(hrcfiles) { +# Return the hierarchical variable with the fewest nodes/subtotals +smallest_hrc <- function(hrcfiles, totcode) { v <- list() - for (i in 1:length(hrcfiles)) { - v <- append(v, nb_nodes(hrcfiles, names(hrcfiles[i]))) + for (i in seq_along(hrcfiles)) { + v <- append(v, nb_nodes(hrcfiles, names(hrcfiles)[i], totcode = totcode)) } index_smaller_hrc <- which.min(v) name_smaller_hrc <- names(hrcfiles)[index_smaller_hrc] return(name_smaller_hrc) } -# Returns the variable with the fewest modalities -smallest_mod <- function(dfs) { +# Return the hierarchical variable with the most nodes/subtotals +bigger_hrc <- function(hrcfiles, totcode) { v <- list() - for (colonne in dfs) { - v <- append(v,length(unique(colonne))) + for (i in seq_along(hrcfiles)) { + v <- append(v, nb_nodes(hrcfiles, names(hrcfiles)[i], totcode = totcode)) } - index_smaller_mod <- which.min(v) - name_smaller_mod <- names(dfs)[index_smaller_mod] - return(name_smaller_mod) + index_bigger_hrc <- which.max(v) + name_bigger_hrc <- names(hrcfiles)[index_bigger_hrc] + return(name_bigger_hrc) } -# Choose a categorical variable -# Preferably the non-hierarchical one with the fewest modalities -# If not available, the hierarchical variable with the fewest nodes +# Return the categorical variable with the fewest unique modalities +smallest_mod <- function(dfs) { + v <- sapply(dfs, function(col) length(unique(col))) + names(which.min(v)) +} + +# Return the categorical variable with the most unique modalities +bigger_mod <- function(dfs) { + v <- sapply(dfs, function(col) length(unique(col))) + names(which.max(v)) +} + +# Priority 1: Pick non-hierarchical variable with fewest modalities (fewest tables created). +# Priority 2: If no flat variable, pick hierarchical variable with fewest nodes. choose_var_priority_non_hierarchical <- function(dfs,totcode,hrcfiles){ # The categorical variables without hierarchy cat_vars <- names(totcode) @@ -49,35 +60,12 @@ choose_var_priority_non_hierarchical <- function(dfs,totcode,hrcfiles){ } # Otherwise choose the hierarchical variable with the fewest subtotals else { - return (smallest_hrc(hrcfiles)) + return (smallest_hrc(hrcfiles, totcode)) } } -# Returns the hierarchical variable with the most nodes -bigger_hrc <- function(hrcfiles) { - v <- list() - for (i in 1:length(hrcfiles)) { - v <- append(v, nb_nodes(hrcfiles, names(hrcfiles[i]))) - } - index_bigger_hrc <- which.max(v) - name_bigger_hrc <- names(hrcfiles)[index_bigger_hrc] - return(name_bigger_hrc) -} - -# Returns the variable with the most modalities -bigger_mod <- function(dfs) { - v <- list() - for (colonne in dfs) { - v <- append(v, length(unique(colonne))) - } - index_bigger_mod <- which.max(v) - name_bigger_mod <- names(dfs)[index_bigger_mod] - return(name_bigger_mod) -} - -# Choose a categorical variable -# Preferably the hierarchical one with the most nodes -# If not available, the non-hierarchical variable with the most modalities +# Priority 1: Pick hierarchical variable with most nodes (smaller sub-tables created). +# Priority 2: If no hierarchical variable, pick flat variable with most modalities. choose_var_priority_hierarchical <- function(dfs, totcode, hrcfiles) { # Principle: preferably choose hierarchical variables @@ -86,10 +74,11 @@ choose_var_priority_hierarchical <- function(dfs, totcode, hrcfiles) { return(bigger_mod(dfs[names(dfs) %in% names(totcode)])) # Otherwise, choose the hierarchical variable with the most subtotals } else { - return(bigger_hrc(hrcfiles)) + return(bigger_hrc(hrcfiles, totcode)) } } +# Heuristic selector for merging variables according to 'maximize_nb_tabs' chose_var_to_merge <- function(dfs, totcode, hrcfiles, maximize_nb_tabs = FALSE) { if(maximize_nb_tabs){ return(choose_var_priority_hierarchical(dfs, totcode, hrcfiles)) @@ -98,83 +87,23 @@ chose_var_to_merge <- function(dfs, totcode, hrcfiles, maximize_nb_tabs = FALSE) } } -#' Function reducing from 4 to 3 categorical variables +#' Transition from 4 to 3 categorical variables #' -#' @param dfs data.frame with 4 categorical variables (n >= 2 in the general case) -#' @param dfs_name name of the dataframe +#' @param dfs data.frame with 4 categorical variables +#' @param dfs_name name of the data.frame #' @param totcode named vector of totals for categorical variables -#' @param hrcfiles named vector indicating the hrc files of hierarchical variables -#' among the categorical variables of dfs -#' @param sep_dir allows forcing the writing of hrc into a separate folder, -#' default is FALSE -#' @param hrc_dir folder to write hrc files if writing to a new folder is forced -#' or if no folder is specified in hrcfiles -#' @param v1 allows forcing the value of the first variable to merge, -#' not specified by default (NULL) -#' @param v2 allows forcing the value of the second variable to merge, -#' not specified by default (NULL) -#' @param sep separator used during concatenation of variables -#' @param maximize_nb_tabs specifies whether to prefer selecting hierarchical variables with -#' the most nodes in priority (TRUE), generating more tables but with smaller sizes, -#' or non-hierarchical variables with the fewest modalities (FALSE) to create fewer tables +#' @param hrcfiles named vector of hrc file paths +#' @param sep_dir logical, if TRUE forces writing hrc files into hrc_dir +#' @param hrc_dir folder to write hrc files +#' @param v1 optional first variable to merge +#' @param v2 optional second variable to merge +#' @param sep separator used during variable concatenation +#' @param maximize_nb_tabs logical, whether to prefer selecting hierarchical variables #' -#' @return A list containing the following components: -#' \itemize{ -#' \item `tabs`: named list of 3-dimensional dataframes -#' (n-1 dimensions in the general case) with nested hierarchies -#' \item `hrc`: named list of hrc specific to the variable created -#' through merging -#' \item `alt_tot`: named list of totals -#' \item `vars`: named list of vectors representing the merged variables -#' during the two stages of dimension reduction -#' } +#' @return A list with `tabs`, `hrcs`, `alt_tot` and `vars`. #' -#' @examples -#' library(dplyr) -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), -#' GEO = c("Total", "G1", "G2"), -#' SEX = c("Total", "F", "M"), -#' AGE = c("Total", "AGE1", "AGE2"), -#' stringsAsFactors = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' -#' sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) %>% -#' sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' # Results of the function -#' res1 <- from_4_to_3( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), -#' hrcfiles = c(ACT = hrc_act), -#' sep_dir = TRUE, -#' hrc_dir = "output" -#' ) -#' -#' # Maximize the number of tables -#' res2 <- from_4_to_3( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), -#' hrcfiles = c(ACT = hrc_act), -#' sep_dir = TRUE, -#' hrc_dir = "output", -#' maximize_nb_tabs = TRUE -#' ) #' @keywords internal -#' @export +#' @noRd from_4_to_3 <- function( dfs, dfs_name, @@ -187,6 +116,17 @@ from_4_to_3 <- function( sep = "_", maximize_nb_tabs = FALSE) { + + # ---------------------------------------------------------------------------- + # ROUTER: 4D -> 3D transition + # 1. Determine target directory for generated .hrc files. + # 2. Select / validate candidate variables v1 and v2 to merge. + # 3. Route execution to dedicated sub-method based on count of flat variables: + # - 2 flat vars -> from_4_to_3_case_0_hr + # - 1 flat + 1 HR var -> from_4_to_3_case_1_hr (forces v1=flat, v2=HR) + # - 2 HR vars -> from_4_to_3_case_2_hr + # ---------------------------------------------------------------------------- + # Update the output directory containing the hierarchies if( (length(hrcfiles) != 0) & !sep_dir){ dir_name <- dirname(hrcfiles[[1]]) diff --git a/R/sp_from_4_to_3_case_0_hr.R b/R/sp_from_4_to_3_case_0_hr.R index 1041585..406a749 100644 --- a/R/sp_from_4_to_3_case_0_hr.R +++ b/R/sp_from_4_to_3_case_0_hr.R @@ -1,65 +1,17 @@ #' Transition from 4 to 3 variables by merging two non-hierarchical variables #' -#' @param dfs data.frame with 4 categorical variables (n >= 2 in the general case) -#' @param dfs_name name of the data.frame in the list provided by the user +#' @param dfs data.frame with 4 categorical variables +#' @param dfs_name name of the data.frame in the user list #' @param v1 non-hierarchical categorical variable #' @param v2 non-hierarchical categorical variable #' @param totcode named vector of totals for categorical variables -#' @param dir_name folder where to write the hrc files -#' if no folder is specified in hrcfiles +#' @param dir_name folder where to write generated hrc files #' @param sep separator used when concatenating variables #' -#' @return A list containing: -#' \itemize{ -#' \item `tabs`: named list of 3-dimensional dataframes -#' (n-1 dimensions in the general case) with nested hierarchies -#' \item `hrc`: named list of hrc specific to the variable created via merging -#' \item `alt_tot`: named list of totals -#' \item `vars`: named list of vectors representing the merged variables -#' during the two steps of dimension reduction -#' } +#' @return A list with `tabs`, `hrcs`, `alt_tot` and `vars`. #' -#' @examples -#' library(dplyr) -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), -#' SEX = c("Total", "F", "M","F1","F2","M1","M2"), -#' AGE = c("Total", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), -#' ECO = c("PIB","Households","Companies"), -#' stringsAsFactors = FALSE, -#' KEEP.OUT.ATTRS = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1:n()) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_sex <- "hrc_SEX.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("F","M")) %>% -#' sdcHierarchies::hier_add(root = "F", nodes = c("F1","F2")) %>% -#' sdcHierarchies::hier_add(root = "M", nodes = c("M1","M2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_sex, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' res1 <- from_4_to_3_case_0_hr(dfs = data, -#' dfs_name = "dfs_name", -#' v1 = "ECO",v2 = "AGE", -#' totcode = c(ACT = "Total",SEX = "Total", -#' AGE = "Total",ECO = "PIB"), -#' dir_name = "output") #' @keywords internal -#' @export +#' @noRd from_4_to_3_case_0_hr <- function( dfs, dfs_name, @@ -69,7 +21,16 @@ from_4_to_3_case_0_hr <- function( dir_name, sep = "_") { - # the different totals + # ---------------------------------------------------------------------------- + # STRATEGY (0 Hierarchical Variables / 2 Flat Variables v1 & v2): + # Merging two flat variables creates a synthetic 2-level hierarchy for Tau-Argus. + # We construct two symmetric options: + # - Option 1 (tab1): Group by v1 first (Level 1: v1 x Total_v2; Level 2: v1 x v2). + # - Option 2 (tab2): Group by v2 first (Level 1: Total_v1 x v2; Level 2: v1 x v2). + # 'write_hrc2' builds the corresponding .hrc tree files from the 2-level correspondence. + # ---------------------------------------------------------------------------- + + # Totals for each variable var1_total <- totcode[v1] var2_total <- totcode[v2] @@ -80,9 +41,9 @@ from_4_to_3_case_0_hr <- function( var1_mods_except_total <- mods1[mods1 != var1_total] var2_mods_except_total <- mods2[mods2 != var2_total] - # Traitement ad hoc des feuilles uniques (pour Julien) - # Add a fake modality if there is only one modality except total - # to avoid error with rtauargus::write_hrc2 + # EDGE CASE: If a variable has only 1 non-total modality, 'write_hrc2' fails + # because a hierarchy node requires at least 2 children. + # We append a dummy modality ("...ZZZ") to satisfy the 2-children constraint. if (length(var1_mods_except_total)==1){ var1_mods_except_total<-c(var1_mods_except_total,paste(var1_mods_except_total, "ZZZ", sep = "")) @@ -93,11 +54,10 @@ from_4_to_3_case_0_hr <- function( "ZZZ", sep = "")) } - # number of modality for each var var1_mods_n <- length(var1_mods_except_total) var2_mods_n <- length(var2_mods_except_total) - # generalization creation of the tables with merged variables + # Helper to construct merged dataframe and 2-level hierarchy correspondence table table_and_hierarchy_creator <- function(var_i_total, var_j_total, var_i_mods_except_total, @@ -115,7 +75,7 @@ from_4_to_3_case_0_hr <- function( j <- 1 } - # Construction of the levels for the correspondence table + # Level 1 (Parent): Grouping by primary variable (vi x Total_vj) tabi_lvl1 <- expand.grid( v1 = sort(rep(var_i_mods_except_total, var_j_mods_n)), v2 = var_j_total, @@ -127,7 +87,7 @@ from_4_to_3_case_0_hr <- function( tabi_lvl1$v3 <- paste(tabi_lvl1[[v_i]], tabi_lvl1[[v_j]], sep = sep) - # Creation of the level 2 hierarchy + # Level 2 (Children): Detailed cross-modalities (vi x vj) tabi_lvl2 <- expand.grid( v1 = var_i_mods_except_total, v2 = var_j_mods_except_total, @@ -138,13 +98,14 @@ from_4_to_3_case_0_hr <- function( tabi_lvl2$v3 <- paste(tabi_lvl2[[v_i]], tabi_lvl2[[v_j]], sep = sep) - # Creation of the correspondence table + # Correspondence table mapping parent (Lvl1) to child (Lvl2) tabi_corresp <- data.frame( Lvl1 = tabi_lvl1$v3, Lvl2 = tabi_lvl2$v3, stringsAsFactors = FALSE ) + # Filter data and concatenate v1 and v2 into new single column tabi <- dfs[(dfs[[vi]] != var_i_total) | (dfs[[vi]] == var_i_total & dfs[[vj]] == var_j_total), ] tabi[[paste(v1, v2, sep = sep)]]<- paste(tabi[[v1]],tabi[[v2]],sep = sep) @@ -155,7 +116,7 @@ from_4_to_3_case_0_hr <- function( return(list(tabi,tabi_corresp)) } - # We apply the function for "i=1, j=2" then for "i=2,j=1" + # Build Option 1 (Group by v1 first) res1 <- table_and_hierarchy_creator(var1_total, var2_total, var1_mods_except_total, @@ -165,6 +126,7 @@ from_4_to_3_case_0_hr <- function( tab1 <- res1[[1]] tab1_corresp <- res1[[2]] + # Build Option 2 (Group by v2 first) res2 <- table_and_hierarchy_creator(var2_total, var1_total, var2_mods_except_total, @@ -174,11 +136,7 @@ from_4_to_3_case_0_hr <- function( tab2 <- res2[[1]] tab2_corresp <- res2[[2]] - # Construction of hierarchies - # to do : - # use file.path()? - # do not write if the file already exists? - + # Write HRC hierarchy files for both options hrc_tab1 <- rtauargus::write_hrc2(tab1_corresp, file_name = paste(dir_name,"/", paste("hrc",dfs_name, diff --git a/R/sp_from_4_to_3_case_1_hr.R b/R/sp_from_4_to_3_case_1_hr.R index 917ed55..0fcce0b 100644 --- a/R/sp_from_4_to_3_case_1_hr.R +++ b/R/sp_from_4_to_3_case_1_hr.R @@ -1,69 +1,19 @@ #' Transition from 4 to 3 variables by merging a hierarchical #' and a non-hierarchical variable #' -#' @param dfs data.frame with 4 categorical variables (n >= 2 in the general case) -#' @param dfs_name name of the data.frame in the list provided by the user +#' @param dfs data.frame with 4 categorical variables +#' @param dfs_name name of the data.frame in the user list #' @param v1 non-hierarchical categorical variable #' @param v2 hierarchical categorical variable #' @param totcode named vector of totals for categorical variables -#' @param hrcfiles named vector indicating the hrc files of hierarchical variables -#' among the categorical variables of dfs -#' @param dir_name directory where to write the hrc files -#' if no folder is specified in hrcfiles +#' @param hrcfiles named vector of hrc file paths +#' @param dir_name directory where to write generated hrc files #' @param sep separator used when concatenating variables #' -#' @return A list containing: -#' \itemize{ -#' \item `tabs`: named list of 3-dimensional dataframes -#' (n-1 dimensions in the general case) with nested hierarchies -#' \item `hrc`: named list of hrc specific to the variable created by fusion -#' \item `alt_tot`: named list of totals -#' \item `vars`: named list of vectors representing the merged variables -#' during the two stages of dimension reduction -#' } +#' @return A list with `tabs`, `hrcs`, `alt_tot` and `vars`. #' -#' @examples -#' library(dplyr) -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), -#' SEX = c("Total", "F", "M","F1","F2","M1","M2"), -#' AGE = c("Total", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), -#' ECO = c("PIB","Ménages","Entreprises"), -#' stringsAsFactors = FALSE, -#' KEEP.OUT.ATTRS = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1:n()) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_sex <- "hrc_SEX.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("F","M")) %>% -#' sdcHierarchies::hier_add(root = "F", nodes = c("F1","F2")) %>% -#' sdcHierarchies::hier_add(root = "M", nodes = c("M1","M2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_sex, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' res1 <- from_4_to_3_case_1_hr(dfs = data, -#' dfs_name = "dfs_name", -#' v1 = "ECO",v2 = "SEX", -#' totcode = c(ACT = "Total",SEX = "Total", -#' AGE = "Total",ECO = "PIB"), -#' hrcfiles = c(ACT = hrc_act, SEX = hrc_sex), -#' dir_name = "output") #' @keywords internal -#' @export +#' @noRd from_4_to_3_case_1_hr <- function( dfs, dfs_name, @@ -74,37 +24,52 @@ from_4_to_3_case_1_hr <- function( dir_name, sep = "_") { - ############################# - ## Creation of code_split ## - ############################# + + # ---------------------------------------------------------------------------- + # STRATEGY (1 Hierarchical Variable v2 + 1 Flat Variable v1): + # 1. Split 'dfs' along the nodes of hierarchy 'v2'. + # 2. In each sub-table, 'v2' becomes fixed to its local total, meaning both + # 'v1' and 'v2' are now non-hierarchical (0 HR variables remaining). + # 3. Delegate each sub-table to 'from_4_to_3_case_0_hr' (merging 2 flat vars). + # 4. Aggregate and return 3D tables, generated HRC files, and alt_tot metadata. + # ---------------------------------------------------------------------------- + + hrc <- hrcfiles[[v2]] total <- totcode[[v2]] - res_sdc <- sdcHierarchies::hier_import(inp = hrc, from = "hrc", root = total) %>% - sdcHierarchies::hier_convert(as = "sdc") + # Retrieve vector of code groupings defining the hierarchy levels of v2 + codes_split <- import_hierarchy(hrc, total) - # Code split gives us the hierarchies as well as the hierarchy levels - # Allows to select a node of the tree and its direct branches - codes_split <- lapply( - res_sdc$dims, - names - ) - ########################### - # Reduction of hierarchy # - ########################### + # Pre-index physical row positions by 'v2' value to filter in integer space. + # 'sort()' guarantees that row ordering within sub-dataframes matches original 'dfs'. + row_indices <- split(seq_len(nrow(dfs)), dfs[[v2]]) - liste_df_4_var_0_hr <- lapply( - codes_split, - function(codes){ - res <- dfs %>% - filter(dfs[[v2]] %in% codes) - } - ) - # We now have data.frames with 0 hierarchical variables - # therefore we can apply the dedicated method + liste_df_4_var_0_hr <- lapply(codes_split, function(codes) { + idx <- sort(unlist(row_indices[codes], use.names = FALSE)) + dfs[idx, , drop = FALSE] + }) + + # Sparse hierarchies may produce empty sub-tables. Filter them out to avoid: + # 1. Failure in 'from_4_to_3_case_0_hr' / 'write_hrc2' on 0 rows. + # 2. Mismatch between 'codes_split' and 'liste_df_4_var_0_hr' indices. + is_empty <- vapply(liste_df_4_var_0_hr, function(df) nrow(df) == 0, logical(1)) + valid_idx <- which(!is_empty) - # Updating the arguments then call the function from_4_to_3_case_0_hr + if (length(valid_idx) == 0) { + return(list( + tabs = list(), + hrcs = list(), + alt_tot = list(), + vars = c(v1, v2) + )) + } + + liste_df_4_var_0_hr <- liste_df_4_var_0_hr[valid_idx] + codes_split <- codes_split[valid_idx] + + # Helper: Update 'totcode' for local v2 total, then delegate to 0-HR solver call_4_to_3_0_hr <- function(dfs, i){ if (i <= length(codes_split)) { @@ -125,13 +90,11 @@ from_4_to_3_case_1_hr <- function( } } - # We transform all our 4 var tables into 3 var + # Process all sub-tables and aggregate results res <- lapply(seq_along(liste_df_4_var_0_hr), function(i) { call_4_to_3_0_hr(liste_df_4_var_0_hr[[i]], i) }) - - # We change the object so that it is the same as in the other cases tabs <- unlist(lapply(res, function(x) x$tabs), recursive = FALSE) hrcs <- unlist(lapply(res, function(x) x$hrcs), recursive = FALSE) alt_tot <- unlist(lapply(res, function(x) x$alt_tot), recursive = FALSE) diff --git a/R/sp_from_4_to_3_case_2_hr.R b/R/sp_from_4_to_3_case_2_hr.R index 0b8ddcf..1c16768 100644 --- a/R/sp_from_4_to_3_case_2_hr.R +++ b/R/sp_from_4_to_3_case_2_hr.R @@ -1,69 +1,17 @@ #' Transition from 4 to 3 variables via the merging of two hierarchical variables #' -#' @param dfs data.frame with 4 categorical variables (n >= 2 in the general case) -#' @param dfs_name name of the data.frame in the list provided by the user -#' @param v1 hierarchical categorical variable -#' @param v2 hierarchical categorical variable +#' @param dfs data.frame with 4 categorical variables +#' @param dfs_name name of the data.frame in the user list +#' @param v1,v2 hierarchical categorical variables to merge #' @param totcode named vector of totals for categorical variables -#' @param hrcfiles named vector indicating the hrc files of hierarchical variables -#' among the categorical variables of dfs -#' @param dir_name folder where to write the hrc files -#' if no folder is specified in hrcfiles -#' @param sep separator used during the concatenation of variables +#' @param hrcfiles named vector of hrc file paths +#' @param dir_name directory where to write generated hrc files +#' @param sep separator used for merging variables #' -#' @return A list containing the following components: -#' \itemize{ -#' \item `tabs`: named list of 3-dimensional dataframes -#' (n-1 dimensions in the general case) with nested hierarchies -#' \item `hrcs`: named list of hrc specific to the variable -#' created via the merge -#' \item `alt_tot`: named list of totals -#' \item `vars`: named list of vectors representing the merged variables -#' during the two stages of dimension reduction -#' } +#' @return A list with `tabs`, `hrcs`, `alt_tot` and `vars`. #' -#' @examples -#' library(dplyr) -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), -#' SEX = c("Total", "F", "M","F1","F2","M1","M2"), -#' AGE = c("Total", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), -#' ECO = c("PIB","Ménages","Entreprises"), -#' stringsAsFactors = FALSE, -#' KEEP.OUT.ATTRS = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1:n()) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_sex <- "hrc_SEX.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("F","M")) %>% -#' sdcHierarchies::hier_add(root = "F", nodes = c("F1","F2")) %>% -#' sdcHierarchies::hier_add(root = "M", nodes = c("M1","M2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_sex, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' res <- from_4_to_3_case_2_hr(dfs = data, -#' dfs_name = "dfs_name", -#' v1 = "ACT",v2 = "SEX", -#' totcode = c(ACT = "Total",SEX = "Total", -#' AGE = "Total",ECO = "PIB"), -#' hrcfiles = c(ACT = hrc_act, SEX = hrc_sex), -#' dir_name = "output") #' @keywords internal -#' @export +#' @noRd from_4_to_3_case_2_hr <- function( dfs, dfs_name, @@ -73,47 +21,54 @@ from_4_to_3_case_2_hr <- function( hrcfiles, dir_name, sep = "_"){ - ############################# - ## Creating code_split ## - ############################# + + # ---------------------------------------------------------------------------- + # STRATEGY (2 Hierarchical Variables -> 1 Hierarchical Variable): + # 1. Split 'dfs' into sub-tables corresponding to each node/level of 'v1'. + # 2. Within each sub-table, 'v1' becomes fixed to its local total, leaving only + # 'v2' as hierarchical. + # 3. Delegate each sub-table to 'from_4_to_3_case_1_hr' (the 1-HR solver). + # 4. Combine generated 3D tables, HRC files, and alt_tot metadata. + # ---------------------------------------------------------------------------- + hrc1 <- hrcfiles[[v1]] total1 <- totcode[[v1]] - # Creating the table providing the hierarchy levels - res_sdc <- sdcHierarchies::hier_import(inp = hrc1, from = "hrc", root = total1) %>% - sdcHierarchies::hier_convert(as = "sdc") + # Retrieve vector of code groupings defining the hierarchy levels of v1 + codes_split_1 <- import_hierarchy(hrc1, total1) - codes_split_1 <- lapply( - res_sdc$dims, - names - ) + # Pre-index physical row positions by 'v1' value to perform lookup in integer space. + # 'sort()' guarantees that row ordering within sub-dataframes matches the original 'dfs'. + row_indices <- split(seq_len(nrow(dfs)), dfs[[v1]]) - ########################### - # Hierarchy Reduction # - ########################### + liste_df_4_var_1_hr <- lapply(codes_split_1, function(codes) { + idx <- sort(unlist(row_indices[codes], use.names = FALSE)) + dfs[idx, , drop = FALSE] + }) - # fonc_liste_df_4_var_1_non_hr <- function(codes_split,dfs){ - # lapply( - # codes_split_1, - # function(codes){ - # res <- dfs %>% - # filter(dfs[[v1]] %in% codes) - # } - # ) - # } + # Sparse hierarchies may produce empty sub-tables. Filter them out to avoid: + # 1. Failure in 'write_hrc2' (cannot construct hierarchy from 0 rows). + # 2. Mismatch between 'codes_split_1' and 'liste_df_4_var_1_hr' indices. + is_empty <- vapply(liste_df_4_var_1_hr, function(df) nrow(df) == 0, logical(1)) + valid_idx <- which(!is_empty) - liste_df_4_var_1_hr <- lapply( - codes_split_1, - function(codes){ - res <- dfs %>% - filter(dfs[[v1]] %in% codes) - } - ) + # If all tables are empty, return an empty result early + if (length(valid_idx) == 0) { + return(list( + tabs = list(), + hrcs = list(), + alt_tot = list(), + vars = c(v1, v2) + )) + } + + # Keep only non-empty tables and corresponding hierarchy nodes + liste_df_4_var_1_hr <- liste_df_4_var_1_hr[valid_idx] + codes_split_1 <- codes_split_1[valid_idx] - # We now have data.frames with 1 hierarchical variables (v1) - # therefore we can apply the dedicated method - # Update arguments then call the function from_4_to_3_case_1_hr + # Helper: Update 'totcode' and table name for sub-domain i of 'v1', + # then delegate to the 1-hierarchical variable solver ('case_1_hr'). call_4_to_3_1_hr <- function(dfs, i){ if (i <= length(codes_split_1)) { @@ -135,7 +90,7 @@ from_4_to_3_case_2_hr <- function( } } - # We transform all our 4-var tables into 3-var tables + # Process all sub-tables and aggregate results res <- lapply(seq_along(liste_df_4_var_1_hr), function(i) { call_4_to_3_1_hr(liste_df_4_var_1_hr[[i]], i) }) diff --git a/R/sp_from_5_to_3.R b/R/sp_from_5_to_3.R index 137f92b..3650a3b 100644 --- a/R/sp_from_5_to_3.R +++ b/R/sp_from_5_to_3.R @@ -1,138 +1,21 @@ -# Count the number of nodes in a hierarchical file -# Expects 2 arguments: -# - Either a named list and a variable, -# - Or an hrc (hierarchical file) and hrc_name = FALSE -nb_nodes <- function(hrcfiles, v = NULL, hrc_name = TRUE) { - # Check if the variable has an associated hrc file or if hrc_name == FALSE - if (hrc_name && !(v %in% names(hrcfiles)) || (!hrc_name && is.null(hrcfiles))) { - # Non-hierarchical variable or hrcfiles == NULL - return(1) - } - - # Take the specified file if hrc_name = TRUE, otherwise take the hrc directly provided - hrc <- ifelse(hrc_name, hrcfiles[[v]], hrcfiles) - - # Unimportant value for the following steps - total <- "This_Is_My_Total" - - # Convert to hierarchy - res_sdc <- sdcHierarchies::hier_import(inp = hrc, from = "hrc", root = total) %>% - sdcHierarchies::hier_convert(as = "sdc") - - # Return the number of nodes - return(length(res_sdc$dims)) -} - #' Function reducing from 5 to 3 categorical variables #' -#' @param dfs data.frame with 5 categorical variables (n >= 3 in the general case) +#' @param dfs data.frame with 5 categorical variables #' @param dfs_name name of the data.frame in the list provided by the user #' @param totcode named vector of totals for categorical variables -#' @param hrcfiles named vector indicating the hrc files of hierarchical variables -#' among the categorical variables of dfs -#' @param sep_dir allows forcing the writing of hrc files in a separate folder -#' defaulted to FALSE -#' @param hrc_dir folder where to write the hrc files if forcing the writing -#' in a new folder or if no folder is specified in hrcfiles -#' @param v1 allows forcing the value of the first variable to merge -#' when reducing from 5 to 4 dimensions, not specified by default (NULL) -#' @param v2 allows forcing the value of the second variable to merge -#' when reducing from 5 to 4 dimensions, not specified by default (NULL) -#' @param v3 allows forcing the value of the first variable to merge -#' when reducing from 4 to 3 dimensions, not specified by default (NULL) -#' @param v4 allows forcing the value of the second variable to merge -#' when reducing from 4 to 3 dimensions, not specified by default (NULL) +#' @param hrcfiles named vector of hrc file paths +#' @param sep_dir logical, if TRUE forces writing hrc files into hrc_dir +#' @param hrc_dir folder where to write hrc files +#' @param v1,v2 optional variables to merge when reducing from 5 to 4 dimensions +#' @param v3,v4 optional variables to merge when reducing from 4 to 3 dimensions #' @param sep separator used during concatenation of variables -#' @param maximize_nb_tabs specifies whether to prefer selecting hierarchical variables with -#' the most nodes as a priority (TRUE), which generates more tables -#' but of smaller size, or non-hierarchical variables with the least modality (FALSE) -#' to create fewer tables -#' @param verbose prints the different steps of the function to notify -#' the user of the progress, mainly for the general function gen_tabs_5_4_to_3() -#' -#' @return a list containing the following components: -#' \itemize{ -#' \item `tabs`: named list of dataframes with 3 dimensions -#' (n-2 dimensions in the general case) endowed with nested hierarchies -#' \item `hrcs5_4`: named list of hrc specific to the variable created -#' via the merge when reducing from 5 to 4 dimensions -#' \item `hrcs4_3`: named list of hrc specific to the variable created -#' via the merge when reducing from 4 to 3 dimensions -#' \item `alt_tot5_4`: named list of totals when reducing from 5 to 4 dimensions -#' \item `alt_tot4_3`: named list of totals when reducing from 4 to 3 dimensions -#' \item `vars`: named list of vectors representing the merged variables -#' during the two steps of dimension reduction -#' } +#' @param maximize_nb_tabs logical, whether to prefer selecting hierarchical variables +#' @param verbose logical, print progress steps #' -#' @examples -#' library(dplyr) -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), -#' GEO = c("Total", "GA", "GB", "GA1", "GA2", "GB1", "GB2"), -#' SEX = c("Total", "F", "M","F1","F2","M1","M2"), -#' AGE = c("Total", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), -#' ECO = c("PIB","Ménages","Entreprises"), -#' stringsAsFactors = FALSE, -#' KEEP.OUT.ATTRS = FALSE -#' ) %>% -#' as.data.frame() +#' @return A list containing `tabs`, `hrcs5_4`, `hrcs4_3`, `alt_tot5_4`, `alt_tot4_3`, and `vars`. #' -#' data <- data %>% mutate(VALUE = 1:n()) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_geo <- "hrc_GEO.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("GA","GB")) %>% -#' sdcHierarchies::hier_add(root = "GA", nodes = c("GA1","GA2")) %>% -#' sdcHierarchies::hier_add(root = "GB", nodes = c("GB1","GB2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_sex <- "hrc_SEX.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("F","M")) %>% -#' sdcHierarchies::hier_add(root = "F", nodes = c("F1","F2")) %>% -#' sdcHierarchies::hier_add(root = "M", nodes = c("M1","M2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_sex, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' # Results of the function -#' res1 <- from_5_to_3( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX="Total",AGE="Total", GEO="Total", ACT="Total", ECO = "PIB"), -#' hrcfiles = c(ACT = hrc_act, GEO = hrc_geo, SEX = hrc_sex), -#' sep_dir = TRUE, -#' hrc_dir = "output", -#' v1 = "ACT", -#' v2 = "AGE", -#' v3 = "SEX", -#' v4 = "ECO" -#' ) -#' -#' res2 <- from_5_to_3( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX="Total",AGE="Total", GEO="Total", ACT="Total", ECO = "PIB"), -#' hrcfiles = c(ACT = hrc_act, GEO = hrc_geo, SEX = hrc_sex), -#' sep_dir = TRUE, -#' hrc_dir = "output", -#' verbose = TRUE -#' ) #' @keywords internal -#' @export +#' @noRd from_5_to_3 <- function( dfs, dfs_name, @@ -148,6 +31,18 @@ from_5_to_3 <- function( maximize_nb_tabs = FALSE, verbose = FALSE) { + + # ---------------------------------------------------------------------------- + # STRATEGY (5D -> 3D Two-Step Transition): + # Step 1: Reduce 5D -> 4D using 'from_4_to_3()' on pair (v1, v2). + # This generates intermediate 4D tables and a new merged variable 'new_var'. + # Step 2: Select pair (v3, v4) for the 4D -> 3D step, ensuring a uniform choice + # across all generated 4D sub-tables. + # Step 3: Call 'from_4_to_3()' on each 4D sub-table to reach 3D tables. + # Step 4: Replicate 5D->4D metadata (HRCs and totals) to match final 3D tables, + # enabling 'restore_format()' to reconstruct the full 5D dataset. + # ---------------------------------------------------------------------------- + # Update the output folder containing the hierarchies if( (length(hrcfiles) != 0) & !sep_dir){ dir_name <- dirname(hrcfiles[[1]]) @@ -303,11 +198,10 @@ from_5_to_3 <- function( # Calculate the value of nb_nodes once for each res_5_4$hrcs[[x]] # to avoid calculating the same quantity twice - results <- lapply(1:length(res_5_4$hrcs), function(x) { - nb_node_value <- 2 * nb_nodes(res_5_4$hrcs[[x]], hrc_name = FALSE) * - nb_nodes(hrcfiles2, non_fused_var) - - # Use the calculated value for hrcs5_4 and alt_tot5_4 + results <- lapply(seq_along(res_5_4$hrcs), function(x) { + nb_node_value <- 2 * nb_nodes(res_5_4$hrcs[[x]], hrc_name = FALSE, + total = res_5_4$alt_tot[[x]]) * + nb_nodes(hrcfiles2, non_fused_var, totcode = totcode2) list( hrcs = rep(res_5_4$hrcs[[x]], nb_node_value), alt_tot = rep(res_5_4$alt_tot[[x]], nb_node_value) diff --git a/R/sp_reduce_dims.R b/R/sp_reduce_dims.R index 099b823..22df1a4 100644 --- a/R/sp_reduce_dims.R +++ b/R/sp_reduce_dims.R @@ -1,216 +1,27 @@ -#' General function that selects the appropriate separator and applies dimension reduction. +# Utility function to clear hrc cache +clear_hrc_cache <- function() { + rm(list = ls(envir = .hrc_cache, all.names = TRUE), envir = .hrc_cache) +} + +#' General function that selects the appropriate separator and applies dimension reduction #' #' @param dfs data.frame with 4 or 5 categorical variables -#' @param dfs_name name of the data.frame in the list provided by the user +#' @param dfs_name name of the data.frame #' @param totcode named vector of totals for categorical variables -#' @param hrcfiles named vector indicating the hrc files of hierarchical variables -#' among the categorical variables of dfs -#' @param sep_dir allows forcing the writing of hrc into a separate folder, -#' default is FALSE -#' @param hrc_dir folder to write hrc files if writing to a new folder is forced -#' or if no folder is specified in hrcfiles -#' @param vars_to_merge NULL or vector of variables to be merged: -#' 2 in dimension 4; 3 or 4 in dimension 5 -#' @param nb_tab_option strategy to follow for choosing variables automatically: -#' \itemize{ -#' \item `'min'`: minimize the number of tables; -#' \item `'max'`: maximize the number of tables; -#' \item `'smart'`: minimize the number of tables under the constraint -#' of their row count. -#' } -#' @param limit maximum allowed number of rows in the smart or over_split = TRUE case -#' @param over_split indicates if we split in several tables the tables bigger than -#' limit at the end of the reduction process ; it decreases the number -#' of hierarchy of these tables -#' @param vec_sep vector of candidate separators to use -#' @param verbose print the different steps of the function to inform the user -#' of progress -#' -#' @return A list containing: -#' \itemize{ -#' \item `tabs`: named list of 3-dimensional dataframes -#' with nested hierarchies -#' \item `alt_hrc`: named list of hrc specific to the variables created -#' during merging to go to dimension 3 -#' \item `alt_totcode`: named list of totals specific to the variables -#' created during merging to go to dimension 3 -#' \item `vars`: categorical variables of the output dataframes -#' \item `sep`: separator used to link the variables -#' \item `totcode`: named vector of totals for all categorical variables -#' \item `hrcfiles`: named vector of hrc for categorical variables -#' (except the merged one) -#' \item `fus_vars`: named vector of vectors representing the merged -#' variables during dimension reduction -#' } -#' -#' @importFrom sdcHierarchies hier_import hier_convert -#' @importFrom stringr str_detect -#' @importFrom dplyr select mutate filter -#' -#' @examples -#' \dontrun{ -#' library(dplyr) -#' # Examples for dimension 4 -#' -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2","A3", "B1", -#' "B2","B3","B4","C","D","E","F","G","B5"), -#' GEO = c("Total", "G1", "G2"), -#' SEX = c("Total", "F", "M"), -#' AGE = c("Total", "AGE1", "AGE2"), -#' stringsAsFactors = FALSE -#' ) %>% -#' as.data.frame() %>% -#' mutate(VALUE = 1) -#' -#' if(!dir.exists("hrc")) dir.create("hrc") -#' hrc_act <- "hrc/hrc_ACT4.hrc" -#' -#' sdcHierarchies::hier_create( -#' root = "Total", -#' nodes = c("A","B","C","D","E","F","G") -#' ) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2","A3")) %>% -#' sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2","B3","B4","B5")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table( -#' file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE -#' ) -#' -#' # Reduce dim by forcing variables to be merged -#' res1 <- reduce_dims( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), -#' hrcfiles = c(ACT = hrc_act), -#' sep_dir = TRUE, -#' vars_to_merge = c("ACT", "GEO"), -#' hrc_dir = "output", -#' verbose = TRUE -#' ) -#' -#' # Split the output in order to be under the limit & forcing variables to be merged -#' res1b <- reduce_dims( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), -#' hrcfiles = c(ACT = hrc_act), -#' sep_dir = TRUE, -#' hrc_dir = "output", -#' nb_tab_option = 'smart', -#' over_split = TRUE, -#' verbose = TRUE, -#' limit = 100 -#' ) -#' -#' # Result of the function (minimizes the number of created tables by default) -#' res2 <- reduce_dims( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), -#' hrcfiles = c(ACT = hrc_act), -#' sep_dir = TRUE, -#' hrc_dir = "output", -#' verbose = TRUE -#' ) -#' -#' # Result of the function (maximize the number of created tables) -#' res3 <- reduce_dims( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), -#' hrcfiles = c(ACT = hrc_act), -#' sep_dir = TRUE, -#' hrc_dir = "output", -#' nb_tab_option = "max", -#' verbose = TRUE -#' ) -#' -#' # Example for dimension 5 -#' -#' data <- expand.grid( -#' ACT = c("Total_A", paste0("A", seq(1,5),"_"),paste0("A1_", seq(1,7)),paste0("A2_", seq(1,9))), -#' GEO = c("Total_G", "GA", "GB", "GA1", "GA2", "GB1", "GB2","GA3","GB3","GB4"), -#' SEX = c("Total_S", "F", "M","F1","F2","M1","M2"), -#' AGE = c("Ensemble", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), -#' ECO = c("PIB","Ménages","Entreprises"), -#' stringsAsFactors = FALSE, -#' KEEP.OUT.ATTRS = FALSE -#' ) %>% -#' as.data.frame() %>% -#' mutate(VALUE = 1:n()) -#' -#' hrc_act <- "hrc/hrc_ACT5.hrc" -#' sdcHierarchies::hier_create(root = "Total_A", nodes = paste0("A", seq(1,5),"_")) %>% -#' sdcHierarchies::hier_add(root = "A1_", nodes = paste0("A1_", seq(1,7))) %>% -#' sdcHierarchies::hier_add(root = "A2_", nodes = paste0("A2_", seq(1,9))) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_age <- "hrc/hrc_AGE5.hrc" -#' sdcHierarchies::hier_create(root = "Ensemble", nodes = c("AGE1", "AGE2")) %>% -#' sdcHierarchies::hier_add(root = "AGE1", nodes = c("AGE11", "AGE12")) %>% -#' sdcHierarchies::hier_add(root = "AGE2", nodes = c("AGE21", "AGE22")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_age, row.names = FALSE, col.names = FALSE, quote = FALSE) +#' @param hrcfiles named vector of hrc file paths +#' @param sep_dir logical, if TRUE forces writing hrc into hrc_dir +#' @param hrc_dir folder to write hrc files +#' @param vars_to_merge NULL or vector of variables to be merged +#' @param nb_tab_option strategy: 'min', 'max', or 'smart' +#' @param limit maximum allowed number of rows +#' @param over_split logical, whether to split tables exceeding limit +#' @param vec_sep vector of candidate separators +#' @param verbose logical, print progress steps #' -#' hrc_geo <- "hrc/hrc_GEO5.hrc" -#' sdcHierarchies::hier_create(root = "Total_G", nodes = c("GA","GB")) %>% -#' sdcHierarchies::hier_add(root = "GA", nodes = c("GA1","GA2","GA3")) %>% -#' sdcHierarchies::hier_add(root = "GB", nodes = c("GB1","GB2","GB3","GB4")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) +#' @return A list formatted for tab_multi_manager compatibility. #' -#' # Results of the function -#' res4 <- reduce_dims( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX = "Total_S", AGE = "Ensemble", GEO = "Total_G", ACT = "Total_A", ECO = "PIB"), -#' hrcfiles = c(ACT = hrc_act, GEO = hrc_geo, AGE = hrc_age), -#' sep_dir = TRUE, -#' hrc_dir = "output", -#' verbose = TRUE -#' ) -#' -#' res5 <- reduce_dims( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX = "Total_S", AGE = "Ensemble", GEO = "Total_G", ACT = "Total_A", ECO = "PIB"), -#' hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), -#' sep_dir = TRUE, -#' hrc_dir = "output", -#' nb_tab_option = 'smart', -#' limit = 1300, -#' verbose = TRUE -#' ) -#' -#' res6 <- reduce_dims( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX = "Total_S", AGE = "Ensemble", GEO = "Total_G", ACT = "Total_A", ECO = "PIB"), -#' hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), -#' sep_dir = TRUE, -#' hrc_dir = "output", -#' nb_tab_option = 'min', -#' verbose = TRUE, -#' limit = 4470, -#' over_split = TRUE -#' ) -#' } #' @keywords internal -#' @export +#' @noRd reduce_dims <- function( dfs, dfs_name, @@ -226,10 +37,18 @@ reduce_dims <- function( verbose = FALSE ){ - # TODO OR NOT: - # to save time: parallelize the lapply for variable selection - # lapply for reducing from 4 to 3 dimensions - # in the case of dimension 5 + # ---------------------------------------------------------------------------- + # MAIN ENTRY POINT: Dimension Reduction Pipeline + # 1. Validate inputs and dimensions (4D or 5D). + # 2. Clear hierarchy cache and select a collision-free separator. + # 3. Determine merge variables (enforced by user or computed via 'var_to_merge'). + # 4. Delegate dimension reduction to 'from_4_to_3' or 'from_5_to_3'. + # 5. Format metadata via 'sp_format()' for compatibility with 'tab_multi_manager'. + # 6. Fallback safety: Split oversized tables if 'over_split = TRUE' and max_row > limit. + # ---------------------------------------------------------------------------- + + # Rq for later: using data.table may speed up the process in from_4_to_3_case_* + # for merging / filtering etc ? dfs <- as.data.frame(dfs) @@ -291,7 +110,7 @@ reduce_dims <- function( stop("verbose must be a logical value.") } - # Check if verbose is a logical value + # Check if over_split is a logical value if (!is.logical(over_split)){ stop("over_split must be a logical value.") } @@ -312,7 +131,14 @@ reduce_dims <- function( } } + # ============================================================================ + # Safety initialization to prevent the latent undefined variable bug + # in 'smart' modes or when merge variables are enforced. + # ============================================================================ + maximize_nb_tabs <- FALSE + # clear the hierarchy cache at the very beginning of the dimension reduction process + clear_hrc_cache() # Choose the separator data_var_cat <- dfs[names(dfs) %in% names(totcode)] @@ -324,7 +150,16 @@ reduce_dims <- function( v1 <- vars_to_merge[[1]] v2 <- vars_to_merge[[2]] v3 <- vars_to_merge[[3]] - v4 <- paste(v1, v2, sep = sep) + + # Predict the actual merged variable name, accounting for possible swap + # in from_4_to_3 (non-hierarchical variable always comes first). + non_hier_vars <- setdiff(names(totcode), names(hrcfiles)) + if (v1 %in% names(hrcfiles) && v2 %in% non_hier_vars) { + # v2 is non-hierarchical, v1 is hierarchical => swap + v4 <- paste(v2, v1, sep = sep) + } else { + v4 <- paste(v1, v2, sep = sep) + } } else if (length(vars_to_merge) == 4) { v1 <- vars_to_merge[[1]] @@ -371,7 +206,14 @@ reduce_dims <- function( v1 <- choice_3_var$vars[[1]] v2 <- choice_3_var$vars[[2]] v3 <- choice_3_var$vars[[3]] - v4 <- paste(v1, v2, sep = sep) + + # Correct the swap prediction (non-hierarchical must come first) + non_hier_vars <- setdiff(names(totcode), names(hrcfiles)) + if (v1 %in% names(hrcfiles) && v2 %in% non_hier_vars) { + v4 <- paste(v2, v1, sep = sep) + } else { + v4 <- paste(v1, v2, sep = sep) + } if (choice_3_var$max_row > limit){ cat(c("Warning when choosing variables: @@ -385,10 +227,10 @@ The largest table has ",choice_3_var$max_row," rows.\n")) v3 <- choice_4_var$vars[[3]] v4 <- choice_4_var$vars[[4]] - if (choice_3_var$max_row > limit){ + if (choice_4_var$max_row > limit){ cat(c("Warning when choosing variables: The limit of ",limit," cannot be achieved. -The largest table has ",choice_3_var$max_row," rows.\n")) +The largest table has ",choice_4_var$max_row," rows.\n")) } } @@ -481,6 +323,12 @@ Reducing from 4 to 3...\n") if (verbose) { cat(paste(dfs_name,"has generated",length(res$tabs),"tables in total\n\n")) + + table_sizes <- sapply(res$tabs, nrow) + cat(" Table size distribution :\n") + print(summary(table_sizes)) + cat("\n\n") + } # Put a format usable by rtauargus @@ -490,8 +338,10 @@ Reducing from 4 to 3...\n") totcode = totcode, hrcfiles = hrcfiles) - # Split too big table - if (over_split) { + max_row <- max(sapply(res$tabs, nrow)) + + # Split too big table if we didn't achieve the target value of "limit" + if (over_split && !is.null(limit) && max_row > limit) { if (verbose) { cat("Spliting...\n") @@ -535,6 +385,11 @@ Reducing from 4 to 3...\n") if (verbose) { cat(paste(dfs_name,"has generated",length(res$tabs),"tables in total\n\n")) + + table_sizes <- sapply(res$tabs, nrow) + cat(" Table size distribution :\n") + print(summary(table_sizes)) + cat("\n\n") } # The user specified a limit (smart or over_split case) @@ -552,106 +407,111 @@ The largest table has ",max_row," rows.\n\n")) return(res) } -# split tables according to var_fuse if the nb of row exceed limit -# it creates smaller tabs with a hier variable less +# Split oversized tables exceeding 'limit' by decomposing the merged hierarchical variable 'var_fus' #' @importFrom stats setNames split_tab <- function(res, var_fus, limit) { - # table to split because they are too big - - res$to_split <- sapply(res$tabs, function(x) nrow(x) > limit) - table_to_split <-names(res$to_split[res$to_split == TRUE]) - - # data to stock - - all_tot_stock <- list() - tabs2 <- list() - list_vars <- list() - list_alt_hrcs <- list() - - # loop for table to treat - - for (t in table_to_split) { - - # Create of how to split - - hrc <- res$alt_hrc[[t]][[var_fus]] - total <- res$alt_totcode[[t]][[var_fus]] - other_total <-res$alt_totcode[[t]][names(res$alt_totcode[[t]]) != (var_fus)] - - res_sdc <-sdcHierarchies::hier_import(inp = hrc, from = "hrc",root = total) %>% - sdcHierarchies::hier_convert(as = "sdc") - - codes_split <- lapply(res_sdc$dims,names) - n <- length(codes_split) - - # Names use for tauargus - new_names <- lapply(1:n, function(i) paste(t, i, sep = "_")) - - # Create tabs by filtering - tabs <- lapply(codes_split, - function(codes) { - res <- res$tabs[[t]] %>% - filter(res$tabs[[t]][[var_fus]] %in% codes) - }) - + # todo: actuellement split_tab est plutôt lent + # en effet, sur une réduction complète avec splitage d'environ 51s, + # 50s sont dûes à split_tab à la fin de la réduction + + # cela est dûe à import_hierarchy qui fail sur le cache + # car on utilise les sous totaux intermédiaire + + # il faudrait donc maj import_hierarchy pour ajouter cette fonctionnalité + # Ce n'est pas la priorité cependant : split_tab n'est pas utilisé courament + # il faut que over_split = TRUE (TRUE mpar défaut) + # + que la limite soit très basse (très rare en pratique) + # Et même dans ce cas, split_tab sera négligeable devant tab_multimanager + # Ce n'est donc pas une priorité + + # 1. Calcul rapide des tailles de tableaux et détection précoce + tab_sizes <- vapply(res$tabs, nrow, FUN.VALUE = integer(1L)) + to_split <- tab_sizes > limit + + if (!any(to_split)) return(res) + + table_to_split <- names(res$tabs)[to_split] + table_keep <- names(res$tabs)[!to_split] + n_to_split <- length(table_to_split) + + # 2. Pré-allocation des listes + tabs_split <- vector("list", n_to_split) + alt_totcode_split <- vector("list", n_to_split) + vars_split <- vector("list", n_to_split) + hrcs_split <- vector("list", n_to_split) + + # 3. Boucle sur les tableaux à découper + for (i in seq_len(n_to_split)) { + t <- table_to_split[i] + df_t <- res$tabs[[t]] + v_col <- df_t[[var_fus]] + + # Import spécifique à chaque table t (car total varie selon le sous-tableau) + hrc <- res$alt_hrc[[t]][[var_fus]] + total <- res$alt_totcode[[t]][[var_fus]] + codes_split <- import_hierarchy(hrc, total) + n <- length(codes_split) + + new_names <- paste0(t, "_", seq_len(n)) + + # OPTIMISATION MAJEURE : Filtrage C direct %in% (remplace split + unlist + sort.int) + tabs <- lapply(codes_split, function(codes) { + df_t[v_col %in% codes, , drop = FALSE] + }) names(tabs) <- new_names - tabs2 <- append(tabs2, tabs) + tabs_split[[i]] <- tabs - # alt_totcode for tauargus + # alt_totcode + alt_tot_t <- res$alt_totcode[[t]] + other_total <- alt_tot_t[names(alt_tot_t) != var_fus] + first_codes <- lapply(codes_split, `[[`, 1L) - liste_alt_tot <- setNames(lapply(1:n, function(i) { - totali <- c(codes_split[[i]][1]) - totali <- setNames(list(totali), var_fus) - totali <- c(totali, other_total) - return(totali) }), new_names) - all_tot_stock <- append(all_tot_stock, liste_alt_tot) + liste_alt_tot <- setNames(lapply(first_codes, function(code_1) { + c(setNames(list(code_1), var_fus), other_total) + }), new_names) + alt_totcode_split[[i]] <- liste_alt_tot - # list of variables for the created tables - - var <- replicate(n, list(res$vars[[1]])) - list_add <- replicate(n, list(res$vars[[1]])) - names(list_add) <- new_names - list_vars <- append(list_vars, list_add) - - # remove hierarchies from the variable we split and naming it + # vars + var_t <- res$vars[[t]] + if (is.null(var_t)) var_t <- res$vars[[1L]] + vars_split[[i]] <- setNames(rep(list(var_t), n), new_names) + # hrcs res$alt_hrc[[t]][[var_fus]] <- NULL - - if (length(res$alt_hrc[[t]]) != 0) { - - hrc_e <- list(res$alt_hrc[[t]]) + if (length(res$alt_hrc[[t]]) != 0L) { + hrc_e <- list(res$alt_hrc[[t]]) names(hrc_e) <- names(res$alt_hrc[[t]]) - - alt_hrcs <- replicate(n, hrc_e) - names(alt_hrcs) <- new_names - - list_alt_hrcs <- append(list_alt_hrcs, alt_hrcs) + hrcs_split[[i]] <- setNames(rep(list(hrc_e), n), new_names) } } - # adding the names tables we created to the already existing tables - - table <- names(res$tabs[!(names(res$tabs) %in% table_to_split)]) - tabs_tot <- append(res$tabs[table], tabs2) - alt_totcode <- append(res$alt_totcode[table],all_tot_stock) - vars <- append(res$vars[table], list_vars) - hrcs <- append( res$alt_hrc[table],list_alt_hrcs) - if (length(hrcs) == 0) { hrcs <- NULL } - - - res = list( - tabs = tabs_tot, - vars = vars, - sep = res$sep, - alt_hrc = hrcs, - totcode = res$totcode, + # 4. Fusion des résultats + tabs2 <- do.call(c, unname(tabs_split)) + all_tot_stock <- do.call(c, unname(alt_totcode_split)) + list_vars <- do.call(c, unname(vars_split)) + + has_hrcs <- any(vapply(hrcs_split, function(x) !is.null(x), logical(1L))) + list_alt_hrcs <- if (has_hrcs) do.call(c, unname(hrcs_split)) else list() + + tabs_tot <- c(res$tabs[table_keep], tabs2) + alt_totcode <- c(res$alt_totcode[table_keep], all_tot_stock) + vars <- c(res$vars[table_keep], list_vars) + hrcs <- c(res$alt_hrc[table_keep], list_alt_hrcs) + if (length(hrcs) == 0L) hrcs <- NULL + + return(list( + tabs = tabs_tot, + vars = vars, + sep = res$sep, + alt_hrc = hrcs, + totcode = res$totcode, alt_totcode = alt_totcode, - hrc = res$hrc, - fus_vars = res$fus_vars - ) - return(res) + hrc = res$hrc, + fus_vars = res$fus_vars + )) } +# Select an unused separator guaranteed not to collide with modalities or column names chose_sep <- function( data, liste_sep) @@ -664,14 +524,14 @@ chose_sep <- function( i = 0 is_in_mod = TRUE - while (i <= n_sep & is_in_mod) { + while (i < n_sep & is_in_mod) { i <- i + 1 sep <- liste_sep[i] - is_in_mod = sum(unlist(lapply(liste_mod, function(x) stringr::str_detect(x, sep)))) > 0 + is_in_mod = any(stringr::str_detect(liste_mod, stringr::fixed(sep))) } # We have a working separator! - if (i <= n_sep) { + if (!is_in_mod) { # Remove the "\" in front of the separator #sep <- stringr::str_sub(liste_sep[i], start = 2) sep <- liste_sep[i] @@ -686,78 +546,17 @@ chose_sep <- function( } } -#' Change the result of dimension reduction to be directly usable -#' in rtauargus +#' Format dimension reduction outputs for tab_multi_manager compatibility #' -#' @param res result of variable merging composed of name_non_changed_vars, a list of lists of tables, -#' a list of hierarchical files, a list of subtotals associated with these files, -#' and a list of vectors of variables or a vector of variables depending on the base size -#' of the dataframes -#' @param dfs_name the name of the entered dataframes -#' @param sep character -#' @param totcode character named vector -#' @param hrcfiles character named vector +#' @param res result from dimension reduction +#' @param dfs_name name of input dataframes +#' @param sep separator string +#' @param totcode named vector of totals +#' @param hrcfiles named vector of hrc file paths #' -#' @return A list containing: -#' \itemize{ -#' \item `tabs`: named list of 3-dimensional dataframes -#' with nested hierarchies -#' \item `alt_hrc`: named list of hrc specific to the variables -#' created during merging to go to dimension 3 -#' \item `alt_totcode`: named list of totals specific to the variables -#' created during merging to go to dimension 3 -#' \item `vars`: categorical variables of the output dataframes -#' \item `sep`: separator used to link the variables -#' \item `totcode`: named vector of totals for all categorical variables -#' \item `hrcfiles`: named vector of hrc for categorical variables -#' (except the merged one) -#' \item `fus_vars`: named vector of vectors representing the merged -#' variables during dimension reduction -#' } -#' @importFrom stats setNames -#' @examples -#' library(dplyr) -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), -#' GEO = c("Total", "G1", "G2"), -#' SEX = c("Total", "F", "M"), -#' AGE = c("Total", "AGE1", "AGE2"), -#' stringsAsFactors = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' -#' sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) %>% -#' sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' # Results of the function -#' res1 <- from_4_to_3( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), -#' hrcfiles = c(ACT = hrc_act), -#' sep_dir = TRUE, -#' hrc_dir = "output" -#' ) -#' -#' res <- sp_format(res1, -#' dfs_name = "tab", -#' sep = "_", -#' totcode = c(SEX="Total",AGE="Total", -#' GEO="Total", ACT="Total"), -#' hrcfiles = c(ACT = hrc_act) -#' ) +#' @return Formatted list compatible with tab_multi_manager. #' @keywords internal -#' @export +#' @noRd sp_format <- function( res, dfs_name, @@ -773,7 +572,8 @@ sp_format <- function( } } -# Format for tables with 4 variables +# Format outputs for 4D -> 3D transition +#' @importFrom stats setNames format4 <- function(res, dfs_name, sep, totcode, hrcfiles) { # Data @@ -840,7 +640,7 @@ format4 <- function(res, dfs_name, sep, totcode, hrcfiles) { ) } -# Format for tables with 5 variables +# Format outputs for 5D -> 3D transition #' @importFrom stats setNames format5 <- function(res, dfs_name, sep, totcode, hrcfiles) { if (is.list(res$vars)) { diff --git a/R/sp_restore_format.R b/R/sp_restore_format.R index fd028ad..d742df9 100644 --- a/R/sp_restore_format.R +++ b/R/sp_restore_format.R @@ -1,116 +1,28 @@ #' Function to reverse the process of dimension reduction -#' @param masq a list of data.frames on which the secret has been applied -#' @param res the result of the dimension reduction function (to retrieve -#' the merged variables) and the separator (sep). #' -#' @return the original dataframe with 4 or 5 dimensions +#' @param masq a list of data.frames on which secret/suppression has been applied +#' @param res result of dimension reduction (contains merged variables and separator) #' -#' @examples -#' # Examples with dimension 4 -#' library(dplyr) -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2","A3", "B1", "B2","B3","B4","C", -#' "name_non_changed_vars","E","F","G","B5"), -#' GEO = c("Total", "G1", "G2"), -#' SEX = c("Total", "F", "M"), -#' AGE = c("Total", "AGE1", "AGE2"), -#' stringsAsFactors = FALSE -#' ) %>% -#' as.data.frame() +#' @return The original data.frame restored to 4 or 5 dimensions. #' -#' data <- data %>% mutate(VALUE = 1) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' -#' sdcHierarchies::hier_create( -#' root = "Total", -#' nodes = c("A","B","C","name_non_changed_vars","E","F","G") -#' ) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2","A3")) %>% -#' sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2","B3","B4","B5")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' # Result of the function by forcing some variables to be merged -#' res_red_dim <- reduce_dims( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX="Total",AGE="Total", GEO="Total", ACT="Total"), -#' hrcfiles = c(ACT = hrc_act), -#' sep_dir = TRUE, -#' hrc_dir = "output", -#' vars_to_merge = c("ACT","GEO") -#' ) -#' -#' res1 <- restore_format(masq = res_red_dim$tabs, res = res_red_dim) -#' dim(setdiff(res1,data))[1] == 0 -#' -#' # return TRUE -#' # We have exactly the sames cases in the datatable after splitting and unsplitting data -#' -#' # Exemple dimension 5 -#' -#' data <- expand.grid( -#' ACT = c("Total_A", paste0("A", seq(1,5),"_"),paste0("A1_", seq(1,7)), -#' paste0("A2_", seq(1,9))), -#' GEO = c("Total_G", "GA", "GB", "GA1", "GA2", "GB1", "GB2","GA3","GB3","GB4"), -#' SEX = c("Total_S", "F", "M","F1","F2","M1","M2"), -#' AGE = c("Ensemble", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), -#' ECO = c("PIB","Ménages","Entreprises"), -#' stringsAsFactors = FALSE, -#' KEEP.OUT.ATTRS = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1:n()) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' sdcHierarchies::hier_create(root = "Total_A", nodes = paste0("A", seq(1,5),"_")) %>% -#' sdcHierarchies::hier_add(root = "A1_", nodes = paste0("A1_", seq(1,7))) %>% -#' sdcHierarchies::hier_add(root = "A2_", nodes = paste0("A2_", seq(1,9))) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_geo <- "hrc_GEO.hrc" -#' sdcHierarchies::hier_create(root = "Total_G", nodes = c("GA","GB")) %>% -#' sdcHierarchies::hier_add(root = "GA", nodes = c("GA1","GA2","GA3")) %>% -#' sdcHierarchies::hier_add(root = "GB", nodes = c("GB1","GB2","GB3","GB4")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' # function's result -#' -#' res_red_dim <- reduce_dims( -#' dfs = data, -#' dfs_name = "tab", -#' totcode = c(SEX="Total_S",AGE="Ensemble", GEO="Total_G", ACT="Total_A", ECO = "PIB"), -#' hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), -#' sep_dir = TRUE, -#' hrc_dir = "output" -#' ) -#' -#' res2 <- restore_format(masq = res_red_dim$tabs, res = res_red_dim) #' @keywords internal -#' @export +#' @noRd restore_format <- function(masq, res) { - sep <- res$sep - sep_regex <- gsub("([+])", "\\\\\\1", sep) - + # ---------------------------------------------------------------------------- + # STRATEGY (Reverse Dimension Reduction): + # 1. Recombine all processed sub-tables 'masq' into a single dataframe using + # bind_rows() and deduplicate identical records via distinct(). + # 2. Check reduction metadata: + # - 4D case: Call 'separer4_3()' once to split composite var into (v1, v2). + # - 5D case (2 pairs): Call 'separer4_3()' twice (v1_v2 then v3_v4). + # - 5D case (1 triplet): Call 'separer5_3()' once to split into (v1, v2, v3). + # ---------------------------------------------------------------------------- + sep <- res$sep - # Unique values from 'masq' (a list) are concatenated into a data frame - - masq_liste_empilee <- unique(do.call("rbind", unname(masq))) + # Combine processed sub-tables and keep unique records + masq_liste_empilee <- dplyr::distinct(dplyr::bind_rows(masq)) if (is.character(res$fus_vars)) { # Case with 4 categorical variables @@ -121,7 +33,7 @@ restore_format <- function(masq, res) { v1_v2 <- paste(v1, v2, sep = sep) - result <- separer4_3(masq_liste_empilee, v1, v2,v1_v2, sep_regex) + result <- separer4_3(masq_liste_empilee, v1, v2,v1_v2, sep) return(result) } @@ -138,9 +50,9 @@ restore_format <- function(masq, res) { # Case of fusion between 3 different variables v3_v4 <- paste(v3, v4, sep = sep) # Split based on 'v1', 'v2', and 'v1_v2' using 'separer4_3' function - split1 <- separer4_3(masq_liste_empilee, v1, v2, v1_v2, sep_regex) + split1 <- separer4_3(masq_liste_empilee, v1, v2, v1_v2, sep) # Further split based on 'v3', 'v4', and 'v3_v4' - result <- separer4_3(split1, v3, v4, v3_v4, sep_regex) + result <- separer4_3(split1, v3, v4, v3_v4, sep) } else { # Case of fusion with an already fused variable @@ -148,10 +60,10 @@ restore_format <- function(masq, res) { if(v1_v2 == v3){ # Split based on 'v1', 'v2', and 'v4' using 'separer5_3' function - result<-separer5_3(masq_liste_empilee, v1,v2, v4, v3_v4, sep_regex) + result<-separer5_3(masq_liste_empilee, v1,v2, v4, v3_v4, sep) }else{ # Split based on 'v1', 'v2', and 'v3' using 'separer5_3' function - result<-separer5_3(masq_liste_empilee, v1,v2,v3, v3_v4, sep_regex) + result<-separer5_3(masq_liste_empilee, v1,v2,v3, v3_v4, sep) } @@ -162,15 +74,21 @@ restore_format <- function(masq, res) { -# Function for splitting the merged variable v1_v2_v3 into v1, v2, and v3 -separer5_3 <- function(df, v1, v2, v3,v3_v4, sep_regex) { - splits <- strsplit(df[[v3_v4]], split = sep_regex) - df[[v3]] <- sapply(splits, `[`, 1) - df[[v1]] <- sapply(splits, `[`, 2) - df[[v2]] <- sapply(splits, `[`, 3) +# Extract 3 original variables (v3, v1, v2) from composite variable 'v3_v4' +separer5_3 <- function(df, v1, v2, v3,v3_v4, sep) { + + # 'fixed = TRUE' bypasses the regex engine for fast C-level string splitting + splits <- strsplit(df[[v3_v4]], split = sep, fixed = TRUE) + + # Unlist splits directly into a 3-column C matrix (bypasses R sapply loop overhead) + mat <- matrix(unlist(splits, use.names = FALSE), ncol = 3, byrow = TRUE) + + df[[v3]] <- mat[, 1] + df[[v1]] <- mat[, 2] + df[[v2]] <- mat[, 3] df[[v3_v4]] <- NULL - # Réorganiser les colonnes + # Reorder columns to place restored variables first new_order <- c(v3, v1, v2, setdiff(names(df), c(v3, v1, v2))) df <- df[, new_order] @@ -178,14 +96,20 @@ separer5_3 <- function(df, v1, v2, v3,v3_v4, sep_regex) { } -# Function for splitting the merged variable v1_v2 into v1 and v2 -separer4_3 <- function(df, v1, v2, v1_v2, sep_regex) { - splits <- strsplit(df[[v1_v2]], split = sep_regex) - df[[v1]] <- sapply(splits, `[`, 1) - df[[v2]] <- sapply(splits, `[`, 2) +# Extract 2 original variables (v1, v2) from composite variable 'v1_v2' +separer4_3 <- function(df, v1, v2, v1_v2, sep) { + # splits <- strsplit(df[[v1_v2]], split = sep_regex) + + splits <- strsplit(df[[v1_v2]], split = sep, fixed = TRUE) + + # Unlist splits directly into a 2-column C matrix (bypasses R sapply loop overhead) + mat <- matrix(unlist(splits, use.names = FALSE), ncol = 2, byrow = TRUE) + + df[[v1]] <- mat[, 1] + df[[v2]] <- mat[, 2] df[[v1_v2]] <- NULL - # Réorganiser les colonnes + # Reorder columns to place restored variables first new_order <- c(v1, v2, setdiff(names(df), c(v1, v2))) df <- df[, new_order] df diff --git a/R/sp_tab_rtauargus.R b/R/sp_tab_rtauargus.R index 0ba3c78..4cb37ae 100644 --- a/R/sp_tab_rtauargus.R +++ b/R/sp_tab_rtauargus.R @@ -1,3 +1,41 @@ +#' Automatically computes an intermediate size limit for table reduction +#' +#' @description +#' Uses `explore_reduce_dims()` to find the median configuration in terms of +#' generated tables, and returns the minimum `max_size` among the configurations +#' having that number of tables. +#' +#' @details +#' The current implementation uses a default heuristic designed to strike a simple +#' balance between the number of generated tables and their maximum size. +#' This selection logic is subject to future refinements +#' +#' @inheritParams explore_reduce_dims +#' +#' @return An integer representing the computed row limit. +#' +#' @keywords internal +#' @noRd +auto_limit <- function(dfs, totcode, hrcfiles = NULL) { + + # 1. Explore candidate configurations for table reduction + exp_df <- explore_reduce_dims(dfs = dfs, totcode = totcode, hrcfiles = hrcfiles) + + if (nrow(exp_df) == 0) { + stop("`explore_reduce_dims` returned an empty data frame.") + } + + # 2. Pick the median configuration index in terms of generated table count + mid_idx <- ceiling(nrow(exp_df) / 2) + target_nb_tab <- exp_df$nb_tab[mid_idx] + + # 3. Filter candidates matching this table count and select the minimum max_size + sub_df <- exp_df[exp_df$nb_tab == target_nb_tab, ] + calculated_limit <- min(sub_df$max_size) + + return(as.integer(calculated_limit)) +} + #' Call Tau-Argus to protect a 4 or 5 dimensions table by splitting it #' in several 3 dimensions table. #' @@ -6,18 +44,32 @@ #' #' @inheritParams tab_rtauargus #' -#' @param limit numeric, used to choose which variable to merge (if nb_tab_option = 'smart') -#' and split table with a number of row above this limit in order to avoid -#' tauargus failures -#' @param nb_tab_option strategy to follow for choosing variables automatically: -#' \itemize{ -#' \item `'min'`: minimize the number of tables; -#' \item `'max'`: maximize the number of tables; -#' \item `'smart'`: minimize the number of tables under the constraint -#' of their row count. -#' } +#' @param limit numeric or NULL, default `NULL`. Used to choose which variable +#' to merge (if nb_tab_option = 'smart') and split table with a number of row +#' above this limit in order to avoid tauargus failures. +#' If `NULL`, an automatic limit is calculated using \code{auto_limit}. +#' @param nb_tab_option `r lifecycle::badge("superseded")` character, default `"smart"`. +#' Strategy used for dimension reduction. **Note:** Only `"smart"` is recommended. +#' Historical options (`"min"` and `"max"`) are legacy heuristics kept for backward +#' compatibility: +#' \itemize{ +#' \item `'smart'` *(default & recommended)*: minimizes the number of tables under +#' the constraint of their row count; +#' \item `'min'` *(legacy)*: minimizes the number of tables; +#' \item `'max'` *(legacy)*: maximizes the number of tables. +#' } #' @param dfs_name name used to write hrc files when reducing dims -#' @param ... additional parameters#' +#' @param sort_table character or NULL, default `NULL`. +#' *(Exploratory / Experimental)* Used to assess the impact of table ordering on +#' secondary secret selection when cells are shared across sub-tables. +#' If `"ASC"`, sub-tables are processed in ascending order of their total cell value +#' (smallest first); if `"DESC"`, in descending order. +#' `NULL` preserves the default order produced by `reduce_dims()`. +#' *Note: this parameter is experimental and may be modified or removed in future versions.* +#' @param compact_verbose logical, default `FALSE`. +#' Whether to display a compact single-line summary for dimension reduction +#' instead of detailed progress logs (recommended for multi-table workflows). +#' @param ... additional parameters #' #' @return The original tabular is returned with additional variables indicating #' whether or not the cell has to be masked according to Tau-Argus @@ -68,6 +120,8 @@ #' ) #' } #' @importFrom stats setNames +#' @importFrom dplyr select filter mutate +#' @importFrom sdcHierarchies hier_import hier_convert #' @export tab_rtauargus4 <- function( tabular, @@ -85,11 +139,17 @@ tab_rtauargus4 <- function( suppress = "MOD(1,5,1,0,0)", safety_rules = paste0("MAN(",ip,")"), nb_tab_option = "smart", - limit = 14700L, + limit = NULL, dfs_name = 'tab', + sort_table = NULL, + compact_verbose = FALSE, ... ){ + if (!is.null(sort_table) && !sort_table %in% c("ASC", "DESC")) { + stop('`sort_table` must be NULL, "ASC" or "DESC".') + } + .dots = list(...) hrc_path <- file.path(dir_name, "hrc") @@ -103,7 +163,47 @@ tab_rtauargus4 <- function( # Reduce dims for 4 or 5 dimensions table if (length(explanatory_vars) %in% c(4, 5)) { - cat("\nReducing dims...\n",dfs_name,"\n\n") + # Clean name for display (e.g. 'd1', 'd2' or 'tab') + name_clean <- if (!is.null(files_name) && files_name != "targus_file") files_name else dfs_name + + # Prefix sub-tables with parent name when called from tab_multi_manager (e.g. 'd1_1', 'd2_1') + name_display <- if (!is.null(files_name) && files_name != "targus_file") files_name else dfs_name + if (!is.null(files_name) && files_name != "targus_file" && dfs_name == 'tab') { + dfs_name <- paste0(files_name, "_") + } + + # Calcul automatique de la limite si limit = NULL + if (is.null(limit) && nb_tab_option == "smart") { + if (isTRUE(.dots[["verbose"]])) { + cat("`limit` est NULL, calcul automatique en cours via `auto_limit()`...\n") + } + limit <- auto_limit(dfs = tabular, totcode = totcode, hrcfiles = hrc) + + if (isTRUE(.dots[["verbose"]])) { + cat("Limite calcul\u00e9e automatiquement :", limit, "\n\n") # \u00e9 pour & + } + } + + if (!compact_verbose) { + cat("\nReducing dims...\n", name_clean, "\n\n") + } + + # Standardize secret column to 'is_secret_prim'. + # Note: Standalone tab_rtauargus() / tab_rtauargus4() work as intended, but under + # tab_multi_manager(split_tab = TRUE), outer iterations >= 2 pass dynamic names + # (e.g. 'is_secret_1'). This alias prevents: + # 1) Name collisions in inner tab_multi_manager (which overwrite cells with NAs). + # 2) Missing column errors in summarize_secret(), which expects 'is_secret_prim'. + tabular$is_secret_prim <- tabular[[secret_var]] + + # Default to verbose = TRUE for standalone detailed logging when compact_verbose is FALSE + verbose_reduce <- if (compact_verbose) { + FALSE + } else if (!is.null(.dots[["verbose"]])) { + isTRUE(.dots[["verbose"]]) + } else { + TRUE + } list_tables <- reduce_dims( dfs = tabular, @@ -113,11 +213,35 @@ tab_rtauargus4 <- function( hrc_dir = hrc_path, nb_tab_option = nb_tab_option, limit = limit, - over_split = TRUE, - verbose = TRUE, # to generalize later + over_split = FALSE, + verbose = verbose_reduce, sep_dir = TRUE ) + # Print a single clean summary line when compact_verbose is TRUE + if (compact_verbose) { + tab_sizes <- sapply(list_tables$tabs, nrow) + cat(sprintf("\n \u21b3 [%s] Split %dD -> 3D : %d sub-tables (%d to %d rows)\n", + name_clean, length(explanatory_vars), length(list_tables$tabs), + min(tab_sizes), max(tab_sizes))) + } + + # Tri des sous-tables par somme de la colonne value + if (!is.null(sort_table)) { + totals <- sapply(list_tables$tabs, function(t) sum(t[[value]], na.rm = TRUE)) + ord <- if (sort_table == "ASC") order(totals) else order(totals, decreasing = TRUE) + + list_tables$tabs <- list_tables$tabs[ord] + list_tables$vars <- list_tables$vars[ord] + list_tables$alt_hrc <- list_tables$alt_hrc[ord] + list_tables$alt_totcode <- list_tables$alt_totcode[ord] + + if (isTRUE(.dots[["verbose"]])){ + cat("Ordre de traitement des tables (sort_table =", sort_table, ") :\n") + print(data.frame(table = names(list_tables$tabs), total_value = totals[ord])) + } + } + params_multi <- formals(fun = "tab_multi_manager") params_multi <- params_multi[1:(length(params_multi)-1)] call <- sys.call(); call[[1]] <- as.name('list') @@ -134,14 +258,30 @@ tab_rtauargus4 <- function( params_multi$alt_hrc = list_tables$alt_hrc params_multi$alt_totcode = list_tables$alt_totcode + # Force inner tab_multi_manager to use 'is_secret_prim' as its initial secret + params_multi$secret_var <- "is_secret_prim" + masq_list <- do.call("tab_multi_manager", params_multi) + # Clean line break after inner multi-table progress output + if (compact_verbose) { + cat("\n") + } result <- restore_format(masq_list, list_tables) + # Restore input secret_var name so tab_rtauargus2() can compute cell Status + result[[secret_var]] <- result$is_secret_prim + + # Clean up temporary alias to prevent column pollution and merge duplication + if (secret_var != "is_secret_prim") { + result$is_secret_prim <- NULL + } + return(result) } else { stop("Do not use table with more than 5 dimensions. Split_tab = TRUE is not compatible with these large tables.") } } + diff --git a/R/sp_var_to_merge.R b/R/sp_var_to_merge.R index 62daf78..4daa266 100644 --- a/R/sp_var_to_merge.R +++ b/R/sp_var_to_merge.R @@ -1,115 +1,65 @@ -#' General function to choose variables to merge, -#' limiting the number of generated tables while ensuring not to generate -#' tables that are too large. -#' -#' @param dfs data.frame -#' @param totcode named vector of totals for categorical variables -#' @param hrcfiles named vector of hrc files for categorical variables -#' @param nb_var number of variables to merge -#' @param nb_tab_option strategy to follow for choosing variables automatically: -#' \itemize{ -#' \item `'min'`: minimize the number of tables; -#' \item `'max'`: maximize the number of tables; -#' \item `'smart'`: minimize the number of tables under the constraint of their row count. -#' } -#' @param limit maximum allowed row count in the 'smart' case -#' -#' @return A list of vectors representing the chosen variables to merge -#' -#' @examples -#' library(dplyr) -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), -#' GEO = c("Total", "GA", "GB", "GA1", "GA2"), -#' SEX = c("Total", "F", "M"), -#' AGE = c("Total", "AGE1", "AGE2"), -#' stringsAsFactors = FALSE, -#' KEEP.OUT.ATTRS = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1:n()) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) %>% -#' sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_geo <- "hrc_GEO.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("GA","GB")) %>% -#' sdcHierarchies::hier_add(root = "GA", nodes = c("GA1","GA2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' totcode <- c(SEX="Total",AGE="Total", GEO="Total", ACT="Total") -#' -#' hrcfiles <- c(ACT = hrc_act, GEO = hrc_geo) -#' -#' # Consistent: choose two hierarchical variables -#' res1 <- var_to_merge(dfs = data, -#' totcode = totcode, -#' hrcfiles = hrcfiles, -#' nb_var = 2, -#' nb_tab_option = 'max') -#' res1 -#' max(unlist(length_tabs(dfs = data, -#' hrcfiles = hrcfiles, -#' totcode = totcode, -#' v1 = res1$vars[1], v2 = res1$vars[2]))) +# Cache environment to store imported sdcHierarchies levels and prevent redundant disk parsing. +.hrc_cache <- new.env(parent = emptyenv()) + +#' Count the number of nodes in a hierarchical file #' -#' # Consistent: choose two non-hierarchical variables -#' res2 <- var_to_merge(dfs = data, -#' totcode = totcode, -#' hrcfiles = hrcfiles, -#' nb_var = 2, -#' nb_tab_option = 'min') -#' res2 -#' max(unlist(length_tabs(dfs = data, -#' hrcfiles = hrcfiles, -#' totcode = totcode, -#' v1 = res2$vars[1], v2 = res2$vars[2]))) +#' @param hrcfiles named vector of hrc files +#' @param v variable name +#' @param hrc_name logical, if TRUE v is a name in hrcfiles +#' @param totcode named vector of totals +#' @param total total code if totcode is NULL #' -#' res3 <- var_to_merge(dfs = data, -#' totcode = totcode, -#' hrcfiles = hrcfiles, -#' limit = 200, -#' nb_var = 2, -#' nb_tab_option = 'smart') -#' res3 -#' max(unlist(length_tabs(dfs = data, -#' hrcfiles = hrcfiles, -#' totcode = totcode, -#' v1 = res3$vars[1], v2 = res3$vars[2]))) +#' @return integer number of nodes +#' @keywords internal +#' @noRd +nb_nodes <- function(hrcfiles = NULL, v = NULL, hrc_name = TRUE, + totcode = NULL, total = NULL) { + if (hrc_name && !is.null(hrcfiles) && v %in% names(hrcfiles)) { + # Fallback to "Total" if totcode is NULL or if v is not present in totcode + total_val <- if (!is.null(totcode) && v %in% names(totcode)) totcode[[v]] else "Total" + return(length(import_hierarchy(hrcfiles[[v]], total_val))) + } else if (!hrc_name && !is.null(hrcfiles)) { + # Fallback to "Total" if total is NULL + total_val <- if (!is.null(total)) total else "Total" + return(length(import_hierarchy(hrcfiles, total_val))) + } else { + return(1) + } +} + +#' Import a hierarchy and cache its levels #' -#' # Obtains 147, which is well below 200 +#' @param hrcfile character path to a .hrc file +#' @param total character, the root total for the hierarchy #' -#' res4 <- var_to_merge(dfs = data, -#' totcode = totcode, -#' hrcfiles = hrcfiles, -#' limit = 5, -#' nb_var = 2, -#' nb_tab_option = 'smart') -#' res4 -#' max(unlist(length_tabs(dfs = data, -#' hrcfiles = hrcfiles, -#' totcode = totcode, -#' v1 = res4$vars[1], v2 = res4$vars[2]))) +#' @return A list of character vectors representing hierarchy nodes. +#' @keywords internal +#' @noRd +import_hierarchy <- function(hrcfile, total) { + # Cache key combines filepath and root total code + cache_key <- paste0(hrcfile, "|||", total) + if (exists(cache_key, envir = .hrc_cache)) { + return(get(cache_key, envir = .hrc_cache)) + } + res_sdc <- sdcHierarchies::hier_import(inp = hrcfile, from = "hrc", root = total) %>% + sdcHierarchies::hier_convert(as = "sdc") + levels <- lapply(res_sdc$dims, names) + assign(cache_key, levels, envir = .hrc_cache) + return(levels) +} + +#' General function to choose variables to merge #' -#' # Receives a warning: unable to reach the announced value -#' # There are 63 rows (equivalent to the max -#' # -> this is what reduces the table size) -#' # And the warning announces 63 rows, which is consistent with the output +#' @param dfs data.frame +#' @param totcode named vector of totals for categorical variables +#' @param hrcfiles named vector of hrc files +#' @param nb_var number of variables to merge +#' @param nb_tab_option strategy: 'min', 'max', or 'smart' +#' @param limit maximum allowed row count in the 'smart' case #' +#' @return A list with `vars`, `max_row`, and `nb_tab`. #' @keywords internal -#' @export +#' @noRd var_to_merge <- function( dfs, totcode, @@ -118,36 +68,54 @@ var_to_merge <- function( nb_tab_option = "min", limit = 150) { - # Case of 2 pairs in dimension 5 + + # Precompute unique values across all categorical columns once (O(N) cost) + # to avoid repeating expensive unique() calls inside evaluation loops. + unique_mods <- lapply(dfs[names(totcode)], unique) + + # Generate candidate combinations based on target dimension reduction if (nb_var == 4){ - result_comb <- generate_two_pairs(totcode) + result_comb <- generate_two_pairs(totcode) # 5D -> 3D (2 pairs merged) # Case of a triplet in dimension 5 } else if (nb_var == 3){ - result_comb <- generate_a_triplet(totcode) + result_comb <- generate_a_triplet(totcode) # 5D -> 3D (1 triplet merged) # Case of dimension 4 } else { - result_comb <- generate_a_pair(totcode) + result_comb <- generate_a_pair(totcode) # 4D -> 3D (1 pair merged) } return(var_to_merge_fragment(dfs = dfs, - result_comb = result_comb, - totcode = totcode, - hrcfiles = hrcfiles, - limit = limit, - nb_tab_option = nb_tab_option)) + result_comb = result_comb, + totcode = totcode, + hrcfiles = hrcfiles, + limit = limit, + nb_tab_option = nb_tab_option, + unique_mods = unique_mods) + ) } +#' Evaluate combinations and select optimal variable merge strategy +#' +#' @keywords internal +#' @noRd var_to_merge_fragment <- function( dfs, result_comb, totcode, hrcfiles = NULL, limit = 150, - nb_tab_option = "smart") + nb_tab_option = "smart", + unique_mods = NULL) { - # Calculate the number of tables and maximum rows for each combination of variables + + # Fallback initialization for unique_mods if called directly without precomputed list. + if (is.null(unique_mods)) { + unique_mods <- lapply(dfs[names(totcode)], unique) + } + + # Simulate generated table sizes and counts for each candidate combination res_func <- lapply(result_comb, function(x) length_tabs( dfs = dfs, v1 = x[1], @@ -155,7 +123,8 @@ var_to_merge_fragment <- function( v3 = x[3], v4 = x[4], totcode = totcode, - hrcfiles = hrcfiles)) + hrcfiles = hrcfiles, + unique_mods = unique_mods)) # Get the maximum rows and number of created tables res_max <- sapply(res_func, function(x) max(unlist(x))) @@ -167,8 +136,9 @@ var_to_merge_fragment <- function( # Save the row number by adding a column df$original_index <- seq(nrow(df)) - # Case: minimize the number of tables + # Selection logic according to 'nb_tab_option' if (nb_tab_option == "min"){ + # Minimize number of tables, break ties with smallest max table size min_nb_tab <- min(df$res_len) filtered_df <- df[df$res_len == min_nb_tab, ] @@ -182,8 +152,8 @@ var_to_merge_fragment <- function( nb_tab = filtered_df$res_len[min_index]) ) - # Case: maximize the number of tables } else if (nb_tab_option == "max"){ + # Maximize number of tables, break ties with smallest max table size max_nb_tab <- max(df$res_len) filtered_df <- df[df$res_len == max_nb_tab, ] @@ -197,8 +167,9 @@ var_to_merge_fragment <- function( nb_tab = filtered_df$res_len[min_index]) ) - # Case: 'smart' - maximize under the constraint of the size limit } else { + # 'smart' option: Minimize table count under constraint max_row < limit + # Filter based on the maximum rows condition filtered_df <- df[df$res_max < limit, ] @@ -216,21 +187,13 @@ var_to_merge_fragment <- function( ) } else { - # Return the result with the fewest tables among those - # with the shortest tables - min_res_max <- min(df$res_max) - - # Silence warning since it is only display at the end... - # warning(c(" - # The limit of ",limit," cannot be achieved. - # The largest table has ",min_res_max," rows.")) + # Fallback: If no combination is under limit, pick candidate with smallest max size + min_res_max <- min(df$res_max) filtered_df <- df[df$res_max == min_res_max, ] # Get the index of the filtered table min_index <- which.min(filtered_df$res_len) - - # Print the original index i <- filtered_df$original_index[min_index] return(list(vars = result_comb[[i]], @@ -241,6 +204,9 @@ var_to_merge_fragment <- function( } } +#' Generate all candidate pairs of variables +#' @keywords internal +#' @noRd #' @importFrom utils combn generate_a_pair <- function(totcode) { # Retrieve the categorical variables from the dataframe @@ -255,6 +221,9 @@ generate_a_pair <- function(totcode) { return(result) } +#' Generate candidate disjoint double pairs of variables +#' @keywords internal +#' @noRd #' @importFrom utils combn generate_two_pairs <- function(totcode) { # Retrieve the categorical variables from the dataframe @@ -299,6 +268,9 @@ generate_two_pairs <- function(totcode) { return(result) } +#' Generate all candidate triplets of variables +#' @keywords internal +#' @noRd #' @importFrom utils combn generate_a_triplet <- function(totcode) { # Retrieve the categorical variables from the dataframe @@ -313,111 +285,18 @@ generate_a_triplet <- function(totcode) { return(result) } -#' Calculation of the table sizes generated a priori during the reduction of dimension -#' from 4 or 5 dimensions to 3 dimensions -#' -#' @param dfs a data.frame -#' -#' Variable in the 5->4 or 4->3 step -#' @param v1 the first merged variable -#' @param v2 the second merged variable -#' -#' Variable in the case of 4->3 passage in the 4->3 process -#' do not specify v1_v2 if three variables are merged into one -#' @param v3 the third original variable to be merged -#' @param v4 the fourth original variable to be merged -#' @param totcode character named vector -#' @param hrcfiles named vector of hrc files related to the variables -#' -#' @return a list of the lengths of the tables created during the dimension reduction -#' -#' @examples -#' # Dimension 4 -#' library(dplyr) -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2","A3", "B1", "B2","B3","B4","C", -#' "name_non_changed_vars","E","F","G","B5"), -#' GEO = c("Total", "G1", "G2"), -#' SEX = c("Total", "F", "M"), -#' AGE = c("Total", "AGE1", "AGE2"), -#' stringsAsFactors = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1) -#' -#' -#' hrc_act <- "hrc_ACT.hrc" -#' -#' sdcHierarchies::hier_create( -#' root = "Total", -#' nodes = c("A","B","C","name_non_changed_vars","E","F","G") -#' ) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2","A3")) %>% -#' sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2","B3","B4","B5")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' # Function results -#' -#' res1 <- length_tabs(dfs = data, -#' hrcfiles = c(ACT = hrc_act), -#' totcode = c(SEX="Total",AGE="Total", GEO="Total", ACT="Total"), -#' v1 = "ACT", -#' v2 = "GEO") -#' -#' # Dimension 5 -#' data <- expand.grid( -#' ACT = c("Total_A", paste0("A", seq(1,5),"_"), -#' paste0("A1_", seq(1,7)),paste0("A2_", seq(1,9))), -#' GEO = c("Total_G", "GA", "GB", "GA1", "GA2", "GB1", "GB2","GA3","GB3","GB4"), -#' SEX = c("Total_S", "F", "M","F1","F2","M1","M2"), -#' AGE = c("Ensemble", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), -#' ECO = c("PIB","Ménages","Entreprises"), -#' stringsAsFactors = FALSE, -#' KEEP.OUT.ATTRS = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1:n()) +#' Simulate generated table sizes for dimension reduction #' -#' hrc_act <- "hrc_ACT.hrc" -#' sdcHierarchies::hier_create(root = "Total_A", nodes = paste0("A", seq(1,5),"_")) %>% -#' sdcHierarchies::hier_add(root = "A1_", nodes = paste0("A1_", seq(1,7))) %>% -#' sdcHierarchies::hier_add(root = "A2_", nodes = paste0("A2_", seq(1,9))) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_geo <- "hrc_GEO.hrc" -#' sdcHierarchies::hier_create(root = "Total_G", nodes = c("GA","GB")) %>% -#' sdcHierarchies::hier_add(root = "GA", nodes = c("GA1","GA2","GA3")) %>% -#' sdcHierarchies::hier_add(root = "GB", nodes = c("GB1","GB2","GB3","GB4")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level,name),3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' res2 <- length_tabs(dfs = data, -#' hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), -#' totcode = c(SEX="Total_S",AGE="Ensemble", GEO="Total_G", -#' ACT="Total_A", ECO = "PIB"), -#' v1 = "ACT",v2 = "AGE", -#' v3 = "GEO",v4 = "SEX") +#' @param dfs data.frame +#' @param v1,v2 primary pair of variables +#' @param v3,v4 optional 3rd and 4th variables for 5D cases +#' @param totcode named vector of totals +#' @param hrcfiles named vector of hrc files +#' @param unique_mods precomputed unique modalities #' -#' res3 <- length_tabs(dfs = data, -#' hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), -#' totcode = c(SEX="Total_S",AGE="Ensemble", GEO="Total_G", -#' ACT="Total_A", ECO = "PIB"), -#' v1 = "ACT",v2 = "AGE",v3 = "GEO") +#' @return A list of expected row counts. #' @keywords internal -#' @export +#' @noRd length_tabs <- function( dfs, v1, @@ -425,412 +304,421 @@ length_tabs <- function( v3 = NULL, v4 = NULL, totcode, - hrcfiles = NULL) + hrcfiles = NULL, + unique_mods = NULL) { # To generalize the function to handle NA for an external function v3 <- if (!is.null(v3) && is.na(v3)) NULL else v3 v4 <- if (!is.null(v4) && is.na(v4)) NULL else v4 - # If 4 variables are specified -> 5 dimensions case, 2 couples are created + # Security in case the function is called outside var_to_merge + if (is.null(unique_mods)) { + unique_mods <- lapply(dfs[names(totcode)], unique) + } + if (!is.null(v4)) { + # 5D -> 3D (2 pairs) return(length_tabs_5_4_var(dfs = dfs, hrcfiles = hrcfiles, v1 = v1, v2 = v2, v3 = v3, v4 = v4, - totcode = totcode)) - - # If 3 variables are specified -> 5 dimensions case, a trio is merged + totcode = totcode, + unique_mods = unique_mods)) } else if (!is.null(v3)) { + # 5D -> 3D (1 triplet) return(length_tabs_5_3_var(dfs = dfs, hrcfiles = hrcfiles, v1 = v1, v2 = v2, v3 = v3, - totcode = totcode)) - - # If 2 variables are specified -> 4 dimensions case + totcode = totcode, + unique_mods = unique_mods)) } else { + # 4D -> 3D (1 pair) return(length_tabs_4(dfs = dfs, hrcfiles = hrcfiles, v1 = v1, v2 = v2, - totcode = totcode)) + totcode = totcode, + unique_mods = unique_mods)) } } -# case : 4 dimensions -length_tabs_4 <- function(dfs,v1,v2,totcode,hrcfiles=NULL){ +# Simulate table sizes for 4D -> 3D transition +length_tabs_4 <- function(dfs, v1, v2, totcode, hrcfiles = NULL, unique_mods = NULL){ - # Retrieval of groupings {nodes + branch} - # based on whether the variable is hierarchical or not - - # We need to list and then unlist - # otherwise the ifelse returns the first element of import_hierarchy (big total) - # instead of returning all the nodes - level_v1 <- unlist(ifelse(v1 %in% names(hrcfiles), - list(import_hierarchy(hrcfiles[[v1]])), - list(list(unique(dfs[[v1]])))), - recursive = FALSE) + if (v1 %in% names(hrcfiles)) { + level_v1 <- import_hierarchy(hrcfiles[[v1]], totcode[[v1]]) + } else { + level_v1 <- list(unique_mods[[v1]]) + } - level_v2 <- unlist(ifelse(v2 %in% names(hrcfiles), - list(import_hierarchy(hrcfiles[[v2]])), - list(list(unique(dfs[[v2]])))), - recursive = FALSE) + if (v2 %in% names(hrcfiles)) { + level_v2 <- import_hierarchy(hrcfiles[[v2]], totcode[[v2]]) + } else { + level_v2 <- list(unique_mods[[v2]]) + } - # If case 1 non hrc (not hierarchical) and v2 in hrcfiles, then we need to reorder + # Ensure flat variable is first if only one of {v1, v2} is hierarchical if (!(v2 %in% names(hrcfiles)) & (v1 %in% names(hrcfiles))) { tmp <- level_v1 level_v1 <- level_v2 level_v2 <- tmp } - # We do all possible combinations between v1 and v2 - # which represents the tables created during the creation of v1_v2 in the 5->4 step - - # For each of these tables, there are two possible hierarchies - # one with the totals of v1, and the other with the totals of v2 - # thus, for one of the modalities, we do not make any combination with its total - # hence the -1 - # and finally, we add the grand total, hence the +1 - nb_rows <- lapply(1:length(level_v1), function(i) { - lapply(1:length(level_v2), function(j) { - c((length(level_v1[[i]]) - 1) * length(level_v2[[j]]) + 1, - length(level_v1[[i]]) * (length(level_v2[[j]]) - 1) + 1) - }) - }) + # Vectorized calculation of sub-table row counts for each node pair (i, j) + len1 <- sapply(level_v1, length) + len2 <- sapply(level_v2, length) - # Now we need to multiply by the modalities of the non-merged variables + L1 <- length(len1) + L2 <- length(len2) + len1_grid <- rep(len1, each = L2) + len2_grid <- rep(len2, times = L1) + + val1 <- (len1_grid - 1) * len2_grid + 1 + val2 <- len1_grid * (len2_grid - 1) + 1 + + nb_rows <- as.vector(rbind(val1, val2)) + + # Multiply by number of modalities of non-merged variables list_non_merged_vars <- names(totcode[!(names(totcode) %in% c(v1, v2))]) - mod_non_merged_vars <- lapply(list_non_merged_vars, - function(x) length(unique(dfs[[x]]))) + # Get the number of non-merged modalities using unique_mods lengths (much faster than lapply on unique). + mod_non_merged_vars <- sapply(list_non_merged_vars, + function(x) length(unique_mods[[x]])) prod_numbers <- prod(unlist(mod_non_merged_vars)) - nb_rows_tot <- lapply(unlist(nb_rows), function(x) x * prod_numbers) + # Direct vector multiplication and conversion to a list for optimization. + nb_rows_tot <- as.list(nb_rows * prod_numbers) return(nb_rows_tot) } -# case : 5 dimensions, two pairs of merged variables -length_tabs_5_4_var <- function(dfs, v1, v2, v3, v4, totcode, hrcfiles = NULL) { +# Simulate table sizes for 5D -> 3D transition with 2 merged pairs +length_tabs_5_4_var <- function(dfs, v1, v2, v3, v4, totcode, hrcfiles = NULL, unique_mods = NULL){ - # Retrieve groupings {nodes + branches} based on whether the variable is hierarchical or not, transitioning from 5 dimensions to 4 dimensions. + if (is.null(unique_mods)) { + unique_mods <- lapply(dfs[names(totcode)], unique) + } - # List and then unlist the results; ifelse returns all nodes instead of just the first one. - level_v1 <- unlist(ifelse(v1 %in% names(hrcfiles), - list(import_hierarchy(hrcfiles[[v1]])), - list(list(unique(dfs[[v1]])))), - recursive = FALSE) + if (v1 %in% names(hrcfiles)) { + level_v1 <- import_hierarchy(hrcfiles[[v1]], totcode[[v1]]) + } else { + level_v1 <- list(unique_mods[[v1]]) + } - level_v2 <- unlist(ifelse(v2 %in% names(hrcfiles), - list(import_hierarchy(hrcfiles[[v2]])), - list(list(unique(dfs[[v2]])))), - recursive = FALSE) + if (v2 %in% names(hrcfiles)) { + level_v2 <- import_hierarchy(hrcfiles[[v2]], totcode[[v2]]) + } else { + level_v2 <- list(unique_mods[[v2]]) + } - # Swap level_v1 and level_v2 in case v2 is not hierarchical but v1 is (to maintain order). + # Swap hierarchy levels so the flat variable comes first (convention for 4D -> 3D steps). + # Variable name strings themselves (v1/v2, v3/v4) are not swapped because c(v1,v2,v3,v4) + # is used as an unordered set downstream. if (!(v2 %in% names(hrcfiles)) & (v1 %in% names(hrcfiles))) { tmp <- level_v1 level_v1 <- level_v2 level_v2 <- tmp } - level_v3 <- unlist(ifelse(v3 %in% names(hrcfiles), - list(import_hierarchy(hrcfiles[[v3]])), - list(list(unique(dfs[[v3]])))), - recursive = FALSE) + if (v3 %in% names(hrcfiles)) { + level_v3 <- import_hierarchy(hrcfiles[[v3]], totcode[[v3]]) + } else { + level_v3 <- list(unique_mods[[v3]]) + } - level_v4 <- unlist(ifelse(v4 %in% names(hrcfiles), - list(import_hierarchy(hrcfiles[[v4]])), - list(list(unique(dfs[[v4]])))), - recursive = FALSE) + if (v4 %in% names(hrcfiles)) { + level_v4 <- import_hierarchy(hrcfiles[[v4]], totcode[[v4]]) + } else { + level_v4 <- list(unique_mods[[v4]]) + } - # Swap level_v3 and level_v4 in case v4 is not hierarchical but v3 is (to maintain order). if (!(v4 %in% names(hrcfiles)) & (v3 %in% names(hrcfiles))) { tmp <- level_v3 level_v3 <- level_v4 level_v4 <- tmp - - tmp <- v3 - v3 <- v4 - v4 <- tmp } - # Calculate the length of resulting 4-dimensional datasets for each combination of variables. - - nb_rows <- lapply(1:length(level_v1), function(i) { - lapply(1:length(level_v2), function(j) { + # Fully vectorized 5D -> 4D row count computation across all combinations + len1 <- sapply(level_v1, length) + len2 <- sapply(level_v2, length) + len3 <- sapply(level_v3, length) + len4 <- sapply(level_v4, length) - c( - lapply(1:length(level_v3), function(k) { - lapply(1:length(level_v4), function(l) { + L1 <- length(len1) + L2 <- length(len2) + L3 <- length(len3) + L4 <- length(len4) - # A formula to calculate the length of the arrays. - c( ((length(level_v1[[i]]) - 1) * length(level_v2[[j]]) + 1) * - ((length(level_v3[[k]]) - 1) * length(level_v4[[l]]) + 1), + len1_ij <- rep(len1, each = L2) + len2_ij <- rep(len2, times = L1) + A_ij <- (len1_ij - 1) * len2_ij + 1 + B_ij <- len1_ij * (len2_ij - 1) + 1 - ((length(level_v1[[i]]) - 1) * length(level_v2[[j]]) + 1) * - (length(level_v3[[k]]) * (length(level_v4[[l]]) - 1) + 1) - ) - }) - }), + len3_kl <- rep(len3, each = L4) + len4_kl <- rep(len4, times = L3) + C_kl <- (len3_kl - 1) * len4_kl + 1 + D_kl <- len3_kl * (len4_kl - 1) + 1 - lapply(1:length(level_v3), function(k) { - lapply(1:length(level_v4), function(l) { + CD_woven <- as.vector(rbind(C_kl, D_kl)) + AB_woven <- as.vector(rbind(A_ij, B_ij)) - c( (length(level_v1[[i]]) * (length(level_v2[[j]]) - 1) + 1) * - ((length(level_v3[[k]]) - 1) * length(level_v4[[l]]) + 1), - - (length(level_v1[[i]]) * (length(level_v2[[j]]) - 1) + 1) * - (length(level_v3[[k]]) * (length(level_v4[[l]]) - 1) + 1) - ) - }) - }) - ) + multipliers <- rep(AB_woven, each = length(CD_woven)) + nb_rows <- multipliers * rep(CD_woven, times = 2 * L1 * L2) - }) - }) # Calculate the total number of rows by multiplying with the unique modalities of non-merged variables. list_non_fused_vars <- names(totcode[!(names(totcode) %in% c(v1, v2, v3, v4))]) - non_fused_vars_mod <- lapply(list_non_fused_vars, - function(x) length(unique(dfs[[x]]))) + # Get the number of non-merged modalities using unique_mods lengths (much faster than lapply on unique). + non_fused_vars_mod <- sapply(list_non_fused_vars, + function(x) length(unique_mods[[x]])) prod_numbers <- prod(unlist(non_fused_vars_mod)) - nb_rows_tot <- lapply(unlist(nb_rows), function(x) x * prod_numbers) + nb_rows_tot <- as.list(nb_rows * prod_numbers) + return(nb_rows_tot) } -# case : 5 dimensions, three variables merged into one -length_tabs_5_3_var <- function(dfs, v1, v2, v3, totcode, hrcfiles = NULL) { +# Simulate table sizes for 5D -> 3D transition with a merged triplet +length_tabs_5_3_var <- function(dfs, v1, v2, v3, totcode, hrcfiles = NULL, unique_mods = NULL) { - # Case of at least one hierarchical variable - if (length(setdiff(names(hrcfiles), c(v1, v2, v3))) != length(hrcfiles)) { - - # WARNING - # This case is a work in progress (WIP) - # Only the different lengths of modalities are calculated - # But we do not know specifically the length of table i, for example - # However, this is not currently critical - # All modalities appear the correct number of times, but not in the correct order + # Fallback security in case unique_mods is not provided. + if (is.null(unique_mods)) { + unique_mods <- lapply(dfs[names(totcode)], unique) + } - # Transition from 5 dimensions to 4 dimensions + # Case: At least 1 variable in triplet is hierarchical + if (length(setdiff(names(hrcfiles), c(v1, v2, v3))) != length(hrcfiles)) { - # List and then unlist the results; ifelse returns all nodes instead of just the first one. - level_v1 <- unlist(ifelse(v1 %in% names(hrcfiles), - list(import_hierarchy(hrcfiles[[v1]])), - list(list(unique(dfs[[v1]])))), - recursive = FALSE) + if (v1 %in% names(hrcfiles)) { + level_v1 <- import_hierarchy(hrcfiles[[v1]], totcode[[v1]]) + } else { + level_v1 <- list(unique_mods[[v1]]) + } - level_v2 <- unlist(ifelse(v2 %in% names(hrcfiles), - list(import_hierarchy(hrcfiles[[v2]])), - list(list(unique(dfs[[v2]])))), - recursive = FALSE) + if (v2 %in% names(hrcfiles)) { + level_v2 <- import_hierarchy(hrcfiles[[v2]], totcode[[v2]]) + } else { + level_v2 <- list(unique_mods[[v2]]) + } - # Swap level_v1 and level_v2 if v2 is not hierarchical but v1 is (to maintain order). + # Ensure v1 is non-hierarchical if only one of {v1, v2} has a hierarchy. + # The merging algorithm always places the non-hierarchical variable first + # for the 4‑D to 3‑D step, so we swap if necessary. if (!(v2 %in% names(hrcfiles)) & (v1 %in% names(hrcfiles))) { tmp <- level_v1 level_v1 <- level_v2 level_v2 <- tmp } - # Transition from 4 dimensions to 3 dimensions - - # List and then unlist the results; ifelse returns all nodes instead of just the first one. - level_v3 <- unlist(ifelse(v3 %in% names(hrcfiles), - list(import_hierarchy(hrcfiles[[v3]])), - list(list(unique(dfs[[v3]])))), - recursive = FALSE) - - - nb_rows <- lapply(1:length(level_v1), function(i) { - - lapply(1:length(level_v3), function(k) { - - c( (length(level_v1[[i]]) - 1) * length(level_v3[[k]]) + 1, - length(level_v1[[i]]) * (length(level_v3[[k]]) - 1) + 1 - ) - }) - - lapply(1:length(level_v2), function(j) { - lapply(1:length(level_v3), function(k) { - - c( - rep(c((length(level_v2[[j]]) - 1) * length(level_v3[[k]]) + 1, - length(level_v2[[j]]) * (length(level_v3[[k]]) - 1) + 1 - ), - times = length(level_v1[[i]]) - ), + if (v3 %in% names(hrcfiles)) { + level_v3 <- import_hierarchy(hrcfiles[[v3]], totcode[[v3]]) + } else { + level_v3 <- list(unique_mods[[v3]]) + } - rep(c((length(level_v1[[i]]) - 1) * length(level_v3[[k]]) + 1, - length(level_v1[[i]]) * (length(level_v3[[k]]) - 1) + 1 - ), - times = length(level_v2[[j]]) - ) - ) - }) - }) - }) + # Number of modalities within each hierarchy node + len1 <- sapply(level_v1, length) + len2 <- sapply(level_v2, length) + len3 <- sapply(level_v3, length) + L1 <- length(len1) + L2 <- length(len2) + L3 <- length(len3) + + + # --- Build all (i, j) pairs --- + # Each pair corresponds to a combination of a node from level_v1 (i) + # and a node from level_v2 (j). These represent the tables created during + # the 5‑D to 4‑D merging step. + grid_ij <- expand.grid(i = seq_len(L1), j = seq_len(L2)) + i <- grid_ij$i + j <- grid_ij$j + + len1_i <- len1[i] # len1 for each pair + len2_j <- len2[j] # len2 for each pair + + # --- Calculate the four pattern matrices --- + # These formulas come from the original nested lapply structure: + # For a given (i, j, k), the original code generates four numbers: + # (len2_j - 1) * len3[k] + 1 + # len2_j * (len3[k] - 1) + 1 + # (len1_i - 1) * len3[k] + 1 + # len1_i * (len3[k] - 1) + 1 + # We compute them all at once for every (i, j) and every k using + # matrix multiplication (%*%) to obtain matrices of size (n_pairs, L3). + n_pairs <- length(i) + + # Pattern A: based on v2 & v3 + A1 <- (len2_j - 1) %*% t(len3) + 1 # (n_pairs x L3) + A2 <- len2_j %*% t(len3 - 1) + 1 # (n_pairs x L3) + + # Pattern B: based on v1 & v3 + B1 <- (len1_i - 1) %*% t(len3) + 1 + B2 <- len1_i %*% t(len3 - 1) + 1 + + # --- Replicate rows according to the original repetition logic --- + # In the original algorithm, for a given (i, j): + # - A1 and A2 are repeated len1_i times (once for each element of the v1 node) + # - B1 and B2 are repeated len2_j times (once for each element of the v2 node) + # They are then interleaved column‑wise (i.e., by k) in the order: + # A1, A2, B1, B2, A1, A2, B1, B2, ... (for each k) + # Here we stack all repetitions row‑wise first, then interleave by rows. + + # Indices to repeat each pair's row in A1/A2 len1_i times + idx_A <- rep(seq_len(n_pairs), times = len1_i) + # Indices to repeat each pair's row in B1/B2 len2_j times + idx_B <- rep(seq_len(n_pairs), times = len2_j) + + # Stack the matrices with the appropriate row repetitions + stack_A1 <- A1[idx_A, , drop = FALSE] + stack_A2 <- A2[idx_A, , drop = FALSE] + stack_B1 <- B1[idx_B, , drop = FALSE] + stack_B2 <- B2[idx_B, , drop = FALSE] + + # --- Interleave the stacked rows in the correct order --- + # For each pair (i, j), we must place: + # len1_i rows of A1, len1_i rows of A2, len2_j rows of B1, len2_j rows of B2. + # This small loop iterates only over n_pairs, not over the data size, + # so it remains negligible while keeping the code readable. + total_rows <- nrow(stack_A1) + nrow(stack_A2) + nrow(stack_B1) + nrow(stack_B2) + res_mat <- matrix(0, nrow = total_rows, ncol = L3) + + pos <- 1 + start_A <- 1 # current position in stack_A1 / stack_A2 + start_B <- 1 # current position in stack_B1 / stack_B2 + for (k in seq_len(n_pairs)) { + rA <- len1_i[k] # number of rows for this pair from A1/A2 + rB <- len2_j[k] # number of rows for this pair from B1/B2 + + # Copy the rA rows of A1, then rA rows of A2 + res_mat[pos:(pos + rA - 1), ] <- stack_A1[start_A:(start_A + rA - 1), ] + pos <- pos + rA + res_mat[pos:(pos + rA - 1), ] <- stack_A2[start_A:(start_A + rA - 1), ] + pos <- pos + rA + + # Copy the rB rows of B1, then rB rows of B2 + res_mat[pos:(pos + rB - 1), ] <- stack_B1[start_B:(start_B + rB - 1), ] + pos <- pos + rB + res_mat[pos:(pos + rB - 1), ] <- stack_B2[start_B:(start_B + rB - 1), ] + pos <- pos + rB + + start_A <- start_A + rA + start_B <- start_B + rB + } - # Case of 3 non-hierarchical variables: exact result (the length of table i is known) + # Flatten the matrix column‑wise (by k) to obtain the final vector of sizes + nb_rows <- as.vector(t(res_mat)) } else { - - n_mod_v1 <- length(unique(dfs[[v1]])) - n_mod_v2 <- length(unique(dfs[[v2]])) - n_mod_v3 <- length(unique(dfs[[v3]])) - + # ------------------------------------------------------------------- + # 3 non‑hierarchical variables: exact result (the length of table i is known) + # The formulas below come from the analytical derivation for flat variables. + # They are already fully vectorized and correctly predict every table size. + # ------------------------------------------------------------------- + + # Fetch unique modality counts directly from unique_mods list rather than executing raw unique() calls. + n_mod_v1 <- length(unique_mods[[v1]]) + n_mod_v2 <- length(unique_mods[[v2]]) + n_mod_v3 <- length(unique_mods[[v3]]) + + # RATIONALE FOR THE 14-TABLE FORMULA (e.g., n_mod_v1=3, n_mod_v2=4, n_mod_v3=3): + # Merging 3 flat variables v1, v2, v3 in a 5D-to-3D reduction is a nested process: + # + # Step 1: Merges v1 and v2, generating 2 intermediate 4D tables (tab1 and tab2). + # - tab1: v1 is the primary split variable. Its custom hierarchy has: + # * 1 Root Split (total "Total_Total" cut into v1 level 1 children) + # * (n_mod_v1 - 1) Intermediate Splits (v1 node cut into v2 children) + # - tab2: v2 is the primary split variable. Its custom hierarchy has: + # * 1 Root Split (total "Total_Total" cut into v2 level 1 children) + # * (n_mod_v2 - 1) Intermediate Splits (v2 node cut into v1 children) + # + # Step 2: Merges the newly hierarchical V1_V2 with v3 using 'from_4_to_3_case_1_hr'. + # Every single split from Step 1 (both Root and Intermediate splits) is further + # split and crossed with v3, generating TWO 3D tables per split. + # + # Summing all generated tables: + # - From tab1: + # * 1 pair from the Root Split (sizes based on v1 and v3) + # * (n_mod_v1 - 1) pairs from the Intermediate Splits (sizes based on v2 and v3) + # - From tab2: + # * 1 pair from the Root Split (sizes based on v2 and v3) + # * (n_mod_v2 - 1) pairs from the Intermediate Splits (sizes based on v1 and v3) + # + # Grouping these symmetrically (which yields the original package's formula): + # - Root Split of tab1 + Intermediate Splits of tab2 (both based on v1 & v3) + # Total splits = 1 + (n_mod_v2 - 1) = n_mod_v2 splits (2 * n_mod_v2 tables). + # - Root Split of tab2 + Intermediate Splits of tab1 (both based on v2 & v3) + # Total splits = 1 + (n_mod_v1 - 1) = n_mod_v1 splits (2 * n_mod_v1 tables). nb_rows <- c( + # Standalone: 1 pair of tables from tab1's Root Split (sizes based on v1 and v3) 1 + (n_mod_v3 - 1) * n_mod_v1, 1 + n_mod_v3 * (n_mod_v1 - 1), + # Rep 1: n_mod_v1 pairs of tables representing: + # - (n_mod_v1 - 1) Intermediate Splits from tab1 + # - 1 Root Split from tab2 + # (All of these have sizes based on v2 and v3) rep(c(1 + (n_mod_v3 - 1) * n_mod_v2, - 1 + n_mod_v3 * (n_mod_v2 - 1)) - , n_mod_v1), + 1 + n_mod_v3 * (n_mod_v2 - 1)), + times = n_mod_v1), + # Rep 2: (n_mod_v2 - 1) pairs of tables representing: + # - (n_mod_v2 - 1) Intermediate Splits from tab2 + # (All of these have sizes based on v1 and v3) rep(c(1 + (n_mod_v3 - 1) * n_mod_v1, - 1 + n_mod_v3 * (n_mod_v1 - 1)) - , n_mod_v2 - 1) + 1 + n_mod_v3 * (n_mod_v1 - 1)), + times = n_mod_v2 - 1) ) + } # Calculate the total number of rows by multiplying with the unique modalities of non-merged variables. list_non_fused_vars <- names(totcode[!(names(totcode) %in% c(v1, v2, v3))]) - non_fused_vars_mod <- lapply(list_non_fused_vars, - function(x) length(unique(dfs[[x]]))) + # Get the number of non-merged modalities using unique_mods lengths (much faster than lapply on unique). + non_fused_vars_mod <- sapply(list_non_fused_vars, + function(x) length(unique_mods[[x]])) prod_numbers <- prod(unlist(non_fused_vars_mod)) - nb_rows_tot <- lapply(unlist(nb_rows), function(x) x * prod_numbers) + nb_rows_tot <- as.list(nb_rows * prod_numbers) return(nb_rows_tot) } -# Function to manage the import of the hierarchy -import_hierarchy <- function(hrcfile) { - total <- "BIG_Total" - res_sdc <- sdcHierarchies::hier_import(inp = hrcfile, from = "hrc", root = total) %>% - sdcHierarchies::hier_convert(as = "sdc") - # Store all sets of parent + direct child - levels <- lapply(res_sdc$dims, names) - return(levels) -} - -#' Calculate the number of tables generated when merging 3 variables -#' in the transition from 5 to 3 dimensions -#' -#' @param v1 first variable to be merged -#' @param v2 second variable to be merged -#' @param v3 third variable to be merged ( -#' variable that will be merged with v1 and v2 if v4 is not specified) -#' @param v4 fourth variable to be merged (with v3) -#' @param hrcfiles named list of hrc files -#' @param data data.frame (used only in the case where a trio is formed) +#' Calculate total count of generated tables #' -#' @return an integer representing the number of tables generated -#' -#' @examples -#' # Dimension 4 -#' library(dplyr) -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), -#' GEO = c("Total", "G1", "G2"), -#' SEX = c("Total", "F", "M"), -#' AGE = c("Total", "AGE1", "AGE2"), -#' stringsAsFactors = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' -#' sdcHierarchies::hier_create(root = "Total", nodes = c("A", "B")) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1", "A2")) %>% -#' sdcHierarchies::hier_add(root = "B", nodes = c("B1", "B2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level, name), 3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' # 1 pair created -#' nb_tab_generated(v1 = "ACT", v2 = "GEO", -#' hrcfiles = c(ACT = hrc_act)) -#' -#' # Dimension 5 -#' data <- expand.grid( -#' ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), -#' GEO = c("Total", "GA", "GB", "GA1", "GA2", "GB1", "GB2"), -#' SEX = c("Total", "F", "M", "F1", "F2", "M1", "M2"), -#' AGE = c("Total", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), -#' ECO = c("PIB", "Ménages", "Entreprises"), -#' stringsAsFactors = FALSE, -#' KEEP.OUT.ATTRS = FALSE -#' ) %>% -#' as.data.frame() -#' -#' data <- data %>% mutate(VALUE = 1:n()) -#' -#' hrc_act <- "hrc_ACT.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("A", "B")) %>% -#' sdcHierarchies::hier_add(root = "A", nodes = c("A1", "A2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level, name), 3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_geo <- "hrc_GEO.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("GA", "GB")) %>% -#' sdcHierarchies::hier_add(root = "GA", nodes = c("GA1", "GA2")) %>% -#' sdcHierarchies::hier_add(root = "GB", nodes = c("GB1", "GB2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level, name), 3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' hrc_sex <- "hrc_SEX.hrc" -#' sdcHierarchies::hier_create(root = "Total", nodes = c("F", "M")) %>% -#' sdcHierarchies::hier_add(root = "F", nodes = c("F1", "F2")) %>% -#' sdcHierarchies::hier_add(root = "M", nodes = c("M1", "M2")) %>% -#' sdcHierarchies::hier_convert(as = "argus") %>% -#' slice(-1) %>% -#' mutate(levels = substring(paste0(level, name), 3)) %>% -#' select(levels) %>% -#' write.table(file = hrc_sex, row.names = FALSE, col.names = FALSE, quote = FALSE) -#' -#' # Trio merged -#' nb_tab_generated(data = data, -#' v1 = "ACT", v2 = "GEO", v3 = "SEX", -#' hrcfiles = c(ACT = hrc_act, GEO = hrc_geo, SEX = hrc_sex)) -#' -#' # 2 pairs created -#' nb_tab_generated(v1 = "ACT", v2 = "GEO", -#' v3 = "SEX", v4 = "EXO", -#' hrcfiles = c(ACT = hrc_act, GEO = hrc_geo, SEX = hrc_sex)) #' @keywords internal -#' @export +#' @noRd nb_tab_generated <- function( v1, v2, v3 = NULL, v4 = NULL, hrcfiles = NULL, - data = NULL) + totcode = NULL, + data = NULL, + unique_mods = NULL) { + # Fallback setup to minimize duplicate calculations in nb_tab_generated + if (is.null(unique_mods) && !is.null(data)) { + needed_vars <- c(v1, v2, v3, v4) + needed_vars <- needed_vars[!is.null(needed_vars) & !is.na(needed_vars)] + unique_mods <- lapply(data[needed_vars], unique) + } + # Case dimension 5: 2 couples created if (!is.null(v4)) { - return(4 * nb_nodes(hrcfiles = hrcfiles, v = v1) * - nb_nodes(hrcfiles = hrcfiles, v = v2) * - nb_nodes(hrcfiles = hrcfiles, v = v3) * - nb_nodes(hrcfiles = hrcfiles, v = v4)) + return(4 * nb_nodes(hrcfiles = hrcfiles, v = v1, totcode = totcode) * + nb_nodes(hrcfiles = hrcfiles, v = v2, totcode = totcode) * + nb_nodes(hrcfiles = hrcfiles, v = v3, totcode = totcode) * + nb_nodes(hrcfiles = hrcfiles, v = v4, totcode = totcode)) # Case dimension 5: one triplet merged } else if (!is.null(v3)) { @@ -839,21 +727,20 @@ nb_tab_generated <- function( if (!is.null(hrcfiles) & v1 %in% names(hrcfiles) & v2 %in% names(hrcfiles)) { # The hierarchy of each variable - level_v1 <- import_hierarchy(hrcfiles[[v1]]) - level_v2 <- import_hierarchy(hrcfiles[[v2]]) - - # Store the sum of nodes of v1_v2 for each table - # We consider all possible combinations between v1 and v2 - # => represents the tables created during the creation of v1_v2 in the 5->4 step - - # For each of these tables, there are two possible hierarchies - # one with the totals of v1, and the other with the totals of v2 - # the number of nodes is equal to their number of modalities - nb_noeuds_var <- sum(sapply(1:length(level_v1), function(i) { - sum(sapply(1:length(level_v2), function(j) { - length(level_v1[[i]]) + length(level_v2[[j]]) - })) - })) + level_v1 <- import_hierarchy(hrcfiles[[v1]], totcode[[v1]]) + level_v2 <- import_hierarchy(hrcfiles[[v2]], totcode[[v2]]) + + # ALGEBRAIC SIMPLIFICATION JUSTIFICATION: + # The original nested sapply loops computed: + # sum_{i=1}^{L1} [ sum_{j=1}^{L2} ( length(level_v1[[i]]) + length(level_v2[[j]]) ) ] + # By linearity of summation, this can be distributed as: + # L2 * sum_{i=1}^{L1} length(level_v1[[i]]) + L1 * sum_{j=1}^{L2} length(level_v2[[j]]) + # Where L1 = length(level_v1) and L2 = length(level_v2). + # This removes all nested loops and executes instantaneously. + len1 <- sapply(level_v1, length) + len2 <- sapply(level_v2, length) + + nb_noeuds_var <- length(level_v2) * sum(len1) + length(level_v1) * sum(len2) # 2 non-hierarchical variables merged } else if (is.null(hrcfiles) | !(v1 %in% names(hrcfiles)) & !(v2 %in% names(hrcfiles))) { @@ -861,27 +748,27 @@ nb_tab_generated <- function( # which can have two hierarchies # totals on v1, or totals on v2 # the number of nodes is equivalent to the number of modalities - nb_noeuds_var <- length(unique(data[[v1]])) + length(unique(data[[v2]])) + nb_noeuds_var <- length(unique_mods[[v1]]) + length(unique_mods[[v2]]) # 1 hierarchical variable and 1 non-hierarchical variable merged } else { var_hier <- ifelse(v1 %in% names(hrcfiles), v1, v2) mod_var_non_hier <- ifelse(var_hier == v1, - length(unique(data[[v2]])), - length(unique(data[[v1]]))) + length(unique_mods[[v2]]), + length(unique_mods[[v1]])) # Analysis of the hierarchy of var_hier - level_var_hier <- import_hierarchy(hrcfiles[[var_hier]]) + level_var_hier <- import_hierarchy(hrcfiles[[var_hier]], totcode[[var_hier]]) - # We consider all possible combinations between v1 and v2 - # => represents the tables created during the creation of v1_v2 in the 5->4 step + # ALGEBRAIC SIMPLIFICATION JUSTIFICATION: + # The original single sapply computed: + # sum_{i=1}^{L_hier} ( length(level_var_hier[[i]]) + mod_var_non_hier ) + # Since mod_var_non_hier is a constant across all iterations, this is equivalent to: + # sum_{i=1}^{L_hier} length(level_var_hier[[i]]) + L_hier * mod_var_non_hier + # Where L_hier = length(level_var_hier). + len_hier <- sapply(level_var_hier, length) - # For each of these tables, there are two possible hierarchies - # one with the totals of v1, and the other with the totals of v2 - # the number of nodes is equal to their number of modalities - nb_noeuds_var <- sum(sapply(1:length(level_var_hier), function(i) { - length(level_var_hier[[i]]) + mod_var_non_hier - })) + nb_noeuds_var <- sum(len_hier) + length(level_var_hier) * mod_var_non_hier } # nb_nodes corresponds to the number of tables that need to be created @@ -890,11 +777,96 @@ nb_tab_generated <- function( # and we create as many tables as its hierarchy has nodes # finally, for each created table, two hierarchies are possible # totals on v1_v2 and totals on v3 - return(2 * nb_noeuds_var * nb_nodes(hrcfiles, v = v3)) + return(2 * nb_noeuds_var * nb_nodes(hrcfiles, v = v3, totcode = totcode)) # Case dimension 4 } else { - return(2 * nb_nodes(hrcfiles = hrcfiles, v = v1) * - nb_nodes(hrcfiles = hrcfiles, v = v2)) + return(2 * nb_nodes(hrcfiles = hrcfiles, v = v1, totcode = totcode) * + nb_nodes(hrcfiles = hrcfiles, v = v2, totcode = totcode)) + } +} + +#' Analytically computes all possible table splits and summarizes their statistics. +#' +#' @param dfs data.frame containing 4 or 5 categorical variables +#' @param totcode named vector of totals for categorical variables +#' @param hrcfiles named vector of hrc files (optional) +#' +#' @return A deduplicated data.frame containing the following columns: +#' \itemize{ +#' \item `nb_tab`: number of generated tables +#' \item `nb_hrc`: number of remaining hierarchical variables +#' \item `min_size`: minimum table size (rows) +#' \item `med_size`: median table size (rows, rounded to integer) +#' \item `max_size`: maximum table size (rows) +#' } +#' @export +explore_reduce_dims <- function(dfs, totcode, hrcfiles = NULL) { + + # Ensure dfs is a standard data.frame (handles data.table input) + dfs <- as.data.frame(dfs) + + # 1. Check dimensions (4D or 5D) + num_dims <- length(totcode) + if (!num_dims %in% c(4, 5)) { + stop("Please provide a totcode object with 4 or 5 dimensions!") + } + + # Initial number of hierarchical variables + hrc_var_names <- intersect(names(hrcfiles), names(totcode)) + nb_hrc_initial <- length(hrc_var_names) + + # Precompute unique_mods to speed up computation (as in var_to_merge) + unique_mods <- lapply(dfs[names(totcode)], unique) + + # 2. Generate possible variable combinations + if (num_dims == 4) { + # 4D: 6 combinations of 2 variables + result_comb <- generate_a_pair(totcode) + } else { + # 5D: 10 triplets (3-var merge) + 15 double pairs (4-var merge) = 25 cases + triplets <- generate_a_triplet(totcode) + two_pairs <- generate_two_pairs(totcode) + result_comb <- c(triplets, two_pairs) } + + # 3. Analytically compute table lengths using length_tabs + results <- lapply(result_comb, function(x) { + # x contains 2, 3, or 4 variables. + # x[3] and x[4] return NA if the index exceeds length(x), + # which length_tabs() automatically converts to NULL. + tab_sizes <- unlist( + length_tabs( + dfs = dfs, + v1 = x[1], + v2 = x[2], + v3 = x[3], + v4 = x[4], + totcode = totcode, + hrcfiles = hrcfiles, + unique_mods = unique_mods + ) + ) + + # Calculate remaining hierarchical variables + merged_vars <- x[!is.na(x)] + nb_hrc_merged <- sum(merged_vars %in% hrc_var_names) + nb_created <- if (length(x) == 4) 2L else 1L + nb_hrc_val <- as.integer(nb_hrc_initial - nb_hrc_merged + nb_created) + + data.frame( + nb_tab = as.integer(length(tab_sizes)), + nb_hrc = nb_hrc_val, + min_size = as.integer(min(tab_sizes)), + med_size = as.integer(round(stats::median(tab_sizes))), + max_size = as.integer(max(tab_sizes)) + ) + }) + + # 4. Combine, deduplicate (distinct), and sort by ascending nb_tab + res_df <- dplyr::bind_rows(results) %>% + dplyr::distinct() %>% + dplyr::arrange(nb_tab, max_size, min_size) + + return(res_df) } diff --git a/R/tab_rtauargus.R b/R/tab_rtauargus.R index c129f8b..c1cda6c 100644 --- a/R/tab_rtauargus.R +++ b/R/tab_rtauargus.R @@ -16,20 +16,13 @@ #' @param split_tab `r lifecycle::badge("experimental")` boolean, #' whether to reduce dimension to 3 while treating a table of dimension 4 or 5 #' (default to `FALSE`) -#' @param limit `r lifecycle::badge("experimental")` numeric, used to choose -#' which variable to merge (if nb_tab_option = 'smart') -#' and split table with a number of row above this limit in order to avoid -#' tauargus failures -#' @param nb_tab_option `r lifecycle::badge("experimental")` strategy to follow -#' to choose variables automatically while splitting: -#' \itemize{ -#' \item{`"min"`: minimize the number of tables;} -#' \item{`"max"`: maximize the number of tables;} -#' \item{`"smart"`: minimize the number of tables under the constraint -#' of their row count.} -#' } +#' @param split_limit `r lifecycle::badge("experimental")` NULL or numeric, default `NULL`. +#' Only used when `split_tab = TRUE`: maximum number of rows tolerated in a +#' sub-table. If `NULL` (recommended), it is computed automatically via +#' `auto_limit()`. #' @param ... any parameter of the tab_rda, tab_arb or run_arb functions, relevant -#' for the treatment of tabular. +#' for the treatment of tabular. When `split_tab = TRUE`, can also be used to +#' pass `nb_tab_option` (advanced, default `"smart"`, see `tab_rtauargus4`). #' #' @return #' If output_type equals to 4 and summary_secret = FALSE and split_tab = FALSE, @@ -139,8 +132,7 @@ tab_rtauargus <- function( output_options = "", unif_labels = TRUE, split_tab = FALSE, - nb_tab_option = "smart", - limit = 14700, + split_limit = NULL, ... ){ @@ -217,6 +209,8 @@ tab_rtauargus <- function( params_rt4$totcode <- totcode params_rt4$dir_name <- dir_name params_rt4$files_name <- files_name + params_rt4$limit <- split_limit + params_rt4$compact_verbose <- if (!is.null(.dots[["compact_verbose"]])) .dots[["compact_verbose"]] else FALSE return(do.call("tab_rtauargus4", params_rt4)) @@ -417,8 +411,7 @@ tab_rtauargus2 <- function( ip = 10, suppress = "MOD(1,5,1,0,0)", split_tab = TRUE, - nb_tab_option = "smart", - limit = 14700, + split_limit = NULL, ... ){ @@ -447,8 +440,12 @@ tab_rtauargus2 <- function( params$suppress = suppress params$split_tab = if(length(explanatory_vars) > 3) split_tab else FALSE params$dir_name = if(params$split_tab) file.path(dir_name, files_name) else dir_name - params$nb_tab_option = nb_tab_option - params$limit = limit + + params$nb_tab_option = if (!is.null(.dots$nb_tab_option)) .dots$nb_tab_option else "smart" + params$split_limit = split_limit + # Enabled by default for multi-table manager calls + params$compact_verbose <- if (!is.null(.dots[["compact_verbose"]])) .dots[["compact_verbose"]] else TRUE + params$summary_secret = FALSE params$show_batch_console = FALSE params$output_type = 4 diff --git a/man/explore_reduce_dims.Rd b/man/explore_reduce_dims.Rd new file mode 100644 index 0000000..a89d1a5 --- /dev/null +++ b/man/explore_reduce_dims.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sp_var_to_merge.R +\name{explore_reduce_dims} +\alias{explore_reduce_dims} +\title{Analytically computes all possible table splits and summarizes their statistics.} +\usage{ +explore_reduce_dims(dfs, totcode, hrcfiles = NULL) +} +\arguments{ +\item{dfs}{data.frame containing 4 or 5 categorical variables} + +\item{totcode}{named vector of totals for categorical variables} + +\item{hrcfiles}{named vector of hrc files (optional)} +} +\value{ +A deduplicated data.frame containing the following columns: +\itemize{ +\item \code{nb_tab}: number of generated tables +\item \code{nb_hrc}: number of remaining hierarchical variables +\item \code{min_size}: minimum table size (rows) +\item \code{med_size}: median table size (rows, rounded to integer) +\item \code{max_size}: maximum table size (rows) +} +} +\description{ +Analytically computes all possible table splits and summarizes their statistics. +} diff --git a/man/from_4_to_3.Rd b/man/from_4_to_3.Rd deleted file mode 100644 index 3acd48f..0000000 --- a/man/from_4_to_3.Rd +++ /dev/null @@ -1,108 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_from_4_to_3.R -\name{from_4_to_3} -\alias{from_4_to_3} -\title{Function reducing from 4 to 3 categorical variables} -\usage{ -from_4_to_3( - dfs, - dfs_name, - totcode, - hrcfiles = NULL, - sep_dir = FALSE, - hrc_dir = "hrc_alt", - v1 = NULL, - v2 = NULL, - sep = "_", - maximize_nb_tabs = FALSE -) -} -\arguments{ -\item{dfs}{data.frame with 4 categorical variables (n >= 2 in the general case)} - -\item{dfs_name}{name of the dataframe} - -\item{totcode}{named vector of totals for categorical variables} - -\item{hrcfiles}{named vector indicating the hrc files of hierarchical variables -among the categorical variables of dfs} - -\item{sep_dir}{allows forcing the writing of hrc into a separate folder, -default is FALSE} - -\item{hrc_dir}{folder to write hrc files if writing to a new folder is forced -or if no folder is specified in hrcfiles} - -\item{v1}{allows forcing the value of the first variable to merge, -not specified by default (NULL)} - -\item{v2}{allows forcing the value of the second variable to merge, -not specified by default (NULL)} - -\item{sep}{separator used during concatenation of variables} - -\item{maximize_nb_tabs}{specifies whether to prefer selecting hierarchical variables with -the most nodes in priority (TRUE), generating more tables but with smaller sizes, -or non-hierarchical variables with the fewest modalities (FALSE) to create fewer tables} -} -\value{ -A list containing the following components: -\itemize{ -\item \code{tabs}: named list of 3-dimensional dataframes -(n-1 dimensions in the general case) with nested hierarchies -\item \code{hrc}: named list of hrc specific to the variable created -through merging -\item \code{alt_tot}: named list of totals -\item \code{vars}: named list of vectors representing the merged variables -during the two stages of dimension reduction -} -} -\description{ -Function reducing from 4 to 3 categorical variables -} -\examples{ -library(dplyr) -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), - GEO = c("Total", "G1", "G2"), - SEX = c("Total", "F", "M"), - AGE = c("Total", "AGE1", "AGE2"), - stringsAsFactors = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1) - -hrc_act <- "hrc_ACT.hrc" - -sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) \%>\% - sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -# Results of the function -res1 <- from_4_to_3( - dfs = data, - dfs_name = "tab", - totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), - hrcfiles = c(ACT = hrc_act), - sep_dir = TRUE, - hrc_dir = "output" -) - -# Maximize the number of tables -res2 <- from_4_to_3( - dfs = data, - dfs_name = "tab", - totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), - hrcfiles = c(ACT = hrc_act), - sep_dir = TRUE, - hrc_dir = "output", - maximize_nb_tabs = TRUE -) -} -\keyword{internal} diff --git a/man/from_4_to_3_case_0_hr.Rd b/man/from_4_to_3_case_0_hr.Rd deleted file mode 100644 index 9f6bf51..0000000 --- a/man/from_4_to_3_case_0_hr.Rd +++ /dev/null @@ -1,79 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_from_4_to_3_case_0_hr.R -\name{from_4_to_3_case_0_hr} -\alias{from_4_to_3_case_0_hr} -\title{Transition from 4 to 3 variables by merging two non-hierarchical variables} -\usage{ -from_4_to_3_case_0_hr(dfs, dfs_name, v1, v2, totcode, dir_name, sep = "_") -} -\arguments{ -\item{dfs}{data.frame with 4 categorical variables (n >= 2 in the general case)} - -\item{dfs_name}{name of the data.frame in the list provided by the user} - -\item{v1}{non-hierarchical categorical variable} - -\item{v2}{non-hierarchical categorical variable} - -\item{totcode}{named vector of totals for categorical variables} - -\item{dir_name}{folder where to write the hrc files -if no folder is specified in hrcfiles} - -\item{sep}{separator used when concatenating variables} -} -\value{ -A list containing: -\itemize{ -\item \code{tabs}: named list of 3-dimensional dataframes -(n-1 dimensions in the general case) with nested hierarchies -\item \code{hrc}: named list of hrc specific to the variable created via merging -\item \code{alt_tot}: named list of totals -\item \code{vars}: named list of vectors representing the merged variables -during the two steps of dimension reduction -} -} -\description{ -Transition from 4 to 3 variables by merging two non-hierarchical variables -} -\examples{ -library(dplyr) -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), - SEX = c("Total", "F", "M","F1","F2","M1","M2"), - AGE = c("Total", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), - ECO = c("PIB","Households","Companies"), - stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1:n()) - -hrc_act <- "hrc_ACT.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_sex <- "hrc_SEX.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("F","M")) \%>\% - sdcHierarchies::hier_add(root = "F", nodes = c("F1","F2")) \%>\% - sdcHierarchies::hier_add(root = "M", nodes = c("M1","M2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_sex, row.names = FALSE, col.names = FALSE, quote = FALSE) - -res1 <- from_4_to_3_case_0_hr(dfs = data, - dfs_name = "dfs_name", - v1 = "ECO",v2 = "AGE", - totcode = c(ACT = "Total",SEX = "Total", - AGE = "Total",ECO = "PIB"), - dir_name = "output") -} -\keyword{internal} diff --git a/man/from_4_to_3_case_1_hr.Rd b/man/from_4_to_3_case_1_hr.Rd deleted file mode 100644 index a74b9a4..0000000 --- a/man/from_4_to_3_case_1_hr.Rd +++ /dev/null @@ -1,94 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_from_4_to_3_case_1_hr.R -\name{from_4_to_3_case_1_hr} -\alias{from_4_to_3_case_1_hr} -\title{Transition from 4 to 3 variables by merging a hierarchical -and a non-hierarchical variable} -\usage{ -from_4_to_3_case_1_hr( - dfs, - dfs_name, - v1, - v2, - totcode, - hrcfiles, - dir_name, - sep = "_" -) -} -\arguments{ -\item{dfs}{data.frame with 4 categorical variables (n >= 2 in the general case)} - -\item{dfs_name}{name of the data.frame in the list provided by the user} - -\item{v1}{non-hierarchical categorical variable} - -\item{v2}{hierarchical categorical variable} - -\item{totcode}{named vector of totals for categorical variables} - -\item{hrcfiles}{named vector indicating the hrc files of hierarchical variables -among the categorical variables of dfs} - -\item{dir_name}{directory where to write the hrc files -if no folder is specified in hrcfiles} - -\item{sep}{separator used when concatenating variables} -} -\value{ -A list containing: -\itemize{ -\item \code{tabs}: named list of 3-dimensional dataframes -(n-1 dimensions in the general case) with nested hierarchies -\item \code{hrc}: named list of hrc specific to the variable created by fusion -\item \code{alt_tot}: named list of totals -\item \code{vars}: named list of vectors representing the merged variables -during the two stages of dimension reduction -} -} -\description{ -Transition from 4 to 3 variables by merging a hierarchical -and a non-hierarchical variable -} -\examples{ -library(dplyr) -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), - SEX = c("Total", "F", "M","F1","F2","M1","M2"), - AGE = c("Total", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), - ECO = c("PIB","Ménages","Entreprises"), - stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1:n()) - -hrc_act <- "hrc_ACT.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_sex <- "hrc_SEX.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("F","M")) \%>\% - sdcHierarchies::hier_add(root = "F", nodes = c("F1","F2")) \%>\% - sdcHierarchies::hier_add(root = "M", nodes = c("M1","M2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_sex, row.names = FALSE, col.names = FALSE, quote = FALSE) - -res1 <- from_4_to_3_case_1_hr(dfs = data, - dfs_name = "dfs_name", - v1 = "ECO",v2 = "SEX", - totcode = c(ACT = "Total",SEX = "Total", - AGE = "Total",ECO = "PIB"), - hrcfiles = c(ACT = hrc_act, SEX = hrc_sex), - dir_name = "output") -} -\keyword{internal} diff --git a/man/from_4_to_3_case_2_hr.Rd b/man/from_4_to_3_case_2_hr.Rd deleted file mode 100644 index 9e36bb0..0000000 --- a/man/from_4_to_3_case_2_hr.Rd +++ /dev/null @@ -1,93 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_from_4_to_3_case_2_hr.R -\name{from_4_to_3_case_2_hr} -\alias{from_4_to_3_case_2_hr} -\title{Transition from 4 to 3 variables via the merging of two hierarchical variables} -\usage{ -from_4_to_3_case_2_hr( - dfs, - dfs_name, - v1, - v2, - totcode, - hrcfiles, - dir_name, - sep = "_" -) -} -\arguments{ -\item{dfs}{data.frame with 4 categorical variables (n >= 2 in the general case)} - -\item{dfs_name}{name of the data.frame in the list provided by the user} - -\item{v1}{hierarchical categorical variable} - -\item{v2}{hierarchical categorical variable} - -\item{totcode}{named vector of totals for categorical variables} - -\item{hrcfiles}{named vector indicating the hrc files of hierarchical variables -among the categorical variables of dfs} - -\item{dir_name}{folder where to write the hrc files -if no folder is specified in hrcfiles} - -\item{sep}{separator used during the concatenation of variables} -} -\value{ -A list containing the following components: -\itemize{ -\item \code{tabs}: named list of 3-dimensional dataframes -(n-1 dimensions in the general case) with nested hierarchies -\item \code{hrcs}: named list of hrc specific to the variable -created via the merge -\item \code{alt_tot}: named list of totals -\item \code{vars}: named list of vectors representing the merged variables -during the two stages of dimension reduction -} -} -\description{ -Transition from 4 to 3 variables via the merging of two hierarchical variables -} -\examples{ -library(dplyr) -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), - SEX = c("Total", "F", "M","F1","F2","M1","M2"), - AGE = c("Total", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), - ECO = c("PIB","Ménages","Entreprises"), - stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1:n()) - -hrc_act <- "hrc_ACT.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_sex <- "hrc_SEX.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("F","M")) \%>\% - sdcHierarchies::hier_add(root = "F", nodes = c("F1","F2")) \%>\% - sdcHierarchies::hier_add(root = "M", nodes = c("M1","M2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_sex, row.names = FALSE, col.names = FALSE, quote = FALSE) - -res <- from_4_to_3_case_2_hr(dfs = data, - dfs_name = "dfs_name", - v1 = "ACT",v2 = "SEX", - totcode = c(ACT = "Total",SEX = "Total", - AGE = "Total",ECO = "PIB"), - hrcfiles = c(ACT = hrc_act, SEX = hrc_sex), - dir_name = "output") -} -\keyword{internal} diff --git a/man/from_5_to_3.Rd b/man/from_5_to_3.Rd deleted file mode 100644 index e4827cc..0000000 --- a/man/from_5_to_3.Rd +++ /dev/null @@ -1,147 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_from_5_to_3.R -\name{from_5_to_3} -\alias{from_5_to_3} -\title{Function reducing from 5 to 3 categorical variables} -\usage{ -from_5_to_3( - dfs, - dfs_name, - totcode, - hrcfiles = NULL, - sep_dir = FALSE, - hrc_dir = "hrc_alt", - v1 = NULL, - v2 = NULL, - v3 = NULL, - v4 = NULL, - sep = "_", - maximize_nb_tabs = FALSE, - verbose = FALSE -) -} -\arguments{ -\item{dfs}{data.frame with 5 categorical variables (n >= 3 in the general case)} - -\item{dfs_name}{name of the data.frame in the list provided by the user} - -\item{totcode}{named vector of totals for categorical variables} - -\item{hrcfiles}{named vector indicating the hrc files of hierarchical variables -among the categorical variables of dfs} - -\item{sep_dir}{allows forcing the writing of hrc files in a separate folder -defaulted to FALSE} - -\item{hrc_dir}{folder where to write the hrc files if forcing the writing -in a new folder or if no folder is specified in hrcfiles} - -\item{v1}{allows forcing the value of the first variable to merge -when reducing from 5 to 4 dimensions, not specified by default (NULL)} - -\item{v2}{allows forcing the value of the second variable to merge -when reducing from 5 to 4 dimensions, not specified by default (NULL)} - -\item{v3}{allows forcing the value of the first variable to merge -when reducing from 4 to 3 dimensions, not specified by default (NULL)} - -\item{v4}{allows forcing the value of the second variable to merge -when reducing from 4 to 3 dimensions, not specified by default (NULL)} - -\item{sep}{separator used during concatenation of variables} - -\item{maximize_nb_tabs}{specifies whether to prefer selecting hierarchical variables with -the most nodes as a priority (TRUE), which generates more tables -but of smaller size, or non-hierarchical variables with the least modality (FALSE) -to create fewer tables} - -\item{verbose}{prints the different steps of the function to notify -the user of the progress, mainly for the general function gen_tabs_5_4_to_3()} -} -\value{ -a list containing the following components: -\itemize{ -\item \code{tabs}: named list of dataframes with 3 dimensions -(n-2 dimensions in the general case) endowed with nested hierarchies -\item \code{hrcs5_4}: named list of hrc specific to the variable created -via the merge when reducing from 5 to 4 dimensions -\item \code{hrcs4_3}: named list of hrc specific to the variable created -via the merge when reducing from 4 to 3 dimensions -\item \code{alt_tot5_4}: named list of totals when reducing from 5 to 4 dimensions -\item \code{alt_tot4_3}: named list of totals when reducing from 4 to 3 dimensions -\item \code{vars}: named list of vectors representing the merged variables -during the two steps of dimension reduction -} -} -\description{ -Function reducing from 5 to 3 categorical variables -} -\examples{ -library(dplyr) -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), - GEO = c("Total", "GA", "GB", "GA1", "GA2", "GB1", "GB2"), - SEX = c("Total", "F", "M","F1","F2","M1","M2"), - AGE = c("Total", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), - ECO = c("PIB","Ménages","Entreprises"), - stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1:n()) - -hrc_act <- "hrc_ACT.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_geo <- "hrc_GEO.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("GA","GB")) \%>\% - sdcHierarchies::hier_add(root = "GA", nodes = c("GA1","GA2")) \%>\% - sdcHierarchies::hier_add(root = "GB", nodes = c("GB1","GB2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_sex <- "hrc_SEX.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("F","M")) \%>\% - sdcHierarchies::hier_add(root = "F", nodes = c("F1","F2")) \%>\% - sdcHierarchies::hier_add(root = "M", nodes = c("M1","M2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_sex, row.names = FALSE, col.names = FALSE, quote = FALSE) - -# Results of the function -res1 <- from_5_to_3( - dfs = data, - dfs_name = "tab", - totcode = c(SEX="Total",AGE="Total", GEO="Total", ACT="Total", ECO = "PIB"), - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo, SEX = hrc_sex), - sep_dir = TRUE, - hrc_dir = "output", - v1 = "ACT", - v2 = "AGE", - v3 = "SEX", - v4 = "ECO" -) - -res2 <- from_5_to_3( - dfs = data, - dfs_name = "tab", - totcode = c(SEX="Total",AGE="Total", GEO="Total", ACT="Total", ECO = "PIB"), - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo, SEX = hrc_sex), - sep_dir = TRUE, - hrc_dir = "output", - verbose = TRUE -) -} -\keyword{internal} diff --git a/man/length_tabs.Rd b/man/length_tabs.Rd deleted file mode 100644 index 263cfbb..0000000 --- a/man/length_tabs.Rd +++ /dev/null @@ -1,123 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_var_to_merge.R -\name{length_tabs} -\alias{length_tabs} -\title{Calculation of the table sizes generated a priori during the reduction of dimension -from 4 or 5 dimensions to 3 dimensions} -\usage{ -length_tabs(dfs, v1, v2, v3 = NULL, v4 = NULL, totcode, hrcfiles = NULL) -} -\arguments{ -\item{dfs}{a data.frame - -Variable in the 5->4 or 4->3 step} - -\item{v1}{the first merged variable} - -\item{v2}{the second merged variable - -Variable in the case of 4->3 passage in the 4->3 process -do not specify v1_v2 if three variables are merged into one} - -\item{v3}{the third original variable to be merged} - -\item{v4}{the fourth original variable to be merged} - -\item{totcode}{character named vector} - -\item{hrcfiles}{named vector of hrc files related to the variables} -} -\value{ -a list of the lengths of the tables created during the dimension reduction -} -\description{ -Calculation of the table sizes generated a priori during the reduction of dimension -from 4 or 5 dimensions to 3 dimensions -} -\examples{ -# Dimension 4 -library(dplyr) -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2","A3", "B1", "B2","B3","B4","C", - "name_non_changed_vars","E","F","G","B5"), - GEO = c("Total", "G1", "G2"), - SEX = c("Total", "F", "M"), - AGE = c("Total", "AGE1", "AGE2"), - stringsAsFactors = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1) - - -hrc_act <- "hrc_ACT.hrc" - -sdcHierarchies::hier_create( - root = "Total", - nodes = c("A","B","C","name_non_changed_vars","E","F","G") -) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2","A3")) \%>\% - sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2","B3","B4","B5")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -# Function results - -res1 <- length_tabs(dfs = data, - hrcfiles = c(ACT = hrc_act), - totcode = c(SEX="Total",AGE="Total", GEO="Total", ACT="Total"), - v1 = "ACT", - v2 = "GEO") - -# Dimension 5 -data <- expand.grid( - ACT = c("Total_A", paste0("A", seq(1,5),"_"), - paste0("A1_", seq(1,7)),paste0("A2_", seq(1,9))), - GEO = c("Total_G", "GA", "GB", "GA1", "GA2", "GB1", "GB2","GA3","GB3","GB4"), - SEX = c("Total_S", "F", "M","F1","F2","M1","M2"), - AGE = c("Ensemble", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), - ECO = c("PIB","Ménages","Entreprises"), - stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1:n()) - -hrc_act <- "hrc_ACT.hrc" -sdcHierarchies::hier_create(root = "Total_A", nodes = paste0("A", seq(1,5),"_")) \%>\% - sdcHierarchies::hier_add(root = "A1_", nodes = paste0("A1_", seq(1,7))) \%>\% - sdcHierarchies::hier_add(root = "A2_", nodes = paste0("A2_", seq(1,9))) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_geo <- "hrc_GEO.hrc" -sdcHierarchies::hier_create(root = "Total_G", nodes = c("GA","GB")) \%>\% - sdcHierarchies::hier_add(root = "GA", nodes = c("GA1","GA2","GA3")) \%>\% - sdcHierarchies::hier_add(root = "GB", nodes = c("GB1","GB2","GB3","GB4")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) - -res2 <- length_tabs(dfs = data, - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), - totcode = c(SEX="Total_S",AGE="Ensemble", GEO="Total_G", - ACT="Total_A", ECO = "PIB"), - v1 = "ACT",v2 = "AGE", - v3 = "GEO",v4 = "SEX") - -res3 <- length_tabs(dfs = data, - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), - totcode = c(SEX="Total_S",AGE="Ensemble", GEO="Total_G", - ACT="Total_A", ECO = "PIB"), - v1 = "ACT",v2 = "AGE",v3 = "GEO") -} -\keyword{internal} diff --git a/man/nb_tab_generated.Rd b/man/nb_tab_generated.Rd deleted file mode 100644 index 05a3d90..0000000 --- a/man/nb_tab_generated.Rd +++ /dev/null @@ -1,113 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_var_to_merge.R -\name{nb_tab_generated} -\alias{nb_tab_generated} -\title{Calculate the number of tables generated when merging 3 variables -in the transition from 5 to 3 dimensions} -\usage{ -nb_tab_generated(v1, v2, v3 = NULL, v4 = NULL, hrcfiles = NULL, data = NULL) -} -\arguments{ -\item{v1}{first variable to be merged} - -\item{v2}{second variable to be merged} - -\item{v3}{third variable to be merged ( -variable that will be merged with v1 and v2 if v4 is not specified)} - -\item{v4}{fourth variable to be merged (with v3)} - -\item{hrcfiles}{named list of hrc files} - -\item{data}{data.frame (used only in the case where a trio is formed)} -} -\value{ -an integer representing the number of tables generated -} -\description{ -Calculate the number of tables generated when merging 3 variables -in the transition from 5 to 3 dimensions -} -\examples{ -# Dimension 4 -library(dplyr) -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), - GEO = c("Total", "G1", "G2"), - SEX = c("Total", "F", "M"), - AGE = c("Total", "AGE1", "AGE2"), - stringsAsFactors = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1) - -hrc_act <- "hrc_ACT.hrc" - -sdcHierarchies::hier_create(root = "Total", nodes = c("A", "B")) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1", "A2")) \%>\% - sdcHierarchies::hier_add(root = "B", nodes = c("B1", "B2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level, name), 3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -# 1 pair created -nb_tab_generated(v1 = "ACT", v2 = "GEO", - hrcfiles = c(ACT = hrc_act)) - -# Dimension 5 -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), - GEO = c("Total", "GA", "GB", "GA1", "GA2", "GB1", "GB2"), - SEX = c("Total", "F", "M", "F1", "F2", "M1", "M2"), - AGE = c("Total", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), - ECO = c("PIB", "Ménages", "Entreprises"), - stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1:n()) - -hrc_act <- "hrc_ACT.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("A", "B")) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1", "A2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level, name), 3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_geo <- "hrc_GEO.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("GA", "GB")) \%>\% - sdcHierarchies::hier_add(root = "GA", nodes = c("GA1", "GA2")) \%>\% - sdcHierarchies::hier_add(root = "GB", nodes = c("GB1", "GB2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level, name), 3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_sex <- "hrc_SEX.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("F", "M")) \%>\% - sdcHierarchies::hier_add(root = "F", nodes = c("F1", "F2")) \%>\% - sdcHierarchies::hier_add(root = "M", nodes = c("M1", "M2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level, name), 3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_sex, row.names = FALSE, col.names = FALSE, quote = FALSE) - -# Trio merged -nb_tab_generated(data = data, - v1 = "ACT", v2 = "GEO", v3 = "SEX", - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo, SEX = hrc_sex)) - -# 2 pairs created -nb_tab_generated(v1 = "ACT", v2 = "GEO", - v3 = "SEX", v4 = "EXO", - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo, SEX = hrc_sex)) -} -\keyword{internal} diff --git a/man/reduce_dims.Rd b/man/reduce_dims.Rd deleted file mode 100644 index c6eb68d..0000000 --- a/man/reduce_dims.Rd +++ /dev/null @@ -1,244 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_reduce_dims.R -\name{reduce_dims} -\alias{reduce_dims} -\title{General function that selects the appropriate separator and applies dimension reduction.} -\usage{ -reduce_dims( - dfs, - dfs_name, - totcode, - hrcfiles = NULL, - sep_dir = FALSE, - hrc_dir = "hrc_alt", - vars_to_merge = NULL, - nb_tab_option = "min", - limit = NULL, - over_split = FALSE, - vec_sep = c("___", "_XXX_", "_YYY_", "_TTT_", "_UVW_"), - verbose = FALSE -) -} -\arguments{ -\item{dfs}{data.frame with 4 or 5 categorical variables} - -\item{dfs_name}{name of the data.frame in the list provided by the user} - -\item{totcode}{named vector of totals for categorical variables} - -\item{hrcfiles}{named vector indicating the hrc files of hierarchical variables -among the categorical variables of dfs} - -\item{sep_dir}{allows forcing the writing of hrc into a separate folder, -default is FALSE} - -\item{hrc_dir}{folder to write hrc files if writing to a new folder is forced -or if no folder is specified in hrcfiles} - -\item{vars_to_merge}{NULL or vector of variables to be merged: -2 in dimension 4; 3 or 4 in dimension 5} - -\item{nb_tab_option}{strategy to follow for choosing variables automatically: -\itemize{ -\item \code{'min'}: minimize the number of tables; -\item \code{'max'}: maximize the number of tables; -\item \code{'smart'}: minimize the number of tables under the constraint -of their row count. -}} - -\item{limit}{maximum allowed number of rows in the smart or over_split = TRUE case} - -\item{over_split}{indicates if we split in several tables the tables bigger than -limit at the end of the reduction process ; it decreases the number -of hierarchy of these tables} - -\item{vec_sep}{vector of candidate separators to use} - -\item{verbose}{print the different steps of the function to inform the user -of progress} -} -\value{ -A list containing: -\itemize{ -\item \code{tabs}: named list of 3-dimensional dataframes -with nested hierarchies -\item \code{alt_hrc}: named list of hrc specific to the variables created -during merging to go to dimension 3 -\item \code{alt_totcode}: named list of totals specific to the variables -created during merging to go to dimension 3 -\item \code{vars}: categorical variables of the output dataframes -\item \code{sep}: separator used to link the variables -\item \code{totcode}: named vector of totals for all categorical variables -\item \code{hrcfiles}: named vector of hrc for categorical variables -(except the merged one) -\item \code{fus_vars}: named vector of vectors representing the merged -variables during dimension reduction -} -} -\description{ -General function that selects the appropriate separator and applies dimension reduction. -} -\examples{ -\dontrun{ -library(dplyr) -# Examples for dimension 4 - -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2","A3", "B1", - "B2","B3","B4","C","D","E","F","G","B5"), - GEO = c("Total", "G1", "G2"), - SEX = c("Total", "F", "M"), - AGE = c("Total", "AGE1", "AGE2"), - stringsAsFactors = FALSE -) \%>\% - as.data.frame() \%>\% - mutate(VALUE = 1) - -if(!dir.exists("hrc")) dir.create("hrc") -hrc_act <- "hrc/hrc_ACT4.hrc" - -sdcHierarchies::hier_create( - root = "Total", - nodes = c("A","B","C","D","E","F","G") -) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2","A3")) \%>\% - sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2","B3","B4","B5")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table( - file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE - ) - -# Reduce dim by forcing variables to be merged -res1 <- reduce_dims( - dfs = data, - dfs_name = "tab", - totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), - hrcfiles = c(ACT = hrc_act), - sep_dir = TRUE, - vars_to_merge = c("ACT", "GEO"), - hrc_dir = "output", - verbose = TRUE -) - -# Split the output in order to be under the limit & forcing variables to be merged -res1b <- reduce_dims( - dfs = data, - dfs_name = "tab", - totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), - hrcfiles = c(ACT = hrc_act), - sep_dir = TRUE, - hrc_dir = "output", - nb_tab_option = 'smart', - over_split = TRUE, - verbose = TRUE, - limit = 100 -) - -# Result of the function (minimizes the number of created tables by default) -res2 <- reduce_dims( - dfs = data, - dfs_name = "tab", - totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), - hrcfiles = c(ACT = hrc_act), - sep_dir = TRUE, - hrc_dir = "output", - verbose = TRUE -) - -# Result of the function (maximize the number of created tables) -res3 <- reduce_dims( - dfs = data, - dfs_name = "tab", - totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), - hrcfiles = c(ACT = hrc_act), - sep_dir = TRUE, - hrc_dir = "output", - nb_tab_option = "max", - verbose = TRUE -) - -# Example for dimension 5 - -data <- expand.grid( - ACT = c("Total_A", paste0("A", seq(1,5),"_"),paste0("A1_", seq(1,7)),paste0("A2_", seq(1,9))), - GEO = c("Total_G", "GA", "GB", "GA1", "GA2", "GB1", "GB2","GA3","GB3","GB4"), - SEX = c("Total_S", "F", "M","F1","F2","M1","M2"), - AGE = c("Ensemble", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), - ECO = c("PIB","Ménages","Entreprises"), - stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = FALSE -) \%>\% - as.data.frame() \%>\% - mutate(VALUE = 1:n()) - -hrc_act <- "hrc/hrc_ACT5.hrc" -sdcHierarchies::hier_create(root = "Total_A", nodes = paste0("A", seq(1,5),"_")) \%>\% - sdcHierarchies::hier_add(root = "A1_", nodes = paste0("A1_", seq(1,7))) \%>\% - sdcHierarchies::hier_add(root = "A2_", nodes = paste0("A2_", seq(1,9))) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_age <- "hrc/hrc_AGE5.hrc" -sdcHierarchies::hier_create(root = "Ensemble", nodes = c("AGE1", "AGE2")) \%>\% - sdcHierarchies::hier_add(root = "AGE1", nodes = c("AGE11", "AGE12")) \%>\% - sdcHierarchies::hier_add(root = "AGE2", nodes = c("AGE21", "AGE22")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_age, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_geo <- "hrc/hrc_GEO5.hrc" -sdcHierarchies::hier_create(root = "Total_G", nodes = c("GA","GB")) \%>\% - sdcHierarchies::hier_add(root = "GA", nodes = c("GA1","GA2","GA3")) \%>\% - sdcHierarchies::hier_add(root = "GB", nodes = c("GB1","GB2","GB3","GB4")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) - -# Results of the function -res4 <- reduce_dims( - dfs = data, - dfs_name = "tab", - totcode = c(SEX = "Total_S", AGE = "Ensemble", GEO = "Total_G", ACT = "Total_A", ECO = "PIB"), - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo, AGE = hrc_age), - sep_dir = TRUE, - hrc_dir = "output", - verbose = TRUE -) - -res5 <- reduce_dims( - dfs = data, - dfs_name = "tab", - totcode = c(SEX = "Total_S", AGE = "Ensemble", GEO = "Total_G", ACT = "Total_A", ECO = "PIB"), - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), - sep_dir = TRUE, - hrc_dir = "output", - nb_tab_option = 'smart', - limit = 1300, - verbose = TRUE -) - -res6 <- reduce_dims( - dfs = data, - dfs_name = "tab", - totcode = c(SEX = "Total_S", AGE = "Ensemble", GEO = "Total_G", ACT = "Total_A", ECO = "PIB"), - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), - sep_dir = TRUE, - hrc_dir = "output", - nb_tab_option = 'min', - verbose = TRUE, - limit = 4470, - over_split = TRUE -) -} -} -\keyword{internal} diff --git a/man/restore_format.Rd b/man/restore_format.Rd deleted file mode 100644 index ebdf590..0000000 --- a/man/restore_format.Rd +++ /dev/null @@ -1,116 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_restore_format.R -\name{restore_format} -\alias{restore_format} -\title{Function to reverse the process of dimension reduction} -\usage{ -restore_format(masq, res) -} -\arguments{ -\item{masq}{a list of data.frames on which the secret has been applied} - -\item{res}{the result of the dimension reduction function (to retrieve -the merged variables) and the separator (sep).} -} -\value{ -the original dataframe with 4 or 5 dimensions -} -\description{ -Function to reverse the process of dimension reduction -} -\examples{ -# Examples with dimension 4 -library(dplyr) -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2","A3", "B1", "B2","B3","B4","C", - "name_non_changed_vars","E","F","G","B5"), - GEO = c("Total", "G1", "G2"), - SEX = c("Total", "F", "M"), - AGE = c("Total", "AGE1", "AGE2"), - stringsAsFactors = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1) - -hrc_act <- "hrc_ACT.hrc" - -sdcHierarchies::hier_create( - root = "Total", - nodes = c("A","B","C","name_non_changed_vars","E","F","G") -) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2","A3")) \%>\% - sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2","B3","B4","B5")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -# Result of the function by forcing some variables to be merged -res_red_dim <- reduce_dims( - dfs = data, - dfs_name = "tab", - totcode = c(SEX="Total",AGE="Total", GEO="Total", ACT="Total"), - hrcfiles = c(ACT = hrc_act), - sep_dir = TRUE, - hrc_dir = "output", - vars_to_merge = c("ACT","GEO") -) - -res1 <- restore_format(masq = res_red_dim$tabs, res = res_red_dim) -dim(setdiff(res1,data))[1] == 0 - -# return TRUE -# We have exactly the sames cases in the datatable after splitting and unsplitting data - -# Exemple dimension 5 - -data <- expand.grid( - ACT = c("Total_A", paste0("A", seq(1,5),"_"),paste0("A1_", seq(1,7)), - paste0("A2_", seq(1,9))), - GEO = c("Total_G", "GA", "GB", "GA1", "GA2", "GB1", "GB2","GA3","GB3","GB4"), - SEX = c("Total_S", "F", "M","F1","F2","M1","M2"), - AGE = c("Ensemble", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), - ECO = c("PIB","Ménages","Entreprises"), - stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1:n()) - -hrc_act <- "hrc_ACT.hrc" -sdcHierarchies::hier_create(root = "Total_A", nodes = paste0("A", seq(1,5),"_")) \%>\% - sdcHierarchies::hier_add(root = "A1_", nodes = paste0("A1_", seq(1,7))) \%>\% - sdcHierarchies::hier_add(root = "A2_", nodes = paste0("A2_", seq(1,9))) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_geo <- "hrc_GEO.hrc" -sdcHierarchies::hier_create(root = "Total_G", nodes = c("GA","GB")) \%>\% - sdcHierarchies::hier_add(root = "GA", nodes = c("GA1","GA2","GA3")) \%>\% - sdcHierarchies::hier_add(root = "GB", nodes = c("GB1","GB2","GB3","GB4")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) - -# function's result - -res_red_dim <- reduce_dims( - dfs = data, - dfs_name = "tab", - totcode = c(SEX="Total_S",AGE="Ensemble", GEO="Total_G", ACT="Total_A", ECO = "PIB"), - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), - sep_dir = TRUE, - hrc_dir = "output" -) - -res2 <- restore_format(masq = res_red_dim$tabs, res = res_red_dim) -} -\keyword{internal} diff --git a/man/sp_format.Rd b/man/sp_format.Rd deleted file mode 100644 index 99e2cbd..0000000 --- a/man/sp_format.Rd +++ /dev/null @@ -1,88 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_reduce_dims.R -\name{sp_format} -\alias{sp_format} -\title{Change the result of dimension reduction to be directly usable -in rtauargus} -\usage{ -sp_format(res, dfs_name, sep, totcode, hrcfiles) -} -\arguments{ -\item{res}{result of variable merging composed of name_non_changed_vars, a list of lists of tables, -a list of hierarchical files, a list of subtotals associated with these files, -and a list of vectors of variables or a vector of variables depending on the base size -of the dataframes} - -\item{dfs_name}{the name of the entered dataframes} - -\item{sep}{character} - -\item{totcode}{character named vector} - -\item{hrcfiles}{character named vector} -} -\value{ -A list containing: -\itemize{ -\item \code{tabs}: named list of 3-dimensional dataframes -with nested hierarchies -\item \code{alt_hrc}: named list of hrc specific to the variables -created during merging to go to dimension 3 -\item \code{alt_totcode}: named list of totals specific to the variables -created during merging to go to dimension 3 -\item \code{vars}: categorical variables of the output dataframes -\item \code{sep}: separator used to link the variables -\item \code{totcode}: named vector of totals for all categorical variables -\item \code{hrcfiles}: named vector of hrc for categorical variables -(except the merged one) -\item \code{fus_vars}: named vector of vectors representing the merged -variables during dimension reduction -} -} -\description{ -Change the result of dimension reduction to be directly usable -in rtauargus -} -\examples{ -library(dplyr) -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), - GEO = c("Total", "G1", "G2"), - SEX = c("Total", "F", "M"), - AGE = c("Total", "AGE1", "AGE2"), - stringsAsFactors = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1) - -hrc_act <- "hrc_ACT.hrc" - -sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) \%>\% - sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -# Results of the function -res1 <- from_4_to_3( - dfs = data, - dfs_name = "tab", - totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total"), - hrcfiles = c(ACT = hrc_act), - sep_dir = TRUE, - hrc_dir = "output" -) - -res <- sp_format(res1, - dfs_name = "tab", - sep = "_", - totcode = c(SEX="Total",AGE="Total", - GEO="Total", ACT="Total"), - hrcfiles = c(ACT = hrc_act) - ) -} -\keyword{internal} diff --git a/man/tab_multi_manager.Rd b/man/tab_multi_manager.Rd index 6859740..9175a97 100644 --- a/man/tab_multi_manager.Rd +++ b/man/tab_multi_manager.Rd @@ -22,8 +22,7 @@ tab_multi_manager( num_iter_max = 10, summary_secret = FALSE, split_tab = FALSE, - nb_tab_option = "smart", - limit = 14700, + split_limit = NULL, ... ) } @@ -96,19 +95,10 @@ parameters for it.\cr whether to reduce dimension to 3 while treating a table of dimension 4 or 5 (default to \code{FALSE})} -\item{nb_tab_option}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} strategy to follow -to choose variables automatically while splitting: -\itemize{ -\item{\code{"min"}: minimize the number of tables;} -\item{\code{"max"}: maximize the number of tables;} -\item{\code{"smart"}: minimize the number of tables under the constraint -of their row count.} -}} - -\item{limit}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} numeric, used to choose -which variable to merge (if nb_tab_option = 'smart') -and split table with a number of row above this limit in order to avoid -tauargus failures} +\item{split_limit}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} NULL or numeric, default \code{NULL}. +Only used when \code{split_tab = TRUE}: maximum number of rows tolerated in a +sub-table. If \code{NULL} (recommended), it is computed automatically via +\code{auto_limit()}.} \item{...}{other arguments of \code{tab_rtauargus2()}} } diff --git a/man/tab_rtauargus.Rd b/man/tab_rtauargus.Rd index c365d5a..01a2c99 100644 --- a/man/tab_rtauargus.Rd +++ b/man/tab_rtauargus.Rd @@ -26,8 +26,7 @@ tab_rtauargus( output_options = "", unif_labels = TRUE, split_tab = FALSE, - nb_tab_option = "smart", - limit = 14700, + split_limit = NULL, ... ) } @@ -141,22 +140,14 @@ spécifier aucune option, \code{""}.)} whether to reduce dimension to 3 while treating a table of dimension 4 or 5 (default to \code{FALSE})} -\item{nb_tab_option}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} strategy to follow -to choose variables automatically while splitting: -\itemize{ -\item{\code{"min"}: minimize the number of tables;} -\item{\code{"max"}: maximize the number of tables;} -\item{\code{"smart"}: minimize the number of tables under the constraint -of their row count.} -}} - -\item{limit}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} numeric, used to choose -which variable to merge (if nb_tab_option = 'smart') -and split table with a number of row above this limit in order to avoid -tauargus failures} +\item{split_limit}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} NULL or numeric, default \code{NULL}. +Only used when \code{split_tab = TRUE}: maximum number of rows tolerated in a +sub-table. If \code{NULL} (recommended), it is computed automatically via +\code{auto_limit()}.} \item{...}{any parameter of the tab_rda, tab_arb or run_arb functions, relevant -for the treatment of tabular.} +for the treatment of tabular. When \code{split_tab = TRUE}, can also be used to +pass \code{nb_tab_option} (advanced, default \code{"smart"}, see \code{tab_rtauargus4}).} } \value{ If output_type equals to 4 and summary_secret = FALSE and split_tab = FALSE, diff --git a/man/tab_rtauargus2.Rd b/man/tab_rtauargus2.Rd index e8db463..d4af95e 100644 --- a/man/tab_rtauargus2.Rd +++ b/man/tab_rtauargus2.Rd @@ -19,8 +19,7 @@ tab_rtauargus2( ip = 10, suppress = "MOD(1,5,1,0,0)", split_tab = TRUE, - nb_tab_option = "smart", - limit = 14700, + split_limit = NULL, ... ) } @@ -99,19 +98,10 @@ parameters for it.\cr whether to reduce dimension to 3 while treating a table of dimension 4 or 5 (default to \code{FALSE})} -\item{nb_tab_option}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} strategy to follow -to choose variables automatically while splitting: -\itemize{ -\item{\code{"min"}: minimize the number of tables;} -\item{\code{"max"}: maximize the number of tables;} -\item{\code{"smart"}: minimize the number of tables under the constraint -of their row count.} -}} - -\item{limit}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} numeric, used to choose -which variable to merge (if nb_tab_option = 'smart') -and split table with a number of row above this limit in order to avoid -tauargus failures} +\item{split_limit}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} NULL or numeric, default \code{NULL}. +Only used when \code{split_tab = TRUE}: maximum number of rows tolerated in a +sub-table. If \code{NULL} (recommended), it is computed automatically via +\code{auto_limit()}.} \item{...}{Other arguments of \code{tab_rtauargus} function} } diff --git a/man/tab_rtauargus4.Rd b/man/tab_rtauargus4.Rd index e8b5ef7..663354f 100644 --- a/man/tab_rtauargus4.Rd +++ b/man/tab_rtauargus4.Rd @@ -21,8 +21,9 @@ tab_rtauargus4( suppress = "MOD(1,5,1,0,0)", safety_rules = paste0("MAN(", ip, ")"), nb_tab_option = "smart", - limit = 14700L, + limit = NULL, dfs_name = "tab", + sort_table = NULL, ... ) } @@ -105,21 +106,33 @@ for example.\cr Chaîne de caractères en syntaxe batch Tau-Argus. Si le secret primaire a été traité dans un fichier d'apriori : utiliser "MAN(10)")} -\item{nb_tab_option}{strategy to follow for choosing variables automatically: +\item{nb_tab_option}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#superseded}{\figure{lifecycle-superseded.svg}{options: alt='[Superseded]'}}}{\strong{[Superseded]}} character, default \code{"smart"}. +Strategy used for dimension reduction. \strong{Note:} Only \code{"smart"} is recommended. +Historical options (\code{"min"} and \code{"max"}) are legacy heuristics kept for backward +compatibility: \itemize{ -\item \code{'min'}: minimize the number of tables; -\item \code{'max'}: maximize the number of tables; -\item \code{'smart'}: minimize the number of tables under the constraint -of their row count. +\item \code{'smart'} \emph{(default & recommended)}: minimizes the number of tables under +the constraint of their row count; +\item \code{'min'} \emph{(legacy)}: minimizes the number of tables; +\item \code{'max'} \emph{(legacy)}: maximizes the number of tables. }} -\item{limit}{numeric, used to choose which variable to merge (if nb_tab_option = 'smart') -and split table with a number of row above this limit in order to avoid -tauargus failures} +\item{limit}{numeric or NULL, default \code{NULL}. Used to choose which variable +to merge (if nb_tab_option = 'smart') and split table with a number of row +above this limit in order to avoid tauargus failures. +If \code{NULL}, an automatic limit is calculated using \code{auto_limit}.} \item{dfs_name}{name used to write hrc files when reducing dims} -\item{...}{additional parameters#'} +\item{sort_table}{character or NULL, default \code{NULL}. +\emph{(Exploratory / Experimental)} Used to assess the impact of table ordering on +secondary secret selection when cells are shared across sub-tables. +If \code{"ASC"}, sub-tables are processed in ascending order of their total cell value +(smallest first); if \code{"DESC"}, in descending order. +\code{NULL} preserves the default order produced by \code{reduce_dims()}. +\emph{Note: this parameter is experimental and may be modified or removed in future versions.}} + +\item{...}{additional parameters} } \value{ The original tabular is returned with additional variables indicating diff --git a/man/var_to_merge.Rd b/man/var_to_merge.Rd deleted file mode 100644 index 763f1f6..0000000 --- a/man/var_to_merge.Rd +++ /dev/null @@ -1,137 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_var_to_merge.R -\name{var_to_merge} -\alias{var_to_merge} -\title{General function to choose variables to merge, -limiting the number of generated tables while ensuring not to generate -tables that are too large.} -\usage{ -var_to_merge( - dfs, - totcode, - hrcfiles = NULL, - nb_var = 4, - nb_tab_option = "min", - limit = 150 -) -} -\arguments{ -\item{dfs}{data.frame} - -\item{totcode}{named vector of totals for categorical variables} - -\item{hrcfiles}{named vector of hrc files for categorical variables} - -\item{nb_var}{number of variables to merge} - -\item{nb_tab_option}{strategy to follow for choosing variables automatically: -\itemize{ -\item \code{'min'}: minimize the number of tables; -\item \code{'max'}: maximize the number of tables; -\item \code{'smart'}: minimize the number of tables under the constraint of their row count. -}} - -\item{limit}{maximum allowed row count in the 'smart' case} -} -\value{ -A list of vectors representing the chosen variables to merge -} -\description{ -General function to choose variables to merge, -limiting the number of generated tables while ensuring not to generate -tables that are too large. -} -\examples{ -library(dplyr) -data <- expand.grid( - ACT = c("Total", "A", "B", "A1", "A2", "B1", "B2"), - GEO = c("Total", "GA", "GB", "GA1", "GA2"), - SEX = c("Total", "F", "M"), - AGE = c("Total", "AGE1", "AGE2"), - stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = FALSE -) \%>\% - as.data.frame() - -data <- data \%>\% mutate(VALUE = 1:n()) - -hrc_act <- "hrc_ACT.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("A","B")) \%>\% - sdcHierarchies::hier_add(root = "A", nodes = c("A1","A2")) \%>\% - sdcHierarchies::hier_add(root = "B", nodes = c("B1","B2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_act, row.names = FALSE, col.names = FALSE, quote = FALSE) - -hrc_geo <- "hrc_GEO.hrc" -sdcHierarchies::hier_create(root = "Total", nodes = c("GA","GB")) \%>\% - sdcHierarchies::hier_add(root = "GA", nodes = c("GA1","GA2")) \%>\% - sdcHierarchies::hier_convert(as = "argus") \%>\% - slice(-1) \%>\% - mutate(levels = substring(paste0(level,name),3)) \%>\% - select(levels) \%>\% - write.table(file = hrc_geo, row.names = FALSE, col.names = FALSE, quote = FALSE) - -totcode <- c(SEX="Total",AGE="Total", GEO="Total", ACT="Total") - -hrcfiles <- c(ACT = hrc_act, GEO = hrc_geo) - -# Consistent: choose two hierarchical variables -res1 <- var_to_merge(dfs = data, - totcode = totcode, - hrcfiles = hrcfiles, - nb_var = 2, - nb_tab_option = 'max') -res1 -max(unlist(length_tabs(dfs = data, - hrcfiles = hrcfiles, - totcode = totcode, - v1 = res1$vars[1], v2 = res1$vars[2]))) - -# Consistent: choose two non-hierarchical variables -res2 <- var_to_merge(dfs = data, - totcode = totcode, - hrcfiles = hrcfiles, - nb_var = 2, - nb_tab_option = 'min') -res2 -max(unlist(length_tabs(dfs = data, - hrcfiles = hrcfiles, - totcode = totcode, - v1 = res2$vars[1], v2 = res2$vars[2]))) - -res3 <- var_to_merge(dfs = data, - totcode = totcode, - hrcfiles = hrcfiles, - limit = 200, - nb_var = 2, - nb_tab_option = 'smart') -res3 -max(unlist(length_tabs(dfs = data, - hrcfiles = hrcfiles, - totcode = totcode, - v1 = res3$vars[1], v2 = res3$vars[2]))) - -# Obtains 147, which is well below 200 - -res4 <- var_to_merge(dfs = data, - totcode = totcode, - hrcfiles = hrcfiles, - limit = 5, - nb_var = 2, - nb_tab_option = 'smart') -res4 -max(unlist(length_tabs(dfs = data, - hrcfiles = hrcfiles, - totcode = totcode, - v1 = res4$vars[1], v2 = res4$vars[2]))) - -# Receives a warning: unable to reach the announced value -# There are 63 rows (equivalent to the max -# -> this is what reduces the table size) -# And the warning announces 63 rows, which is consistent with the output - -} -\keyword{internal}