From 8107bbaa84e6e5c250770934ac027a26e47b0f98 Mon Sep 17 00:00:00 2001 From: Pomel Wistan Date: Mon, 17 Aug 2026 14:48:24 +0200 Subject: [PATCH 01/16] Copy of sp file from split_perf_improvement branch --- R/sp_from_4_to_3.R | 168 +-- R/sp_from_4_to_3_case_0_hr.R | 94 +- R/sp_from_4_to_3_case_1_hr.R | 129 +-- R/sp_from_4_to_3_case_2_hr.R | 141 +-- R/sp_from_5_to_3.R | 158 +-- R/sp_reduce_dims.R | 554 +++------- R/sp_restore_format.R | 168 +-- R/sp_tab_rtauargus.R | 93 +- R/sp_var_to_merge.R | 1058 +++++++++--------- bench/bench_RAM.R | 493 +++++++++ bench/bench_perf_improv_functions.R | 1155 ++++++++++++++++++++ bench/bench_sort.R | 207 ++++ bench/bench_split_nodes.R | 115 ++ bench/bench_tab_multimanager_bloc.R | 834 ++++++++++++++ bench/bench_tab_multimanager_rtauargus4.R | 537 +++++++++ bench/comp_limit_smart_4D.R | 1195 +++++++++++++++++++++ bench/comp_limit_smart_5D.R | 707 ++++++++++++ 17 files changed, 6269 insertions(+), 1537 deletions(-) create mode 100644 bench/bench_RAM.R create mode 100644 bench/bench_perf_improv_functions.R create mode 100644 bench/bench_sort.R create mode 100644 bench/bench_split_nodes.R create mode 100644 bench/bench_tab_multimanager_bloc.R create mode 100644 bench/bench_tab_multimanager_rtauargus4.R create mode 100644 bench/comp_limit_smart_4D.R create mode 100644 bench/comp_limit_smart_5D.R 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..15b229e 100644 --- a/R/sp_tab_rtauargus.R +++ b/R/sp_tab_rtauargus.R @@ -1,3 +1,34 @@ +#' 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. +#' +#' @inheritParams explore_reduce_dims +#' +#' @return An integer representing the computed row limit. +#' @export +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,9 +37,10 @@ #' #' @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 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{\link{auto_limit}}. #' @param nb_tab_option strategy to follow for choosing variables automatically: #' \itemize{ #' \item `'min'`: minimize the number of tables; @@ -17,7 +49,21 @@ #' of their row count. #' } #' @param dfs_name name used to write hrc files when reducing dims -#' @param ... additional parameters#' +#' @param keep_history logical, default `FALSE`. If `TRUE`, the result contains +#' one boolean column `is_secret_N` per iteration, recording the full +#' suppression history (primary + secondary secret at each pass). +#' If `FALSE` (recommended for large tables), only the final suppression +#' status is kept in a single column `is_secret_`, which avoids +#' accumulating hundreds of columns and saves memory proportionally to the +#' number of iterations. +#' @param sort_table character or NULL, default `NULL`. If `"ASC"`, the +#' sub-tables generated by dimension reduction are processed in ascending +#' order of their total cell value (smallest tables first). If `"DESC"`, +#' largest tables are processed first. The processing order can influence +#' which cells receive secondary suppression when common cells are shared +#' across sub-tables. `NULL` preserves the default order produced by +#' `reduce_dims()`. +#' @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 +114,8 @@ #' ) #' } #' @importFrom stats setNames +#' @importFrom dplyr select filter mutate +#' @importFrom sdcHierarchies hier_import hier_convert #' @export tab_rtauargus4 <- function( tabular, @@ -85,11 +133,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', + keep_history = FALSE, + sort_table = NULL, ... ){ + 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,6 +157,18 @@ tab_rtauargus4 <- function( # Reduce dims for 4 or 5 dimensions table if (length(explanatory_vars) %in% c(4, 5)) { + # Calcul automatique de la limite si limit = NULL + if (is.null(limit)) { + 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 & + } + } + cat("\nReducing dims...\n",dfs_name,"\n\n") list_tables <- reduce_dims( @@ -118,6 +184,22 @@ tab_rtauargus4 <- function( sep_dir = TRUE ) + # 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') @@ -145,3 +227,4 @@ tab_rtauargus4 <- function( 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/bench/bench_RAM.R b/bench/bench_RAM.R new file mode 100644 index 0000000..862815c --- /dev/null +++ b/bench/bench_RAM.R @@ -0,0 +1,493 @@ +# ============================================================================= +# 00_setup.R — Session fraîche obligatoire +# Génère les données + hrc persistants. Redémarrer R après exécution. +# ============================================================================= + +BENCH_DIR <- "Z:/benchmark_4d" +dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) + +library(data.table) +library(dplyr) +library(sdcHierarchies) + +# --- 4D volumineux (ACT hiérarchique, GEO hiérarchique, SEX & AGE non hiérarchiques) +create_big_4D <- function( + n = 200000, + n_act_groups = 30, # Nombre de groupes d'activité (Niveau 1 ACT) + n_act_sub = 50, # Nombre de sous-niveaux par groupe d'activité (Niveau 2 ACT) + n_geo_regions = 50, # Nombre de régions (Niveau 1 GEO) + n_geo_sub = 50, # Nombre de sous-régions par région (Niveau 2 GEO) + n_sex = 2, # Nombre de modalités de SEX (ex: F, M si n_sex=2, sinon S01, S02...) + n_age = 4 # Nombre de modalités d'AGE (ex: AGE01 à AGE04) +) { + set.seed(123) + + # Calcul dynamique de la largeur des chiffres (Zero-padding) + w_act_g <- max(2, nchar(n_act_groups)) + w_act_s <- max(2, nchar(n_act_sub)) + w_geo_r <- max(2, nchar(n_geo_regions)) + w_geo_s <- max(2, nchar(n_geo_sub)) + w_age <- max(2, nchar(n_age)) + + fmt_act_g <- paste0("A%0", w_act_g, "d") + fmt_act_s <- paste0("A%0", w_act_g, "d_%0", w_act_s, "d") + + fmt_geo_r <- paste0("G%0", w_geo_r, "d") + fmt_geo_s <- paste0("G%0", w_geo_r, "d_%0", w_geo_s, "d") + + fmt_age <- paste0("AGE%0", w_age, "d") + + # 1. Définition des niveaux ACT + act_level1 <- sprintf(fmt_act_g, 1:n_act_groups) + act_level2 <- unlist(lapply(1:n_act_groups, function(i) sprintf(fmt_act_s, i, 1:n_act_sub))) + + # 2. Définition des niveaux GEO + geo_level1 <- sprintf(fmt_geo_r, 1:n_geo_regions) + geo_level2 <- unlist(lapply(1:n_geo_regions, function(i) sprintf(fmt_geo_s, i, 1:n_geo_sub))) + + # 3. Définition des modalités SEX (F, M si n_sex = 2, sinon S01, S02...) + sex_mods <- if (n_sex == 2) { + c("Total", "F", "M") + } else { + w_sex <- max(2, nchar(n_sex)) + c("Total", sprintf(paste0("S%0", w_sex, "d"), 1:n_sex)) + } + + # 4. Définition des modalités AGE (AGE01, AGE02...) + age_mods <- c("Total", sprintf(fmt_age, 1:n_age)) + + # 5. Génération du jeu de données + data <- data.frame( + ACT = sample(c("Total", act_level1, act_level2), n, replace = TRUE), + GEO = sample(c("Total", geo_level1, geo_level2), n, replace = TRUE), + SEX = sample(sex_mods, n, replace = TRUE), + AGE = sample(age_mods, n, replace = TRUE), + stringsAsFactors = FALSE + ) + data$VALUE <- 1 + + # Hiérarchie ACT + hrc_act <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total", nodes = act_level1) %>% + { + for (i in 1:n_act_groups) { + root_node <- sprintf(fmt_act_g, i) + children <- sprintf(fmt_act_s, i, 1:n_act_sub) + . <- sdcHierarchies::hier_add(., root = root_node, nodes = children) + } + . + } %>% + 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) + + # Hiérarchie GEO + hrc_geo <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total", nodes = geo_level1) %>% + { + for (i in 1:n_geo_regions) { + root_node <- sprintf(fmt_geo_r, i) + children <- sprintf(fmt_geo_s, i, 1:n_geo_sub) + . <- sdcHierarchies::hier_add(., root = root_node, nodes = children) + } + . + } %>% + 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) + + list(data = data, + hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), + totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total")) +} + +# --- Génération --- +big4 <- create_big_4D( + n = 50000000, + n_act_groups = 4, n_act_sub = 11, + n_geo_regions = 5, n_geo_sub = 10, + n_sex = 20, n_age = 15 +) + +# Copie des hrc dans un dossier persistant (tempdir() disparaît au restart) +hrc4 <- c( + ACT = file.path(BENCH_DIR, "hrc", "hrc_ACT.hrc"), + GEO = file.path(BENCH_DIR, "hrc", "hrc_GEO.hrc") +) +file.copy(big4$hrcfiles["ACT"], hrc4["ACT"], overwrite = TRUE) +file.copy(big4$hrcfiles["GEO"], hrc4["GEO"], overwrite = TRUE) + +tot4 <- big4$totcode + +dfs4_agg <- big4$data %>% + group_by(across(all_of(names(tot4)))) %>% + summarise(VALUE = sum(VALUE), freq = n(), .groups = "drop") + +rm(big4); gc() + +set.seed(42) +dfs4_agg$is_secret_prim <- sample( + c(TRUE, FALSE), nrow(dfs4_agg), + replace = TRUE, prob = c(0.01, 0.99) +) +dfs4_agg$secret_no_pl <- FALSE + +save(dfs4_agg, tot4, hrc4, file = file.path(BENCH_DIR, "input_data.RData")) +cat("Setup OK →", BENCH_DIR, "\n") +cat("Redémarrer R, puis lancer 01_bloc_old.R\n") + + +# BLOC 1 ------------------------------------------------------------------------- + + +# ============================================================================= +# 01_bloc_old.R — Session fraîche obligatoire +# Version originale (package installé). Redémarrer R après exécution. +# ============================================================================= +set.seed(42) +BENCH_DIR <- "Z:/benchmark_4d" +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" + +# Capture gc() sous forme de data.frame propre +capture_gc <- function(label) { + g <- gc() + data.frame( + label = label, + type = rownames(g), + used_mb = g[, 2], + trigger_mb = g[, 4], + max_mb = g[, 6], # pic depuis le dernier gc(reset=TRUE) + row.names = NULL + ) +} + +# Extrait la dernière colonne is_secret_N +get_last_secret_col <- function(df) { + cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] + if (!length(cols)) return(NULL) + cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) +} + +# Sauvegarde le résultat minimal pour comparaison (clés + secret final) +save_result_minimal <- function(df, tot4, label) { + cols_base <- c(names(tot4), "is_secret_prim") + last_col <- get_last_secret_col(df) + df_min <- as.data.frame(df)[, c(cols_base, last_col)] + names(df_min)[ncol(df_min)] <- "final_secret" + write.csv(df_min, file.path(BENCH_DIR, paste0("result_", label, ".csv")), + row.names = FALSE) + invisible(df_min) +} + + +BENCH_DIR <- "Z:/benchmark_4d" +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" + +library(data.table); library(dplyr); library(rtauargus) +options(rtauargus.tauargus_exe = loc_tauargus) + +load(file.path(BENCH_DIR, "input_data.RData")) # dfs4_agg, tot4, hrc4 + +# Reset du compteur de pic mémoire +gc(reset = TRUE) + +dir_old <- file.path(BENCH_DIR, "tauargus_old") +dir.create(file.path(dir_old, "hrc"), recursive = TRUE, showWarnings = FALSE) + +# --- reduce_dims --- +t_red <- system.time({ + res_red <- reduce_dims( + dfs = dfs4_agg, dfs_name = "tab_4d_int", + totcode = tot4, hrcfiles = hrc4, + nb_tab_option = "max", sep_dir = TRUE, + hrc_dir = file.path(dir_old, "hrc") + ) +}) + +# --- restore_format --- +t_rest <- system.time({ + rtauargus::restore_format(masq = res_red$tabs, res = res_red) +}) + +# --- flux complet --- +t_full <- system.time({ + res_old <- tab_rtauargus4( + tabular = dfs4_agg, explanatory_vars = names(tot4), + dir_name = dir_old, secret_var = "is_secret_prim", + totcode = tot4, hrc = hrc4, + value = "VALUE", freq = "freq", + suppress = "GH(1,100)", nb_tab_option = "max", + dfs_name = "tab_4d_int", limit = 1000000L + ) +}) + +# --- Sauvegarde --- +timing <- data.frame( + label = "old", + phase = c("reduce_dims", "restore_format", "tab_rtauargus4"), + elapsed = c(t_red["elapsed"], t_rest["elapsed"], t_full["elapsed"]), + user = c(t_red["user.self"], t_rest["user.self"], t_full["user.self"]), + sys = c(t_red["sys.self"], t_rest["sys.self"], t_full["sys.self"]) +) +write.csv(timing, file.path(BENCH_DIR, "timing_old.csv"), row.names = FALSE) + +gc_stats <- capture_gc("old") +write.csv(gc_stats, file.path(BENCH_DIR, "gc_old.csv"), row.names = FALSE) + +save_result_minimal(res_old, tot4, "old") + +cat("Bloc 01 terminé. Redémarrer R, puis lancer 02_bloc_new_true.R\n") + + +# BLOC 2------------------------------------------------------------------------- + +# ============================================================================= +# 02_bloc_new_true.R — Session fraîche obligatoire +# Version optimisée, keep_history = TRUE. Redémarrer R après exécution. +# ============================================================================= +set.seed(42) +BENCH_DIR <- "Z:/benchmark_4d" +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" + +# Capture gc() sous forme de data.frame propre +capture_gc <- function(label) { + g <- gc() + data.frame( + label = label, + type = rownames(g), + used_mb = g[, 2], + trigger_mb = g[, 4], + max_mb = g[, 6], # pic depuis le dernier gc(reset=TRUE) + row.names = NULL + ) +} + +# Extrait la dernière colonne is_secret_N +get_last_secret_col <- function(df) { + cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] + if (!length(cols)) return(NULL) + cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) +} + +# Sauvegarde le résultat minimal pour comparaison (clés + secret final) +save_result_minimal <- function(df, tot4, label) { + cols_base <- c(names(tot4), "is_secret_prim") + last_col <- get_last_secret_col(df) + df_min <- as.data.frame(df)[, c(cols_base, last_col)] + names(df_min)[ncol(df_min)] <- "final_secret" + write.csv(df_min, file.path(BENCH_DIR, paste0("result_", label, ".csv")), + row.names = FALSE) + invisible(df_min) +} + +BENCH_DIR <- "Z:/benchmark_4d" +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" + +library(data.table); library(dplyr) +devtools::load_all("Z:/rtauargus") +options(rtauargus.tauargus_exe = loc_tauargus) + +load(file.path(BENCH_DIR, "input_data.RData")) +gc(reset = TRUE) + +dir_new_t <- file.path(BENCH_DIR, "tauargus_new_true") +dir.create(file.path(dir_new_t, "hrc"), recursive = TRUE, showWarnings = FALSE) + +t_red <- system.time({ + res_red <- reduce_dims( + dfs = dfs4_agg, dfs_name = "tab_4d_int", + totcode = tot4, hrcfiles = hrc4, + nb_tab_option = "max", sep_dir = TRUE, + hrc_dir = file.path(dir_new_t, "hrc") + ) +}) + +t_rest <- system.time({ + restore_format(masq = res_red$tabs, res = res_red) +}) + +t_full <- system.time({ + res_new_true <- tab_rtauargus4( + tabular = dfs4_agg, explanatory_vars = names(tot4), + dir_name = dir_new_t, secret_var = "is_secret_prim", + totcode = tot4, hrc = hrc4, + value = "VALUE", freq = "freq", + suppress = "GH(1,100)", nb_tab_option = "max", + dfs_name = "tab_4d_int", limit = 1000000L, + keep_history = TRUE + ) +}) + +timing <- data.frame( + label = "new_true", + phase = c("reduce_dims", "restore_format", "tab_rtauargus4"), + elapsed = c(t_red["elapsed"], t_rest["elapsed"], t_full["elapsed"]), + user = c(t_red["user.self"], t_rest["user.self"], t_full["user.self"]), + sys = c(t_red["sys.self"], t_rest["sys.self"], t_full["sys.self"]) +) +write.csv(timing, file.path(BENCH_DIR, "timing_new_true.csv"), row.names = FALSE) + +gc_stats <- capture_gc("new_true") +write.csv(gc_stats, file.path(BENCH_DIR, "gc_new_true.csv"), row.names = FALSE) + +save_result_minimal(res_new_true, tot4, "new_true") + +cat("Bloc 02 terminé. Redémarrer R, puis lancer 03_bloc_new_false.R\n") + + +# BLOC 3 ------------------------------------------------------------------------- + +# ============================================================================= +# 03_bloc_new_false.R — Session fraîche obligatoire +# Version optimisée, keep_history = FALSE. Redémarrer R après exécution. +# ============================================================================= +set.seed(42) +BENCH_DIR <- "Z:/benchmark_4d" +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" + +# Capture gc() sous forme de data.frame propre +capture_gc <- function(label) { + g <- gc() + data.frame( + label = label, + type = rownames(g), + used_mb = g[, 2], + trigger_mb = g[, 4], + max_mb = g[, 6], + row.names = NULL + ) +} + +# Extrait la dernière colonne is_secret_N +get_last_secret_col <- function(df) { + cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] + if (!length(cols)) return(NULL) + cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) +} + +# Sauvegarde le résultat minimal pour comparaison (clés + secret final) +save_result_minimal <- function(df, tot4, label) { + cols_base <- c(names(tot4), "is_secret_prim") + last_col <- get_last_secret_col(df) + df_min <- as.data.frame(df)[, c(cols_base, last_col)] + names(df_min)[ncol(df_min)] <- "final_secret" + write.csv(df_min, file.path(BENCH_DIR, paste0("result_", label, ".csv")), + row.names = FALSE) + invisible(df_min) +} + +library(data.table); library(dplyr) +devtools::load_all("Z:/rtauargus") +options(rtauargus.tauargus_exe = loc_tauargus) + +load(file.path(BENCH_DIR, "input_data.RData")) +gc(reset = TRUE) + +dir_new_f <- file.path(BENCH_DIR, "tauargus_new_false") +dir.create(file.path(dir_new_f, "hrc"), recursive = TRUE, showWarnings = FALSE) + +t_red <- system.time({ + res_red <- reduce_dims( + dfs = dfs4_agg, dfs_name = "tab_4d_int", + totcode = tot4, hrcfiles = hrc4, + nb_tab_option = "max", sep_dir = TRUE, + hrc_dir = file.path(dir_new_f, "hrc") + ) +}) + +t_rest <- system.time({ + restore_format(masq = res_red$tabs, res = res_red) +}) + +t_full <- system.time({ + res_new_false <- tab_rtauargus4( + tabular = dfs4_agg, explanatory_vars = names(tot4), + dir_name = dir_new_f, secret_var = "is_secret_prim", + totcode = tot4, hrc = hrc4, + value = "VALUE", freq = "freq", + suppress = "GH(1,100)", nb_tab_option = "max", + dfs_name = "tab_4d_int", limit = 1000000L, + keep_history = FALSE + ) +}) + +timing <- data.frame( + label = "new_false", + phase = c("reduce_dims", "restore_format", "tab_rtauargus4"), + elapsed = c(t_red["elapsed"], t_rest["elapsed"], t_full["elapsed"]), + user = c(t_red["user.self"], t_rest["user.self"], t_full["user.self"]), + sys = c(t_red["sys.self"], t_rest["sys.self"], t_full["sys.self"]) +) +write.csv(timing, file.path(BENCH_DIR, "timing_new_false.csv"), row.names = FALSE) + +gc_stats <- capture_gc("new_false") +write.csv(gc_stats, file.path(BENCH_DIR, "gc_new_false.csv"), row.names = FALSE) + +save_result_minimal(res_new_false, tot4, "new_false") + +cat("Bloc 03 terminé. Redémarrer R, puis lancer 04_summary.R\n") + +# ============================================================================= +# 04_summary.R — Lecture des résultats, pas besoin de session fraîche +# ============================================================================= + +BENCH_DIR <- "Z:/benchmark_4d" +library(dplyr) + +# --- Timings --- +timing <- lapply( + c("old", "new_true", "new_false"), + function(l) read.csv(file.path(BENCH_DIR, paste0("timing_", l, ".csv"))) +) |> bind_rows() + +cat("\n=== TIMINGS (elapsed, secondes) ===\n") +print( + timing |> + select(label, phase, elapsed) |> + tidyr::pivot_wider(names_from = label, values_from = elapsed) +) + +# --- Mémoire peak --- +gc_all <- lapply( + c("old", "new_true", "new_false"), + function(l) read.csv(file.path(BENCH_DIR, paste0("gc_", l, ".csv"))) +) |> bind_rows() + +cat("\n=== PIC MÉMOIRE max_mb (Vcells) ===\n") +print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) + +# --- Égalité des résultats --- +results <- lapply( + c("old", "new_true", "new_false"), + function(l) read.csv(file.path(BENCH_DIR, paste0("result_", l, ".csv"))) +) +names(results) <- c("old", "new_true", "new_false") + +normalize <- function(df) { + df <- df[do.call(order, df[c("ACT", "GEO", "SEX", "AGE")]), ] + rownames(df) <- NULL + df +} + +cat("\n=== ÉGALITÉ DES MASQUES DE SECRET FINAL ===\n") +cat("old == new_true :", identical(normalize(results$old), normalize(results$new_true)), "\n") +cat("old == new_false :", identical(normalize(results$old), normalize(results$new_false)), "\n") + +# --- Stats secret --- +secret_stats <- lapply(names(results), function(l) { + df <- results[[l]] + data.frame( + label = l, + n_prim = sum(df$is_secret_prim), + n_sec = sum(df$final_secret & !df$is_secret_prim), + n_total_masque = sum(df$final_secret), + pct_masque = round(100 * mean(df$final_secret), 2) + ) +}) |> bind_rows() + +cat("\n=== STATISTIQUES DE SECRET ===\n") +print(secret_stats) diff --git a/bench/bench_perf_improv_functions.R b/bench/bench_perf_improv_functions.R new file mode 100644 index 0000000..521afc5 --- /dev/null +++ b/bench/bench_perf_improv_functions.R @@ -0,0 +1,1155 @@ +# ============================================================================= +# Test comparatif – Grosses données – Mode SMART (cas d'usage réel) +# Version officielle (package) vs version locale optimisée +# ============================================================================= + +true_package = TRUE # Warning : restart R before editing this value +if (true_package){ + library(rtauargus) # package originale +} else { + devtools::load_all("Z:/rtauargus") # path où est la version split_perf de github : https://github.com/InseeFrLab/rtauargus/tree/split_perf_improvement +} + +library(dplyr) +library(sdcHierarchies) +library(microbenchmark) + +# ----------------------------- Chargement des sources locales optimisées +local_R_dir <- "Z:/rtauargus/R" # <-- adapter au besoin +source(file.path(local_R_dir, "sp_var_to_merge.R")) +source(file.path(local_R_dir, "sp_from_4_to_3.R")) +source(file.path(local_R_dir, "sp_from_4_to_3_case_0_hr.R")) +source(file.path(local_R_dir, "sp_from_4_to_3_case_1_hr.R")) +source(file.path(local_R_dir, "sp_from_4_to_3_case_2_hr.R")) +source(file.path(local_R_dir, "sp_from_5_to_3.R")) +source(file.path(local_R_dir, "sp_reduce_dims.R")) +source(file.path(local_R_dir, "sp_restore_format.R")) + +# ============================================================================= +# 1. Création de gros jeux de données avec hiérarchies profondes +# ============================================================================= + +# --- 4D volumineux (ACT hiérarchique, GEO hiérarchique, SEX & AGE non hiérarchiques) +create_big_4D <- function(n = 50000) { + set.seed(123) + data <- data.frame( + ACT = sample(c("Total", paste0("A", 1:20), paste0("A", 1:20, "_", 1:5)), n, replace = TRUE), + GEO = sample(c("Total", "G1", "G2", "G1a", "G1b", "G2a", "G2b"), n, replace = TRUE), + SEX = sample(c("Total", "F", "M"), n, replace = TRUE), + AGE = sample(c("Total", "AGE1", "AGE2", "AGE3", "AGE4"), n, replace = TRUE), + stringsAsFactors = FALSE + ) + data$VALUE <- 1 + + # Hiérarchie ACT : 20 groupes, chacun avec 5 sous‑niveaux + hrc_act <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total", nodes = paste0("A", 1:20)) %>% + { + for (i in 1:20) { + . <- sdcHierarchies::hier_add(., root = paste0("A", i), nodes = paste0("A", i, "_", 1:5)) + } + . + } %>% + 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) + + # Hiérarchie GEO : 2 régions, chacune avec 2 sous‑régions + hrc_geo <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total", nodes = c("G1", "G2")) %>% + sdcHierarchies::hier_add(root = "G1", nodes = c("G1a", "G1b")) %>% + sdcHierarchies::hier_add(root = "G2", nodes = c("G2a", "G2b")) %>% + 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) + + list(data = data, + hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), + totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total")) +} + +# --- 5D volumineux (ACT hiérarchique profond, GEO hiérarchique, autres non hiérarchiques) +create_big_5D <- function(n = 80000) { + set.seed(234) + data <- data.frame( + ACT = sample(c("Total_A", paste0("A", 1:20, "_"), paste0("A", 1:20, "_", 1:5)), n, replace = TRUE), + GEO = sample(c("Total_G", "GA","GB","GA1","GA2","GB1","GB2","GA3","GB3"), n, replace = TRUE), + SEX = sample(c("Total_S", "F", "M", "F1", "F2", "M1", "M2"), n, replace = TRUE), + AGE = sample(c("Ensemble", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), n, replace = TRUE), + ECO = sample(c("PIB", "Ménages", "Entreprises"), n, replace = TRUE), + stringsAsFactors = FALSE + ) + data$VALUE <- 1 + + # Hiérarchie ACT (5D) : 20 groupes, chaque avec 5 sous‑niveaux + hrc_act <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total_A", nodes = paste0("A", 1:20, "_")) %>% + { + for (i in 1:20) { + . <- sdcHierarchies::hier_add(., root = paste0("A", i, "_"), nodes = paste0("A", i, "_", 1:5)) + } + . + } %>% + 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) + + # Hiérarchie GEO (5D) : 2 régions, 3‑4 sous‑régions chacune + hrc_geo <- tempfile(fileext = ".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")) %>% + 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) + + list(data = data, + hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), + totcode = c(SEX = "Total_S", AGE = "Ensemble", GEO = "Total_G", ACT = "Total_A", ECO = "PIB")) +} + +# ============================================================================= +# 2. Fonctions de validation et de benchmark +# ============================================================================= + +check_equality <- function(res_orig, res_opt) { + if (is.list(res_orig) && is.list(res_opt)) { + if (length(res_orig) != length(res_opt)) return(FALSE) + return(all(mapply(check_equality, res_orig, res_opt, SIMPLIFY = TRUE))) + } else if (is.data.frame(res_orig)) { + return(identical(res_orig, res_opt)) + } else { + return(identical(res_orig, res_opt)) + } +} + +validate <- function(desc, expr_orig, expr_opt) { + cat("\n--- Validation :", desc, "---\n") + + # On capture les erreurs sous forme d'objets R "error" exploitables + res_o <- tryCatch(expr_orig, error = function(e) e) + res_n <- tryCatch(expr_opt, error = function(e) e) + + has_error_o <- inherits(res_o, "error") + has_error_n <- inherits(res_n, "error") + + # Si l'une des versions a levé une erreur + if (has_error_o || has_error_n) { + cat("Une erreur est survenue lors de l'exécution :\n") + if (has_error_o) { + cat(" - Original : Erreur ->", res_o$message, "\n") + } else { + cat(" - Original : Succès (Type :", class(res_o)[1], ")\n") + } + if (has_error_n) { + cat(" - Optimisé : Erreur ->", res_n$message, "\n") + } else { + cat(" - Optimisé : Succès (Type :", class(res_n)[1], ")\n") + } + return(FALSE) + } + + # Si les deux versions ont réussi, on compare l'égalité logique + eq <- check_equality(res_o, res_n) + if (eq) { + cat("Résultats identiques.\n") + } else { + cat("Résultats DIFFÉRENTS.\n") + } + return(eq) +} + +all_benchmarks <- list() + +clear_cache <- function() { + if (exists(".hrc_cache", envir = .GlobalEnv)) { + rm(list = ls(envir = .hrc_cache), envir = .hrc_cache) + } +} + +bench <- function(name_o, name_n, expr_o, expr_n, times = 20) { + expr_o_sub <- substitute(expr_o) + expr_n_sub <- substitute(expr_n) + + # Création d'expressions composées avec vidage du cache + expr_o_clean <- bquote({ clear_cache(); .(expr_o_sub) }) + expr_n_clean <- bquote({ clear_cache(); .(expr_n_sub) }) + + res <- eval(bquote(microbenchmark::microbenchmark( + original = .(expr_o_clean), + optimise = .(expr_n_clean), + times = .(times) + ))) + print(res, unit = "ms") + all_benchmarks[[paste(name_o, "vs", name_n)]] <<- res + invisible(res) +} + +# ============================================================================= +# 3. Exécution des tests +# ============================================================================= + +# ---- Initialisation des gros jeux de données ---- +cat("Création du jeu 4D volumineux...\n") +big4 <- create_big_4D(50000) +dfs4 <- big4$data; tot4 <- big4$totcode; hrc4 <- big4$hrcfiles + +cat("Création du jeu 5D volumineux...\n") +big5 <- create_big_5D(80000) +dfs5 <- big5$data; tot5 <- big5$totcode; hrc5 <- big5$hrcfiles + +# ---- 3.1 length_tabs (tests de bas niveau avec variables imposées) ---- +cat("\n========== length_tabs ==========\n") + +validate("length_tabs 4D ACT x SEX", + rtauargus:::length_tabs(dfs4, "ACT", "SEX", totcode = tot4, hrcfiles = hrc4), + length_tabs(dfs4, "ACT", "SEX", totcode = tot4, hrcfiles = hrc4)) +bench("length_tabs_4D_ACT_SEX", "length_tabs_4D_ACT_SEX_opt", + rtauargus:::length_tabs(dfs4, "ACT", "SEX", totcode = tot4, hrcfiles = hrc4), + length_tabs(dfs4, "ACT", "SEX", totcode = tot4, hrcfiles = hrc4), times = 5) + +validate("length_tabs 5D ACT/GEO/AGE/ECO", + rtauargus:::length_tabs(dfs5, "ACT", "GEO", "AGE", "ECO", totcode = tot5, hrcfiles = hrc5), + length_tabs(dfs5, "ACT", "GEO", "AGE", "ECO", totcode = tot5, hrcfiles = hrc5)) +bench("length_tabs_5D_ACT_GEO_AGE_ECO", "length_tabs_5D_ACT_GEO_AGE_ECO_opt", + rtauargus:::length_tabs(dfs5, "ACT", "GEO", "AGE", "ECO", totcode = tot5, hrcfiles = hrc5), + length_tabs(dfs5, "ACT", "GEO", "AGE", "ECO", totcode = tot5, hrcfiles = hrc5), times = 5) + +# ---- 3.2 var_to_merge (smart automatique) ---- +cat("\n========== var_to_merge (smart) ==========\n") + +validate("var_to_merge 4D smart", + rtauargus:::var_to_merge(dfs4, tot4, hrc4, nb_var = 2, nb_tab_option = 'smart', limit = 2000), + var_to_merge(dfs4, tot4, hrc4, nb_var = 2, nb_tab_option = 'smart', limit = 2000)) +bench("var_to_merge_4D_smart", "var_to_merge_4D_smart_opt", + rtauargus:::var_to_merge(dfs4, tot4, hrc4, nb_var = 2, nb_tab_option = 'smart', limit = 2000), + var_to_merge(dfs4, tot4, hrc4, nb_var = 2, nb_tab_option = 'smart', limit = 2000), times = 5) + +validate("var_to_merge 5D 4var smart", + rtauargus:::var_to_merge(dfs5, tot5, hrc5, nb_var = 4, nb_tab_option = 'smart', limit = 5000), + var_to_merge(dfs5, tot5, hrc5, nb_var = 4, nb_tab_option = 'smart', limit = 5000)) +bench("var_to_merge_5D_4var_smart", "var_to_merge_5D_4var_smart_opt", + rtauargus:::var_to_merge(dfs5, tot5, hrc5, nb_var = 4, nb_tab_option = 'smart', limit = 5000), + var_to_merge(dfs5, tot5, hrc5, nb_var = 4, nb_tab_option = 'smart', limit = 5000), times = 5) + +validate("var_to_merge 5D 3var smart", + rtauargus:::var_to_merge(dfs5, tot5, hrc5, nb_var = 3, nb_tab_option = 'smart', limit = 5000), + var_to_merge(dfs5, tot5, hrc5, nb_var = 3, nb_tab_option = 'smart', limit = 5000)) +bench("var_to_merge_5D_3var_smart", "var_to_merge_5D_3var_smart_opt", + rtauargus:::var_to_merge(dfs5, tot5, hrc5, nb_var = 3, nb_tab_option = 'smart', limit = 5000), + var_to_merge(dfs5, tot5, hrc5, nb_var = 3, nb_tab_option = 'smart', limit = 5000), times = 5) + +# ---- 3.3 reduce_dims 4D en mode SMART (cas réel) ---- +cat("\n========== reduce_dims 4D SMART ==========\n") + +validate("reduce_dims 4D smart (limit=2000, pas d'over_split)", + rtauargus:::reduce_dims(dfs4, "tab", tot4, hrc4, + vars_to_merge = NULL, + nb_tab_option = "smart", limit = 2000, + over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), + reduce_dims(dfs4, "tab", tot4, hrc4, + vars_to_merge = NULL, + nb_tab_option = "smart", limit = 2000, + over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir())) +bench("reduce_dims_4D_smart", "reduce_dims_4D_smart_opt", + rtauargus:::reduce_dims(dfs4, "tab", tot4, hrc4, + vars_to_merge = NULL, + nb_tab_option = "smart", limit = 2000, + over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), + reduce_dims(dfs4, "tab", tot4, hrc4, + vars_to_merge = NULL, + nb_tab_option = "smart", limit = 2000, + over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), + times = 5) # 10 répétitions seulement car déjà très lourd + +# ---- 3.4 reduce_dims 5D en mode SMART (cas réel) ---- +cat("\n========== reduce_dims 5D SMART ==========\n") + +validate("reduce_dims 5D smart (limit=5000, pas d'over_split)", + rtauargus:::reduce_dims(dfs5, "tab", tot5, hrc5, + vars_to_merge = NULL, + nb_tab_option = "smart", limit = 5000, + over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), + reduce_dims(dfs5, "tab", tot5, hrc5, + vars_to_merge = NULL, + nb_tab_option = "smart", limit = 5000, + over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir())) +bench("reduce_dims_5D_smart", "reduce_dims_5D_smart_opt", + rtauargus:::reduce_dims(dfs5, "tab", tot5, hrc5, + vars_to_merge = NULL, + nb_tab_option = "smart", limit = 5000, + over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), + reduce_dims(dfs5, "tab", tot5, hrc5, + vars_to_merge = NULL, + nb_tab_option = "smart", limit = 5000, + over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), + times = 5) + +cat("\n===== Fin des tests. =====\n") + +# ============================================================================= +# RÉCAPITULATIF FINAL (tous les benchmarks en ms) +# ============================================================================= +cat("\n\n========== RÉCAPITULATIF DE TOUS LES BENCHMARKS (ms) ==========\n") +for (nom in names(all_benchmarks)) { + cat("\n---", nom, "---\n") + print(all_benchmarks[[nom]], unit = "ms") +} + + +# ------------------------------------------------------------------------- + +# ============================================================================= +# Three-Way Comparison Script: Real Output vs. Package Version vs. Local Version +# Verifying table counts and sorted sizes for 3 non-hierarchical variables +# ============================================================================= + +run_three_way_comparison <- function() { + cat("\n=======================================================================\n") + cat(" THREE-WAY COMPARISON: REAL vs. PACKAGE vs. LOCAL \n") + cat("=======================================================================\n") + + # --------------------------------------------------------------------------- + # TEST CASE 1: n_mod_v1 = 3, n_mod_v2 = 4, n_mod_v3 = 3 + # Unmerged variables multiplier (V4 x V5) = 2 x 2 = 4 + # --------------------------------------------------------------------------- + cat("\n--- Test Case 1: n_mod_v1 = 3, n_mod_v2 = 4, n_mod_v3 = 3 ---\n") + + test_data_1 <- expand.grid( + V1 = c("Total", "A1", "A2"), # n_mod_v1 = 3 + V2 = c("Total", "B1", "B2", "B3"), # n_mod_v2 = 4 + V3 = c("Total", "C1", "C2"), # n_mod_v3 = 3 + V4 = c("Total", "D1"), # n_mod_v4 = 2 + V5 = c("Total", "E1"), # n_mod_v5 = 2 + stringsAsFactors = FALSE + ) + test_data_1$VALUE <- 1 + totcode_1 <- c(V1 = "Total", V2 = "Total", V3 = "Total", V4 = "Total", V5 = "Total") + + # 1. Real ground truth: count and sizes of generated data frames + real_res_1 <- reduce_dims( + dfs = test_data_1, + dfs_name = "test1", + totcode = totcode_1, + hrcfiles = NULL, + vars_to_merge = c("V1", "V2", "V3"), + sep_dir = TRUE, + hrc_dir = tempdir() + ) + real_sizes_1 <- sort(sapply(real_res_1$tabs, nrow)) + real_count_1 <- length(real_sizes_1) + + # 2. Package estimation (rtauargus original buggy formula) + pkg_sizes_1 <- sort(unlist(rtauargus:::length_tabs( + dfs = test_data_1, + v1 = "V1", v2 = "V2", v3 = "V3", + totcode = totcode_1, + hrcfiles = NULL + ))) + pkg_count_1 <- length(pkg_sizes_1) + + # 3. Local estimation (corrected formula) + local_sizes_1 <- sort(unlist(length_tabs( + dfs = test_data_1, + v1 = "V1", v2 = "V2", v3 = "V3", + totcode = totcode_1, + hrcfiles = NULL + ))) + local_count_1 <- length(local_sizes_1) + + # Display results for Test Case 1 + cat("\n[Table Count Summary]\n") + cat(" - Real generated tables :", real_count_1, "\n") + cat(" - Package prediction :", pkg_count_1, " (Error:", pkg_count_1 - real_count_1, ")\n") + cat(" - Local prediction :", local_count_1, " (Error:", local_count_1 - real_count_1, ")\n") + + cat("\n[Sorted Table Sizes Comparison]\n") + cat(" - Real actual sizes :", paste(real_sizes_1, collapse = ", "), "\n") + cat(" - Package predicted :", paste(pkg_sizes_1, collapse = ", "), "\n") + cat(" - Local predicted :", paste(local_sizes_1, collapse = ", "), "\n") + + # --------------------------------------------------------------------------- + # TEST CASE 2: n_mod_v1 = 4, n_mod_v2 = 3, n_mod_v3 = 4 + # Unmerged variables multiplier (V4 x V5) = 2 x 3 = 6 + # --------------------------------------------------------------------------- + cat("\n-----------------------------------------------------------------------\n") + cat("\n--- Test Case 2: n_mod_v1 = 4, n_mod_v2 = 3, n_mod_v3 = 4 ---\n") + + test_data_2 <- expand.grid( + V1 = c("Total", "A1", "A2", "A3"), # n_mod_v1 = 4 + V2 = c("Total", "B1", "B2"), # n_mod_v2 = 3 + V3 = c("Total", "C1", "C2", "C3"), # n_mod_v3 = 4 + V4 = c("Total", "D1"), # n_mod_v4 = 2 + V5 = c("Total", "E1", "E2"), # n_mod_v5 = 3 + stringsAsFactors = FALSE + ) + test_data_2$VALUE <- 1 + totcode_2 <- c(V1 = "Total", V2 = "Total", V3 = "Total", V4 = "Total", V5 = "Total") + + # 1. Real ground truth: count and sizes of generated data frames + real_res_2 <- reduce_dims( + dfs = test_data_2, + dfs_name = "test2", + totcode = totcode_2, + hrcfiles = NULL, + vars_to_merge = c("V1", "V2", "V3"), + sep_dir = TRUE, + hrc_dir = tempdir() + ) + real_sizes_2 <- sort(sapply(real_res_2$tabs, nrow)) + real_count_2 <- length(real_sizes_2) + + # 2. Package estimation (rtauargus original buggy formula) + pkg_sizes_2 <- sort(unlist(rtauargus:::length_tabs( + dfs = test_data_2, + v1 = "V1", v2 = "V2", v3 = "V3", + totcode = totcode_2, + hrcfiles = NULL + ))) + pkg_count_2 <- length(pkg_sizes_2) + + # 3. Local estimation (corrected formula) + local_sizes_2 <- sort(unlist(length_tabs( + dfs = test_data_2, + v1 = "V1", v2 = "V2", v3 = "V3", + totcode = totcode_2, + hrcfiles = NULL + ))) + local_count_2 <- length(local_sizes_2) + + # Display results for Test Case 2 + cat("\n[Table Count Summary]\n") + cat(" - Real generated tables :", real_count_2, "\n") + cat(" - Package prediction :", pkg_count_2, " (Error:", pkg_count_2 - real_count_2, ")\n") + cat(" - Local prediction :", local_count_2, " (Error:", local_count_2 - real_count_2, ")\n") + + cat("\n[Sorted Table Sizes Comparison]\n") + cat(" - Real actual sizes :", paste(real_sizes_2, collapse = ", "), "\n") + cat(" - Package predicted :", paste(pkg_sizes_2, collapse = ", "), "\n") + cat(" - Local predicted :", paste(local_sizes_2, collapse = ", "), "\n") +} + +# Run the three-way comparison +run_three_way_comparison() + + +# ------------------------------------------------------------------------- + +# ============================================================================= +# Validation Script for nb_tab_generated: Real vs. Local (corrected) +# Verifying node-counting simplification across different triplet scenarios +# ============================================================================= + +verify_nb_tab_generated <- function() { + cat("\n=======================================================================\n") + cat(" VALIDATION OF nb_tab_generated: REAL vs. LOCAL (CORRECTED) \n") + cat("=======================================================================\n") + + # Configuration du jeu de données 5D (issu de votre script de benchmark) + # dfs5, tot5, hrc5 doivent être chargés en mémoire. + + # --- Scenario 1: Triplet merging 2 hierarchical variables & 1 flat variable + # Variables: ACT (Hierarchical), GEO (Hierarchical), SEX (Flat) + cat("\n[Scenario 1] Merging 2 Hierarchical (ACT, GEO) & 1 Flat (SEX):\n") + + real_res_1 <- reduce_dims( + dfs = dfs5, dfs_name = "scen1", totcode = tot5, hrcfiles = hrc5, + vars_to_merge = c("ACT", "GEO", "SEX"), + sep_dir = TRUE, hrc_dir = tempdir() + ) + real_count_1 <- length(real_res_1$tabs) + + local_count_1 <- nb_tab_generated( + v1 = "ACT", v2 = "GEO", v3 = "SEX", + hrcfiles = hrc5, totcode = tot5, data = dfs5 + ) + + cat(" - Real count :", real_count_1, "\n") + cat(" - Local pred :", local_count_1, "\n") + match_1 <- real_count_1 == local_count_1 + cat(" - Exact match :", match_1, "\n") + + # --- Scenario 2: Triplet merging 1 hierarchical variable & 2 flat variables + # Variables: ACT (Hierarchical), SEX (Flat), AGE (Flat) + cat("\n[Scenario 2] Merging 1 Hierarchical (ACT) & 2 Flat (SEX, AGE):\n") + + real_res_2 <- reduce_dims( + dfs = dfs5, dfs_name = "scen2", totcode = tot5, hrcfiles = hrc5, + vars_to_merge = c("ACT", "SEX", "AGE"), + sep_dir = TRUE, hrc_dir = tempdir() + ) + real_count_2 <- length(real_res_2$tabs) + + local_count_2 <- nb_tab_generated( + v1 = "ACT", v2 = "SEX", v3 = "AGE", + hrcfiles = hrc5, totcode = tot5, data = dfs5 + ) + + cat(" - Real count :", real_count_2, "\n") + cat(" - Local pred :", local_count_2, "\n") + match_2 <- real_count_2 == local_count_2 + cat(" - Exact match :", match_2, "\n") + + # --- Scenario 3: Triplet merging 3 flat variables + # Variables: SEX (Flat), AGE (Flat), ECO (Flat) + cat("\n[Scenario 3] Merging 3 Flat variables (SEX, AGE, ECO):\n") + + real_res_3 <- reduce_dims( + dfs = dfs5, dfs_name = "scen3", totcode = tot5, hrcfiles = hrc5, + vars_to_merge = c("SEX", "AGE", "ECO"), + sep_dir = TRUE, hrc_dir = tempdir() + ) + real_count_3 <- length(real_res_3$tabs) + + local_count_3 <- nb_tab_generated( + v1 = "SEX", v2 = "AGE", v3 = "ECO", + hrcfiles = hrc5, totcode = tot5, data = dfs5 + ) + + cat(" - Real count :", real_count_3, "\n") + cat(" - Local pred :", local_count_3, "\n") + match_3 <- real_count_3 == local_count_3 + cat(" - Exact match :", match_3, "\n") + + cat("\n=======================================================================\n") + if (match_1 && match_2 && match_3) { + cat(" SYNTHESIS: The corrected local formulas are valid.\n") + cat(" The predictions match the real generated table counts\n") + cat(" in all test scenarios.\n") + } else { + cat(" SYNTHESIS: Mismatch detected. Please check the code.\n") + } + cat("=======================================================================\n") +} + +# Run the validation +verify_nb_tab_generated() + +# il y a des écarts, mais cela peut être du à une tbale sparse : des croisements sans observations => pas de tables générées + + +# ------------------------------------------------------------------------- + + +# ============================================================================= +# Validation Script for nb_tab_generated with FULL factorial data +# (no sparse cells – theory == practice) +# ============================================================================= + +verify_nb_tab_generated_full <- function() { + cat("\n=======================================================================\n") + cat(" VALIDATION OF nb_tab_generated: REAL vs. LOCAL (FULL FACTORIAL) \n") + cat("=======================================================================\n") + + # -------------------------------------------------------------------------- + # Helper: create a small hierarchy file (in memory) and return its path + # -------------------------------------------------------------------------- + make_small_hrc <- function(root, children, subchildren = NULL) { + tmp <- tempfile(fileext = ".hrc") + h <- sdcHierarchies::hier_create(root = root, nodes = children) + if (!is.null(subchildren)) { + for (i in seq_along(children)) { + h <- sdcHierarchies::hier_add(h, root = children[i], nodes = subchildren[[i]]) + } + } + h %>% + sdcHierarchies::hier_convert(as = "argus") %>% + slice(-1) %>% + mutate(levels = substring(paste0(level, name), 3)) %>% + select(levels) %>% + write.table(file = tmp, row.names = FALSE, col.names = FALSE, quote = FALSE) + return(tmp) + } + + # -------------------------------------------------------------------------- + # Scenario 1: 2 hierarchical (ACT, GEO) + 1 flat (SEX) + # -------------------------------------------------------------------------- + cat("\n[Scenario 1] 2 hierarchical + 1 flat (full factorial)\n") + + # Small hierarchies + hrc_act <- make_small_hrc( + root = "Total", + children = c("A1", "A2"), + subchildren = list(c("A1_a", "A1_b"), c("A2_a", "A2_b")) + ) + hrc_geo <- make_small_hrc( + root = "Total", + children = c("G1", "G2"), + subchildren = list(c("G1_x", "G1_y"), c("G2_x", "G2_y")) + ) + + # All modalities for each variable (including totals) + act_mods <- c("Total", "A1", "A2", "A1_a", "A1_b", "A2_a", "A2_b") + geo_mods <- c("Total", "G1", "G2", "G1_x", "G1_y", "G2_x", "G2_y") + sex_mods <- c("Total", "F", "M") + # Dummy 4th & 5th variables (not merged) + v4_mods <- c("Total", "X") + v5_mods <- c("Total", "Y") + + d1 <- expand.grid( + ACT = act_mods, + GEO = geo_mods, + SEX = sex_mods, + V4 = v4_mods, + V5 = v5_mods, + stringsAsFactors = FALSE + ) + d1$VALUE <- 1 + + tot1 <- c(ACT = "Total", GEO = "Total", SEX = "Total", V4 = "Total", V5 = "Total") + hrc1 <- c(ACT = hrc_act, GEO = hrc_geo) + + real1 <- reduce_dims( + dfs = d1, dfs_name = "full1", totcode = tot1, hrcfiles = hrc1, + vars_to_merge = c("ACT", "GEO", "SEX"), + sep_dir = TRUE, hrc_dir = tempdir() + ) + local1 <- nb_tab_generated( + v1 = "ACT", v2 = "GEO", v3 = "SEX", + hrcfiles = hrc1, totcode = tot1, data = d1 + ) + + cat(" - Real count :", length(real1$tabs), "\n") + cat(" - Local pred :", local1, "\n") + cat(" - Exact match :", length(real1$tabs) == local1, "\n") + + # -------------------------------------------------------------------------- + # Scenario 2: 1 hierarchical (ACT) + 2 flat (SEX, AGE) + # -------------------------------------------------------------------------- + cat("\n[Scenario 2] 1 hierarchical + 2 flat (full factorial)\n") + + age_mods <- c("Total", "AGE1", "AGE2") + d2 <- expand.grid( + ACT = act_mods, + SEX = sex_mods, + AGE = age_mods, + V4 = v4_mods, + V5 = v5_mods, + stringsAsFactors = FALSE + ) + d2$VALUE <- 1 + + tot2 <- c(ACT = "Total", SEX = "Total", AGE = "Total", V4 = "Total", V5 = "Total") + hrc2 <- c(ACT = hrc_act) + + real2 <- reduce_dims( + dfs = d2, dfs_name = "full2", totcode = tot2, hrcfiles = hrc2, + vars_to_merge = c("ACT", "SEX", "AGE"), + sep_dir = TRUE, hrc_dir = tempdir() + ) + local2 <- nb_tab_generated( + v1 = "ACT", v2 = "SEX", v3 = "AGE", + hrcfiles = hrc2, totcode = tot2, data = d2 + ) + + cat(" - Real count :", length(real2$tabs), "\n") + cat(" - Local pred :", local2, "\n") + cat(" - Exact match :", length(real2$tabs) == local2, "\n") + + # -------------------------------------------------------------------------- + # Scenario 3: 3 flat variables (already matched, but included for completeness) + # -------------------------------------------------------------------------- + cat("\n[Scenario 3] 3 flat variables (full factorial)\n") + + eco_mods <- c("Total", "E1", "E2") + d3 <- expand.grid( + SEX = sex_mods, + AGE = age_mods, + ECO = eco_mods, + V4 = v4_mods, + V5 = v5_mods, + stringsAsFactors = FALSE + ) + d3$VALUE <- 1 + + tot3 <- c(SEX = "Total", AGE = "Total", ECO = "Total", V4 = "Total", V5 = "Total") + hrc3 <- NULL + + real3 <- reduce_dims( + dfs = d3, dfs_name = "full3", totcode = tot3, hrcfiles = hrc3, + vars_to_merge = c("SEX", "AGE", "ECO"), + sep_dir = TRUE, hrc_dir = tempdir() + ) + local3 <- nb_tab_generated( + v1 = "SEX", v2 = "AGE", v3 = "ECO", + hrcfiles = hrc3, totcode = tot3, data = d3 + ) + + cat(" - Real count :", length(real3$tabs), "\n") + cat(" - Local pred :", local3, "\n") + cat(" - Exact match :", length(real3$tabs) == local3, "\n") + + cat("\n=======================================================================\n") + cat(" If all three scenarios show Exact match = TRUE,\n") + cat(" the nb_tab_generated formulas are fully correct.\n") + cat("=======================================================================\n") +} + +# Run the full factorial validation +verify_nb_tab_generated_full() # ok, tout est bon + + +# ------------------------------------------------------------------------- + +# ============================================================================= +# Validation des options heuristiques 'min' et 'max' (4D & 5D) +# ============================================================================= +cat("\n=======================================================================\n") +cat(" VALIDATION DES HEURISTIQUES : OPTIONS MIN ET MAX \n") +cat("=======================================================================\n") + +# --- Validation 4D Option MIN +validate("reduce_dims 4D - Option MIN", + rtauargus:::reduce_dims(dfs4, "tab_min4", tot4, hrc4, + nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir()), + reduce_dims(dfs4, "tab_min4", tot4, hrc4, + nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir())) + +# --- Validation 4D Option MAX +validate("reduce_dims 4D - Option MAX", + rtauargus:::reduce_dims(dfs4, "tab_max4", tot4, hrc4, + nb_tab_option = "max", sep_dir = TRUE, hrc_dir = tempdir()), + reduce_dims(dfs4, "tab_max4", tot4, hrc4, + nb_tab_option = "max", sep_dir = TRUE, hrc_dir = tempdir())) + +# --- Validation 5D Option MIN +validate("reduce_dims 5D - Option MIN", + rtauargus:::reduce_dims(dfs5, "tab_min5", tot5, hrc5, + nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir()), + reduce_dims(dfs5, "tab_min5", tot5, hrc5, + nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir())) + +# --- Validation 5D Option MAX +validate("reduce_dims 5D - Option MAX", + rtauargus:::reduce_dims(dfs5, "tab_max5", tot5, hrc5, + nb_tab_option = "max", sep_dir = TRUE, hrc_dir = tempdir()), + reduce_dims(dfs5, "tab_max5", tot5, hrc5, + nb_tab_option = "max", sep_dir = TRUE, hrc_dir = tempdir())) + +# --- Benchmark comparatif (Option MIN sur données 5D volumineuses) +bench("reduce_dims_5D_min_original", "reduce_dims_5D_min_optimise", + rtauargus:::reduce_dims(dfs5, "tab_min5", tot5, hrc5, + nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir()), + reduce_dims(dfs5, "tab_min5", tot5, hrc5, + nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir()), + times = 5) + + +# ------------------------------------------------------------------------- + +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" +options(rtauargus.tauargus_exe = loc_tauargus) + + +Sys.time() + +# ============================================================================= +# Test d'intégration de bout en bout avec tab_rtauargus4 (avec Tau-Argus) +# ============================================================================= +cat("\n=======================================================================\n") +cat(" TEST D'INTÉGRATION DE BOUT EN BOUT : tab_rtauargus4 \n") +cat("=======================================================================\n") + +# --- Préparation des variables requises par tab_rtauargus4 +# La fonction nécessite des colonnes pour la valeur, la fréquence et le secret primaire. +dfs4$freq <- 1 +dfs4$is_secret_prim <- FALSE + +# On force arbitrairement quelques cellules en secret primaire +dfs4$is_secret_prim[dfs4$ACT %in% c("A1", "A2") & dfs4$GEO == "G1"] <- TRUE + +dfs4_agg <- dfs4 %>% + group_by(across(all_of(names(tot4)))) %>% + summarise( + VALUE = sum(VALUE), + freq = sum(freq), + is_secret_prim = as.logical(max(is_secret_prim)), # TRUE si au moins une ligne est secrète + .groups = "drop" + ) + +# --- Vérification de la configuration de l'exécutable Tau-Argus +tau_exe <- getOption("rtauargus.tauargus_exe") + +if (is.null(tau_exe) || !file.exists(tau_exe)) { + cat("\n[INFO] L'exécutable Tau-Argus n'est pas configuré ou reste introuvable.\n") + cat("Pour lancer ce test d'intégration réel avec Tau-Argus, configurez son chemin :\n") + cat("options(rtauargus.tauargus_exe = \"C:/Chemin/Vers/TauArgus.exe\")\n\n") +} else { + cat("Exécutable Tau-Argus détecté :", tau_exe, "\n") + cat("Lancement des validations et benchmarks de bout en bout...\n") + + # Dossier de sortie temporaire pour les fichiers de travail de Tau-Argus + dir_output <- file.path(tempdir(), "tauargus_output") + if (!dir.exists(dir_output)) dir.create(dir_output, recursive = TRUE) + + # --- Validation logique (Version originale vs Version optimisée) + # On utilise la méthode de suppression rapide Hypercube "GH(1,100)" + validate( + "tab_rtauargus4 - 4D complet (Méthode Hypercube rapide GH)", + # Version originale du package installé + rtauargus::tab_rtauargus4( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_output, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + nb_tab_option = "smart", + limit = 50000, + dfs_name = "tab_4d_int" + ), + # Version locale optimisée (Sourced) + tab_rtauargus4( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_output, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + nb_tab_option = "smart", + limit = 50000, + dfs_name = "tab_4d_int" + ) + ) + + # --- Benchmark du flux complet (Écriture fichiers -> Appel Tau-Argus -> Restauration) + # On effectue 3 répétitions car l'appel externe à Tau-Argus et l'écriture disque + # imposent un temps de traitement incompressible. + bench( + "tab_rtauargus4_original_full", "tab_rtauargus4_optimise_full", + rtauargus::tab_rtauargus4( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_output, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + nb_tab_option = "smart", + limit = 50000, + dfs_name = "tab_4d_int" + ), + tab_rtauargus4( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_output, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + nb_tab_option = "smart", + limit = 50000, + dfs_name = "tab_4d_int" + ), + times = 2 + ) +} + +Sys.time() + +# ------------------------------------------------------------------------- + +create_test_5D_triplet <- function() { + # Variables hiérarchiques (exemple : ACT, GEO) + # ACT : Total_A -> A1, A2 (avec sous-niveaux A1_a, A1_b...) + hrc_act <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total_A", nodes = c("A1", "A2")) %>% + sdcHierarchies::hier_add(root = "A1", nodes = c("A1_a", "A1_b")) %>% + sdcHierarchies::hier_add(root = "A2", nodes = c("A2_a", "A2_b")) %>% + 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 <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total_G", nodes = c("G1", "G2")) %>% + sdcHierarchies::hier_add(root = "G1", nodes = c("G1_x", "G1_y")) %>% + sdcHierarchies::hier_add(root = "G2", nodes = c("G2_x", "G2_y")) %>% + 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) + + # Modalities pour chaque variable + act_mods <- c("Total_A", "A1", "A2", "A1_a", "A1_b", "A2_a", "A2_b") + geo_mods <- c("Total_G", "G1", "G2", "G1_x", "G1_y", "G2_x", "G2_y") + sex_mods <- c("Total_S", "F", "M") # variable plate 1 + age_mods <- c("Total_Age", "AGE1", "AGE2") # variable plate 2 (non fusionnée) + eco_mods <- c("Total_E", "E1", "E2") # variable plate 3 + + # Produit cartésien complet (toutes les combinaisons) + data <- expand.grid( + ACT = act_mods, + GEO = geo_mods, + SEX = sex_mods, + AGE = age_mods, + ECO = eco_mods, + stringsAsFactors = FALSE + ) + data$VALUE <- 1 + + list( + data = data, + hrc = c(ACT = hrc_act, GEO = hrc_geo), + tot = c(ACT = "Total_A", GEO = "Total_G", SEX = "Total_S", AGE = "Total_Age", ECO = "Total_E") + ) +} + +test <- create_test_5D_triplet() +dfs5_test <- test$data +hrc5_test <- test$hrc +tot5_test <- test$tot + +validate_triplet_predictions <- function(v1, v2, v3, dfs, totcode, hrcfiles) { + cat("\n--- Validation pour le triplet", v1, v2, v3, "---\n") + + # 1. Réduction réelle + res_real <- reduce_dims( + dfs = dfs, + dfs_name = "test", + totcode = totcode, + hrcfiles = hrcfiles, + vars_to_merge = c(v1, v2, v3), + sep_dir = TRUE, + hrc_dir = tempdir() + ) + real_sizes <- sort(sapply(res_real$tabs, nrow)) + real_count <- length(real_sizes) + + # 2. Prédiction version locale (celle que vous avez chargée) + local_pred <- length_tabs( + dfs = dfs, v1 = v1, v2 = v2, v3 = v3, + totcode = totcode, hrcfiles = hrcfiles + ) + local_sizes <- sort(unlist(local_pred)) + local_count <- length(local_sizes) + + # 3. Prédiction version package (originale) + pkg_pred <- rtauargus:::length_tabs( + dfs = dfs, v1 = v1, v2 = v2, v3 = v3, + totcode = totcode, hrcfiles = hrcfiles + ) + pkg_sizes <- sort(unlist(pkg_pred)) + pkg_count <- length(pkg_sizes) + + cat("\n Réel :", real_count, "tableaux, tailles :", paste(real_sizes, collapse = ",")) + cat("\n Local :", local_count, "tableaux, tailles :", paste(local_sizes, collapse = ",")) + cat("\n Package:", pkg_count, "tableaux, tailles :", paste(pkg_sizes, collapse = ",")) + + # Vérification + local_ok <- isTRUE(all.equal(real_sizes, local_sizes, check.attributes = FALSE)) + pkg_ok <- isTRUE(all.equal(real_sizes, pkg_sizes, check.attributes = FALSE)) + + cat("\n => Local correct :", local_ok, "| Package correct :", pkg_ok, "\n") + return(list(local = local_ok, pkg = pkg_ok)) +} + +# Cas 1 : deux hiérarchiques + une plate (ACT, GEO, SEX) +validate_triplet_predictions("ACT", "GEO", "SEX", dfs5_test, tot5_test, hrc5_test) + +# Cas 2 : une hiérarchique + deux plates (ACT, SEX, ECO) +validate_triplet_predictions("ACT", "SEX", "ECO", dfs5_test, tot5_test, hrc5_test) + +# Cas 3 : trois plates (SEX, AGE, ECO) +validate_triplet_predictions("SEX", "AGE", "ECO", dfs5_test, tot5_test, hrc5_test) + + +# ------------------------------------------------------------------------- + +# ============================================================================= +# Targeted validation and benchmark for split_tab +# ============================================================================= +cat("\n========== split_tab (Table Splitting) ==========\n") + +# To test split_tab, we first generate a baseline reduced dimension object +# with over_split = FALSE. This creates the exact data structure (res) +# that split_tab expects, allowing us to test it in isolation. +res_base_4D <- reduce_dims( + dfs = dfs4, + dfs_name = "tab_base", + totcode = tot4, + hrcfiles = hrc4, + over_split = FALSE, # Crucial: prevent split_tab from running inside reduce_dims + nb_tab_option = "min", + sep_dir = TRUE, + hrc_dir = tempdir() +) + +# Reconstruct the merged variable name from the baseline results (e.g., "ACT_GEO") +var_fusionnee <- paste(res_base_4D$fus_vars[1], res_base_4D$fus_vars[2], sep = res_base_4D$sep) + +# 1. Logical Validation: Ensure both functions yield mathematically identical lists of dataframes +# We set a low limit (200 rows) to force the splitting loop to run on multiple large tables +validate( + desc = "split_tab 4D (with a strict limit of 200 rows)", + expr_orig = rtauargus:::split_tab(res = res_base_4D, var_fus = var_fusionnee, limit = 200), + expr_opt = split_tab(res = res_base_4D, var_fus = var_fusionnee, limit = 200) +) + +# 2. Performance Benchmark: Measure execution times between the original and optimized versions +bench( + name_o = "split_tab_original", + name_n = "split_tab_optimise", + expr_o = rtauargus:::split_tab(res = res_base_4D, var_fus = var_fusionnee, limit = 200), + expr_n = split_tab(res = res_base_4D, var_fus = var_fusionnee, limit = 200), + times = 10) # 10 runs are sufficient to confirm the memory footprint and CPU speed difference + + +# ------------------------------------------------------------------------- + +# ============================================================================= +# Validation et Benchmark de restore_format (Original vs Optimisé) +# ============================================================================= + +# --- 1. Génération préalable des objets réduits avec reduce_dims +cat("\nGénération des objets réduits (reduce_dims 4D et 5D)...\n") + +res_4D <- reduce_dims( + dfs = dfs4, + dfs_name = "tab_4D", + totcode = tot4, + hrcfiles = hrc4, + nb_tab_option = "max", + sep_dir = TRUE, + hrc_dir = tempdir() +) + +res_5D <- reduce_dims( + dfs = dfs5, + dfs_name = "tab_5D", + totcode = tot5, + hrcfiles = hrc5, + nb_tab_option = "max", + sep_dir = TRUE, + hrc_dir = tempdir() +) + +# On renomme temporairement la fonction optimisée locale pour la distinguer du package installé +restore_format_local <- restore_format + +# --- 2. Fonction de validation de l'égalité logique des jeux de données +validate_restore <- function(desc, masq, res) { + cat("\n--- Validation logique :", desc, "---\n") + + # Version officielle installée du package + res_orig <- rtauargus::restore_format(masq = masq, res = res) + + # Nouvelle version locale optimisée + res_opt <- restore_format_local(masq = masq, res = res) + + # Standardisation (conversion en data.frame classique et nettoyage des rownames) + res_orig_clean <- as.data.frame(res_orig) + rownames(res_orig_clean) <- NULL + + res_opt_clean <- as.data.frame(res_opt) + rownames(res_opt_clean) <- NULL + + # Comparaison stricte du contenu des données + eq <- identical(res_orig_clean, res_opt_clean) + if (eq) { + cat("Résultats strictement identiques (après nettoyage des attributs R).\n") + } else { + cat("Résultats DIFFÉRENTS. Vérifiez la validité des découpages.\n") + } + return(eq) +} + +# Nombre de tables pour le cas 4D +length(res_4D$tabs) + +# Nombre de tables pour le cas 5D +length(res_5D$tabs) + +# Validation sur les structures 4D et 5D +v_4d <- validate_restore("restore_format 4D (Paires)", res_4D$tabs, res_4D) +v_5d <- validate_restore("restore_format 5D (Triplets/Paires)", res_5D$tabs, res_5D) + +# --- 3. Mesures de performances si la validation logique est validée +if (v_4d && v_5d) { + cat("\n=======================================================================\n") + cat(" BENCHMARKS COMPARATIFS : restore_format \n") + cat("=======================================================================\n") + + cat("\n--- Benchmark 1 : restore_format (Cas 4D - 50 000 lignes) ---\n") + bench_4D <- microbenchmark::microbenchmark( + original = rtauargus::restore_format(masq = res_4D$tabs, res = res_4D), + optimise = restore_format_local(masq = res_4D$tabs, res = res_4D), + times = 10 + ) + print(bench_4D, unit = "ms") + + cat("\n--- Benchmark 2 : restore_format (Cas 5D - 80 000 lignes) ---\n") + bench_5D <- microbenchmark::microbenchmark( + original = rtauargus::restore_format(masq = res_5D$tabs, res = res_5D), + optimise = restore_format_local(masq = res_5D$tabs, res = res_5D), + times = 10 + ) + print(bench_5D, unit = "ms") +} else { + cat("\n[ERREUR] Impossible de lancer le benchmark : les résultats divergent.\n") +} + + +# ------------------------------------------------------------------------- + +# ============================================================================= +# Validation et Benchmark de chose_sep (Original vs Optimisé) +# ============================================================================= +cat("\n=======================================================================\n") +cat(" VALIDATION ET BENCHMARK : chose_sep \n") +cat("=======================================================================\n") + +# 1. Création d'un grand jeu de données avec beaucoup de modalités distinctes +# En cumulant VAR1 à VAR4, nous obtenons environ 18 000 modalités uniques sur 100 000 observations. +set.seed(456) +n_obs <- 100000 +gros_df_modalites <- data.frame( + VAR1 = sample(paste0("M1_", 1:5000), n_obs, replace = TRUE), + VAR2 = sample(paste0("M2_", 10000:20000), n_obs, replace = TRUE), + VAR3 = sample(paste0("M3_", 1:2000), n_obs, replace = TRUE), + VAR4 = sample(paste0("M4_", 1:1000), n_obs, replace = TRUE), + stringsAsFactors = FALSE +) + +separateurs_candidats <- c("___", "_XXX_", "_YYY_", "_TTT_", "_UVW_") + +# 2. Validation logique : s'assurer que le séparateur trouvé est identique +cat("\n--- Validation logique de chose_sep ---\n") +sep_orig <- rtauargus:::chose_sep(gros_df_modalites, separateurs_candidats) +sep_opt <- chose_sep(gros_df_modalites, separateurs_candidats) + +if (identical(sep_orig, sep_opt)) { + cat("Résultats identiques : le séparateur sélectionné est '", sep_opt, "'\n", sep = "") + + # 3. Benchmark comparatif de performance + cat("\n--- Benchmark : chose_sep (18 000 modalités) ---\n") + bench_sep <- microbenchmark::microbenchmark( + original = rtauargus:::chose_sep(gros_df_modalites, separateurs_candidats), + optimise = chose_sep(gros_df_modalites, separateurs_candidats), + times = 5 # 5 répétitions suffisent car la version originale est longue à s'exécuter + ) + print(bench_sep, unit = "ms") + +} else { + cat("\n[ERREUR] Résultats DIFFÉRENTS. Vérifiez l'implémentation de votre version locale.\n") +} diff --git a/bench/bench_sort.R b/bench/bench_sort.R new file mode 100644 index 0000000..581023f --- /dev/null +++ b/bench/bench_sort.R @@ -0,0 +1,207 @@ +# ============================================================================= +# bench_sort_table.R — Une seule session suffit (keep_history = FALSE) +# Compare sort_table = NULL / "ASC" / "DESC" +# ============================================================================= + +BENCH_DIR <- "Z:/benchmark_4d" +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" + +library(data.table); library(dplyr) +devtools::load_all("Z:/rtauargus") +options(rtauargus.tauargus_exe = loc_tauargus) + +load(file.path(BENCH_DIR, "input_data.RData")) # dfs4_agg, tot4, hrc4 + +# ============================================================================= +# UTILITAIRES +# ============================================================================= + +capture_gc <- function(label) { + g <- gc() + data.frame( + label = label, + type = rownames(g), + used_mb = g[, 2], + trigger_mb = g[, 4], + max_mb = g[, 6], + row.names = NULL + ) +} + +get_last_secret_col <- function(df) { + cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] + if (!length(cols)) return(NULL) + cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) +} + +get_secret_stats <- function(df, label) { + last_col <- get_last_secret_col(df) + final <- df[[last_col]] + prim <- df$is_secret_prim + sec <- final & !prim + valid <- !final + + data.frame( + label = label, + n_prim = sum(prim), + value_prim = sum(df$VALUE[prim], na.rm = TRUE), + n_sec = sum(sec), + value_sec = sum(df$VALUE[sec], na.rm = TRUE), + n_total_masque = sum(final), + value_total_masque = sum(df$VALUE[final], na.rm = TRUE), + n_valid = sum(valid), + value_valid = sum(df$VALUE[valid], na.rm = TRUE), + pct_masque_cells = round(100 * mean(final), 2), + pct_masque_value = round(100 * sum(df$VALUE[final], na.rm = TRUE) / + sum(df$VALUE, na.rm = TRUE), 2) + ) +} + +# Normalise un df pour comparaison cellule par cellule +normalize <- function(df, key_cols) { + df <- as.data.frame(df)[, c(key_cols, "final_secret")] + df <- df[do.call(order, df[key_cols]), ] + rownames(df) <- NULL + df +} + +# Extrait le masque final sous forme normalisée +extract_mask <- function(df, tot4) { + last_col <- get_last_secret_col(df) + df_min <- as.data.frame(df)[, c(names(tot4), last_col)] + names(df_min)[ncol(df_min)] <- "final_secret" + normalize(df_min, names(tot4)) +} + +# ============================================================================= +# PARAMÈTRES COMMUNS AUX 3 RUNS +# ============================================================================= + +common_args <- list( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + nb_tab_option = "max", + dfs_name = "tab_4d_int", + limit = 1000000L, + keep_history = FALSE +) + +variants <- list( + list(label = "sort_NULL", sort_table = NULL), + list(label = "sort_ASC", sort_table = "ASC"), + list(label = "sort_DESC", sort_table = "DESC") +) + +# Stockage des résultats en mémoire (~50 MB × 3 = négligeable) +results_raw <- list() +stats_list <- list() +timings_list <- list() +gc_list <- list() + +# ============================================================================= +# BOUCLE PRINCIPALE +# ============================================================================= + +for (v in variants) { + + cat("\n======================================================================\n") + cat(" Variant :", v$label, "\n") + cat("======================================================================\n") + + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) + dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) + + gc(reset = TRUE) + + t_v <- system.time({ + res_v <- do.call( + tab_rtauargus4, + c(common_args, list(dir_name = dir_v, sort_table = v$sort_table)) + ) + }) + + # Résultats bruts conservés en mémoire pour comparaison cellule par cellule + results_raw[[v$label]] <- res_v + + # Stats secret + stats_list[[v$label]] <- get_secret_stats(res_v, v$label) + + # Timing + timings_list[[v$label]] <- data.frame( + label = v$label, + elapsed = t_v["elapsed"], + user = t_v["user.self"], + sys = t_v["sys.self"] + ) + + # Mémoire (après la fin du run, gc() déclenché dans capture_gc) + gc_list[[v$label]] <- capture_gc(v$label) + + # Sauvegarde intermédiaire (sécurité en cas de crash session) + write.csv(stats_list[[v$label]], + file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), + row.names = FALSE) + write.csv(timings_list[[v$label]], + file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), + row.names = FALSE) + write.csv(gc_list[[v$label]], + file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), + row.names = FALSE) + + cat("✓", v$label, "terminé en", round(t_v["elapsed"], 1), "s\n") +} + +# ============================================================================= +# BILAN FINAL +# ============================================================================= + +cat("\n======================================================================\n") +cat(" BILAN COMPARATIF : IMPACT DE sort_table \n") +cat("======================================================================\n") + +cat("\n[1. Statistiques de secret]\n") +print(bind_rows(stats_list)) + +cat("\n[2. Timings (elapsed, secondes)]\n") +print(bind_rows(timings_list)) + +cat("\n[3. Pic mémoire Vcells (max_mb, MB)]\n") +gc_all <- bind_rows(gc_list) +print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) + +# ============================================================================= +# COMPARAISON CELLULE PAR CELLULE +# ============================================================================= + +cat("\n[4. Comparaison cellule par cellule des masques de secret final]\n") + +mask_null <- extract_mask(results_raw[["sort_NULL"]], tot4) +mask_asc <- extract_mask(results_raw[["sort_ASC"]], tot4) +mask_desc <- extract_mask(results_raw[["sort_DESC"]], tot4) + +cat("NULL == ASC :", identical(mask_null, mask_asc), "\n") +cat("NULL == DESC :", identical(mask_null, mask_desc), "\n") +cat("ASC == DESC :", identical(mask_asc, mask_desc), "\n") + +# Si des différences existent, les quantifier +if (!identical(mask_null, mask_asc)) { + n_diff <- sum(mask_null$final_secret != mask_asc$final_secret) + cat(" → Cellules différentes NULL vs ASC :", n_diff, + sprintf("(%.3f%%)\n", 100 * n_diff / nrow(mask_null))) +} +if (!identical(mask_null, mask_desc)) { + n_diff <- sum(mask_null$final_secret != mask_desc$final_secret) + cat(" → Cellules différentes NULL vs DESC :", n_diff, + sprintf("(%.3f%%)\n", 100 * n_diff / nrow(mask_null))) +} +if (!identical(mask_asc, mask_desc)) { + n_diff <- sum(mask_asc$final_secret != mask_desc$final_secret) + cat(" → Cellules différentes ASC vs DESC :", n_diff, + sprintf("(%.3f%%)\n", 100 * n_diff / nrow(mask_asc))) +} diff --git a/bench/bench_split_nodes.R b/bench/bench_split_nodes.R new file mode 100644 index 0000000..1b296b2 --- /dev/null +++ b/bench/bench_split_nodes.R @@ -0,0 +1,115 @@ +# Benchmarking and Verification script for Z:/rtauargus/R optimizations +library(microbenchmark) + +# ============================================================================== +# 1. Benchmark & Verification for Priority 1: Subsetting (from_4_to_3_case_1_hr logic) +# ============================================================================== +set.seed(42) +n_rows <- 1e5 +unique_codes <- paste0("CODE_", 1:50) +dfs_test <- data.frame( + v2 = sample(unique_codes, n_rows, replace = TRUE), + VALUE = runif(n_rows), + stringsAsFactors = FALSE +) +codes_split_test <- lapply(1:50, function(i) sample(unique_codes, 10)) + +# --- Package original logic --- +run_old_p1 <- function(dfs, codes_split) { + lapply(codes_split, function(codes) { + dfs[dfs$v2 %in% codes, , drop = FALSE] + }) +} + +# --- Package optimized logic --- +run_new_p1 <- function(dfs, codes_split) { + # OPTIMIZATION: Physically pre-index positions once + row_indices <- split(seq_len(nrow(dfs)), dfs$v2) + + lapply(codes_split, function(codes) { + # OPTIMIZATION: Combine indices and sort to preserve exact original row order + idx <- sort(unlist(row_indices[codes], use.names = FALSE)) + dfs[idx, , drop = FALSE] + }) +} + +# VERIFICATION: Assert that both implementations return 100% identical dataframes +res_old_p1 <- run_old_p1(dfs_test, codes_split_test) +res_new_p1 <- run_new_p1(dfs_test, codes_split_test) +p1_is_identical <- identical(res_old_p1, res_new_p1) +cat("Priority 1 (Subsetting): Are outputs identical?", p1_is_identical, "\n\n") + +benchmark_p1 <- microbenchmark( + "Old %in% subsetting" = { + run_old_p1(dfs_test, codes_split_test) + }, + "New Index-based (Sorted)" = { + run_new_p1(dfs_test, codes_split_test) + }, + times = 10 +) +print(benchmark_p1) +cat("\n----------------------------------------------------------------------\n\n") + + +# ============================================================================== +# 2. Benchmark & Verification for Priority 2: Stride-based extraction (separer4_3 logic) +# ============================================================================== +# Generate a realistic dataframe of 100,000 rows with a concatenated column +set.seed(42) +n_splits <- 1e5 +df_base <- data.frame( + v1_v2 = paste(sample(paste0("A", 1:500), n_splits, replace = TRUE), + sample(paste0("B", 1:500), n_splits, replace = TRUE), + sep = "_"), + OTHER_VAL = runif(n_splits), + stringsAsFactors = FALSE +) + +# --- Original separer4_3 function --- +separer4_3_old <- function(df, v1, v2, v1_v2, sep) { + splits <- strsplit(df[[v1_v2]], split = sep, fixed = TRUE) + mat <- matrix(unlist(splits, use.names = FALSE), ncol = 2, byrow = TRUE) + + df[[v1]] <- mat[, 1] + df[[v2]] <- mat[, 2] + df[[v1_v2]] <- NULL + + # Reorder columns + new_order <- c(v1, v2, setdiff(names(df), c(v1, v2))) + df[, new_order] +} + +# --- Optimized separer4_3 function --- +separer4_3_new <- function(df, v1, v2, v1_v2, sep) { + splits <- strsplit(df[[v1_v2]], split = sep, fixed = TRUE) + + # OPTIMIZATION: Stride-based extraction bypassing 2D matrix allocation + unlisted <- unlist(splits, use.names = FALSE) + n_rows <- length(splits) + + df[[v1]] <- unlisted[seq(1, by = 2, length.out = n_rows)] + df[[v2]] <- unlisted[seq(2, by = 2, length.out = n_rows)] + df[[v1_v2]] <- NULL + + # Reorder columns + new_order <- c(v1, v2, setdiff(names(df), c(v1, v2))) + df[, new_order] +} + +# VERIFICATION: Assert that both dataframes are 100% identical after columns splitting +df_old_res <- separer4_3_old(df_base, "v1", "v2", "v1_v2", "_") +df_new_res <- separer4_3_new(df_base, "v1", "v2", "v1_v2", "_") +p2_is_identical <- identical(df_old_res, df_new_res) +cat("Priority 2 (separer4_3): Are outputs identical?", p2_is_identical, "\n\n") + +benchmark_p2 <- microbenchmark( + "Old separer4_3 (Matrix)" = { + separer4_3_old(df_base, "v1", "v2", "v1_v2", "_") + }, + "New separer4_3 (Stride)" = { + separer4_3_new(df_base, "v1", "v2", "v1_v2", "_") + }, + times = 10 +) +print(benchmark_p2) diff --git a/bench/bench_tab_multimanager_bloc.R b/bench/bench_tab_multimanager_bloc.R new file mode 100644 index 0000000..dfbf2bf --- /dev/null +++ b/bench/bench_tab_multimanager_bloc.R @@ -0,0 +1,834 @@ +library(microbenchmark) +library(data.table) +library(purrr) +library(rlang) +library(dplyr) +library(sdcHierarchies) + +library(rtauargus) # package original +# on fait une copie de la fonction du package, car sera remplacé lors du load_all +tab_multi_manager_old <- rtauargus::tab_multi_manager + +# pour charger reduce_dims et le package rtauargus local +devtools::load_all("Z:/rtauargus") # path où est la version split_perf de github : https://github.com/InseeFrLab/rtauargus/tree/split_perf_improvement + +set.seed(42) + +# ============================================================================= +# 0. ÉTAPE PRÉALABLE : Création du jeu 5D et découpage par reduce_dims +# ============================================================================= +cat("======================================================================\n") +cat("0. INITIALISATION : Génération du jeu 5D et exécution de reduce_dims \n") +cat("======================================================================\n") + +# 1. Fonction create_big_5D corrigée (largeur de codes fixe) +create_big_5D <- function(n = 80000) { + set.seed(234) + + # Codes de largeur fixe pour CHAQUE niveau : + # Level 1 ACT: A01_0 (5 caracteres) + # Level 2 ACT: A01_1 (5 caracteres) + act_level1 <- sprintf("A%02d_0", 1:20) + act_level2 <- unlist(lapply(1:20, function(i) sprintf("A%02d_%d", i, 1:5))) + + # Level 1 GEO: GA_ (3 caracteres) + # Level 2 GEO: GA1 (3 caracteres) + geo_level1 <- c("GA_", "GB_") + geo_level2 <- c("GA1", "GA2", "GA3", "GB1", "GB2", "GB3") + + data <- data.frame( + ACT = sample(c("Total_A", act_level1, act_level2), n, replace = TRUE), + GEO = sample(c("Total_G", geo_level1, geo_level2), n, replace = TRUE), + SEX = sample(c("Total_S", "F0", "M0", "F1", "F2", "M1", "M2"), n, replace = TRUE), + AGE = sample(c("Ensemble", "AGE01", "AGE02", "AGE11", "AGE12", "AGE21", "AGE22"), n, replace = TRUE), + ECO = sample(c("PIB", "Ménages", "Entreprises"), n, replace = TRUE), + stringsAsFactors = FALSE + ) + data$VALUE <- 1 + + # Hiérarchie ACT + hrc_act <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total_A", nodes = act_level1) %>% + { + for (i in 1:20) { + root_node <- sprintf("A%02d_0", i) + children <- sprintf("A%02d_%d", i, 1:5) + . <- sdcHierarchies::hier_add(., root = root_node, nodes = children) + } + . + } %>% + 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) + + # Hiérarchie GEO + hrc_geo <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total_G", nodes = geo_level1) %>% + sdcHierarchies::hier_add(root = "GA_", nodes = c("GA1", "GA2", "GA3")) %>% + sdcHierarchies::hier_add(root = "GB_", nodes = c("GB1", "GB2", "GB3")) %>% + 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) + + list(data = data, + hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), + totcode = c(SEX = "Total_S", AGE = "Ensemble", GEO = "Total_G", ACT = "Total_A", ECO = "PIB")) +} + +# 1. Création du jeu 5D +big5 <- create_big_5D(80000) +dfs5 <- big5$data + +# 2. AGRÉGATION PRÉALABLE DES DONNÉES (Pour obtenir un vrai tableau statistique de cellules uniques) +dfs5_agg <- dfs5 %>% + group_by(ACT, GEO, SEX, AGE, ECO) %>% + summarise( + VALUE = sum(VALUE), + freq = n(), + .groups = "drop" + ) + +cat("Nombre de lignes tableau avant reduce dims :", nrow(dfs5_agg), "\n") + + +dfs5_agg$is_secret_prim <- sample(c(TRUE, FALSE), nrow(dfs5_agg), replace = TRUE, prob = c(0.05, 0.95)) +dfs5_agg$secret_no_pl <- FALSE + +tot5 <- big5$totcode +hrc5 <- big5$hrcfiles + +cat("=== CONTENU DU FICHIER HRC GEO ===\n") +print(readLines(hrc5[["GEO"]])) + +cat("\n=== CONTENU DU FICHIER HRC ACT ===\n") +print(readLines(hrc5[["ACT"]])) + +# 3. Réduction de dimension sur les données agrégées +# res5 <- reduce_dims( +# dfs = dfs5_agg, +# dfs_name = "tab_5D", +# totcode = tot5, +# hrcfiles = hrc5, +# nb_tab_option = "smart", +# limit = 50000, +# over_split = TRUE, +# # nb_tab_option = "max", +# sep_dir = TRUE, +# hrc_dir = tempdir() +# ) + +res5 <- reduce_dims( + dfs = dfs5_agg, + dfs_name = "tab_5D", + totcode = tot5, + hrcfiles = hrc5, + vars_to_merge = c("ACT", "GEO", "SEX", "AGE"), # <-- Force 2 couples (ACT_GEO et SEX_AGE) + sep_dir = TRUE, + hrc_dir = tempdir() +) + +cat("Nombre de tableaux générés :", length(res5$tabs), "\n") + +list_tables_5d <- res5$tabs +list_expl_5d <- res5$vars + +all_expl_vars <- unique(unname(unlist(list_expl_5d))) +noms_tbx <- names(list_tables_5d) +noms_col_T <- stats::setNames(paste0("T_", noms_tbx), noms_tbx) + + + +# Bench bloc 1 ------------------------------------------------------------ + + +# Construction de table_majeure_list +table_majeure_list <- purrr::imap( + .x = list_tables_5d, + .f = function(tableau, nom_tab){ + tableau <- as.data.frame(tableau)[, c(list_expl_5d[[nom_tab]], "VALUE", "freq", "secret_no_pl", "is_secret_prim")] + + var_a_ajouter <- setdiff(all_expl_vars, names(tableau)) + for (nom_col in var_a_ajouter){ + tableau[[nom_col]] <- unname( + purrr::keep(res5$alt_totcode, function(x) nom_col %in% names(x))[[1]][nom_col] + ) + } + tableau[[noms_col_T[[nom_tab]]]] <- TRUE + + for (col in list_expl_5d[[nom_tab]]) { + tableau[[col]] <- as.character(tableau[[col]]) + } + return(tableau) + } +) + +by_vars <- purrr::reduce(purrr::map(table_majeure_list, names), intersect) + +# Helper de normalisation pour la comparaison exacte +normalize_for_compare <- function(df, key_cols) { + df <- as.data.frame(df) + df <- df[, order(names(df)), drop = FALSE] + df <- df[do.call(order, df[key_cols]), , drop = FALSE] + row.names(df) <- NULL + return(df) +} + +# --- CODE EXACT D'ORIGINE DU PACKAGE --- +run_old_block1 <- function(table_majeure_list, by_vars, noms_col_T) { + table_majeure <- purrr::reduce( + .x = table_majeure_list, + .f = merge, + by = by_vars, + all = TRUE + ) + + table_majeure$secret_no_pl_iter <- table_majeure$secret_no_pl + secret_no_pl_iter <- "secret_no_pl_iter" + + purrr::walk( + noms_col_T, + function(col_T){ + e_par <- rlang::env_parent() + e_par$table_majeure[[col_T]] <- ifelse( + is.na(e_par$table_majeure[[col_T]]), + FALSE, + e_par$table_majeure[[col_T]] + ) + } + ) + return(table_majeure) +} + +# --- CODE PROPOSÉ OPTIMISÉ --- +run_new_block1 <- function(table_majeure_list, by_vars, noms_col_T) { + dt_list <- lapply(table_majeure_list, data.table::as.data.table) + dt_all <- data.table::rbindlist(dt_list, use.names = TRUE, fill = TRUE) + table_majeure <- dt_all[, lapply(.SD, function(col) any(!is.na(col))), by = by_vars, .SDcols = noms_col_T] + data.table::setDT(table_majeure) + + table_majeure[, secret_no_pl_iter := secret_no_pl] + secret_no_pl_iter <- "secret_no_pl_iter" + + for (col_T in noms_col_T) { + data.table::set(table_majeure, i = which(is.na(table_majeure[[col_T]])), j = col_T, value = FALSE) + } + return(as.data.frame(table_majeure)) +} + +t_res_old_b1 <- system.time({ + res_old_b1 <- run_old_block1(table_majeure_list, by_vars, noms_col_T) +}) +cat("Temps res_old_b1 :\n") +print(t_res_old_b1) + +t_res_new_b1 <- system.time({ + res_new_b1 <- run_new_block1(table_majeure_list, by_vars, noms_col_T) +}) +cat("Temps res_new_b1 :\n") +print(t_res_new_b1) + +b1_is_identical <- identical( + normalize_for_compare(res_old_b1, by_vars), + normalize_for_compare(res_new_b1, by_vars) +) +cat("Nombre de lignes Original :", nrow(res_old_b1), "\n") +cat("Nombre de lignes Optimisé :", nrow(res_new_b1), "\n") +cat("Block 1 Verification: Are outputs 100% identical?", b1_is_identical, "\n\n") + +benchmark_b1 <- microbenchmark( + "Old: purrr::reduce(merge)" = run_old_block1(table_majeure_list, by_vars, noms_col_T), + "New: rbindlist + group-by" = run_new_block1(table_majeure_list, by_vars, noms_col_T), + times = 3 +) +print(benchmark_b1) +cat("\n----------------------------------------------------------------------\n\n") + + +# Bloc 2 ------------------------------------------------------------------ + +cat("======================================================================\n") +cat("2. BENCHMARK BLOCK 2: In-place table_majeure Update (Processing Phase)\n") +cat("======================================================================\n") + +# Prise de la table_majeure generee au Bloc 1 +tm_base <- res_old_b1 +nom_tab_1 <- noms_tbx[1] + +# Identification des lignes de la premiere sous-table et extraction de ses variables explicatives +active_idx <- which(tm_base[[paste0("T_", nom_tab_1)]]) +ex_var_1 <- list_expl_5d[[nom_tab_1]] + +# Simulation du resultat renvoye par Tau-Argus pour ce sous-tableau +res_tau <- tm_base[active_idx, ex_var_1, drop = FALSE] +set.seed(42) +res_tau$is_secret <- sample(c(TRUE, FALSE), length(active_idx), replace = TRUE, prob = c(0.2, 0.8)) + +# Noms des variables de secret pour l'iteration 1 +var_sec_apriori <- "is_secret_prim" +var_sec_new <- "is_secret_1" +secret_var_name <- "is_secret_prim" + +# Préparation préalable de table_majeure au format data.table +# Reflète fidèlement le déroulement réel où table_majeure est DÉJÀ un data.table dans la boucle +t_conv <- system.time({ + tm_dt_base <- data.table::as.data.table(tm_base) +}) + +cat("Temps de conversion data.frame -> data.table :\n") +print(t_conv) + +# --- CODE EXACT D'ORIGINE DU PACKAGE --- +run_old_block2 <- function(table_majeure, res, var_secret_apriori, var_secret, secret_var) { + table_majeure <- merge(table_majeure, res, all = TRUE) + table_majeure[[var_secret]] <- table_majeure$is_secret + table_majeure <- subset( + table_majeure, + select = setdiff(names(table_majeure), "is_secret") + ) + + table_majeure[[var_secret]] <- ifelse( + is.na(table_majeure[[var_secret]]), + table_majeure[[var_secret_apriori]], + table_majeure[[var_secret]] + ) + + table_majeure$secret_no_pl_iter <- ifelse( + table_majeure[[secret_var]], + table_majeure$secret_no_pl, + table_majeure[[var_secret]] + ) + return(table_majeure) +} + +# --- CODE PROPOSÉ OPTIMISÉ (data.table) --- +run_new_block2 <- function(table_majeure_dt, res, var_secret_apriori, var_secret, secret_var, all_expl, list_tot) { + + # NEW 2 : Seule une copie très légère de sécurité est faite pour éviter que les répétitions + # NEW 2 : du microbenchmark ne modifient l'objet initial entre deux répétitions + tm_dt <- data.table::copy(table_majeure_dt) + + # NEW 2 : Passage de res en data.table par référence (aligné sur le code réel) + res_dt <- data.table::as.data.table(res) + + # Correction mode générique : compléter res avec les variables explicatives absentes de res (fixées à leur total) + missing_expl <- setdiff(all_expl, names(res_dt)) + for (v in missing_expl) { + val_tot <- unname(purrr::keep(list_tot, function(x) v %in% names(x))[[1]][v]) + data.table::set(res_dt, j = v, value = as.character(val_tot)) + } + + # Initialisation de la colonne d'itération avec l'état précédent + tm_dt[, (var_secret) := get(var_secret_apriori)] + + # Mise à jour en place par référence sur all_expl_vars + tm_dt[res_dt, (var_secret) := i.is_secret, on = all_expl] + + # Mise à jour de la colonne de gestion du PL + tm_dt[, secret_no_pl_iter := data.table::fifelse(get(secret_var), secret_no_pl, get(var_secret))] + + return(as.data.frame(tm_dt)) +} + +# Exécution des deux versions +t_res_old_b2 <- system.time({ + res_old_b2 <- run_old_block2(tm_base, res_tau, var_sec_apriori, var_sec_new, secret_var_name) +}) +cat("Temps res_old_b2 :\n") +print(t_res_old_b2) + +# On passe tm_dt_base (déjà converti en data.table) à la version optimisée +t_res_new_b2<- system.time({ + res_new_b2 <- run_new_block2(tm_dt_base, res_tau, var_sec_apriori, var_sec_new, secret_var_name, all_expl_vars, res5$alt_totcode) +}) +cat("Temps res_new_b2 :\n") +print(t_res_new_b2) + + +# Vérification de l'égalité exacte des résultats +b2_is_identical <- identical( + normalize_for_compare(res_old_b2, by_vars), + normalize_for_compare(res_new_b2, by_vars) +) + +cat("Nombre de lignes Original :", nrow(res_old_b2), "\n") +cat("Nombre de lignes Optimisé :", nrow(res_new_b2), "\n") +cat("Block 2 Verification: Are outputs 100% identical?", b2_is_identical, "\n\n") + +# Benchmark de performance +benchmark_b2 <- microbenchmark( + "Old: merge + ifelse" = run_old_block2(tm_base, res_tau, var_sec_apriori, var_sec_new, secret_var_name), + + # NEW 2 : Le benchmark mesure la fonction opérant directement sur data.table + "New: in-place data.table" = run_new_block2(tm_dt_base, res_tau, var_sec_apriori, var_sec_new, secret_var_name, all_expl_vars, res5$alt_totcode), + times = 3 +) +print(benchmark_b2) +cat("\n----------------------------------------------------------------------\n\n") + + +# Bloc 3 ------------------------------------------------------------------ + +cat("======================================================================\n") +cat("3. BENCHMARK BLOCK 3: Common Cell Detection & Queue Update\n") +cat("======================================================================\n") + +# Prise de la table_majeure issue du Bloc 2 +tm_b3 <- res_old_b2 +nom_tab_1 <- noms_tbx[1] + +# On simule un changement de statut de secret sur 15 cellules du sous-tableau courant +active_idx <- which(tm_b3[[paste0("T_", nom_tab_1)]]) +tm_b3$is_secret_2 <- tm_b3$is_secret_1 +changed_rows <- active_idx[1:15] +tm_b3$is_secret_2[changed_rows] <- !tm_b3$is_secret_1[changed_rows] + +# Todolist et remainlist initiales fictives +todolist_init <- noms_tbx[1:3] +remainlist_init <- noms_tbx[4:length(noms_tbx)] + +var_sec_apriori <- "is_secret_1" +var_sec_new <- "is_secret_2" + +# --- CODE EXACT D'ORIGINE DU PACKAGE --- +run_old_block3 <- function(table_majeure, var_secret_apriori, var_secret, noms_col_T, num_tableau, all_expl, todolist, remainlist) { + lignes_modifs <- which(table_majeure[[var_secret_apriori]] != table_majeure[[var_secret]]) + + cur_tab <- paste0("T_", num_tableau) + other_tabs <- setdiff(noms_col_T, cur_tab) + cur_cells <- rowSums(table_majeure[, cur_tab, drop=FALSE]) + other_cells <- rowSums(table_majeure[, other_tabs, drop=FALSE]) + + common_cells_rows <- which(cur_cells == 1 & other_cells > 0) + common_cells <- table_majeure[common_cells_rows, , drop=FALSE] + + modified <- common_cells[common_cells[[var_secret_apriori]] != common_cells[[var_secret]], all_expl, drop=FALSE] + + noms_tbx_local <- names(noms_col_T) + for(tab in noms_tbx_local){ + nom_col_identifiante <- paste0("T_", tab) + if( !(tab %in% todolist) + & (any(table_majeure[[nom_col_identifiante]][lignes_modifs])) + ){ + todolist <- append(todolist, tab) + remainlist <- remainlist[remainlist != tab] + } + } + + return(list(modified = modified, todolist = todolist, remainlist = remainlist)) +} + +# --- CODE PROPOSÉ OPTIMISÉ (data.table) --- +run_new_block3 <- function(table_majeure, var_secret_apriori, var_secret, noms_col_T, num_tableau, all_expl, active_rows, todolist, remainlist) { + tm_dt <- data.table::as.data.table(table_majeure) + nom_col_identifiante <- paste0("T_", num_tableau) + all_col_T <- unname(noms_col_T) + + # Restricton stricte de la recherche aux seules lignes de la sous-table courante + idx_changed <- tm_dt[[var_secret_apriori]][active_rows] != tm_dt[[var_secret]][active_rows] + lignes_modifs <- active_rows[idx_changed] + + other_tabs <- setdiff(all_col_T, nom_col_identifiante) + common_modified_idx <- integer(0) + + if (length(lignes_modifs) > 0) { + if (length(other_tabs) > 0) { + # rowSums calcule uniquement sur les 15 lignes modifiees (au lieu des 41 817 lignes) + is_common <- rowSums(as.matrix(tm_dt[lignes_modifs, ..other_tabs])) > 0 + common_modified_idx <- lignes_modifs[is_common] + } + + noms_tbx_local <- names(noms_col_T) + for(tab in noms_tbx_local){ + nom_col_identifiante_tab <- paste0("T_", tab) + if( !(tab %in% todolist) + && any(tm_dt[[nom_col_identifiante_tab]][lignes_modifs]) + ){ + todolist <- c(todolist, tab) + remainlist <- remainlist[remainlist != tab] + } + } + } + + if (length(common_modified_idx) > 0) { + modified <- as.data.frame(tm_dt[common_modified_idx, ..all_expl]) + } else { + modified <- as.data.frame(tm_dt[0, ..all_expl]) + } + + return(list(modified = modified, todolist = todolist, remainlist = remainlist)) +} + +# Execution des deux versions +t_res_old_b3 <- system.time({ + res_old_b3 <- run_old_block3(tm_b3, var_sec_apriori, var_sec_new, noms_col_T, nom_tab_1, all_expl_vars, todolist_init, remainlist_init) +}) +cat("Temps t_res_old_b3 :\n") +print(t_res_old_b3) + +t_res_new_b3 <- system.time({ + res_new_b3 <- run_new_block3(tm_b3, var_sec_apriori, var_sec_new, noms_col_T, nom_tab_1, all_expl_vars, active_idx, todolist_init, remainlist_init) +}) +cat("Temps t_res_new_b3 :\n") +print(t_res_new_b3) + +# Verification de l'egalite exacte du tableau "modified" et de la file "todolist" +b3_mod_identical <- identical( + normalize_for_compare(res_old_b3$modified, all_expl_vars), + normalize_for_compare(res_new_b3$modified, all_expl_vars) +) +b3_todo_identical <- identical(res_old_b3$todolist, res_new_b3$todolist) + +cat("Block 3 Verification: Are modified cells 100% identical?", b3_mod_identical, "\n") +cat("Block 3 Verification: Are todolists 100% identical?", b3_todo_identical, "\n\n") + +# Benchmark de performance +benchmark_b3 <- microbenchmark( + "Old: rowSums on full 41k rows" = run_old_block3(tm_b3, var_sec_apriori, var_sec_new, noms_col_T, nom_tab_1, all_expl_vars, todolist_init, remainlist_init), + "New: rowSums on modified rows" = run_new_block3(tm_b3, var_sec_apriori, var_sec_new, noms_col_T, nom_tab_1, all_expl_vars, active_idx, todolist_init, remainlist_init), + times = 3 +) +print(benchmark_b3) +cat("\n----------------------------------------------------------------------\n\n") + +# Bloc 4 ------------------------------------------------------------------ + +cat("======================================================================\n") +cat("4. BENCHMARK BLOCK 4: Final Sub-table Assembly (Processing Phase)\n") +cat("======================================================================\n") + +# Prise de la table_majeure mise a jour issue du Bloc 3 +tm_b4 <- tm_b3 + +# --- CODE EXACT D'ORIGINE DU PACKAGE --- +run_old_block4 <- function(tbl_list, expl_list, tm) { + purrr::imap( + tbl_list, + function(tab, nom){ + expl_vars <- expl_list[[nom]] + tab_rows <- tm[[paste0("T_", nom)]] + secret_vars <- names(tm)[grep("^is_secret_[1-9]", names(tm))] + secret_vars <- secret_vars[order(as.integer(gsub("is_secret_", "", secret_vars)))] + res <- merge( + tab, + tm[tab_rows, c(expl_vars, secret_vars)], + all.x = TRUE, all.y = FALSE, by = expl_vars + ) + } + ) +} + +# --- CODE PROPOSÉ OPTIMISÉ (data.table) --- +run_new_block4 <- function(tbl_list, expl_list, tm) { + tm_dt <- data.table::as.data.table(tm) + secret_vars <- names(tm_dt)[grep("^is_secret_[1-9]", names(tm_dt))] + secret_vars <- secret_vars[order(as.integer(gsub("is_secret_", "", secret_vars)))] + + purrr::imap( + tbl_list, + function(tab, nom){ + expl_vars <- expl_list[[nom]] + tab_rows <- tm_dt[[paste0("T_", nom)]] + + sub_majeure <- tm_dt[tab_rows, c(expl_vars, secret_vars), with = FALSE] + + tab_is_dt <- data.table::is.data.table(tab) + # Copy si deja un data.table pour eviter toute mutation de memoire utilisateur + tab_dt <- if (tab_is_dt) data.table::copy(tab) else data.table::as.data.table(tab) + + # Sauvegarde des types d'origine + original_classes <- vapply(expl_vars, function(v) class(tab[[v]])[1], character(1)) + + for (v in expl_vars) { + if (v %in% names(tab_dt)) data.table::set(tab_dt, j = v, value = as.character(tab_dt[[v]])) + } + + res_dt <- merge(tab_dt, sub_majeure, by = expl_vars, all.x = TRUE, sort = FALSE) + + # Restauration des types d'origine (factor, integer, etc.) + for (v in expl_vars) { + cls <- original_classes[v] + if (cls == "factor") { + data.table::set(res_dt, j = v, value = factor(res_dt[[v]])) + } else if (cls == "integer") { + data.table::set(res_dt, j = v, value = as.integer(res_dt[[v]])) + } + } + + if (!tab_is_dt) { + return(as.data.frame(res_dt)) + } else { + return(res_dt) + } + } + ) +} + +# Execution des deux versions avec system.time +t_res_old_b4 <- system.time({ + res_old_b4 <- run_old_block4(list_tables_5d, list_expl_5d, tm_b4) +}) +cat("Temps t_res_old_b4 :\n") +print(t_res_old_b4) + +t_res_new_b4 <- system.time({ + res_new_b4 <- run_new_block4(list_tables_5d, list_expl_5d, tm_b4) +}) +cat("Temps t_res_new_b4 :\n") +print(t_res_new_b4) + +# Verification de l'egalite exacte pour chacun des sous-tableaux restitues +b4_results_identical <- vapply(seq_along(res_old_b4), function(i) { + nom_t <- names(res_old_b4)[i] + expl_v <- list_expl_5d[[nom_t]] + identical( + normalize_for_compare(res_old_b4[[i]], expl_v), + normalize_for_compare(res_new_b4[[i]], expl_v) + ) +}, logical(1)) + +cat("\nBlock 4 Verification: Are all output tables 100% identical?", all(b4_results_identical), "\n\n") + +# Benchmark de performance +benchmark_b4 <- microbenchmark( + "Old: sequential base merges" = run_old_block4(list_tables_5d, list_expl_5d, tm_b4), + "New: data.table merges" = run_new_block4(list_tables_5d, list_expl_5d, tm_b4), + times = 3 +) +print(benchmark_b4) +cat("\n----------------------------------------------------------------------\n\n") + +# Bloc 5 ------------------------------------------------------------------ + +cat("======================================================================\n") +cat("5. BENCHMARK BLOCK 5: Full End-to-End Multi-Iteration Integration Test \n") +cat("======================================================================\n") + +Sys.time() +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" +options(rtauargus.tauargus_exe = loc_tauargus) + +# 1. Reprise des sous-tables et ajout d'une variable de cout (Inclusion de cost_var) +list_tables_5d_cost <- lapply(list_tables_5d, function(df) { + df$cost_col <- round(runif(nrow(df), 1, 100)) + df +}) + +dir_old <- file.path(tempdir(), "test_old_real") +dir_new <- file.path(tempdir(), "test_new_real") +if (!dir.exists(dir_old)) dir.create(dir_old, recursive = TRUE) +if (!dir.exists(dir_new)) dir.create(dir_new, recursive = TRUE) + +# Initialisation des résultats +res_full_old <- NULL +t_full_old <- NULL +res_full_new <- NULL +t_full_new <- NULL + +# 2. Exécution version ORIGINALE ------------------------------------------- +cat("\nLancement de tab_multi_manager version ORIGINALE (Multi-itérations)...\n") +tryCatch({ + t_full_old <- system.time({ + res_full_old <- tab_multi_manager_old( + list_tables = list_tables_5d_cost, + list_explanatory_vars = list_expl_5d, + totcode = res5$totcode, + hrc = res5$hrc, + alt_totcode = res5$alt_totcode, + alt_hrc = res5$alt_hrc, + value = "VALUE", + freq = "freq", + secret_var = "is_secret_prim", + cost_var = "cost_col", + suppress = "GH(1,100)", # Hypercube rapide + dir_name = dir_old + ) + }) + cat("Temps version ORIGINALE :\n") + print(t_full_old) +}, error = function(e) { + cat("\n[ERREUR] Échec de tab_multi_manager_old :\n") + message(e$message) +}) + +# 3. Exécution version OPTIMISÉE ------------------------------------------ +cat("\nLancement de tab_multi_manager version OPTIMISÉE (Multi-itérations)...\n") +tryCatch({ + t_full_new <- system.time({ + res_full_new <- tab_multi_manager( + list_tables = list_tables_5d_cost, + list_explanatory_vars = list_expl_5d, + totcode = res5$totcode, + hrc = res5$hrc, + alt_totcode = res5$alt_totcode, + alt_hrc = res5$alt_hrc, + value = "VALUE", + freq = "freq", + secret_var = "is_secret_prim", + cost_var = "cost_col", + suppress = "GH(1,100)", # Hypercube rapide + dir_name = dir_new + ) + }) + cat("Temps version OPTIMISÉE :\n") + print(t_full_new) +}, error = function(e) { + cat("\n[ERREUR] Échec de tab_multi_manager :\n") + message(e$message) +}) + +# 4. VERIFICATION INTEGRALE ET RIGOUREUSE DE BOUT EN BOUT +if (!is.null(res_full_old) && !is.null(res_full_new)) { + + check_e2e <- vapply(seq_along(res_full_old), function(i) { + nom_t <- names(res_full_old)[i] + expl_v <- list_expl_5d[[nom_t]] + + df_o <- res_full_old[[i]] + df_n <- res_full_new[[i]] + + identical( + normalize_for_compare(df_o, expl_v), + normalize_for_compare(df_n, expl_v) + ) + }, logical(1)) + + cat("\n======================================================================\n") + cat("RÉSULTAT DU TEST D'INTÉGRATION GLOBAL (END-TO-END)\n") + cat("======================================================================\n") + cat("1. Nombre de tableaux traites (", length(res_full_old), ") : TRUE\n", sep = "") + cat("2. Egalite stricte de TOUTES les itérations et colonnes :", all(check_e2e), "\n") + + if (all(check_e2e)) { + cat("\n>>> SUCCÈS TOTAL : 100% d'équivalence logique sur toutes les itérations !\n") + cat(">>> Gain de temps global de bout en bout : x", round(t_full_old["elapsed"] / t_full_new["elapsed"], 1), "\n") + } else { + cat("\n>>> ERREUR : Divergence detectee dans les tables :", names(res_full_old)[!check_e2e], "\n") + } + +} else { + cat("\n======================================================================\n") + cat("COMPARAISON IMPOSSIBLE : Au moins une des deux fonctions a échoué.\n") + cat("======================================================================\n") +} + + +# Bloc 6 - unif_labels=FALSE ------------------------------------------------------------------ + +cat("======================================================================\n") +cat("6. BENCHMARK BLOCK 5: Full End-to-End Multi-Iteration Integration Test \n") +cat("======================================================================\n") + +Sys.time() +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" +options(rtauargus.tauargus_exe = loc_tauargus) + +# 1. Reprise des sous-tables et ajout d'une variable de cout (Inclusion de cost_var) +list_tables_5d_cost <- lapply(list_tables_5d, function(df) { + df$cost_col <- round(runif(nrow(df), 1, 100)) + df +}) + +dir_old <- file.path(tempdir(), "test_old_real") +dir_new <- file.path(tempdir(), "test_new_real") +if (!dir.exists(dir_old)) dir.create(dir_old, recursive = TRUE) +if (!dir.exists(dir_new)) dir.create(dir_new, recursive = TRUE) + +# Initialisation des résultats +res_full_old <- NULL +t_full_old <- NULL +res_full_new <- NULL +t_full_new <- NULL + +# 2. Exécution version ORIGINALE ------------------------------------------- +cat("\nLancement de tab_multi_manager version ORIGINALE (Multi-itérations)...\n") +tryCatch({ + t_full_old <- system.time({ + res_full_old <- tab_multi_manager_old( + list_tables = list_tables_5d_cost, + list_explanatory_vars = list_expl_5d, + totcode = res5$totcode, + hrc = res5$hrc, + alt_totcode = res5$alt_totcode, + alt_hrc = res5$alt_hrc, + value = "VALUE", + freq = "freq", + secret_var = "is_secret_prim", + cost_var = "cost_col", + suppress = "GH(1,100)", # Hypercube rapide + unif_labels = FALSE, + dir_name = dir_old + ) + }) + cat("Temps version ORIGINALE :\n") + print(t_full_old) +}, error = function(e) { + cat("\n[ERREUR] Échec de tab_multi_manager_old :\n") + message(e$message) +}) + +# 3. Exécution version OPTIMISÉE ------------------------------------------ +cat("\nLancement de tab_multi_manager version OPTIMISÉE (Multi-itérations)...\n") +tryCatch({ + t_full_new <- system.time({ + res_full_new <- tab_multi_manager( + list_tables = list_tables_5d_cost, + list_explanatory_vars = list_expl_5d, + totcode = res5$totcode, + hrc = res5$hrc, + alt_totcode = res5$alt_totcode, + alt_hrc = res5$alt_hrc, + value = "VALUE", + freq = "freq", + secret_var = "is_secret_prim", + cost_var = "cost_col", + suppress = "GH(1,100)", # Hypercube rapide + unif_labels = FALSE, + dir_name = dir_new + ) + }) + cat("Temps version OPTIMISÉE :\n") + print(t_full_new) +}, error = function(e) { + cat("\n[ERREUR] Échec de tab_multi_manager :\n") + message(e$message) +}) + +# 4. VERIFICATION INTEGRALE ET RIGOUREUSE DE BOUT EN BOUT +if (!is.null(res_full_old) && !is.null(res_full_new)) { + + check_e2e <- vapply(seq_along(res_full_old), function(i) { + nom_t <- names(res_full_old)[i] + expl_v <- list_expl_5d[[nom_t]] + + df_o <- res_full_old[[i]] + df_n <- res_full_new[[i]] + + identical( + normalize_for_compare(df_o, expl_v), + normalize_for_compare(df_n, expl_v) + ) + }, logical(1)) + + cat("\n======================================================================\n") + cat("RÉSULTAT DU TEST D'INTÉGRATION GLOBAL (END-TO-END)\n") + cat("======================================================================\n") + cat("1. Nombre de tableaux traites (", length(res_full_old), ") : TRUE\n", sep = "") + cat("2. Egalite stricte de TOUTES les itérations et colonnes :", all(check_e2e), "\n") + + if (all(check_e2e)) { + cat("\n>>> SUCCÈS TOTAL : 100% d'équivalence logique sur toutes les itérations !\n") + cat(">>> Gain de temps global de bout en bout : x", round(t_full_old["elapsed"] / t_full_new["elapsed"], 1), "\n") + } else { + cat("\n>>> ERREUR : Divergence detectee dans les tables :", names(res_full_old)[!check_e2e], "\n") + } + +} else { + cat("\n======================================================================\n") + cat("COMPARAISON IMPOSSIBLE : Au moins une des deux fonctions a échoué.\n") + cat("======================================================================\n") +} + diff --git a/bench/bench_tab_multimanager_rtauargus4.R b/bench/bench_tab_multimanager_rtauargus4.R new file mode 100644 index 0000000..5ea09c7 --- /dev/null +++ b/bench/bench_tab_multimanager_rtauargus4.R @@ -0,0 +1,537 @@ +library(microbenchmark) +library(data.table) +library(purrr) +library(rlang) +library(dplyr) +library(sdcHierarchies) + +library(rtauargus) + +# 1. Sauvegarde des fonctions du package original avant load_all +reduce_dims_old <- rtauargus:::reduce_dims +tab_multi_manager_old <- rtauargus::tab_multi_manager +tab_rtauargus4_old <- rtauargus::tab_rtauargus4 + + +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" +options(rtauargus.tauargus_exe = loc_tauargus) + +set.seed(42) + +# ============================================================================= +# PRÉPARATION DU JEU DE DONNÉES 4D AGRÉGÉ +# ============================================================================= +cat("======================================================================\n") +cat("TEST D'INTÉGRATION 4D : DÉCOMPOSITION DES TEMPS DE CALCUL \n") +cat("======================================================================\n") + +# --- 4D volumineux (ACT hiérarchique, GEO hiérarchique, SEX & AGE non hiérarchiques) +create_big_4D <- function( + n = 200000, + n_act_groups = 30, # Nombre de groupes d'activité (Niveau 1 ACT) + n_act_sub = 50, # Nombre de sous-niveaux par groupe d'activité (Niveau 2 ACT) + n_geo_regions = 50, # Nombre de régions (Niveau 1 GEO) + n_geo_sub = 50, # Nombre de sous-régions par région (Niveau 2 GEO) + n_sex = 2, # Nombre de modalités de SEX (ex: F, M si n_sex=2, sinon S01, S02...) + n_age = 4 # Nombre de modalités d'AGE (ex: AGE01 à AGE04) +) { + set.seed(123) + + # Calcul dynamique de la largeur des chiffres (Zero-padding) + w_act_g <- max(2, nchar(n_act_groups)) + w_act_s <- max(2, nchar(n_act_sub)) + w_geo_r <- max(2, nchar(n_geo_regions)) + w_geo_s <- max(2, nchar(n_geo_sub)) + w_age <- max(2, nchar(n_age)) + + fmt_act_g <- paste0("A%0", w_act_g, "d") + fmt_act_s <- paste0("A%0", w_act_g, "d_%0", w_act_s, "d") + + fmt_geo_r <- paste0("G%0", w_geo_r, "d") + fmt_geo_s <- paste0("G%0", w_geo_r, "d_%0", w_geo_s, "d") + + fmt_age <- paste0("AGE%0", w_age, "d") + + # 1. Définition des niveaux ACT + act_level1 <- sprintf(fmt_act_g, 1:n_act_groups) + act_level2 <- unlist(lapply(1:n_act_groups, function(i) sprintf(fmt_act_s, i, 1:n_act_sub))) + + # 2. Définition des niveaux GEO + geo_level1 <- sprintf(fmt_geo_r, 1:n_geo_regions) + geo_level2 <- unlist(lapply(1:n_geo_regions, function(i) sprintf(fmt_geo_s, i, 1:n_geo_sub))) + + # 3. Définition des modalités SEX (F, M si n_sex = 2, sinon S01, S02...) + sex_mods <- if (n_sex == 2) { + c("Total", "F", "M") + } else { + w_sex <- max(2, nchar(n_sex)) + c("Total", sprintf(paste0("S%0", w_sex, "d"), 1:n_sex)) + } + + # 4. Définition des modalités AGE (AGE01, AGE02...) + age_mods <- c("Total", sprintf(fmt_age, 1:n_age)) + + # 5. Génération du jeu de données + data <- data.frame( + ACT = sample(c("Total", act_level1, act_level2), n, replace = TRUE), + GEO = sample(c("Total", geo_level1, geo_level2), n, replace = TRUE), + SEX = sample(sex_mods, n, replace = TRUE), + AGE = sample(age_mods, n, replace = TRUE), + stringsAsFactors = FALSE + ) + data$VALUE <- 1 + + # Hiérarchie ACT + hrc_act <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total", nodes = act_level1) %>% + { + for (i in 1:n_act_groups) { + root_node <- sprintf(fmt_act_g, i) + children <- sprintf(fmt_act_s, i, 1:n_act_sub) + . <- sdcHierarchies::hier_add(., root = root_node, nodes = children) + } + . + } %>% + 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) + + # Hiérarchie GEO + hrc_geo <- tempfile(fileext = ".hrc") + sdcHierarchies::hier_create(root = "Total", nodes = geo_level1) %>% + { + for (i in 1:n_geo_regions) { + root_node <- sprintf(fmt_geo_r, i) + children <- sprintf(fmt_geo_s, i, 1:n_geo_sub) + . <- sdcHierarchies::hier_add(., root = root_node, nodes = children) + } + . + } %>% + 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) + + list(data = data, + hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), + totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total")) +} + +calc_4D_dimensions <- function( + n_act_groups = 7, # Nombre de groupes d'activité (Niveau 1 ACT) + n_act_sub = 11, # Nombre de sous-niveaux par groupe d'activité (Niveau 2 ACT) + n_geo_regions = 8, # Nombre de régions (Niveau 1 GEO) + n_geo_sub = 10, # Nombre de sous-régions par région (Niveau 2 GEO) + n_sex = 20, # Nombre de modalités fines de SEX + n_age = 15 # Nombre de modalités fines d'AGE +) { + # 1. Calcul du nombre total de modalités par variable (y compris les totaux) + n_mod_act <- (n_act_groups * n_act_sub) + n_act_groups + 1 + n_mod_geo <- (n_geo_regions * n_geo_sub) + n_geo_regions + 1 + n_mod_sex <- n_sex + 1 + n_mod_age <- n_age + 1 + + # 2. Calcul du nombre de sous-tableaux générés (Option MAX / découpage par noeuds) + # Formule : 2 x (noeuds ACT + Total) x (noeuds GEO + Total) + nb_tables <- 2 * (n_act_groups + 1) * (n_geo_regions + 1) + + # 3. Calcul du nombre total de croisements possibles dans la table 4D + nb_croisements <- n_mod_act * n_mod_geo * n_mod_sex * n_mod_age + + # Affichage structuré + cat("======================================================================\n") + cat(" ESTIMATION DE LA COMPLEXITÉ DU DÉCOUPAGE 4D \n") + cat("======================================================================\n") + cat("1. Nombre de sous-tableaux générés :", format(nb_tables, big.mark = " "), "\n") + cat("2. Nombre total de croisements :", format(nb_croisements, big.mark = " "), "\n\n") + cat("Détail des modalités par variable (Totaux inclus) :\n") + cat(" - ACT :", n_mod_act, "modalités (1 Total +", n_act_groups, "groupes +", n_act_groups * n_act_sub, "sous-niveaux)\n") + cat(" - GEO :", n_mod_geo, "modalités (1 Total +", n_geo_regions, "régions +", n_geo_regions * n_geo_sub, "sous-régions)\n") + cat(" - SEX :", n_mod_sex, "modalités (1 Total +", n_sex, "modalités fines)\n") + cat(" - AGE :", n_mod_age, "modalités (1 Total +", n_age, "modalités fines)\n") + cat("======================================================================\n") + + # Retourne les résultats sous forme de liste + invisible(list( + nb_tables = nb_tables, + nb_croisements = nb_croisements, + modalites = c(ACT = n_mod_act, GEO = n_mod_geo, SEX = n_mod_sex, AGE = n_mod_age) + )) +} + + +# 1. Génération des microdonnées 4D +big4 <- create_big_4D( + n = 50000000, + n_act_groups = 4, + n_act_sub = 11, + n_geo_regions = 5, + n_geo_sub = 10, + n_sex = 20, + n_age = 15 +) + +# Exécution avec vos valeurs par défaut +res <- calc_4D_dimensions( + n_act_groups = 4, + n_act_sub = 11, + n_geo_regions = 5, + n_geo_sub = 10, + n_sex = 20, + n_age = 15 +) + +dfs4 <- big4$data + +tot4 <- big4$totcode +hrc4 <- big4$hrcfiles + +# 2. AGRÉGATION : Elimination des doublons pour obtenir des cellules uniques +dfs4_agg <- dfs4 %>% + group_by(across(all_of(names(tot4)))) %>% + summarise( + VALUE = sum(VALUE), + freq = n(), + .groups = "drop" + ) + +# Libère la RAM inutile pendant le reste des benchmarks +rm(dfs4, big4); gc() + +# 3. POSE DU SECRET PRIMAIRE : 10% de secret aléatoire déterministe +set.seed(42) +prop_secret = 0.01 # proabilité qu'une cellule soit en secret primaire +dfs4_agg$is_secret_prim <- sample(c(TRUE, FALSE), nrow(dfs4_agg), replace = TRUE, prob = c(prop_secret, 1 - prop_secret)) +dfs4_agg$secret_no_pl <- FALSE + +# AFFICHAGE DU SECRET AVANT TAU-ARGUS +n_total_cellules <- nrow(dfs4_agg) +n_secret_primaire <- sum(dfs4_agg$is_secret_prim) + +cat("\n----------------------------------------------------------------------\n") +cat("=== BILAN DU SECRET PRIMAIRE (AVANT TAU-ARGUS) ===\n") +cat("Nombre total de cellules uniques dans la table 4D :", n_total_cellules, "\n") +cat("Nombre de cellules en secret primaire :", n_secret_primaire, + sprintf("(%.2f%%)\n", 100 * n_secret_primaire / n_total_cellules)) +cat("----------------------------------------------------------------------\n") + +dir_out_old <- file.path(tempdir(), "tau_4d_old") +dir_out_new <- file.path(tempdir(), "tau_4d_new") +if (!dir.exists(dir_out_old)) dir.create(dir_out_old, recursive = TRUE) +if (!dir.exists(dir_out_new)) dir.create(dir_out_new, recursive = TRUE) + + + +# ============================================================================= +# 1. MESURES SUR LA VERSION ORIGINALE (PACKAGE) +# ============================================================================= +cat("\n--- 1. VERSION ORIGINALE (PACKAGE) ---\n") + +# A1. Mesure isolée de reduce_dims originale +# t_red_old <- system.time({ +# res_red_old <- reduce_dims_old( +# dfs = dfs4_agg, dfs_name = "tab_4d_int", totcode = tot4, hrcfiles = hrc4, +# nb_tab_option = "smart", limit = 50000, over_split = TRUE, sep_dir = TRUE, +# hrc_dir = file.path(dir_out_old, "hrc") +# ) +# }) + +t_red_old <- system.time({ + res_red_old <- reduce_dims_old( + dfs = dfs4_agg, dfs_name = "tab_4d_int", totcode = tot4, hrcfiles = hrc4, + nb_tab_option = "max", sep_dir = TRUE, + hrc_dir = file.path(dir_out_old, "hrc") + ) +}) + +print(t_red_old) + +cat("Nombre de tableaux générés :", length(res_red_old$tabs), "\n") + +# Récupération de la taille (nombre de lignes) de chaque sous-tableau +tailles_tables <- sapply(res_red_old$tabs, nrow) +cat("Statistiques sur le nombre de lignes par tableau (Min, Q1, Médiane, Q3, Max) :\n") +print(summary(tailles_tables)) + +# A2. Mesure isolée de restore_format sur la sortie de reduce_dims +t_rest_old <- system.time({ + dummy_rest_old <- rtauargus::restore_format(masq = res_red_old$tabs, res = res_red_old) +}) + +print(t_rest_old) + +# B. Mesure du flux complet tab_rtauargus4 originale +# t_full_old <- system.time({ +# res_4d_old <- tab_rtauargus4_old( +# tabular = dfs4_agg, +# explanatory_vars = names(tot4), +# dir_name = dir_out_old, +# secret_var = "is_secret_prim", +# totcode = tot4, +# hrc = hrc4, +# value = "VALUE", +# freq = "freq", +# suppress = "GH(1,100)", +# nb_tab_option = "smart", +# limit = 50000, +# dfs_name = "tab_4d_int" +# ) +# }) + +t_full_old <- system.time({ + res_4d_old <- tab_rtauargus4_old( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_out_old, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + nb_tab_option = "max", + dfs_name = "tab_4d_int", + limit = 1000000L # très grand nombre, pour ne pas avoir d'oversplit + ) +}) + +print(t_full_old) + +# ============================================================================= +# 2. MESURES SUR LA VERSION OPTIMISÉE (LOCALE) +# ============================================================================= +cat("\n--- 2. VERSION OPTIMISÉE (LOCALE) ---\n") + +# Chargement du code local APRÈS l'exécution de la version originale +devtools::load_all("Z:/rtauargus") + +# ESSENTIEL : Redéfinir l'option Tau-Argus car load_all() l'a réinitialisée +options(rtauargus.tauargus_exe = loc_tauargus) + +# A1. Mesure isolée de reduce_dims optimisée +# t_red_new <- system.time({ +# res_red_new <- reduce_dims( +# dfs = dfs4_agg, dfs_name = "tab_4d_int", totcode = tot4, hrcfiles = hrc4, +# nb_tab_option = "smart", limit = 50000, over_split = TRUE, sep_dir = TRUE, +# hrc_dir = file.path(dir_out_new, "hrc") +# ) +# }) + +t_red_new <- system.time({ + res_red_new <- reduce_dims( + dfs = dfs4_agg, dfs_name = "tab_4d_int", totcode = tot4, hrcfiles = hrc4, + nb_tab_option = "max", sep_dir = TRUE, + hrc_dir = file.path(dir_out_new, "hrc") + ) +}) + +print(t_red_new) + +cat("Nombre de tableaux générés :", length(res_red_new$tabs), "\n") + +# Récupération de la taille (nombre de lignes) de chaque sous-tableau +tailles_tables <- sapply(res_red_new$tabs, nrow) +cat("Statistiques sur le nombre de lignes par tableau (Min, Q1, Médiane, Q3, Max) :\n") +print(summary(tailles_tables)) + +# A2. Mesure isolée de restore_format sur la sortie de reduce_dims +t_rest_new <- system.time({ + dummy_rest_new <- restore_format(masq = res_red_new$tabs, res = res_red_new) +}) + +print(t_rest_new) + +# B. Mesure du flux complet tab_rtauargus4 optimisée +# t_full_new <- system.time({ +# res_4d_new <- tab_rtauargus4( +# tabular = dfs4_agg, +# explanatory_vars = names(tot4), +# dir_name = dir_out_new, +# secret_var = "is_secret_prim", +# totcode = tot4, +# hrc = hrc4, +# value = "VALUE", +# freq = "freq", +# suppress = "GH(1,100)", +# nb_tab_option = "smart", +# limit = 50000, +# dfs_name = "tab_4d_int" +# ) +# }) + +t_full_new <- system.time({ + res_4d_new <- tab_rtauargus4( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_out_new, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + nb_tab_option = "max", + dfs_name = "tab_4d_int", + keep_history = TRUE, # pour conserver le comportement par défaut + limit = 1000000L # très grand nombre, pour ne pas avoir d'oversplit + ) +}) + +print(t_full_new) + +# ============================================================================= +# 3. BILAN DES SECRETS ET DÉCOMPOSITION DES TEMPS DE CALCUL +# ============================================================================= +cat("\n======================================================================\n") +cat("=== BILAN DU SECRET APPRÈS TAU-ARGUS ===\n") +cat("======================================================================\n") + +# Fonction d'extraction des métriques de secret +get_secret_stats <- function(df) { + # La dernière colonne is_secret_* contient le secret total final + sec_cols <- names(df)[grep("^is_secret_[1-9]", names(df))] + sec_cols <- sec_cols[order(as.integer(gsub("is_secret_", "", sec_cols)))] + last_col <- if(length(sec_cols) > 0) tail(sec_cols, 1) else "Status" + + tot_sec <- if(last_col == "Status") df$Status != "V" else df[[last_col]] + prim_sec <- df$is_secret_prim + sec_sec <- tot_sec & !prim_sec + + data.frame( + "Total_Cellules" = nrow(df), + "Secret_Primaire" = sum(prim_sec), + "Secret_Secondaire" = sum(sec_sec), + "Total_Masque" = sum(tot_sec), + "Pourcentage_Masque" = sprintf("%.2f%%", 100 * sum(tot_sec) / nrow(df)) + ) +} + +cat("\n[Statistiques du secret - Version Originale] :\n") +print(get_secret_stats(res_4d_old)) + +cat("\n[Statistiques du secret - Version Optimisée] :\n") +print(get_secret_stats(res_4d_new)) + +# Décomposition fine des temps +pure_multi_old <- t_full_old["elapsed"] - t_red_old["elapsed"] - t_rest_old["elapsed"] +pure_multi_new <- t_full_new["elapsed"] - t_red_new["elapsed"] - t_rest_new["elapsed"] + +cat("\n======================================================================\n") +cat(" BILAN COMPARATIF DES TEMPS (en secondes) \n") +cat("======================================================================\n") + +cat("\n[1. Temps Total tab_rtauargus4]\n") +cat(" - Original :", round(t_full_old["elapsed"], 2), "s | Optimisé :", round(t_full_new["elapsed"], 2), "s\n") + +cat("\n[2. Part reduce_dims (Amont)]\n") +cat(" - Original :", round(t_red_old["elapsed"], 2), "s | Optimisé :", round(t_red_new["elapsed"], 2), "s\n") + +cat("\n[3. Part restore_format (Aval)]\n") +cat(" - Original :", round(t_rest_old["elapsed"], 2), "s | Optimisé :", round(t_rest_new["elapsed"], 2), "s\n") + +cat("\n[4. Temps PUR tab_multi_manager (Moteur + Tau-Argus)]\n") +cat(" - Original :", round(pure_multi_old, 2), "s | Optimisé :", round(pure_multi_new, 2), "s\n") +cat(" - Gain net :", round(pure_multi_old - pure_multi_new, 2), "secondes économisées\n") + +# Égalité logique finale +normalize_for_compare <- function(df, key_cols) { + df <- as.data.frame(df) + df <- df[, order(names(df)), drop = FALSE] + df <- df[do.call(order, df[key_cols]), , drop = FALSE] + row.names(df) <- NULL + return(df) +} + +b4_is_identical <- identical( + normalize_for_compare(res_4d_old, names(tot4)), + normalize_for_compare(res_4d_new, names(tot4)) +) + +cat("\n======================================================================\n") +cat("Égalité stricte du tableau 4D final reconstitué :", b4_is_identical, "\n") +cat("======================================================================\n") + +# ============================================================================= +# 4. BENCHMARK COMPLÉMENTAIRE : KEEP_HISTORY = FALSE (EXÉCUTION SEULE) +# ============================================================================= +cat("\n======================================================================\n") +cat(" BENCHMARK COMPLÉMENTAIRE : EXÉCUTION AVEC KEEP_HISTORY = FALSE \n") +cat("======================================================================\n") + +dir_kh_false <- file.path(tempdir(), "tau_4d_kh_false") +if (!dir.exists(dir_kh_false)) dir.create(dir_kh_false, recursive = TRUE) + +cat("\n--- Exécution de la version optimisée avec keep_history = FALSE ---\n") +t_full_no_hist <- system.time({ + res_4d_no_hist <- tab_rtauargus4( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_kh_false, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + nb_tab_option = "max", + dfs_name = "tab_4d_int", + limit = 1000000L, + keep_history = FALSE + ) +}) + +print(t_full_no_hist) + +# ============================================================================= +# 5. VÉRIFICATION DE L'ÉGALITÉ ET COMPARISON : TRUE vs FALSE +# ============================================================================= +cat("\n======================================================================\n") +cat("=== COMPARISON KEEP_HISTORY = TRUE vs KEEP_HISTORY = FALSE ===\n") +cat("======================================================================\n") + +get_last_secret_col <- function(df) { + sec_cols <- names(df)[grep("^is_secret_[0-9]+$", names(df))] + if (length(sec_cols) == 0) return(NULL) + sec_cols[order(as.integer(gsub("is_secret_", "", sec_cols)))] |> tail(1) +} + +last_col_true <- get_last_secret_col(res_4d_new) +last_col_false <- get_last_secret_col(res_4d_no_hist) + +cat("Colonne de secret final (keep_history = TRUE) :", last_col_true, "\n") +cat("Colonne de secret final (keep_history = FALSE) :", last_col_false, "\n") + +cols_base <- c(names(tot4), "VALUE", "freq", "is_secret_prim", "secret_no_pl") + +df_true_sub <- res_4d_new[, c(cols_base, last_col_true)] +df_false_sub <- res_4d_no_hist[, c(cols_base, last_col_false)] + +colnames(df_true_sub)[ncol(df_true_sub)] <- "final_secret_mask" +colnames(df_false_sub)[ncol(df_false_sub)] <- "final_secret_mask" + +b_identical_history <- identical( + normalize_for_compare(df_true_sub, names(tot4)), + normalize_for_compare(df_false_sub, names(tot4)) +) + +cat("\n----------------------------------------------------------------------\n") +cat("Égalité stricte des masques de secret finaux :", b_identical_history, "\n") +cat("----------------------------------------------------------------------\n") + +cat("Cellules en secret secondaire (TRUE) :", sum(df_true_sub$final_secret_mask & !df_true_sub$is_secret_prim), "\n") +cat("Cellules en secret secondaire (FALSE) :", sum(df_false_sub$final_secret_mask & !df_false_sub$is_secret_prim), "\n") + +mem_true <- format(object.size(res_4d_new), units = "auto") +mem_false <- format(object.size(res_4d_no_hist), units = "auto") + +cat("\n[Bilan Mémoire R (object.size)] :\n") +cat(" - keep_history = TRUE (274 colonnes) :", mem_true, "\n") +cat(" - keep_history = FALSE ( 9 colonnes) :", mem_false, "\n") + +cat("\n[Bilan Temps d'exécution (Elapsed)] :\n") +cat(" - keep_history = TRUE :", round(t_full_new["elapsed"], 2), "s\n") +cat(" - keep_history = FALSE :", round(t_full_no_hist["elapsed"], 2), "s\n") +cat(" - Gain de temps :", round(t_full_new["elapsed"] - t_full_no_hist["elapsed"], 2), "s\n") diff --git a/bench/comp_limit_smart_4D.R b/bench/comp_limit_smart_4D.R new file mode 100644 index 0000000..e5272c8 --- /dev/null +++ b/bench/comp_limit_smart_4D.R @@ -0,0 +1,1195 @@ +create_big_4D <- function( + n = 200000, + n_act_groups = 30, + n_act_sub = 50, + n_geo_regions = 50, + n_geo_sub = 50, + n_sex = 2, + n_age = 4, + add_dim5 = FALSE, + complete_grid = TRUE +){ + set.seed(123) + + w_act_g <- max(2, nchar(n_act_groups)) + w_act_s <- max(2, nchar(n_act_sub)) + w_geo_r <- max(2, nchar(n_geo_regions)) + w_geo_s <- max(2, nchar(n_geo_sub)) + w_age <- max(2, nchar(n_age)) + + fmt_act_g <- paste0("A%0", w_act_g, "d") + fmt_act_s <- paste0("A%0", w_act_g, "d_%0", w_act_s, "d") # typo corrigée + fmt_geo_r <- paste0("G%0", w_geo_r, "d") + fmt_geo_s <- paste0("G%0", w_geo_r, "d_%0", w_geo_s, "d") + fmt_age <- paste0("AGE%0", w_age, "d") + + act_level1 <- sprintf(fmt_act_g, 1:n_act_groups) + act_level2 <- unlist(lapply(1:n_act_groups, function(i) sprintf(fmt_act_s, i, 1:n_act_sub))) + geo_level1 <- sprintf(fmt_geo_r, 1:n_geo_regions) + geo_level2 <- unlist(lapply(1:n_geo_regions, function(i) sprintf(fmt_geo_s, i, 1:n_geo_sub))) + + sex_leaves <- if (n_sex == 2) c("F", "M") else { + w_sex <- max(2, nchar(n_sex)) + sprintf(paste0("S%0", w_sex, "d"), 1:n_sex) + } + age_leaves <- sprintf(fmt_age, 1:n_age) + + dim_vars <- if (add_dim5) c("ACT", "GEO", "SEX", "AGE", "ECO") + else c("ACT", "GEO", "SEX", "AGE") + + # ---- 1. Microdonnées FEUILLES uniquement -------------------------------- + dt <- data.table( + ACT = sample(act_level2, n, replace = TRUE), + GEO = sample(geo_level2, n, replace = TRUE), + SEX = sample(sex_leaves, n, replace = TRUE), + AGE = sample(age_leaves, n, replace = TRUE) + ) + if (add_dim5) dt[, ECO := sample(c("mod1", "mod2"), n, replace = TRUE)] + + # Agrégation feuilles : libère immédiatement les 50M lignes + dt_leaf <- dt[, .(VALUE = .N), by = dim_vars] + rm(dt); invisible(gc()) + + # ---- 2. Tables de correspondance hiérarchiques -------------------------- + # mk_map : leaf → {leaf, parent (si fourni), "Total"} + mk_map <- function(leaves, parents = NULL) { + rows <- list(data.table(from = leaves, to = leaves)) + if (!is.null(parents)) rows[[2]] <- data.table(from = leaves, to = parents) + rows[[length(rows) + 1]] <- data.table(from = leaves, to = "Total") + rbindlist(rows) + } + + map_act <- mk_map(act_level2, sub("_[0-9]+$", "", act_level2)) + map_geo <- mk_map(geo_level2, sub("_[0-9]+$", "", geo_level2)) + map_sex <- mk_map(sex_leaves) + map_age <- mk_map(age_leaves) + + # ---- 3. Expansion dimension par dimension (join data.table) ------------- + # Pour chaque dimension : on remplace la valeur feuille par TOUTES ses + # valeurs hiérarchiques (leaf, parent, Total) via un join one-to-many. + rollup_dim <- function(dt, col, map) { + # map[dt, ...] : right-join — pour chaque ligne de dt, trouve les + # correspondances dans map (3 ou 2 lignes par valeur feuille) + result <- map[dt, on = c(from = col), allow.cartesian = TRUE] + # result a : from | to | [autres colonnes de dt sauf col] + result[, (col) := to][, c("from", "to") := NULL] + result + } + + dt_exp <- rollup_dim(dt_leaf, "ACT", map_act) + dt_exp <- rollup_dim(dt_exp, "GEO", map_geo) + dt_exp <- rollup_dim(dt_exp, "SEX", map_sex) + dt_exp <- rollup_dim(dt_exp, "AGE", map_age) + + if (add_dim5) dt_exp <- rollup_dim(dt_exp, "ECO", mk_map(c("mod1", "mod2"))) + + rm(dt_leaf); invisible(gc()) + + # ---- 4. Agrégation finale ----------------------------------------------- + # À ce stade dt_exp a : 96 000 × 3 × 3 × 2 × 2 ≈ 3,5 M lignes (4D) + dfs_agg <- dt_exp[, .(VALUE = sum(VALUE)), by = dim_vars] + rm(dt_exp); invisible(gc()) + + # ---- 4b. COMPLÉTION DE LA GRILLE AVEC LES 0 (Si complete_grid = TRUE) --- + if (complete_grid) { + grid_all <- list( + ACT = unique(map_act$to), + GEO = unique(map_geo$to), + SEX = unique(map_sex$to), + AGE = unique(map_age$to) + ) + if (add_dim5) grid_all$ECO <- c("mod1", "mod2", "Total") + + # Produit cartésien de toutes les modalités (feuilles, parents, Total) + full_grid <- do.call(CJ, c(grid_all, list(sorted = FALSE))) + + # Jointure avec la grille complète et remplacement des NA par 0 + dfs_agg <- dfs_agg[full_grid, on = dim_vars] + dfs_agg[is.na(VALUE), VALUE := 0] + } + + # ---- 5. Fichiers .hrc --------------------------------------------------- + write_hrc <- function(hier, path) { + hier %>% + sdcHierarchies::hier_convert(as = "argus") %>% + dplyr::slice(-1) %>% + dplyr::mutate(levels = substring(paste0(level, name), 3)) %>% + dplyr::select(levels) %>% + write.table(file = path, row.names = FALSE, col.names = FALSE, quote = FALSE) + } + + hrc_act <- tempfile(fileext = ".hrc") + h_act <- sdcHierarchies::hier_create(root = "Total", nodes = act_level1) + for (i in seq_len(n_act_groups)) + h_act <- sdcHierarchies::hier_add(h_act, root = sprintf(fmt_act_g, i), + nodes = sprintf(fmt_act_s, i, 1:n_act_sub)) + write_hrc(h_act, hrc_act) + + hrc_geo <- tempfile(fileext = ".hrc") + h_geo <- sdcHierarchies::hier_create(root = "Total", nodes = geo_level1) + for (i in seq_len(n_geo_regions)) + h_geo <- sdcHierarchies::hier_add(h_geo, root = sprintf(fmt_geo_r, i), + nodes = sprintf(fmt_geo_s, i, 1:n_geo_sub)) + write_hrc(h_geo, hrc_geo) + + totcode <- if (add_dim5) + c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total", ECO = "Total") + else + c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total") + + list(data = dfs_agg, hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), totcode = totcode) +} + +# ============================================================================ = +# 00_setup_bench_options +# Génère données 5D pour le benchmark min/smart/max +# ============================================================================ = + +BENCH_DIR <- "Z:/benchmark_options_4D" +dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) + +library(data.table); library(dplyr); library(sdcHierarchies) + +set.seed(123) +big4 <- create_big_4D( + n = 500000, + n_act_groups = 8, n_act_sub = 7, + n_geo_regions = 7, n_geo_sub = 8, + n_sex = 5, n_age = 4, + add_dim5 = FALSE +) + +hrc4 <- c( + ACT = file.path(BENCH_DIR, "hrc", "hrc_ACT.hrc"), + GEO = file.path(BENCH_DIR, "hrc", "hrc_GEO.hrc") +) +file.copy(big4$hrcfiles["ACT"], hrc4["ACT"], overwrite = TRUE) +file.copy(big4$hrcfiles["GEO"], hrc4["GEO"], overwrite = TRUE) + +tot4 <- big4$totcode +# # 1. Filtrer les cellules à 0 inutiles (conserver uniquement VALUE > 0 ou secret primaire) +# dfs4_agg <- dfs4_agg %>% filter(VALUE > 0 | is_secret_prim) + +# 2. S'assurer du format data.frame classique +# dfs4_agg <- as.data.frame(big4$data) +dfs4_agg = big4$data + +dfs4_agg %>% tally() +dfs4_agg %>% arrange(VALUE) + +dfs4_agg %>% summarise(secret_prim = mean(as.integer(VALUE > 0 & VALUE <= 5))) + +dfs4_agg$is_secret_prim <- dfs4_agg$VALUE > 0 & dfs4_agg$VALUE <= 5 +dfs4_agg$secret_no_pl <- FALSE +dfs4_agg$freq <- dfs4_agg$VALUE + +cat("Nombre de cellules :", nrow(dfs4_agg), "\n") +cat("Secret primaire :", sum(dfs4_agg$is_secret_prim), + sprintf("(%.2f%%)\n", 100 * mean(dfs4_agg$is_secret_prim))) + +save(dfs4_agg, tot4, hrc4, + file = file.path(BENCH_DIR, "input_data_4d.RData")) +cat("Setup 5D OK →", BENCH_DIR, "\n") +cat("Redémarrer R, puis lancer bench_nb_tab_option.R\n") + +# ============================================================================ = +# bench_nb_tab_option.R ---- +# Compare nb_tab_option "min" / "smart" / "max" +# ============================================================================ = + +BENCH_DIR <- "Z:/benchmark_options_4D" +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" + +library(data.table); library(dplyr) +devtools::load_all("Z:/rtauargus") +options(rtauargus.tauargus_exe = loc_tauargus) + +load(file.path(BENCH_DIR, "input_data_4d.RData")) # dfs4_agg, tot4, hrc4 + +# ============================================================================ = +# UTILITAIRES ---- +# ============================================================================ = + +capture_gc <- function(label) { + g <- gc() + data.frame( + label = label, type = rownames(g), + used_mb = g[, 2], trigger_mb = g[, 4], max_mb = g[, 6], + row.names = NULL + ) +} + +# Fonction universelle pour récupérer le masque de secret final (compatible split_tab = TRUE et FALSE) +get_final_secret_vec <- function(df) { + # Cas 1 : colonnes du type is_secret_1, is_secret_2 (split_tab = TRUE) + cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] + if (length(cols) > 0) { + last_col <- cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) + return(as.logical(df[[last_col]])) + } + + # Cas 2 : colonne Status (split_tab = FALSE) + if ("Status" %in% names(df)) { + if (is.logical(df$Status)) { + return(df$Status) + } else { + # TauArgus : 'V' = Valide, 'A'/'B'/'D' = Masqué (primaire ou secondaire) + return(df$Status != "V") + } + } + + stop("Aucune colonne de secret valide (is_secret_N ou Status) n'a été trouvée dans le data.frame.") +} + +# Mise à jour de get_secret_stats (utilise désormais get_final_secret_vec) +get_secret_stats <- function(df, label) { + final <- get_final_secret_vec(df) + prim <- as.logical(df$is_secret_prim) + sec <- final & !prim + + data.frame( + label = label, + n_prim = sum(prim, na.rm = TRUE), + value_prim = sum(df$VALUE[prim], na.rm = TRUE), + n_sec = sum(sec, na.rm = TRUE), + value_sec = sum(df$VALUE[sec], na.rm = TRUE), + n_total_masque = sum(final, na.rm = TRUE), + value_total_masque = sum(df$VALUE[final], na.rm = TRUE), + pct_masque_cells = round(100 * mean(final, na.rm = TRUE), 2), + pct_masque_value = round(100 * sum(df$VALUE[final], na.rm = TRUE) / + sum(df$VALUE, na.rm = TRUE), 2) + ) +} + +# Mise à jour de extract_mask +extract_mask <- function(df, tot) { + final <- get_final_secret_vec(df) + df_min <- as.data.frame(df)[, names(tot), drop = FALSE] + df_min$final_secret <- final + df_min <- df_min[do.call(order, df_min[names(tot)]), ] + rownames(df_min) <- NULL + df_min +} + +# ============================================================================ = +# VARIANTS ---- +# ============================================================================ = + +# Pour "min" et "max", limit très grand = pas d'oversplit parasite +# Pour "smart", limit change de fonction du scénario +variants <- list( + list(label = "min", nb_tab_option = "min", limit = 1000000L), + #list(label = "smart_false_min", nb_tab_option = "smart", limit = 10000000L), + list(label = "smart_108000", nb_tab_option = "smart", limit = 108000L), + # list(label = "smart_80000", nb_tab_option = "smart", limit = 80000L), + # list(label = "smart_70000", nb_tab_option = "smart", limit = 70000L), + # list(label = "smart_50000", nb_tab_option = "smart", limit = 50000L), + list(label = "smart_15800", nb_tab_option = "smart", limit = 15800L), + # list(label = "smart_26000", nb_tab_option = "smart", limit = 26000L), + list(label = "smart_15600", nb_tab_option = "smart", limit = 15600L) + # list(label = "smart_false_max", nb_tab_option = "smart", limit = 1L), + # list(label = "max", nb_tab_option = "max", limit = 1000000L) +) + +# pre-run de reduce dims pour voir combien de tables génèrent les configs +# et si certaines sont redondantes entre elles (même résultat) +for (v in variants) { + + cat("\n======================================================================\n") + cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, + "| limit =", v$limit, ")\n") + cat("======================================================================\n") + + # --- Pré-mesure : nombre de sous-tables générées --- + # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. + # Overhead ~5-10s, négligeable face au run complet. + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs4_agg, + dfs_name = "tab_4d", + totcode = tot4, + hrcfiles = hrc4, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = TRUE # affichera le nombre de tables générées ainsi que leur distribution + ) + rm(res_count); gc() + +} + +# HYPBERCUBE -------------------------------------------------------------- + +results_raw <- list() +stats_list <- list() +timings_list <- list() +gc_list <- list() +ntables_list <- list() + +# ============================================================================ = +# BOUCLE PRINCIPALE +# ============================================================================ = + +for (v in variants) { + + cat("\n======================================================================\n") + cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, + "| limit =", v$limit, ")\n") + cat("======================================================================\n") + + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) + dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) + + # --- Pré-mesure : nombre de sous-tables générées --- + # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. + # Overhead ~5-10s, négligeable face au run complet. + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs4_agg, + dfs_name = "tab_4d", + totcode = tot4, + hrcfiles = hrc4, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = FALSE + ) + n_tables <- length(res_count$tabs) + tailles <- sapply(res_count$tabs, nrow) + + # cat(" Sous-tables générées :", n_tables, "\n") + # cat(" Lignes par sous-table :\n") + # print(summary(tailles)) + # cat("\n\n\n") + rm(res_count); gc() + + ntables_list[[v$label]] <- data.frame( + label = v$label, + n_tables = n_tables, + min_rows = if (length(tailles) > 0) min(tailles) else 0, + med_rows = if (length(tailles) > 0) median(tailles) else 0, + max_rows = if (length(tailles) > 0) max(tailles) else 0 + ) + + # --- Run complet --- + gc(reset = TRUE) + + t_v <- system.time({ + res_v <- tab_rtauargus4( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_v, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + nb_tab_option = v$nb_tab_option, + dfs_name = "tab_4d", + limit = v$limit, + keep_history = FALSE + ) + }) + + results_raw[[v$label]] <- res_v + stats_list[[v$label]] <- get_secret_stats(res_v, v$label) + timings_list[[v$label]] <- data.frame( + label = v$label, + elapsed = t_v["elapsed"], + user = t_v["user.self"], + sys = t_v["sys.self"] + ) + gc_list[[v$label]] <- capture_gc(v$label) + + # Sauvegarde intermédiaire (filet de sécurité) + write.csv(stats_list[[v$label]], + file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), + row.names = FALSE) + write.csv(timings_list[[v$label]], + file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), + row.names = FALSE) + write.csv(gc_list[[v$label]], + file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), + row.names = FALSE) + + # ======================================================================== = + # 📊 AFFICHAGE IMMÉDIAT EN CONSOLE + # ======================================================================== = + cat("\n----------------------------------------------------------------------\n") + cat(" 📊 RÉSULTATS OBTENUS POUR :", v$label, "\n") + cat("----------------------------------------------------------------------\n") + + cat("⏱️ [Timing] :\n") + print(timings_list[[v$label]]) + + cat("\n🔒 [Statistiques de secret] :\n") + print(stats_list[[v$label]]) + + cat("\n💾 [Mémoire (Vcells)] :\n") + print(gc_list[[v$label]] %>% filter(type == "Vcells")) + + cat("\n✓", v$label, "terminé avec succès en", round(t_v["elapsed"] / 60, 2), "minutes.\n") +} + +# ============================================================================ = +# RECHARGEMENT DES RÉSULTATS DEPUIS LE DISQUE +# ============================================================================ = + +results_raw <- list() +stats_list <- list() +timings_list <- list() +gc_list <- list() +ntables_list <- list() + +cat("Rechargement des fichiers CSV enregistrés...\n") + +for (v in variants) { + lbl <- v$label + + # 1. Lecture des fichiers CSV sauvegardés + file_secret <- file.path(BENCH_DIR, paste0("secret_", lbl, ".csv")) + file_timing <- file.path(BENCH_DIR, paste0("timing_", lbl, ".csv")) + file_gc <- file.path(BENCH_DIR, paste0("gc_", lbl, ".csv")) + + if (file.exists(file_secret)) stats_list[[lbl]] <- read.csv(file_secret) + if (file.exists(file_timing)) timings_list[[lbl]] <- read.csv(file_timing) + if (file.exists(file_gc)) gc_list[[lbl]] <- read.csv(file_gc) + + # 2. Recalcul rapide du nombre de sous-tables (reduce_dims seul est très rapide, ~5s) + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", lbl)) + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs4_agg, + dfs_name = "tab_4d", + totcode = tot4, + hrcfiles = hrc4, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = FALSE + ) + + n_tables <- length(res_count$tabs) + tailles <- sapply(res_count$tabs, nrow) + + ntables_list[[lbl]] <- data.frame( + label = lbl, + n_tables = n_tables, + min_rows = if (length(tailles) > 0) min(tailles) else 0, + med_rows = if (length(tailles) > 0) median(tailles) else 0, + max_rows = if (length(tailles) > 0) max(tailles) else 0 + ) + + rm(res_count); gc() +} + + +# ============================================================================ = +# BILAN FINAL +# ============================================================================ = + +cat("\n======================================================================\n") +cat(" BILAN COMPARATIF : min / smart_* / max \n") +cat("======================================================================\n") + +cat("\n[1. Nombre et dimensions des sous-tables générées]\n") +df_tables_summary <- bind_rows(ntables_list) %>% + rename( + `Variant` = label, + `Nb tables` = n_tables, + `Taille min (lignes)` = min_rows, + `Taille med (lignes)` = med_rows, + `Taille max (lignes)` = max_rows + ) +print(as.data.frame(df_tables_summary)) + +cat("\n[2. Timings (elapsed, secondes)]\n") +print(bind_rows(timings_list)) + +cat("\n[3. Pic mémoire Vcells]\n") +gc_all <- bind_rows(gc_list) +print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) + +cat("\n[4. Statistiques de secret]\n") +print(bind_rows(stats_list)) + +# # ============================================================================ = +# # COMPARAISON CELLULE PAR CELLULE +# # ============================================================================ = +# +# cat("\n[5. Comparaison des masques de secret final]\n") +# +# # mask_min <- extract_mask(results_raw[["min"]], tot4) +# # mask_smart <- extract_mask(results_raw[["smart"]], tot4) +# # mask_max <- extract_mask(results_raw[["max"]], tot4) +# +# # Extraction dynamique des masques pour TOUTES les variantes exécutées +# masks <- lapply(results_raw, extract_mask, tot4) +# +# compare_masks <- function(m1, m2, l1, l2) { +# if (identical(m1, m2)) { +# cat(l1, "==", l2, ": TRUE\n"); return(invisible(NULL)) +# } +# n_diff <- sum(m1$final_secret != m2$final_secret) +# cat(l1, "==", l2, ": FALSE —", +# n_diff, sprintf("cellules différentes (%.3f%%)\n", +# 100 * n_diff / nrow(m1))) +# } +# +# cat("\n--- Comparaison par rapport aux références (min & max) ---\n") +# +# ref_labels <- c("min", "max") +# other_labels <- setdiff(names(masks), ref_labels) +# +# # 1. Comparaison min vs max +# compare_masks(masks[["min"]], masks[["max"]], "min", "max") +# +# # 2. Comparaison de chaque smart_* contre min (on peut ajouter d'autres références au besoin) +# for (lbl in other_labels) { +# compare_masks(masks[["min"]], masks[[lbl]], "min", lbl) +# } + +# ============================================================================ = +# TEST INDÉPENDANT : split_tab = FALSE +# ============================================================================ = + +cat("\n======================================================================\n") +cat(" TEST INDÉPENDANT : tab_rtauargus (split_tab = FALSE)\n") +cat("======================================================================\n") + +dir_nosplit <- file.path(BENCH_DIR, "tauargus_no_split") +dir.create(file.path(dir_nosplit, "hrc"), recursive = TRUE, showWarnings = FALSE) + +gc(reset = TRUE) + +t_nosplit <- system.time({ + run_nosplit <- tryCatch({ + + res_nosplit <- tab_rtauargus( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_nosplit, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + split_tab = FALSE + ) + + list(status = "OK", data = res_nosplit) + + }, error = function(e) { + list(status = "ERROR", message = e$message) + }) +}) + +if (run_nosplit$status == "OK") { + cat("\n✓ Exécution split_tab = FALSE réussie !\n") + cat(" Temps d'exécution :", round(t_nosplit["elapsed"], 2), "secondes (", + round(t_nosplit["elapsed"] / 60, 2), "minutes )\n\n") + + stats_nosplit <- get_secret_stats(run_nosplit$data, "no_split") + cat(" Statistiques de secret (no_split) :\n") + print(stats_nosplit) + + # Sauvegarde séparée du résultat sans split + write.csv(stats_nosplit, file.path(BENCH_DIR, "secret_no_split.csv"), row.names = FALSE) + write.csv(data.frame(label = "no_split", elapsed = t_nosplit["elapsed"]), + file.path(BENCH_DIR, "timing_no_split.csv"), row.names = FALSE) + + # # Comparaison du masque sans split vs min + # if (!is.null(results_raw[["min"]])) { + # mask_min <- extract_mask(results_raw[["min"]], tot4) + # mask_nosplit <- extract_mask(run_nosplit$data, tot4) + # cat("\n Comparaison du masque 'no_split' vs 'min' :\n") + # compare_masks(mask_min, mask_nosplit, "min", "no_split") + # } + +} else { + cat("\n❌ ERREUR lors de l'exécution de split_tab = FALSE :\n") + cat(" Message :", run_nosplit$message, "\n") + cat(" Temps écoulé avant échec :", round(t_nosplit["elapsed"], 2), "secondes\n") +} + + +# MODULAR ----------------------------------------------------------------- +BENCH_DIR <- "Z:/benchmark_options_4D_MODULAR" +dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) + +results_raw_mod <- list() +stats_list_mod <- list() +timings_list_mod <- list() +gc_list_mod <- list() +ntables_list_mod <- list() + +# ============================================================================ = +# BOUCLE PRINCIPALE +# ============================================================================ = + +for (v in variants) { + + cat("\n======================================================================\n") + cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, + "| limit =", v$limit, ")\n") + cat("======================================================================\n") + + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) + dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) + + # --- Pré-mesure : nombre de sous-tables générées --- + # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. + # Overhead ~5-10s, négligeable face au run complet. + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs4_agg, + dfs_name = "tab_4d", + totcode = tot4, + hrcfiles = hrc4, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = FALSE + ) + n_tables <- length(res_count$tabs) + tailles <- sapply(res_count$tabs, nrow) + + # cat(" Sous-tables générées :", n_tables, "\n") + # cat(" Lignes par sous-table :\n") + # print(summary(tailles)) + # cat("\n\n\n") + rm(res_count); gc() + + ntables_list_mod[[v$label]] <- data.frame( + label = v$label, + n_tables = n_tables, + min_rows = if (length(tailles) > 0) min(tailles) else 0, + med_rows = if (length(tailles) > 0) median(tailles) else 0, + max_rows = if (length(tailles) > 0) max(tailles) else 0 + ) + + # --- Run complet --- + gc(reset = TRUE) + + t_v <- system.time({ + res_v <- tab_rtauargus4( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_v, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + nb_tab_option = v$nb_tab_option, + dfs_name = "tab_4d", + limit = v$limit, + keep_history = FALSE + ) + }) + + results_raw_mod[[v$label]] <- res_v + stats_list_mod[[v$label]] <- get_secret_stats(res_v, v$label) + timings_list_mod[[v$label]] <- data.frame( + label = v$label, + elapsed = t_v["elapsed"], + user = t_v["user.self"], + sys = t_v["sys.self"] + ) + gc_list_mod[[v$label]] <- capture_gc(v$label) + + # Sauvegarde intermédiaire (filet de sécurité) + write.csv(stats_list_mod[[v$label]], + file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), + row.names = FALSE) + write.csv(timings_list_mod[[v$label]], + file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), + row.names = FALSE) + write.csv(gc_list_mod[[v$label]], + file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), + row.names = FALSE) + + # ======================================================================== = + # 📊 AFFICHAGE IMMÉDIAT EN CONSOLE + # ======================================================================== = + cat("\n----------------------------------------------------------------------\n") + cat(" 📊 RÉSULTATS OBTENUS POUR :", v$label, "\n") + cat("----------------------------------------------------------------------\n") + + cat("⏱️ [Timing] :\n") + print(timings_list[[v$label]]) + + cat("\n🔒 [Statistiques de secret] :\n") + print(stats_list[[v$label]]) + + cat("\n💾 [Mémoire (Vcells)] :\n") + print(gc_list[[v$label]] %>% filter(type == "Vcells")) + + cat("\n✓", v$label, "terminé avec succès en", round(t_v["elapsed"] / 60, 2), "minutes.\n") +} + +# ============================================================================ = +# RECHARGEMENT DES RÉSULTATS DEPUIS LE DISQUE +# ============================================================================ = + +results_raw_mod <- list() +stats_list_mod <- list() +timings_list_mod <- list() +gc_list_mod <- list() +ntables_list_mod <- list() + +cat("Rechargement des fichiers CSV enregistrés...\n") + +for (v in variants) { + lbl <- v$label + + # 1. Lecture des fichiers CSV sauvegardés + file_secret <- file.path(BENCH_DIR, paste0("secret_", lbl, ".csv")) + file_timing <- file.path(BENCH_DIR, paste0("timing_", lbl, ".csv")) + file_gc <- file.path(BENCH_DIR, paste0("gc_", lbl, ".csv")) + + if (file.exists(file_secret)) stats_list_mod[[lbl]] <- read.csv(file_secret) + if (file.exists(file_timing)) timings_list_mod[[lbl]] <- read.csv(file_timing) + if (file.exists(file_gc)) gc_list_mod[[lbl]] <- read.csv(file_gc) + + # 2. Recalcul rapide du nombre de sous-tables (reduce_dims seul est très rapide, ~5s) + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", lbl)) + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs4_agg, + dfs_name = "tab_4d", + totcode = tot4, + hrcfiles = hrc4, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = FALSE + ) + + n_tables <- length(res_count$tabs) + tailles <- sapply(res_count$tabs, nrow) + + ntables_list_mod[[lbl]] <- data.frame( + label = lbl, + n_tables = n_tables, + min_rows = if (length(tailles) > 0) min(tailles) else 0, + med_rows = if (length(tailles) > 0) median(tailles) else 0, + max_rows = if (length(tailles) > 0) max(tailles) else 0 + ) + + rm(res_count); gc() +} + + +# ============================================================================ = +# BILAN FINAL +# ============================================================================ = + +cat("\n======================================================================\n") +cat(" BILAN COMPARATIF : min / smart_* / max \n") +cat("======================================================================\n") + +cat("\n[1. Nombre et dimensions des sous-tables générées]\n") +df_tables_summary <- bind_rows(ntables_list_mod) %>% + rename( + `Variant` = label, + `Nb tables` = n_tables, + `Taille min (lignes)` = min_rows, + `Taille med (lignes)` = med_rows, + `Taille max (lignes)` = max_rows + ) +print(as.data.frame(df_tables_summary)) + +cat("\n[2. Timings (elapsed, secondes)]\n") +print(bind_rows(timings_list_mod)) + +cat("\n[3. Pic mémoire Vcells]\n") +gc_all <- bind_rows(gc_list_mod) +print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) + +cat("\n[4. Statistiques de secret]\n") +print(bind_rows(stats_list_mod)) +# +# # ============================================================================ = +# # COMPARAISON CELLULE PAR CELLULE +# # ============================================================================ = +# +# cat("\n[5. Comparaison des masques de secret final]\n") +# +# # mask_min <- extract_mask(results_raw_mod[["min"]], tot4) +# # mask_smart <- extract_mask(results_raw_mod[["smart"]], tot4) +# # mask_max <- extract_mask(results_raw_mod[["max"]], tot4) +# +# # Extraction dynamique des masques pour TOUTES les variantes exécutées +# masks <- lapply(results_raw_mod, extract_mask, tot4) +# +# compare_masks <- function(m1, m2, l1, l2) { +# if (identical(m1, m2)) { +# cat(l1, "==", l2, ": TRUE\n"); return(invisible(NULL)) +# } +# n_diff <- sum(m1$final_secret != m2$final_secret) +# cat(l1, "==", l2, ": FALSE —", +# n_diff, sprintf("cellules différentes (%.3f%%)\n", +# 100 * n_diff / nrow(m1))) +# } +# +# cat("\n--- Comparaison par rapport aux références (min & max) ---\n") +# +# ref_labels <- c("min", "max") +# other_labels <- setdiff(names(masks), ref_labels) +# +# # 1. Comparaison min vs max +# compare_masks(masks[["min"]], masks[["max"]], "min", "max") +# +# # 2. Comparaison de chaque smart_* contre min (on peut ajouter d'autres références au besoin) +# for (lbl in other_labels) { +# compare_masks(masks[["min"]], masks[[lbl]], "min", lbl) +# } + +# ============================================================================ = +# TEST INDÉPENDANT : split_tab = FALSE +# ============================================================================ = + +cat("\n======================================================================\n") +cat(" TEST INDÉPENDANT : tab_rtauargus (split_tab = FALSE)\n") +cat("======================================================================\n") + +dir_nosplit <- file.path(BENCH_DIR, "tauargus_no_split") +dir.create(file.path(dir_nosplit, "hrc"), recursive = TRUE, showWarnings = FALSE) + +gc(reset = TRUE) + +t_nosplit <- system.time({ + run_nosplit <- tryCatch({ + + res_nosplit <- tab_rtauargus( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_nosplit, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + split_tab = FALSE + ) + + list(status = "OK", data = res_nosplit) + + }, error = function(e) { + list(status = "ERROR", message = e$message) + }) +}) + +if (run_nosplit$status == "OK") { + cat("\n✓ Exécution split_tab = FALSE réussie !\n") + cat(" Temps d'exécution :", round(t_nosplit["elapsed"], 2), "secondes (", + round(t_nosplit["elapsed"] / 60, 2), "minutes )\n\n") + + stats_nosplit <- get_secret_stats(run_nosplit$data, "no_split") + cat(" Statistiques de secret (no_split) :\n") + print(stats_nosplit) + + # Sauvegarde séparée du résultat sans split + write.csv(stats_nosplit, file.path(BENCH_DIR, "secret_no_split.csv"), row.names = FALSE) + write.csv(data.frame(label = "no_split", elapsed = t_nosplit["elapsed"]), + file.path(BENCH_DIR, "timing_no_split.csv"), row.names = FALSE) + + # # Comparaison du masque sans split vs min + # if (!is.null(results_raw_mod[["min"]])) { + # mask_min <- extract_mask(results_raw_mod[["min"]], tot4) + # mask_nosplit <- extract_mask(run_nosplit$data, tot4) + # cat("\n Comparaison du masque 'no_split' vs 'min' :\n") + # compare_masks(mask_min, mask_nosplit, "min", "no_split") + # } + +} else { + cat("\n❌ ERREUR lors de l'exécution de split_tab = FALSE :\n") + cat(" Message :", run_nosplit$message, "\n") + cat(" Temps écoulé avant échec :", round(t_nosplit["elapsed"], 2), "secondes\n") +} + + +# ============================================================================ = +# OPTIMAL --------------------------------------------------------------------- +# ============================================================================ = + +BENCH_DIR <- "Z:/benchmark_options_4D_OPTIMAL" +dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) + +results_raw_opt <- list() +stats_list_opt <- list() +timings_list_opt <- list() +gc_list_opt <- list() +ntables_list_opt <- list() + +# ============================================================================ = +# BOUCLE PRINCIPALE +# ============================================================================ = + +for (v in variants) { + + cat("\n======================================================================\n") + cat(" [OPTIMAL] Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, + "| limit =", v$limit, ")\n") + cat("======================================================================\n") + + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) + dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) + + # --- Pré-mesure : nombre de sous-tables générées --- + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs4_agg, + dfs_name = "tab_4d", + totcode = tot4, + hrcfiles = hrc4, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = FALSE + ) + n_tables <- length(res_count$tabs) + tailles <- sapply(res_count$tabs, nrow) + + rm(res_count); gc() + + ntables_list_opt[[v$label]] <- data.frame( + label = v$label, + n_tables = n_tables, + min_rows = if (length(tailles) > 0) min(tailles) else 0, + med_rows = if (length(tailles) > 0) median(tailles) else 0, + max_rows = if (length(tailles) > 0) max(tailles) else 0 + ) + + # --- Run complet --- + gc(reset = TRUE) + + t_v <- system.time({ + res_v <- tab_rtauargus4( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_v, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "OPT(1, 20)", + nb_tab_option = v$nb_tab_option, + dfs_name = "tab_4d", + limit = v$limit, + keep_history = FALSE + ) + }) + + results_raw_opt[[v$label]] <- res_v + stats_list_opt[[v$label]] <- get_secret_stats(res_v, v$label) + timings_list_opt[[v$label]] <- data.frame( + label = v$label, + elapsed = t_v["elapsed"], + user = t_v["user.self"], + sys = t_v["sys.self"] + ) + gc_list_opt[[v$label]] <- capture_gc(v$label) + + # Sauvegarde intermédiaire (filet de sécurité) + write.csv(stats_list_opt[[v$label]], + file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), + row.names = FALSE) + write.csv(timings_list_opt[[v$label]], + file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), + row.names = FALSE) + write.csv(gc_list_opt[[v$label]], + file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), + row.names = FALSE) + + # ======================================================================== = + # 📊 AFFICHAGE IMMÉDIAT EN CONSOLE + # ======================================================================== = + cat("\n----------------------------------------------------------------------\n") + cat(" 📊 RÉSULTATS OPTIMAL OBTENUS POUR :", v$label, "\n") + cat("----------------------------------------------------------------------\n") + + cat("⏱️ [Timing] :\n") + print(timings_list_opt[[v$label]]) + + cat("\n🔒 [Statistiques de secret] :\n") + print(stats_list_opt[[v$label]]) + + cat("\n💾 [Mémoire (Vcells)] :\n") + print(gc_list_opt[[v$label]] %>% filter(type == "Vcells")) + + cat("\n✓", v$label, "(Optimal) terminé avec succès en", round(t_v["elapsed"] / 60, 2), "minutes.\n") +} + + +# ============================================================================ = +# RECHARGEMENT DES RÉSULTATS DEPUIS LE DISQUE +# ============================================================================ = + +results_raw_opt <- list() +stats_list_opt <- list() +timings_list_opt <- list() +gc_list_opt <- list() +ntables_list_opt <- list() + +cat("Rechargement des fichiers CSV enregistrés (OPTIMAL)...\n") + +for (v in variants) { + lbl <- v$label + + # 1. Lecture des fichiers CSV sauvegardés + file_secret <- file.path(BENCH_DIR, paste0("secret_", lbl, ".csv")) + file_timing <- file.path(BENCH_DIR, paste0("timing_", lbl, ".csv")) + file_gc <- file.path(BENCH_DIR, paste0("gc_", lbl, ".csv")) + + if (file.exists(file_secret)) stats_list_opt[[lbl]] <- read.csv(file_secret) + if (file.exists(file_timing)) timings_list_opt[[lbl]] <- read.csv(file_timing) + if (file.exists(file_gc)) gc_list_opt[[lbl]] <- read.csv(file_gc) + + # 2. Recalcul rapide du nombre de sous-tables + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", lbl)) + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs4_agg, + dfs_name = "tab_4d", + totcode = tot4, + hrcfiles = hrc4, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = FALSE + ) + + n_tables <- length(res_count$tabs) + tailles <- sapply(res_count$tabs, nrow) + + ntables_list_opt[[lbl]] <- data.frame( + label = lbl, + n_tables = n_tables, + min_rows = if (length(tailles) > 0) min(tailles) else 0, + med_rows = if (length(tailles) > 0) median(tailles) else 0, + max_rows = if (length(tailles) > 0) max(tailles) else 0 + ) + + rm(res_count); gc() +} + + +# ============================================================================ = +# BILAN FINAL OPTIMAL +# ============================================================================ = + +cat("\n======================================================================\n") +cat(" BILAN COMPARATIF (OPTIMAL) : min / smart_* \n") +cat("======================================================================\n") + +cat("\n[1. Nombre et dimensions des sous-tables générées]\n") +df_tables_summary_opt <- bind_rows(ntables_list_opt) %>% + rename( + `Variant` = label, + `Nb tables` = n_tables, + `Taille min (lignes)` = min_rows, + `Taille med (lignes)` = med_rows, + `Taille max (lignes)` = max_rows + ) +print(as.data.frame(df_tables_summary_opt)) + +cat("\n[2. Timings (elapsed, secondes)]\n") +print(bind_rows(timings_list_opt)) + +cat("\n[3. Pic mémoire Vcells]\n") +gc_all_opt <- bind_rows(gc_list_opt) +print(gc_all_opt |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) + +cat("\n[4. Statistiques de secret]\n") +print(bind_rows(stats_list_opt)) + + +# ============================================================================ = +# TEST INDÉPENDANT : split_tab = FALSE (OPTIMAL) +# ============================================================================ = + +cat("\n======================================================================\n") +cat(" TEST INDÉPENDANT : tab_rtauargus (split_tab = FALSE, OPTIMAL)\n") +cat("======================================================================\n") + +dir_nosplit <- file.path(BENCH_DIR, "tauargus_no_split") +dir.create(file.path(dir_nosplit, "hrc"), recursive = TRUE, showWarnings = FALSE) + +gc(reset = TRUE) + +t_nosplit <- system.time({ + run_nosplit <- tryCatch({ + + res_nosplit <- tab_rtauargus( + tabular = dfs4_agg, + explanatory_vars = names(tot4), + dir_name = dir_nosplit, + secret_var = "is_secret_prim", + totcode = tot4, + hrc = hrc4, + value = "VALUE", + freq = "freq", + suppress = "OPT(1, 20)", # Optimal sans split + split_tab = FALSE + ) + + list(status = "OK", data = res_nosplit) + + }, error = function(e) { + list(status = "ERROR", message = e$message) + }) +}) + +if (run_nosplit$status == "OK") { + cat("\n✓ Exécution split_tab = FALSE (Optimal) réussie !\n") + cat(" Temps d'exécution :", round(t_nosplit["elapsed"], 2), "secondes (", + round(t_nosplit["elapsed"] / 60, 2), "minutes )\n\n") + + stats_nosplit <- get_secret_stats(run_nosplit$data, "no_split_opt") + cat(" Statistiques de secret (no_split OPTIMAL) :\n") + print(stats_nosplit) + + # Sauvegarde séparée du résultat sans split + write.csv(stats_nosplit, file.path(BENCH_DIR, "secret_no_split.csv"), row.names = FALSE) + write.csv(data.frame(label = "no_split_opt", elapsed = t_nosplit["elapsed"]), + file.path(BENCH_DIR, "timing_no_split.csv"), row.names = FALSE) + +} else { + cat("\n❌ ERREUR lors de l'exécution de split_tab = FALSE (Optimal) :\n") + cat(" Message :", run_nosplit$message, "\n") + cat(" Temps écoulé avant échec :", round(t_nosplit["elapsed"], 2), "secondes\n") +} diff --git a/bench/comp_limit_smart_5D.R b/bench/comp_limit_smart_5D.R new file mode 100644 index 0000000..de00f88 --- /dev/null +++ b/bench/comp_limit_smart_5D.R @@ -0,0 +1,707 @@ +create_big_4D <- function( + n = 200000, + n_act_groups = 30, + n_act_sub = 50, + n_geo_regions = 50, + n_geo_sub = 50, + n_sex = 2, + n_age = 4, + add_dim5 = FALSE, + complete_grid = TRUE +){ + set.seed(123) + + w_act_g <- max(2, nchar(n_act_groups)) + w_act_s <- max(2, nchar(n_act_sub)) + w_geo_r <- max(2, nchar(n_geo_regions)) + w_geo_s <- max(2, nchar(n_geo_sub)) + w_age <- max(2, nchar(n_age)) + + fmt_act_g <- paste0("A%0", w_act_g, "d") + fmt_act_s <- paste0("A%0", w_act_g, "d_%0", w_act_s, "d") # typo corrigée + fmt_geo_r <- paste0("G%0", w_geo_r, "d") + fmt_geo_s <- paste0("G%0", w_geo_r, "d_%0", w_geo_s, "d") + fmt_age <- paste0("AGE%0", w_age, "d") + + act_level1 <- sprintf(fmt_act_g, 1:n_act_groups) + act_level2 <- unlist(lapply(1:n_act_groups, function(i) sprintf(fmt_act_s, i, 1:n_act_sub))) + geo_level1 <- sprintf(fmt_geo_r, 1:n_geo_regions) + geo_level2 <- unlist(lapply(1:n_geo_regions, function(i) sprintf(fmt_geo_s, i, 1:n_geo_sub))) + + sex_leaves <- if (n_sex == 2) c("F", "M") else { + w_sex <- max(2, nchar(n_sex)) + sprintf(paste0("S%0", w_sex, "d"), 1:n_sex) + } + age_leaves <- sprintf(fmt_age, 1:n_age) + + dim_vars <- if (add_dim5) c("ACT", "GEO", "SEX", "AGE", "ECO") + else c("ACT", "GEO", "SEX", "AGE") + + # ---- 1. Microdonnées FEUILLES uniquement -------------------------------- + dt <- data.table( + ACT = sample(act_level2, n, replace = TRUE), + GEO = sample(geo_level2, n, replace = TRUE), + SEX = sample(sex_leaves, n, replace = TRUE), + AGE = sample(age_leaves, n, replace = TRUE) + ) + if (add_dim5) dt[, ECO := sample(c("mod1", "mod2"), n, replace = TRUE)] + + # Agrégation feuilles : libère immédiatement les 50M lignes + dt_leaf <- dt[, .(VALUE = .N), by = dim_vars] + rm(dt); invisible(gc()) + + # ---- 2. Tables de correspondance hiérarchiques -------------------------- + # mk_map : leaf → {leaf, parent (si fourni), "Total"} + mk_map <- function(leaves, parents = NULL) { + rows <- list(data.table(from = leaves, to = leaves)) + if (!is.null(parents)) rows[[2]] <- data.table(from = leaves, to = parents) + rows[[length(rows) + 1]] <- data.table(from = leaves, to = "Total") + rbindlist(rows) + } + + map_act <- mk_map(act_level2, sub("_[0-9]+$", "", act_level2)) + map_geo <- mk_map(geo_level2, sub("_[0-9]+$", "", geo_level2)) + map_sex <- mk_map(sex_leaves) + map_age <- mk_map(age_leaves) + + # ---- 3. Expansion dimension par dimension (join data.table) ------------- + # Pour chaque dimension : on remplace la valeur feuille par TOUTES ses + # valeurs hiérarchiques (leaf, parent, Total) via un join one-to-many. + rollup_dim <- function(dt, col, map) { + # map[dt, ...] : right-join — pour chaque ligne de dt, trouve les + # correspondances dans map (3 ou 2 lignes par valeur feuille) + result <- map[dt, on = c(from = col), allow.cartesian = TRUE] + # result a : from | to | [autres colonnes de dt sauf col] + result[, (col) := to][, c("from", "to") := NULL] + result + } + + dt_exp <- rollup_dim(dt_leaf, "ACT", map_act) + dt_exp <- rollup_dim(dt_exp, "GEO", map_geo) + dt_exp <- rollup_dim(dt_exp, "SEX", map_sex) + dt_exp <- rollup_dim(dt_exp, "AGE", map_age) + + if (add_dim5) dt_exp <- rollup_dim(dt_exp, "ECO", mk_map(c("mod1", "mod2"))) + + rm(dt_leaf); invisible(gc()) + + # ---- 4. Agrégation finale ----------------------------------------------- + # À ce stade dt_exp a : 96 000 × 3 × 3 × 2 × 2 ≈ 3,5 M lignes (4D) + dfs_agg <- dt_exp[, .(VALUE = sum(VALUE)), by = dim_vars] + rm(dt_exp); invisible(gc()) + + # ---- 4b. COMPLÉTION DE LA GRILLE AVEC LES 0 (Si complete_grid = TRUE) --- + if (complete_grid) { + grid_all <- list( + ACT = unique(map_act$to), + GEO = unique(map_geo$to), + SEX = unique(map_sex$to), + AGE = unique(map_age$to) + ) + if (add_dim5) grid_all$ECO <- c("mod1", "mod2", "Total") + + # Produit cartésien de toutes les modalités (feuilles, parents, Total) + full_grid <- do.call(CJ, c(grid_all, list(sorted = FALSE))) + + # Jointure avec la grille complète et remplacement des NA par 0 + dfs_agg <- dfs_agg[full_grid, on = dim_vars] + dfs_agg[is.na(VALUE), VALUE := 0] + } + + # ---- 5. Fichiers .hrc --------------------------------------------------- + write_hrc <- function(hier, path) { + hier %>% + sdcHierarchies::hier_convert(as = "argus") %>% + dplyr::slice(-1) %>% + dplyr::mutate(levels = substring(paste0(level, name), 3)) %>% + dplyr::select(levels) %>% + write.table(file = path, row.names = FALSE, col.names = FALSE, quote = FALSE) + } + + hrc_act <- tempfile(fileext = ".hrc") + h_act <- sdcHierarchies::hier_create(root = "Total", nodes = act_level1) + for (i in seq_len(n_act_groups)) + h_act <- sdcHierarchies::hier_add(h_act, root = sprintf(fmt_act_g, i), + nodes = sprintf(fmt_act_s, i, 1:n_act_sub)) + write_hrc(h_act, hrc_act) + + hrc_geo <- tempfile(fileext = ".hrc") + h_geo <- sdcHierarchies::hier_create(root = "Total", nodes = geo_level1) + for (i in seq_len(n_geo_regions)) + h_geo <- sdcHierarchies::hier_add(h_geo, root = sprintf(fmt_geo_r, i), + nodes = sprintf(fmt_geo_s, i, 1:n_geo_sub)) + write_hrc(h_geo, hrc_geo) + + totcode <- if (add_dim5) + c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total", ECO = "Total") + else + c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total") + + list(data = dfs_agg, hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), totcode = totcode) +} +# ============================================================================= +# 00_setup_bench_options +# Génère données 5D pour le benchmark min/smart/max +# ============================================================================= + +BENCH_DIR <- "Z:/rtauargus/benchmark_options_5D" +dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) + +library(data.table); library(dplyr); library(sdcHierarchies) + +set.seed(123) +big5 <- create_big_4D( + n = 900000, + n_act_groups = 4, n_act_sub = 5, + n_geo_regions = 5, n_geo_sub = 6, + n_sex = 10, n_age = 15, + add_dim5 = TRUE +) + +hrc5 <- c( + ACT = file.path(BENCH_DIR, "hrc", "hrc_ACT.hrc"), + GEO = file.path(BENCH_DIR, "hrc", "hrc_GEO.hrc") +) +file.copy(big5$hrcfiles["ACT"], hrc5["ACT"], overwrite = TRUE) +file.copy(big5$hrcfiles["GEO"], hrc5["GEO"], overwrite = TRUE) + +tot5 <- big5$totcode + +dfs5_agg = big5$data + +dfs5_agg %>% tally() +dfs5_agg %>% arrange(VALUE) + +dfs5_agg %>% summarise(secret_prim = mean(as.integer(VALUE > 0 & VALUE <= 3))) + +dfs5_agg$is_secret_prim <- dfs5_agg$VALUE > 0 & dfs5_agg$VALUE <= 3 +dfs5_agg$secret_no_pl <- FALSE +dfs5_agg$freq <- dfs5_agg$VALUE + +cat("Nombre de cellules :", nrow(dfs5_agg), "\n") +cat("Secret primaire :", sum(dfs5_agg$is_secret_prim), + sprintf("(%.2f%%)\n", 100 * mean(dfs5_agg$is_secret_prim))) + +save(dfs5_agg, tot5, hrc5, + file = file.path(BENCH_DIR, "input_data_5d.RData")) +cat("Setup 5D OK →", BENCH_DIR, "\n") +cat("Redémarrer R, puis lancer bench_nb_tab_option.R\n") + +# ============================================================================= +# bench_nb_tab_option.R +# Compare nb_tab_option "min" / "smart" / "max" +# ============================================================================= + +BENCH_DIR <- "benchmark_options_5D" +loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" + +library(data.table); library(dplyr) +devtools::load_all("Z:/rtauargus") +options(rtauargus.tauargus_exe = loc_tauargus) + +load(file.path(BENCH_DIR, "input_data_5d.RData")) # dfs5_agg, tot5, hrc5 + +# ============================================================================= +# UTILITAIRES +# ============================================================================= + +capture_gc <- function(label) { + g <- gc() + data.frame( + label = label, type = rownames(g), + used_mb = g[, 2], trigger_mb = g[, 4], max_mb = g[, 6], + row.names = NULL + ) +} + +get_last_secret_col <- function(df) { + cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] + if (!length(cols)) return(NULL) + cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) +} + +get_secret_stats <- function(df, label) { + last_col <- get_last_secret_col(df) + final <- df[[last_col]] + prim <- df$is_secret_prim + sec <- final & !prim + data.frame( + label = label, + n_prim = sum(prim), + value_prim = sum(df$VALUE[prim], na.rm = TRUE), + n_sec = sum(sec), + value_sec = sum(df$VALUE[sec], na.rm = TRUE), + n_total_masque = sum(final), + value_total_masque = sum(df$VALUE[final], na.rm = TRUE), + pct_masque_cells = round(100 * mean(final), 2), + pct_masque_value = round(100 * sum(df$VALUE[final], na.rm = TRUE) / + sum(df$VALUE, na.rm = TRUE), 2) + ) +} + +extract_mask <- function(df, tot) { + last_col <- get_last_secret_col(df) + df_min <- as.data.frame(df)[, c(names(tot), last_col)] + names(df_min)[ncol(df_min)] <- "final_secret" + df_min <- df_min[do.call(order, df_min[names(tot)]), ] + rownames(df_min) <- NULL + df_min +} + +# ============================================================================= +# VARIANTS +# ============================================================================= + +explore_reduce_dims(dfs = dfs5_agg, + totcode = tot5, + hrcfiles = hrc5) + +# Pour "min" et "max", limit très grand = pas d'oversplit parasite +# Pour "smart", limit change de fonction du scénario +variants <- list( + list(label = "smart_100000", nb_tab_option = "smart", limit = 100000L), + list(label = "smart_45000", nb_tab_option = "smart", limit = 45000L), + list(label = "smart_20000", nb_tab_option = "smart", limit = 20000L), + list(label = "smart_18000", nb_tab_option = "smart", limit = 18000L), + list(label = "smart_13000", nb_tab_option = "smart", limit = 13000L) +) + +# pre-run de reduce dims pour voir combien de tables génèrent les configs +# et si certaines sont redondantes entre elles (même résultat) +for (v in variants) { + + cat("\n======================================================================\n") + cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, + "| limit =", v$limit, ")\n") + cat("======================================================================\n") + + # --- Pré-mesure : nombre de sous-tables générées --- + # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. + # Overhead ~5-10s, négligeable face au run complet. + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs5_agg, + dfs_name = "tab_5d", + totcode = tot5, + hrcfiles = hrc5, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = TRUE # affichera le nombre de tables générées ainsi que leur distribution + ) + rm(res_count); gc() + +} + + +# HYPERCUBE------------------------------------------------------------------------- +BENCH_DIR <- "Z:/benchmark_options_5D_HYPERCUBE" +dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) + +results_raw <- list() +stats_list <- list() +timings_list <- list() +gc_list <- list() +ntables_list <- list() + +# ============================================================================= +# BOUCLE PRINCIPALE +# ============================================================================= + +for (v in variants) { + + cat("\n======================================================================\n") + cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, + "| limit =", v$limit, ")\n") + cat("======================================================================\n") + + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) + dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) + + # --- Pré-mesure : nombre de sous-tables générées --- + # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. + # Overhead ~5-10s, négligeable face au run complet. + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs5_agg, + dfs_name = "tab_5d", + totcode = tot5, + hrcfiles = hrc5, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = FALSE + ) + n_tables <- length(res_count$tabs) + tailles <- sapply(res_count$tabs, nrow) + + rm(res_count); gc() + + ntables_list[[v$label]] <- data.frame( + label = v$label, + n_tables = n_tables, + min_rows = if (length(tailles) > 0) min(tailles) else 0, + med_rows = if (length(tailles) > 0) median(tailles) else 0, + max_rows = if (length(tailles) > 0) max(tailles) else 0 + ) + + # --- Run complet --- + gc(reset = TRUE) + + t_v <- system.time({ + res_v <- tab_rtauargus4( + tabular = dfs5_agg, + explanatory_vars = names(tot5), + dir_name = dir_v, + secret_var = "is_secret_prim", + totcode = tot5, + hrc = hrc5, + value = "VALUE", + freq = "freq", + suppress = "GH(1,100)", + nb_tab_option = v$nb_tab_option, + dfs_name = "tab_5d", + limit = v$limit, + keep_history = FALSE + ) + }) + + results_raw[[v$label]] <- res_v + stats_list[[v$label]] <- get_secret_stats(res_v, v$label) + timings_list[[v$label]] <- data.frame( + label = v$label, + elapsed = t_v["elapsed"], + user = t_v["user.self"], + sys = t_v["sys.self"] + ) + gc_list[[v$label]] <- capture_gc(v$label) + + # Sauvegarde intermédiaire (filet de sécurité) + write.csv(stats_list[[v$label]], + file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), + row.names = FALSE) + write.csv(timings_list[[v$label]], + file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), + row.names = FALSE) + write.csv(gc_list[[v$label]], + file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), + row.names = FALSE) + + # ======================================================================== = + # 📊 AFFICHAGE IMMÉDIAT EN CONSOLE + # ======================================================================== = + cat("\n----------------------------------------------------------------------\n") + cat(" 📊 RÉSULTATS OBTENUS POUR :", v$label, "\n") + cat("----------------------------------------------------------------------\n") + + cat("⏱️ [Timing] :\n") + print(timings_list[[v$label]]) + + cat("\n🔒 [Statistiques de secret] :\n") + print(stats_list[[v$label]]) + + cat("\n💾 [Mémoire (Vcells)] :\n") + print(gc_list[[v$label]] %>% filter(type == "Vcells")) + + cat("\n✓", v$label, "terminé avec succès en", round(t_v["elapsed"] / 60, 2), "minutes.\n") +} + +# ============================================================================= +# RECHARGEMENT DES RÉSULTATS DEPUIS LE DISQUE +# ============================================================================= + +results_raw <- list() +stats_list <- list() +timings_list <- list() +gc_list <- list() +ntables_list <- list() + +cat("Rechargement des fichiers CSV enregistrés...\n") + +for (v in variants) { + lbl <- v$label + + # 1. Lecture des fichiers CSV sauvegardés + file_secret <- file.path(BENCH_DIR, paste0("secret_", lbl, ".csv")) + file_timing <- file.path(BENCH_DIR, paste0("timing_", lbl, ".csv")) + file_gc <- file.path(BENCH_DIR, paste0("gc_", lbl, ".csv")) + + if (file.exists(file_secret)) stats_list[[lbl]] <- read.csv(file_secret) + if (file.exists(file_timing)) timings_list[[lbl]] <- read.csv(file_timing) + if (file.exists(file_gc)) gc_list[[lbl]] <- read.csv(file_gc) + + # 2. Recalcul rapide du nombre de sous-tables (reduce_dims seul est très rapide, ~5s) + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", lbl)) + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs5_agg, + dfs_name = "tab_5d", + totcode = tot5, + hrcfiles = hrc5, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = FALSE + ) + + n_tables <- length(res_count$tabs) + tailles <- sapply(res_count$tabs, nrow) + + ntables_list[[lbl]] <- data.frame( + label = lbl, + n_tables = n_tables, + min_rows = if (length(tailles) > 0) min(tailles) else 0, + med_rows = if (length(tailles) > 0) median(tailles) else 0, + max_rows = if (length(tailles) > 0) max(tailles) else 0 + ) + + rm(res_count); gc() +} + + +# ============================================================================= +# BILAN FINAL +# ============================================================================= + +cat("\n======================================================================\n") +cat(" BILAN COMPARATIF : min / smart_* / max \n") +cat("======================================================================\n") + +cat("\n[1. Nombre et dimensions des sous-tables générées]\n") +df_tables_summary <- bind_rows(ntables_list) %>% + rename( + `Variant` = label, + `Nb tables` = n_tables, + `Taille min (lignes)` = min_rows, + `Taille med (lignes)` = med_rows, + `Taille max (lignes)` = max_rows + ) +print(as.data.frame(df_tables_summary)) + +cat("\n[2. Timings (elapsed, secondes)]\n") +print(bind_rows(timings_list)) + +cat("\n[3. Pic mémoire Vcells]\n") +gc_all <- bind_rows(gc_list) +print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) + +cat("\n[4. Statistiques de secret]\n") +print(bind_rows(stats_list)) + +# MODULAR ------------------------------------------------------------------------- + +BENCH_DIR <- "Z:/benchmark_options_5D_MODULAR" +dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) + +results_raw_mod <- list() +stats_list_mod <- list() +timings_list_mod <- list() +gc_list_mod <- list() +ntables_list_mod <- list() + +# ============================================================================= +# BOUCLE PRINCIPALE +# ============================================================================= + +for (v in variants[1]) { + + cat("\n======================================================================\n") + cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, + "| limit =", v$limit, ")\n") + cat("======================================================================\n") + + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) + dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) + + # --- Pré-mesure : nombre de sous-tables générées --- + # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. + # Overhead ~5-10s, négligeable face au run complet. + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs5_agg, + dfs_name = "tab_5d", + totcode = tot5, + hrcfiles = hrc5, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = FALSE + ) + n_tables <- length(res_count$tabs) + tailles <- sapply(res_count$tabs, nrow) + + rm(res_count); gc() + + ntables_list_mod[[v$label]] <- data.frame( + label = v$label, + n_tables = n_tables, + min_rows = if (length(tailles) > 0) min(tailles) else 0, + med_rows = if (length(tailles) > 0) median(tailles) else 0, + max_rows = if (length(tailles) > 0) max(tailles) else 0 + ) + + # --- Run complet --- + gc(reset = TRUE) + + t_v <- system.time({ + res_v <- tab_rtauargus4( + tabular = dfs5_agg, + explanatory_vars = names(tot5), + dir_name = dir_v, + secret_var = "is_secret_prim", + totcode = tot5, + hrc = hrc5, + value = "VALUE", + freq = "freq", + nb_tab_option = v$nb_tab_option, + dfs_name = "tab_5d", + limit = v$limit, + keep_history = FALSE + ) + }) + + results_raw_mod[[v$label]] <- res_v + stats_list_mod[[v$label]] <- get_secret_stats(res_v, v$label) + timings_list_mod[[v$label]] <- data.frame( + label = v$label, + elapsed = t_v["elapsed"], + user = t_v["user.self"], + sys = t_v["sys.self"] + ) + gc_list_mod[[v$label]] <- capture_gc(v$label) + + # Sauvegarde intermédiaire (filet de sécurité) + write.csv(stats_list_mod[[v$label]], + file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), + row.names = FALSE) + write.csv(timings_list_mod[[v$label]], + file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), + row.names = FALSE) + write.csv(gc_list_mod[[v$label]], + file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), + row.names = FALSE) + + # ======================================================================== = + # 📊 AFFICHAGE IMMÉDIAT EN CONSOLE + # ======================================================================== = + cat("\n----------------------------------------------------------------------\n") + cat(" 📊 RÉSULTATS OBTENUS POUR :", v$label, "\n") + cat("----------------------------------------------------------------------\n") + + cat("⏱️ [Timing] :\n") + print(timings_list_mod[[v$label]]) + + cat("\n🔒 [Statistiques de secret] :\n") + print(stats_list_mod[[v$label]]) + + cat("\n💾 [Mémoire (Vcells)] :\n") + print(gc_list_mod[[v$label]] %>% filter(type == "Vcells")) + + cat("\n✓", v$label, "terminé avec succès en", round(t_v["elapsed"] / 60, 2), "minutes.\n") +} + +# ============================================================================= +# RECHARGEMENT DES RÉSULTATS DEPUIS LE DISQUE +# ============================================================================= + +results_raw_mod <- list() +stats_list_mod <- list() +timings_list_mod <- list() +gc_list_mod <- list() +ntables_list_mod <- list() + +cat("Rechargement des fichiers CSV enregistrés...\n") + +for (v in variants) { + lbl <- v$label + + # 1. Lecture des fichiers CSV sauvegardés + file_secret <- file.path(BENCH_DIR, paste0("secret_", lbl, ".csv")) + file_timing <- file.path(BENCH_DIR, paste0("timing_", lbl, ".csv")) + file_gc <- file.path(BENCH_DIR, paste0("gc_", lbl, ".csv")) + + if (file.exists(file_secret)) stats_list_mod[[lbl]] <- read.csv(file_secret) + if (file.exists(file_timing)) timings_list_mod[[lbl]] <- read.csv(file_timing) + if (file.exists(file_gc)) gc_list_mod[[lbl]] <- read.csv(file_gc) + + # 2. Recalcul rapide du nombre de sous-tables (reduce_dims seul est très rapide, ~5s) + dir_v <- file.path(BENCH_DIR, paste0("tauargus_", lbl)) + dir_count <- file.path(dir_v, "count_hrc") + dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) + + res_count <- reduce_dims( + dfs = dfs5_agg, + dfs_name = "tab_5d", + totcode = tot5, + hrcfiles = hrc5, + nb_tab_option = v$nb_tab_option, + limit = v$limit, + over_split = TRUE, + sep_dir = TRUE, + hrc_dir = dir_count, + verbose = FALSE + ) + + n_tables <- length(res_count$tabs) + tailles <- sapply(res_count$tabs, nrow) + + ntables_list_mod[[lbl]] <- data.frame( + label = lbl, + n_tables = n_tables, + min_rows = if (length(tailles) > 0) min(tailles) else 0, + med_rows = if (length(tailles) > 0) median(tailles) else 0, + max_rows = if (length(tailles) > 0) max(tailles) else 0 + ) + + rm(res_count); gc() +} + + +# ============================================================================= +# BILAN FINAL +# ============================================================================= + +cat("\n======================================================================\n") +cat(" BILAN COMPARATIF : min / smart_* / max \n") +cat("======================================================================\n") + +cat("\n[1. Nombre et dimensions des sous-tables générées]\n") +df_tables_summary <- bind_rows(ntables_list_mod) %>% + rename( + `Variant` = label, + `Nb tables` = n_tables, + `Taille min (lignes)` = min_rows, + `Taille med (lignes)` = med_rows, + `Taille max (lignes)` = max_rows + ) +print(as.data.frame(df_tables_summary)) + +cat("\n[2. Timings (elapsed, secondes)]\n") +print(bind_rows(timings_list_mod)) + +cat("\n[3. Pic mémoire Vcells]\n") +gc_all <- bind_rows(gc_list_mod) +print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) + +cat("\n[4. Statistiques de secret]\n") +print(bind_rows(stats_list_mod)) + + + From 6418360045bcc2944a6e65ac79faa8c754f8c292 Mon Sep 17 00:00:00 2001 From: Pomel Wistan Date: Tue, 18 Aug 2026 13:44:27 +0200 Subject: [PATCH 02/16] Add details on auto_limit doc + some simplificaitons --- R/sp_tab_rtauargus.R | 48 +++++++++++++++++++++++--------------------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/R/sp_tab_rtauargus.R b/R/sp_tab_rtauargus.R index 15b229e..4a9b16d 100644 --- a/R/sp_tab_rtauargus.R +++ b/R/sp_tab_rtauargus.R @@ -5,10 +5,17 @@ #' 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. -#' @export +#' +#' @keywords internal +#' @noRd auto_limit <- function(dfs, totcode, hrcfiles = NULL) { # 1. Explore candidate configurations for table reduction @@ -41,28 +48,24 @@ auto_limit <- function(dfs, totcode, hrcfiles = NULL) { #' 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{\link{auto_limit}}. -#' @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 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 keep_history logical, default `FALSE`. If `TRUE`, the result contains -#' one boolean column `is_secret_N` per iteration, recording the full -#' suppression history (primary + secondary secret at each pass). -#' If `FALSE` (recommended for large tables), only the final suppression -#' status is kept in a single column `is_secret_`, which avoids -#' accumulating hundreds of columns and saves memory proportionally to the -#' number of iterations. -#' @param sort_table character or NULL, default `NULL`. If `"ASC"`, the -#' sub-tables generated by dimension reduction are processed in ascending -#' order of their total cell value (smallest tables first). If `"DESC"`, -#' largest tables are processed first. The processing order can influence -#' which cells receive secondary suppression when common cells are shared -#' across sub-tables. `NULL` preserves the default order produced by -#' `reduce_dims()`. +#' @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 ... additional parameters #' #' @return The original tabular is returned with additional variables indicating @@ -135,7 +138,6 @@ tab_rtauargus4 <- function( nb_tab_option = "smart", limit = NULL, dfs_name = 'tab', - keep_history = FALSE, sort_table = NULL, ... ){ From 0c10b860c9c2b34033e600ebc684799219460f04 Mon Sep 17 00:00:00 2001 From: Pomel Wistan Date: Tue, 18 Aug 2026 13:45:05 +0200 Subject: [PATCH 03/16] Flush console to avoid to be flooded by the console with tab_multi_manager --- R/multitable.R | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/R/multitable.R b/R/multitable.R index a945bd1..bc9af16 100644 --- a/R/multitable.R +++ b/R/multitable.R @@ -368,7 +368,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 +496,8 @@ tab_multi_manager <- function( } + cat("\n") + # Reconstruire la liste des tableaux d'entrée liste_tbx_res <- purrr::imap( list_tables, From 1afa4790ad9cd075635d12ac5648e617887d325b Mon Sep 17 00:00:00 2001 From: Pomel Wistan Date: Tue, 18 Aug 2026 17:24:14 +0200 Subject: [PATCH 04/16] Simplify split_tab arguments in user functions --- NAMESPACE | 111 ++++++++-------- R/globals.R | 2 +- R/multitable.R | 8 +- R/sp_tab_rtauargus.R | 6 +- R/tab_rtauargus.R | 32 ++--- man/explore_reduce_dims.Rd | 28 ++++ man/from_4_to_3.Rd | 108 ---------------- man/from_4_to_3_case_0_hr.Rd | 79 ------------ man/from_4_to_3_case_1_hr.Rd | 94 -------------- man/from_4_to_3_case_2_hr.Rd | 93 ------------- man/from_5_to_3.Rd | 147 --------------------- man/length_tabs.Rd | 123 ------------------ man/nb_tab_generated.Rd | 113 ---------------- man/reduce_dims.Rd | 244 ----------------------------------- man/restore_format.Rd | 116 ----------------- man/sp_format.Rd | 88 ------------- man/tab_multi_manager.Rd | 20 +-- man/tab_rtauargus.Rd | 23 +--- man/tab_rtauargus2.Rd | 20 +-- man/tab_rtauargus4.Rd | 33 +++-- man/var_to_merge.Rd | 137 -------------------- 21 files changed, 145 insertions(+), 1480 deletions(-) create mode 100644 man/explore_reduce_dims.Rd delete mode 100644 man/from_4_to_3.Rd delete mode 100644 man/from_4_to_3_case_0_hr.Rd delete mode 100644 man/from_4_to_3_case_1_hr.Rd delete mode 100644 man/from_4_to_3_case_2_hr.Rd delete mode 100644 man/from_5_to_3.Rd delete mode 100644 man/length_tabs.Rd delete mode 100644 man/nb_tab_generated.Rd delete mode 100644 man/reduce_dims.Rd delete mode 100644 man/restore_format.Rd delete mode 100644 man/sp_format.Rd delete mode 100644 man/var_to_merge.Rd diff --git a/NAMESPACE b/NAMESPACE index 9b39347..eacf1d6 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,56 +28,66 @@ 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) import(utils) -importFrom(dplyr,"%>%") -importFrom(dplyr,across) -importFrom(dplyr,all_of) -importFrom(dplyr,arrange) -importFrom(dplyr,bind_rows) -importFrom(dplyr,case_when) -importFrom(dplyr,distinct) -importFrom(dplyr,everything) -importFrom(dplyr,filter) -importFrom(dplyr,group_by) -importFrom(dplyr,last_col) -importFrom(dplyr,left_join) -importFrom(dplyr,mutate) -importFrom(dplyr,n) -importFrom(dplyr,n_distinct) -importFrom(dplyr,pull) -importFrom(dplyr,rename) -importFrom(dplyr,rename_with) -importFrom(dplyr,row_number) -importFrom(dplyr,rowwise) -importFrom(dplyr,select) -importFrom(dplyr,summarise) -importFrom(dplyr,tibble) -importFrom(dplyr,ungroup) -importFrom(dplyr,where) -importFrom(igraph,graph_from_data_frame) -importFrom(igraph,which_mutual) -importFrom(lifecycle,badge) -importFrom(lifecycle,deprecated) -importFrom(purrr,compact) -importFrom(purrr,discard) -importFrom(purrr,imap_dfr) -importFrom(purrr,list_c) -importFrom(purrr,map) -importFrom(purrr,map2) -importFrom(purrr,map_at) -importFrom(purrr,transpose) +importFrom(dplyr, + "%>%", + across, + all_of, + arrange, + bind_rows, + case_when, + distinct, + everything, + filter, + group_by, + last_col, + left_join, + mutate, + n, + n_distinct, + pull, + rename, + rename_with, + row_number, + rowwise, + select, + summarise, + tibble, + ungroup, + where +) +importFrom(igraph, + graph_from_data_frame, + which_mutual +) +importFrom(lifecycle, + badge, + deprecated +) +importFrom(purrr, + compact, + discard, + imap_dfr, + list_c, + map, + map2, + map_at, + transpose +) importFrom(rlang,.data) -importFrom(sdcHierarchies,hier_convert) -importFrom(sdcHierarchies,hier_import) +importFrom(sdcHierarchies, + hier_convert, + hier_import +) importFrom(stats,setNames) -importFrom(stringr,str_detect) -importFrom(tidyr,nest) -importFrom(tidyr,pivot_longer) -importFrom(tidyr,unnest) -importFrom(tidyr,unnest_wider) +importFrom(tidyr, + nest, + pivot_longer, + unnest, + unnest_wider +) importFrom(utils,combn) importFrom(zoo,na.locf) 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 bc9af16..fc7222b 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,9 @@ 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 n_tbx = length(list_tables) # nombre de tableaux diff --git a/R/sp_tab_rtauargus.R b/R/sp_tab_rtauargus.R index 4a9b16d..d997b64 100644 --- a/R/sp_tab_rtauargus.R +++ b/R/sp_tab_rtauargus.R @@ -47,7 +47,7 @@ auto_limit <- function(dfs, totcode, hrcfiles = NULL) { #' @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{\link{auto_limit}}. +#' 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 @@ -160,7 +160,7 @@ tab_rtauargus4 <- function( if (length(explanatory_vars) %in% c(4, 5)) { # Calcul automatique de la limite si limit = NULL - if (is.null(limit)) { + if (is.null(limit) && nb_tab_option == "smart") { if (isTRUE(.dots[["verbose"]])) { cat("`limit` est NULL, calcul automatique en cours via `auto_limit()`...\n") } @@ -181,7 +181,7 @@ tab_rtauargus4 <- function( hrc_dir = hrc_path, nb_tab_option = nb_tab_option, limit = limit, - over_split = TRUE, + over_split = FALSE, verbose = TRUE, # to generalize later sep_dir = TRUE ) diff --git a/R/tab_rtauargus.R b/R/tab_rtauargus.R index c129f8b..21bd786 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,7 @@ tab_rtauargus <- function( params_rt4$totcode <- totcode params_rt4$dir_name <- dir_name params_rt4$files_name <- files_name + params_rt4$limit <- split_limit return(do.call("tab_rtauargus4", params_rt4)) @@ -417,8 +410,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 +439,10 @@ 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 + 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} From b03624ec00463d276d16d6bb453e5e6ae3ecb772 Mon Sep 17 00:00:00 2001 From: Pomel Wistan Date: Tue, 18 Aug 2026 17:49:10 +0200 Subject: [PATCH 05/16] Delete bench/ from git --- .gitignore | 1 + bench/bench_RAM.R | 493 --------- bench/bench_perf_improv_functions.R | 1155 -------------------- bench/bench_sort.R | 207 ---- bench/bench_split_nodes.R | 115 -- bench/bench_tab_multimanager_bloc.R | 834 -------------- bench/bench_tab_multimanager_rtauargus4.R | 537 --------- bench/comp_limit_smart_4D.R | 1195 --------------------- bench/comp_limit_smart_5D.R | 707 ------------ 9 files changed, 1 insertion(+), 5243 deletions(-) delete mode 100644 bench/bench_RAM.R delete mode 100644 bench/bench_perf_improv_functions.R delete mode 100644 bench/bench_sort.R delete mode 100644 bench/bench_split_nodes.R delete mode 100644 bench/bench_tab_multimanager_bloc.R delete mode 100644 bench/bench_tab_multimanager_rtauargus4.R delete mode 100644 bench/comp_limit_smart_4D.R delete mode 100644 bench/comp_limit_smart_5D.R 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/bench/bench_RAM.R b/bench/bench_RAM.R deleted file mode 100644 index 862815c..0000000 --- a/bench/bench_RAM.R +++ /dev/null @@ -1,493 +0,0 @@ -# ============================================================================= -# 00_setup.R — Session fraîche obligatoire -# Génère les données + hrc persistants. Redémarrer R après exécution. -# ============================================================================= - -BENCH_DIR <- "Z:/benchmark_4d" -dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) - -library(data.table) -library(dplyr) -library(sdcHierarchies) - -# --- 4D volumineux (ACT hiérarchique, GEO hiérarchique, SEX & AGE non hiérarchiques) -create_big_4D <- function( - n = 200000, - n_act_groups = 30, # Nombre de groupes d'activité (Niveau 1 ACT) - n_act_sub = 50, # Nombre de sous-niveaux par groupe d'activité (Niveau 2 ACT) - n_geo_regions = 50, # Nombre de régions (Niveau 1 GEO) - n_geo_sub = 50, # Nombre de sous-régions par région (Niveau 2 GEO) - n_sex = 2, # Nombre de modalités de SEX (ex: F, M si n_sex=2, sinon S01, S02...) - n_age = 4 # Nombre de modalités d'AGE (ex: AGE01 à AGE04) -) { - set.seed(123) - - # Calcul dynamique de la largeur des chiffres (Zero-padding) - w_act_g <- max(2, nchar(n_act_groups)) - w_act_s <- max(2, nchar(n_act_sub)) - w_geo_r <- max(2, nchar(n_geo_regions)) - w_geo_s <- max(2, nchar(n_geo_sub)) - w_age <- max(2, nchar(n_age)) - - fmt_act_g <- paste0("A%0", w_act_g, "d") - fmt_act_s <- paste0("A%0", w_act_g, "d_%0", w_act_s, "d") - - fmt_geo_r <- paste0("G%0", w_geo_r, "d") - fmt_geo_s <- paste0("G%0", w_geo_r, "d_%0", w_geo_s, "d") - - fmt_age <- paste0("AGE%0", w_age, "d") - - # 1. Définition des niveaux ACT - act_level1 <- sprintf(fmt_act_g, 1:n_act_groups) - act_level2 <- unlist(lapply(1:n_act_groups, function(i) sprintf(fmt_act_s, i, 1:n_act_sub))) - - # 2. Définition des niveaux GEO - geo_level1 <- sprintf(fmt_geo_r, 1:n_geo_regions) - geo_level2 <- unlist(lapply(1:n_geo_regions, function(i) sprintf(fmt_geo_s, i, 1:n_geo_sub))) - - # 3. Définition des modalités SEX (F, M si n_sex = 2, sinon S01, S02...) - sex_mods <- if (n_sex == 2) { - c("Total", "F", "M") - } else { - w_sex <- max(2, nchar(n_sex)) - c("Total", sprintf(paste0("S%0", w_sex, "d"), 1:n_sex)) - } - - # 4. Définition des modalités AGE (AGE01, AGE02...) - age_mods <- c("Total", sprintf(fmt_age, 1:n_age)) - - # 5. Génération du jeu de données - data <- data.frame( - ACT = sample(c("Total", act_level1, act_level2), n, replace = TRUE), - GEO = sample(c("Total", geo_level1, geo_level2), n, replace = TRUE), - SEX = sample(sex_mods, n, replace = TRUE), - AGE = sample(age_mods, n, replace = TRUE), - stringsAsFactors = FALSE - ) - data$VALUE <- 1 - - # Hiérarchie ACT - hrc_act <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total", nodes = act_level1) %>% - { - for (i in 1:n_act_groups) { - root_node <- sprintf(fmt_act_g, i) - children <- sprintf(fmt_act_s, i, 1:n_act_sub) - . <- sdcHierarchies::hier_add(., root = root_node, nodes = children) - } - . - } %>% - 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) - - # Hiérarchie GEO - hrc_geo <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total", nodes = geo_level1) %>% - { - for (i in 1:n_geo_regions) { - root_node <- sprintf(fmt_geo_r, i) - children <- sprintf(fmt_geo_s, i, 1:n_geo_sub) - . <- sdcHierarchies::hier_add(., root = root_node, nodes = children) - } - . - } %>% - 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) - - list(data = data, - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), - totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total")) -} - -# --- Génération --- -big4 <- create_big_4D( - n = 50000000, - n_act_groups = 4, n_act_sub = 11, - n_geo_regions = 5, n_geo_sub = 10, - n_sex = 20, n_age = 15 -) - -# Copie des hrc dans un dossier persistant (tempdir() disparaît au restart) -hrc4 <- c( - ACT = file.path(BENCH_DIR, "hrc", "hrc_ACT.hrc"), - GEO = file.path(BENCH_DIR, "hrc", "hrc_GEO.hrc") -) -file.copy(big4$hrcfiles["ACT"], hrc4["ACT"], overwrite = TRUE) -file.copy(big4$hrcfiles["GEO"], hrc4["GEO"], overwrite = TRUE) - -tot4 <- big4$totcode - -dfs4_agg <- big4$data %>% - group_by(across(all_of(names(tot4)))) %>% - summarise(VALUE = sum(VALUE), freq = n(), .groups = "drop") - -rm(big4); gc() - -set.seed(42) -dfs4_agg$is_secret_prim <- sample( - c(TRUE, FALSE), nrow(dfs4_agg), - replace = TRUE, prob = c(0.01, 0.99) -) -dfs4_agg$secret_no_pl <- FALSE - -save(dfs4_agg, tot4, hrc4, file = file.path(BENCH_DIR, "input_data.RData")) -cat("Setup OK →", BENCH_DIR, "\n") -cat("Redémarrer R, puis lancer 01_bloc_old.R\n") - - -# BLOC 1 ------------------------------------------------------------------------- - - -# ============================================================================= -# 01_bloc_old.R — Session fraîche obligatoire -# Version originale (package installé). Redémarrer R après exécution. -# ============================================================================= -set.seed(42) -BENCH_DIR <- "Z:/benchmark_4d" -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" - -# Capture gc() sous forme de data.frame propre -capture_gc <- function(label) { - g <- gc() - data.frame( - label = label, - type = rownames(g), - used_mb = g[, 2], - trigger_mb = g[, 4], - max_mb = g[, 6], # pic depuis le dernier gc(reset=TRUE) - row.names = NULL - ) -} - -# Extrait la dernière colonne is_secret_N -get_last_secret_col <- function(df) { - cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] - if (!length(cols)) return(NULL) - cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) -} - -# Sauvegarde le résultat minimal pour comparaison (clés + secret final) -save_result_minimal <- function(df, tot4, label) { - cols_base <- c(names(tot4), "is_secret_prim") - last_col <- get_last_secret_col(df) - df_min <- as.data.frame(df)[, c(cols_base, last_col)] - names(df_min)[ncol(df_min)] <- "final_secret" - write.csv(df_min, file.path(BENCH_DIR, paste0("result_", label, ".csv")), - row.names = FALSE) - invisible(df_min) -} - - -BENCH_DIR <- "Z:/benchmark_4d" -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" - -library(data.table); library(dplyr); library(rtauargus) -options(rtauargus.tauargus_exe = loc_tauargus) - -load(file.path(BENCH_DIR, "input_data.RData")) # dfs4_agg, tot4, hrc4 - -# Reset du compteur de pic mémoire -gc(reset = TRUE) - -dir_old <- file.path(BENCH_DIR, "tauargus_old") -dir.create(file.path(dir_old, "hrc"), recursive = TRUE, showWarnings = FALSE) - -# --- reduce_dims --- -t_red <- system.time({ - res_red <- reduce_dims( - dfs = dfs4_agg, dfs_name = "tab_4d_int", - totcode = tot4, hrcfiles = hrc4, - nb_tab_option = "max", sep_dir = TRUE, - hrc_dir = file.path(dir_old, "hrc") - ) -}) - -# --- restore_format --- -t_rest <- system.time({ - rtauargus::restore_format(masq = res_red$tabs, res = res_red) -}) - -# --- flux complet --- -t_full <- system.time({ - res_old <- tab_rtauargus4( - tabular = dfs4_agg, explanatory_vars = names(tot4), - dir_name = dir_old, secret_var = "is_secret_prim", - totcode = tot4, hrc = hrc4, - value = "VALUE", freq = "freq", - suppress = "GH(1,100)", nb_tab_option = "max", - dfs_name = "tab_4d_int", limit = 1000000L - ) -}) - -# --- Sauvegarde --- -timing <- data.frame( - label = "old", - phase = c("reduce_dims", "restore_format", "tab_rtauargus4"), - elapsed = c(t_red["elapsed"], t_rest["elapsed"], t_full["elapsed"]), - user = c(t_red["user.self"], t_rest["user.self"], t_full["user.self"]), - sys = c(t_red["sys.self"], t_rest["sys.self"], t_full["sys.self"]) -) -write.csv(timing, file.path(BENCH_DIR, "timing_old.csv"), row.names = FALSE) - -gc_stats <- capture_gc("old") -write.csv(gc_stats, file.path(BENCH_DIR, "gc_old.csv"), row.names = FALSE) - -save_result_minimal(res_old, tot4, "old") - -cat("Bloc 01 terminé. Redémarrer R, puis lancer 02_bloc_new_true.R\n") - - -# BLOC 2------------------------------------------------------------------------- - -# ============================================================================= -# 02_bloc_new_true.R — Session fraîche obligatoire -# Version optimisée, keep_history = TRUE. Redémarrer R après exécution. -# ============================================================================= -set.seed(42) -BENCH_DIR <- "Z:/benchmark_4d" -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" - -# Capture gc() sous forme de data.frame propre -capture_gc <- function(label) { - g <- gc() - data.frame( - label = label, - type = rownames(g), - used_mb = g[, 2], - trigger_mb = g[, 4], - max_mb = g[, 6], # pic depuis le dernier gc(reset=TRUE) - row.names = NULL - ) -} - -# Extrait la dernière colonne is_secret_N -get_last_secret_col <- function(df) { - cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] - if (!length(cols)) return(NULL) - cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) -} - -# Sauvegarde le résultat minimal pour comparaison (clés + secret final) -save_result_minimal <- function(df, tot4, label) { - cols_base <- c(names(tot4), "is_secret_prim") - last_col <- get_last_secret_col(df) - df_min <- as.data.frame(df)[, c(cols_base, last_col)] - names(df_min)[ncol(df_min)] <- "final_secret" - write.csv(df_min, file.path(BENCH_DIR, paste0("result_", label, ".csv")), - row.names = FALSE) - invisible(df_min) -} - -BENCH_DIR <- "Z:/benchmark_4d" -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" - -library(data.table); library(dplyr) -devtools::load_all("Z:/rtauargus") -options(rtauargus.tauargus_exe = loc_tauargus) - -load(file.path(BENCH_DIR, "input_data.RData")) -gc(reset = TRUE) - -dir_new_t <- file.path(BENCH_DIR, "tauargus_new_true") -dir.create(file.path(dir_new_t, "hrc"), recursive = TRUE, showWarnings = FALSE) - -t_red <- system.time({ - res_red <- reduce_dims( - dfs = dfs4_agg, dfs_name = "tab_4d_int", - totcode = tot4, hrcfiles = hrc4, - nb_tab_option = "max", sep_dir = TRUE, - hrc_dir = file.path(dir_new_t, "hrc") - ) -}) - -t_rest <- system.time({ - restore_format(masq = res_red$tabs, res = res_red) -}) - -t_full <- system.time({ - res_new_true <- tab_rtauargus4( - tabular = dfs4_agg, explanatory_vars = names(tot4), - dir_name = dir_new_t, secret_var = "is_secret_prim", - totcode = tot4, hrc = hrc4, - value = "VALUE", freq = "freq", - suppress = "GH(1,100)", nb_tab_option = "max", - dfs_name = "tab_4d_int", limit = 1000000L, - keep_history = TRUE - ) -}) - -timing <- data.frame( - label = "new_true", - phase = c("reduce_dims", "restore_format", "tab_rtauargus4"), - elapsed = c(t_red["elapsed"], t_rest["elapsed"], t_full["elapsed"]), - user = c(t_red["user.self"], t_rest["user.self"], t_full["user.self"]), - sys = c(t_red["sys.self"], t_rest["sys.self"], t_full["sys.self"]) -) -write.csv(timing, file.path(BENCH_DIR, "timing_new_true.csv"), row.names = FALSE) - -gc_stats <- capture_gc("new_true") -write.csv(gc_stats, file.path(BENCH_DIR, "gc_new_true.csv"), row.names = FALSE) - -save_result_minimal(res_new_true, tot4, "new_true") - -cat("Bloc 02 terminé. Redémarrer R, puis lancer 03_bloc_new_false.R\n") - - -# BLOC 3 ------------------------------------------------------------------------- - -# ============================================================================= -# 03_bloc_new_false.R — Session fraîche obligatoire -# Version optimisée, keep_history = FALSE. Redémarrer R après exécution. -# ============================================================================= -set.seed(42) -BENCH_DIR <- "Z:/benchmark_4d" -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" - -# Capture gc() sous forme de data.frame propre -capture_gc <- function(label) { - g <- gc() - data.frame( - label = label, - type = rownames(g), - used_mb = g[, 2], - trigger_mb = g[, 4], - max_mb = g[, 6], - row.names = NULL - ) -} - -# Extrait la dernière colonne is_secret_N -get_last_secret_col <- function(df) { - cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] - if (!length(cols)) return(NULL) - cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) -} - -# Sauvegarde le résultat minimal pour comparaison (clés + secret final) -save_result_minimal <- function(df, tot4, label) { - cols_base <- c(names(tot4), "is_secret_prim") - last_col <- get_last_secret_col(df) - df_min <- as.data.frame(df)[, c(cols_base, last_col)] - names(df_min)[ncol(df_min)] <- "final_secret" - write.csv(df_min, file.path(BENCH_DIR, paste0("result_", label, ".csv")), - row.names = FALSE) - invisible(df_min) -} - -library(data.table); library(dplyr) -devtools::load_all("Z:/rtauargus") -options(rtauargus.tauargus_exe = loc_tauargus) - -load(file.path(BENCH_DIR, "input_data.RData")) -gc(reset = TRUE) - -dir_new_f <- file.path(BENCH_DIR, "tauargus_new_false") -dir.create(file.path(dir_new_f, "hrc"), recursive = TRUE, showWarnings = FALSE) - -t_red <- system.time({ - res_red <- reduce_dims( - dfs = dfs4_agg, dfs_name = "tab_4d_int", - totcode = tot4, hrcfiles = hrc4, - nb_tab_option = "max", sep_dir = TRUE, - hrc_dir = file.path(dir_new_f, "hrc") - ) -}) - -t_rest <- system.time({ - restore_format(masq = res_red$tabs, res = res_red) -}) - -t_full <- system.time({ - res_new_false <- tab_rtauargus4( - tabular = dfs4_agg, explanatory_vars = names(tot4), - dir_name = dir_new_f, secret_var = "is_secret_prim", - totcode = tot4, hrc = hrc4, - value = "VALUE", freq = "freq", - suppress = "GH(1,100)", nb_tab_option = "max", - dfs_name = "tab_4d_int", limit = 1000000L, - keep_history = FALSE - ) -}) - -timing <- data.frame( - label = "new_false", - phase = c("reduce_dims", "restore_format", "tab_rtauargus4"), - elapsed = c(t_red["elapsed"], t_rest["elapsed"], t_full["elapsed"]), - user = c(t_red["user.self"], t_rest["user.self"], t_full["user.self"]), - sys = c(t_red["sys.self"], t_rest["sys.self"], t_full["sys.self"]) -) -write.csv(timing, file.path(BENCH_DIR, "timing_new_false.csv"), row.names = FALSE) - -gc_stats <- capture_gc("new_false") -write.csv(gc_stats, file.path(BENCH_DIR, "gc_new_false.csv"), row.names = FALSE) - -save_result_minimal(res_new_false, tot4, "new_false") - -cat("Bloc 03 terminé. Redémarrer R, puis lancer 04_summary.R\n") - -# ============================================================================= -# 04_summary.R — Lecture des résultats, pas besoin de session fraîche -# ============================================================================= - -BENCH_DIR <- "Z:/benchmark_4d" -library(dplyr) - -# --- Timings --- -timing <- lapply( - c("old", "new_true", "new_false"), - function(l) read.csv(file.path(BENCH_DIR, paste0("timing_", l, ".csv"))) -) |> bind_rows() - -cat("\n=== TIMINGS (elapsed, secondes) ===\n") -print( - timing |> - select(label, phase, elapsed) |> - tidyr::pivot_wider(names_from = label, values_from = elapsed) -) - -# --- Mémoire peak --- -gc_all <- lapply( - c("old", "new_true", "new_false"), - function(l) read.csv(file.path(BENCH_DIR, paste0("gc_", l, ".csv"))) -) |> bind_rows() - -cat("\n=== PIC MÉMOIRE max_mb (Vcells) ===\n") -print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) - -# --- Égalité des résultats --- -results <- lapply( - c("old", "new_true", "new_false"), - function(l) read.csv(file.path(BENCH_DIR, paste0("result_", l, ".csv"))) -) -names(results) <- c("old", "new_true", "new_false") - -normalize <- function(df) { - df <- df[do.call(order, df[c("ACT", "GEO", "SEX", "AGE")]), ] - rownames(df) <- NULL - df -} - -cat("\n=== ÉGALITÉ DES MASQUES DE SECRET FINAL ===\n") -cat("old == new_true :", identical(normalize(results$old), normalize(results$new_true)), "\n") -cat("old == new_false :", identical(normalize(results$old), normalize(results$new_false)), "\n") - -# --- Stats secret --- -secret_stats <- lapply(names(results), function(l) { - df <- results[[l]] - data.frame( - label = l, - n_prim = sum(df$is_secret_prim), - n_sec = sum(df$final_secret & !df$is_secret_prim), - n_total_masque = sum(df$final_secret), - pct_masque = round(100 * mean(df$final_secret), 2) - ) -}) |> bind_rows() - -cat("\n=== STATISTIQUES DE SECRET ===\n") -print(secret_stats) diff --git a/bench/bench_perf_improv_functions.R b/bench/bench_perf_improv_functions.R deleted file mode 100644 index 521afc5..0000000 --- a/bench/bench_perf_improv_functions.R +++ /dev/null @@ -1,1155 +0,0 @@ -# ============================================================================= -# Test comparatif – Grosses données – Mode SMART (cas d'usage réel) -# Version officielle (package) vs version locale optimisée -# ============================================================================= - -true_package = TRUE # Warning : restart R before editing this value -if (true_package){ - library(rtauargus) # package originale -} else { - devtools::load_all("Z:/rtauargus") # path où est la version split_perf de github : https://github.com/InseeFrLab/rtauargus/tree/split_perf_improvement -} - -library(dplyr) -library(sdcHierarchies) -library(microbenchmark) - -# ----------------------------- Chargement des sources locales optimisées -local_R_dir <- "Z:/rtauargus/R" # <-- adapter au besoin -source(file.path(local_R_dir, "sp_var_to_merge.R")) -source(file.path(local_R_dir, "sp_from_4_to_3.R")) -source(file.path(local_R_dir, "sp_from_4_to_3_case_0_hr.R")) -source(file.path(local_R_dir, "sp_from_4_to_3_case_1_hr.R")) -source(file.path(local_R_dir, "sp_from_4_to_3_case_2_hr.R")) -source(file.path(local_R_dir, "sp_from_5_to_3.R")) -source(file.path(local_R_dir, "sp_reduce_dims.R")) -source(file.path(local_R_dir, "sp_restore_format.R")) - -# ============================================================================= -# 1. Création de gros jeux de données avec hiérarchies profondes -# ============================================================================= - -# --- 4D volumineux (ACT hiérarchique, GEO hiérarchique, SEX & AGE non hiérarchiques) -create_big_4D <- function(n = 50000) { - set.seed(123) - data <- data.frame( - ACT = sample(c("Total", paste0("A", 1:20), paste0("A", 1:20, "_", 1:5)), n, replace = TRUE), - GEO = sample(c("Total", "G1", "G2", "G1a", "G1b", "G2a", "G2b"), n, replace = TRUE), - SEX = sample(c("Total", "F", "M"), n, replace = TRUE), - AGE = sample(c("Total", "AGE1", "AGE2", "AGE3", "AGE4"), n, replace = TRUE), - stringsAsFactors = FALSE - ) - data$VALUE <- 1 - - # Hiérarchie ACT : 20 groupes, chacun avec 5 sous‑niveaux - hrc_act <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total", nodes = paste0("A", 1:20)) %>% - { - for (i in 1:20) { - . <- sdcHierarchies::hier_add(., root = paste0("A", i), nodes = paste0("A", i, "_", 1:5)) - } - . - } %>% - 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) - - # Hiérarchie GEO : 2 régions, chacune avec 2 sous‑régions - hrc_geo <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total", nodes = c("G1", "G2")) %>% - sdcHierarchies::hier_add(root = "G1", nodes = c("G1a", "G1b")) %>% - sdcHierarchies::hier_add(root = "G2", nodes = c("G2a", "G2b")) %>% - 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) - - list(data = data, - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), - totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total")) -} - -# --- 5D volumineux (ACT hiérarchique profond, GEO hiérarchique, autres non hiérarchiques) -create_big_5D <- function(n = 80000) { - set.seed(234) - data <- data.frame( - ACT = sample(c("Total_A", paste0("A", 1:20, "_"), paste0("A", 1:20, "_", 1:5)), n, replace = TRUE), - GEO = sample(c("Total_G", "GA","GB","GA1","GA2","GB1","GB2","GA3","GB3"), n, replace = TRUE), - SEX = sample(c("Total_S", "F", "M", "F1", "F2", "M1", "M2"), n, replace = TRUE), - AGE = sample(c("Ensemble", "AGE1", "AGE2", "AGE11", "AGE12", "AGE21", "AGE22"), n, replace = TRUE), - ECO = sample(c("PIB", "Ménages", "Entreprises"), n, replace = TRUE), - stringsAsFactors = FALSE - ) - data$VALUE <- 1 - - # Hiérarchie ACT (5D) : 20 groupes, chaque avec 5 sous‑niveaux - hrc_act <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total_A", nodes = paste0("A", 1:20, "_")) %>% - { - for (i in 1:20) { - . <- sdcHierarchies::hier_add(., root = paste0("A", i, "_"), nodes = paste0("A", i, "_", 1:5)) - } - . - } %>% - 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) - - # Hiérarchie GEO (5D) : 2 régions, 3‑4 sous‑régions chacune - hrc_geo <- tempfile(fileext = ".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")) %>% - 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) - - list(data = data, - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), - totcode = c(SEX = "Total_S", AGE = "Ensemble", GEO = "Total_G", ACT = "Total_A", ECO = "PIB")) -} - -# ============================================================================= -# 2. Fonctions de validation et de benchmark -# ============================================================================= - -check_equality <- function(res_orig, res_opt) { - if (is.list(res_orig) && is.list(res_opt)) { - if (length(res_orig) != length(res_opt)) return(FALSE) - return(all(mapply(check_equality, res_orig, res_opt, SIMPLIFY = TRUE))) - } else if (is.data.frame(res_orig)) { - return(identical(res_orig, res_opt)) - } else { - return(identical(res_orig, res_opt)) - } -} - -validate <- function(desc, expr_orig, expr_opt) { - cat("\n--- Validation :", desc, "---\n") - - # On capture les erreurs sous forme d'objets R "error" exploitables - res_o <- tryCatch(expr_orig, error = function(e) e) - res_n <- tryCatch(expr_opt, error = function(e) e) - - has_error_o <- inherits(res_o, "error") - has_error_n <- inherits(res_n, "error") - - # Si l'une des versions a levé une erreur - if (has_error_o || has_error_n) { - cat("Une erreur est survenue lors de l'exécution :\n") - if (has_error_o) { - cat(" - Original : Erreur ->", res_o$message, "\n") - } else { - cat(" - Original : Succès (Type :", class(res_o)[1], ")\n") - } - if (has_error_n) { - cat(" - Optimisé : Erreur ->", res_n$message, "\n") - } else { - cat(" - Optimisé : Succès (Type :", class(res_n)[1], ")\n") - } - return(FALSE) - } - - # Si les deux versions ont réussi, on compare l'égalité logique - eq <- check_equality(res_o, res_n) - if (eq) { - cat("Résultats identiques.\n") - } else { - cat("Résultats DIFFÉRENTS.\n") - } - return(eq) -} - -all_benchmarks <- list() - -clear_cache <- function() { - if (exists(".hrc_cache", envir = .GlobalEnv)) { - rm(list = ls(envir = .hrc_cache), envir = .hrc_cache) - } -} - -bench <- function(name_o, name_n, expr_o, expr_n, times = 20) { - expr_o_sub <- substitute(expr_o) - expr_n_sub <- substitute(expr_n) - - # Création d'expressions composées avec vidage du cache - expr_o_clean <- bquote({ clear_cache(); .(expr_o_sub) }) - expr_n_clean <- bquote({ clear_cache(); .(expr_n_sub) }) - - res <- eval(bquote(microbenchmark::microbenchmark( - original = .(expr_o_clean), - optimise = .(expr_n_clean), - times = .(times) - ))) - print(res, unit = "ms") - all_benchmarks[[paste(name_o, "vs", name_n)]] <<- res - invisible(res) -} - -# ============================================================================= -# 3. Exécution des tests -# ============================================================================= - -# ---- Initialisation des gros jeux de données ---- -cat("Création du jeu 4D volumineux...\n") -big4 <- create_big_4D(50000) -dfs4 <- big4$data; tot4 <- big4$totcode; hrc4 <- big4$hrcfiles - -cat("Création du jeu 5D volumineux...\n") -big5 <- create_big_5D(80000) -dfs5 <- big5$data; tot5 <- big5$totcode; hrc5 <- big5$hrcfiles - -# ---- 3.1 length_tabs (tests de bas niveau avec variables imposées) ---- -cat("\n========== length_tabs ==========\n") - -validate("length_tabs 4D ACT x SEX", - rtauargus:::length_tabs(dfs4, "ACT", "SEX", totcode = tot4, hrcfiles = hrc4), - length_tabs(dfs4, "ACT", "SEX", totcode = tot4, hrcfiles = hrc4)) -bench("length_tabs_4D_ACT_SEX", "length_tabs_4D_ACT_SEX_opt", - rtauargus:::length_tabs(dfs4, "ACT", "SEX", totcode = tot4, hrcfiles = hrc4), - length_tabs(dfs4, "ACT", "SEX", totcode = tot4, hrcfiles = hrc4), times = 5) - -validate("length_tabs 5D ACT/GEO/AGE/ECO", - rtauargus:::length_tabs(dfs5, "ACT", "GEO", "AGE", "ECO", totcode = tot5, hrcfiles = hrc5), - length_tabs(dfs5, "ACT", "GEO", "AGE", "ECO", totcode = tot5, hrcfiles = hrc5)) -bench("length_tabs_5D_ACT_GEO_AGE_ECO", "length_tabs_5D_ACT_GEO_AGE_ECO_opt", - rtauargus:::length_tabs(dfs5, "ACT", "GEO", "AGE", "ECO", totcode = tot5, hrcfiles = hrc5), - length_tabs(dfs5, "ACT", "GEO", "AGE", "ECO", totcode = tot5, hrcfiles = hrc5), times = 5) - -# ---- 3.2 var_to_merge (smart automatique) ---- -cat("\n========== var_to_merge (smart) ==========\n") - -validate("var_to_merge 4D smart", - rtauargus:::var_to_merge(dfs4, tot4, hrc4, nb_var = 2, nb_tab_option = 'smart', limit = 2000), - var_to_merge(dfs4, tot4, hrc4, nb_var = 2, nb_tab_option = 'smart', limit = 2000)) -bench("var_to_merge_4D_smart", "var_to_merge_4D_smart_opt", - rtauargus:::var_to_merge(dfs4, tot4, hrc4, nb_var = 2, nb_tab_option = 'smart', limit = 2000), - var_to_merge(dfs4, tot4, hrc4, nb_var = 2, nb_tab_option = 'smart', limit = 2000), times = 5) - -validate("var_to_merge 5D 4var smart", - rtauargus:::var_to_merge(dfs5, tot5, hrc5, nb_var = 4, nb_tab_option = 'smart', limit = 5000), - var_to_merge(dfs5, tot5, hrc5, nb_var = 4, nb_tab_option = 'smart', limit = 5000)) -bench("var_to_merge_5D_4var_smart", "var_to_merge_5D_4var_smart_opt", - rtauargus:::var_to_merge(dfs5, tot5, hrc5, nb_var = 4, nb_tab_option = 'smart', limit = 5000), - var_to_merge(dfs5, tot5, hrc5, nb_var = 4, nb_tab_option = 'smart', limit = 5000), times = 5) - -validate("var_to_merge 5D 3var smart", - rtauargus:::var_to_merge(dfs5, tot5, hrc5, nb_var = 3, nb_tab_option = 'smart', limit = 5000), - var_to_merge(dfs5, tot5, hrc5, nb_var = 3, nb_tab_option = 'smart', limit = 5000)) -bench("var_to_merge_5D_3var_smart", "var_to_merge_5D_3var_smart_opt", - rtauargus:::var_to_merge(dfs5, tot5, hrc5, nb_var = 3, nb_tab_option = 'smart', limit = 5000), - var_to_merge(dfs5, tot5, hrc5, nb_var = 3, nb_tab_option = 'smart', limit = 5000), times = 5) - -# ---- 3.3 reduce_dims 4D en mode SMART (cas réel) ---- -cat("\n========== reduce_dims 4D SMART ==========\n") - -validate("reduce_dims 4D smart (limit=2000, pas d'over_split)", - rtauargus:::reduce_dims(dfs4, "tab", tot4, hrc4, - vars_to_merge = NULL, - nb_tab_option = "smart", limit = 2000, - over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), - reduce_dims(dfs4, "tab", tot4, hrc4, - vars_to_merge = NULL, - nb_tab_option = "smart", limit = 2000, - over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir())) -bench("reduce_dims_4D_smart", "reduce_dims_4D_smart_opt", - rtauargus:::reduce_dims(dfs4, "tab", tot4, hrc4, - vars_to_merge = NULL, - nb_tab_option = "smart", limit = 2000, - over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), - reduce_dims(dfs4, "tab", tot4, hrc4, - vars_to_merge = NULL, - nb_tab_option = "smart", limit = 2000, - over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), - times = 5) # 10 répétitions seulement car déjà très lourd - -# ---- 3.4 reduce_dims 5D en mode SMART (cas réel) ---- -cat("\n========== reduce_dims 5D SMART ==========\n") - -validate("reduce_dims 5D smart (limit=5000, pas d'over_split)", - rtauargus:::reduce_dims(dfs5, "tab", tot5, hrc5, - vars_to_merge = NULL, - nb_tab_option = "smart", limit = 5000, - over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), - reduce_dims(dfs5, "tab", tot5, hrc5, - vars_to_merge = NULL, - nb_tab_option = "smart", limit = 5000, - over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir())) -bench("reduce_dims_5D_smart", "reduce_dims_5D_smart_opt", - rtauargus:::reduce_dims(dfs5, "tab", tot5, hrc5, - vars_to_merge = NULL, - nb_tab_option = "smart", limit = 5000, - over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), - reduce_dims(dfs5, "tab", tot5, hrc5, - vars_to_merge = NULL, - nb_tab_option = "smart", limit = 5000, - over_split = FALSE, sep_dir = TRUE, hrc_dir = tempdir()), - times = 5) - -cat("\n===== Fin des tests. =====\n") - -# ============================================================================= -# RÉCAPITULATIF FINAL (tous les benchmarks en ms) -# ============================================================================= -cat("\n\n========== RÉCAPITULATIF DE TOUS LES BENCHMARKS (ms) ==========\n") -for (nom in names(all_benchmarks)) { - cat("\n---", nom, "---\n") - print(all_benchmarks[[nom]], unit = "ms") -} - - -# ------------------------------------------------------------------------- - -# ============================================================================= -# Three-Way Comparison Script: Real Output vs. Package Version vs. Local Version -# Verifying table counts and sorted sizes for 3 non-hierarchical variables -# ============================================================================= - -run_three_way_comparison <- function() { - cat("\n=======================================================================\n") - cat(" THREE-WAY COMPARISON: REAL vs. PACKAGE vs. LOCAL \n") - cat("=======================================================================\n") - - # --------------------------------------------------------------------------- - # TEST CASE 1: n_mod_v1 = 3, n_mod_v2 = 4, n_mod_v3 = 3 - # Unmerged variables multiplier (V4 x V5) = 2 x 2 = 4 - # --------------------------------------------------------------------------- - cat("\n--- Test Case 1: n_mod_v1 = 3, n_mod_v2 = 4, n_mod_v3 = 3 ---\n") - - test_data_1 <- expand.grid( - V1 = c("Total", "A1", "A2"), # n_mod_v1 = 3 - V2 = c("Total", "B1", "B2", "B3"), # n_mod_v2 = 4 - V3 = c("Total", "C1", "C2"), # n_mod_v3 = 3 - V4 = c("Total", "D1"), # n_mod_v4 = 2 - V5 = c("Total", "E1"), # n_mod_v5 = 2 - stringsAsFactors = FALSE - ) - test_data_1$VALUE <- 1 - totcode_1 <- c(V1 = "Total", V2 = "Total", V3 = "Total", V4 = "Total", V5 = "Total") - - # 1. Real ground truth: count and sizes of generated data frames - real_res_1 <- reduce_dims( - dfs = test_data_1, - dfs_name = "test1", - totcode = totcode_1, - hrcfiles = NULL, - vars_to_merge = c("V1", "V2", "V3"), - sep_dir = TRUE, - hrc_dir = tempdir() - ) - real_sizes_1 <- sort(sapply(real_res_1$tabs, nrow)) - real_count_1 <- length(real_sizes_1) - - # 2. Package estimation (rtauargus original buggy formula) - pkg_sizes_1 <- sort(unlist(rtauargus:::length_tabs( - dfs = test_data_1, - v1 = "V1", v2 = "V2", v3 = "V3", - totcode = totcode_1, - hrcfiles = NULL - ))) - pkg_count_1 <- length(pkg_sizes_1) - - # 3. Local estimation (corrected formula) - local_sizes_1 <- sort(unlist(length_tabs( - dfs = test_data_1, - v1 = "V1", v2 = "V2", v3 = "V3", - totcode = totcode_1, - hrcfiles = NULL - ))) - local_count_1 <- length(local_sizes_1) - - # Display results for Test Case 1 - cat("\n[Table Count Summary]\n") - cat(" - Real generated tables :", real_count_1, "\n") - cat(" - Package prediction :", pkg_count_1, " (Error:", pkg_count_1 - real_count_1, ")\n") - cat(" - Local prediction :", local_count_1, " (Error:", local_count_1 - real_count_1, ")\n") - - cat("\n[Sorted Table Sizes Comparison]\n") - cat(" - Real actual sizes :", paste(real_sizes_1, collapse = ", "), "\n") - cat(" - Package predicted :", paste(pkg_sizes_1, collapse = ", "), "\n") - cat(" - Local predicted :", paste(local_sizes_1, collapse = ", "), "\n") - - # --------------------------------------------------------------------------- - # TEST CASE 2: n_mod_v1 = 4, n_mod_v2 = 3, n_mod_v3 = 4 - # Unmerged variables multiplier (V4 x V5) = 2 x 3 = 6 - # --------------------------------------------------------------------------- - cat("\n-----------------------------------------------------------------------\n") - cat("\n--- Test Case 2: n_mod_v1 = 4, n_mod_v2 = 3, n_mod_v3 = 4 ---\n") - - test_data_2 <- expand.grid( - V1 = c("Total", "A1", "A2", "A3"), # n_mod_v1 = 4 - V2 = c("Total", "B1", "B2"), # n_mod_v2 = 3 - V3 = c("Total", "C1", "C2", "C3"), # n_mod_v3 = 4 - V4 = c("Total", "D1"), # n_mod_v4 = 2 - V5 = c("Total", "E1", "E2"), # n_mod_v5 = 3 - stringsAsFactors = FALSE - ) - test_data_2$VALUE <- 1 - totcode_2 <- c(V1 = "Total", V2 = "Total", V3 = "Total", V4 = "Total", V5 = "Total") - - # 1. Real ground truth: count and sizes of generated data frames - real_res_2 <- reduce_dims( - dfs = test_data_2, - dfs_name = "test2", - totcode = totcode_2, - hrcfiles = NULL, - vars_to_merge = c("V1", "V2", "V3"), - sep_dir = TRUE, - hrc_dir = tempdir() - ) - real_sizes_2 <- sort(sapply(real_res_2$tabs, nrow)) - real_count_2 <- length(real_sizes_2) - - # 2. Package estimation (rtauargus original buggy formula) - pkg_sizes_2 <- sort(unlist(rtauargus:::length_tabs( - dfs = test_data_2, - v1 = "V1", v2 = "V2", v3 = "V3", - totcode = totcode_2, - hrcfiles = NULL - ))) - pkg_count_2 <- length(pkg_sizes_2) - - # 3. Local estimation (corrected formula) - local_sizes_2 <- sort(unlist(length_tabs( - dfs = test_data_2, - v1 = "V1", v2 = "V2", v3 = "V3", - totcode = totcode_2, - hrcfiles = NULL - ))) - local_count_2 <- length(local_sizes_2) - - # Display results for Test Case 2 - cat("\n[Table Count Summary]\n") - cat(" - Real generated tables :", real_count_2, "\n") - cat(" - Package prediction :", pkg_count_2, " (Error:", pkg_count_2 - real_count_2, ")\n") - cat(" - Local prediction :", local_count_2, " (Error:", local_count_2 - real_count_2, ")\n") - - cat("\n[Sorted Table Sizes Comparison]\n") - cat(" - Real actual sizes :", paste(real_sizes_2, collapse = ", "), "\n") - cat(" - Package predicted :", paste(pkg_sizes_2, collapse = ", "), "\n") - cat(" - Local predicted :", paste(local_sizes_2, collapse = ", "), "\n") -} - -# Run the three-way comparison -run_three_way_comparison() - - -# ------------------------------------------------------------------------- - -# ============================================================================= -# Validation Script for nb_tab_generated: Real vs. Local (corrected) -# Verifying node-counting simplification across different triplet scenarios -# ============================================================================= - -verify_nb_tab_generated <- function() { - cat("\n=======================================================================\n") - cat(" VALIDATION OF nb_tab_generated: REAL vs. LOCAL (CORRECTED) \n") - cat("=======================================================================\n") - - # Configuration du jeu de données 5D (issu de votre script de benchmark) - # dfs5, tot5, hrc5 doivent être chargés en mémoire. - - # --- Scenario 1: Triplet merging 2 hierarchical variables & 1 flat variable - # Variables: ACT (Hierarchical), GEO (Hierarchical), SEX (Flat) - cat("\n[Scenario 1] Merging 2 Hierarchical (ACT, GEO) & 1 Flat (SEX):\n") - - real_res_1 <- reduce_dims( - dfs = dfs5, dfs_name = "scen1", totcode = tot5, hrcfiles = hrc5, - vars_to_merge = c("ACT", "GEO", "SEX"), - sep_dir = TRUE, hrc_dir = tempdir() - ) - real_count_1 <- length(real_res_1$tabs) - - local_count_1 <- nb_tab_generated( - v1 = "ACT", v2 = "GEO", v3 = "SEX", - hrcfiles = hrc5, totcode = tot5, data = dfs5 - ) - - cat(" - Real count :", real_count_1, "\n") - cat(" - Local pred :", local_count_1, "\n") - match_1 <- real_count_1 == local_count_1 - cat(" - Exact match :", match_1, "\n") - - # --- Scenario 2: Triplet merging 1 hierarchical variable & 2 flat variables - # Variables: ACT (Hierarchical), SEX (Flat), AGE (Flat) - cat("\n[Scenario 2] Merging 1 Hierarchical (ACT) & 2 Flat (SEX, AGE):\n") - - real_res_2 <- reduce_dims( - dfs = dfs5, dfs_name = "scen2", totcode = tot5, hrcfiles = hrc5, - vars_to_merge = c("ACT", "SEX", "AGE"), - sep_dir = TRUE, hrc_dir = tempdir() - ) - real_count_2 <- length(real_res_2$tabs) - - local_count_2 <- nb_tab_generated( - v1 = "ACT", v2 = "SEX", v3 = "AGE", - hrcfiles = hrc5, totcode = tot5, data = dfs5 - ) - - cat(" - Real count :", real_count_2, "\n") - cat(" - Local pred :", local_count_2, "\n") - match_2 <- real_count_2 == local_count_2 - cat(" - Exact match :", match_2, "\n") - - # --- Scenario 3: Triplet merging 3 flat variables - # Variables: SEX (Flat), AGE (Flat), ECO (Flat) - cat("\n[Scenario 3] Merging 3 Flat variables (SEX, AGE, ECO):\n") - - real_res_3 <- reduce_dims( - dfs = dfs5, dfs_name = "scen3", totcode = tot5, hrcfiles = hrc5, - vars_to_merge = c("SEX", "AGE", "ECO"), - sep_dir = TRUE, hrc_dir = tempdir() - ) - real_count_3 <- length(real_res_3$tabs) - - local_count_3 <- nb_tab_generated( - v1 = "SEX", v2 = "AGE", v3 = "ECO", - hrcfiles = hrc5, totcode = tot5, data = dfs5 - ) - - cat(" - Real count :", real_count_3, "\n") - cat(" - Local pred :", local_count_3, "\n") - match_3 <- real_count_3 == local_count_3 - cat(" - Exact match :", match_3, "\n") - - cat("\n=======================================================================\n") - if (match_1 && match_2 && match_3) { - cat(" SYNTHESIS: The corrected local formulas are valid.\n") - cat(" The predictions match the real generated table counts\n") - cat(" in all test scenarios.\n") - } else { - cat(" SYNTHESIS: Mismatch detected. Please check the code.\n") - } - cat("=======================================================================\n") -} - -# Run the validation -verify_nb_tab_generated() - -# il y a des écarts, mais cela peut être du à une tbale sparse : des croisements sans observations => pas de tables générées - - -# ------------------------------------------------------------------------- - - -# ============================================================================= -# Validation Script for nb_tab_generated with FULL factorial data -# (no sparse cells – theory == practice) -# ============================================================================= - -verify_nb_tab_generated_full <- function() { - cat("\n=======================================================================\n") - cat(" VALIDATION OF nb_tab_generated: REAL vs. LOCAL (FULL FACTORIAL) \n") - cat("=======================================================================\n") - - # -------------------------------------------------------------------------- - # Helper: create a small hierarchy file (in memory) and return its path - # -------------------------------------------------------------------------- - make_small_hrc <- function(root, children, subchildren = NULL) { - tmp <- tempfile(fileext = ".hrc") - h <- sdcHierarchies::hier_create(root = root, nodes = children) - if (!is.null(subchildren)) { - for (i in seq_along(children)) { - h <- sdcHierarchies::hier_add(h, root = children[i], nodes = subchildren[[i]]) - } - } - h %>% - sdcHierarchies::hier_convert(as = "argus") %>% - slice(-1) %>% - mutate(levels = substring(paste0(level, name), 3)) %>% - select(levels) %>% - write.table(file = tmp, row.names = FALSE, col.names = FALSE, quote = FALSE) - return(tmp) - } - - # -------------------------------------------------------------------------- - # Scenario 1: 2 hierarchical (ACT, GEO) + 1 flat (SEX) - # -------------------------------------------------------------------------- - cat("\n[Scenario 1] 2 hierarchical + 1 flat (full factorial)\n") - - # Small hierarchies - hrc_act <- make_small_hrc( - root = "Total", - children = c("A1", "A2"), - subchildren = list(c("A1_a", "A1_b"), c("A2_a", "A2_b")) - ) - hrc_geo <- make_small_hrc( - root = "Total", - children = c("G1", "G2"), - subchildren = list(c("G1_x", "G1_y"), c("G2_x", "G2_y")) - ) - - # All modalities for each variable (including totals) - act_mods <- c("Total", "A1", "A2", "A1_a", "A1_b", "A2_a", "A2_b") - geo_mods <- c("Total", "G1", "G2", "G1_x", "G1_y", "G2_x", "G2_y") - sex_mods <- c("Total", "F", "M") - # Dummy 4th & 5th variables (not merged) - v4_mods <- c("Total", "X") - v5_mods <- c("Total", "Y") - - d1 <- expand.grid( - ACT = act_mods, - GEO = geo_mods, - SEX = sex_mods, - V4 = v4_mods, - V5 = v5_mods, - stringsAsFactors = FALSE - ) - d1$VALUE <- 1 - - tot1 <- c(ACT = "Total", GEO = "Total", SEX = "Total", V4 = "Total", V5 = "Total") - hrc1 <- c(ACT = hrc_act, GEO = hrc_geo) - - real1 <- reduce_dims( - dfs = d1, dfs_name = "full1", totcode = tot1, hrcfiles = hrc1, - vars_to_merge = c("ACT", "GEO", "SEX"), - sep_dir = TRUE, hrc_dir = tempdir() - ) - local1 <- nb_tab_generated( - v1 = "ACT", v2 = "GEO", v3 = "SEX", - hrcfiles = hrc1, totcode = tot1, data = d1 - ) - - cat(" - Real count :", length(real1$tabs), "\n") - cat(" - Local pred :", local1, "\n") - cat(" - Exact match :", length(real1$tabs) == local1, "\n") - - # -------------------------------------------------------------------------- - # Scenario 2: 1 hierarchical (ACT) + 2 flat (SEX, AGE) - # -------------------------------------------------------------------------- - cat("\n[Scenario 2] 1 hierarchical + 2 flat (full factorial)\n") - - age_mods <- c("Total", "AGE1", "AGE2") - d2 <- expand.grid( - ACT = act_mods, - SEX = sex_mods, - AGE = age_mods, - V4 = v4_mods, - V5 = v5_mods, - stringsAsFactors = FALSE - ) - d2$VALUE <- 1 - - tot2 <- c(ACT = "Total", SEX = "Total", AGE = "Total", V4 = "Total", V5 = "Total") - hrc2 <- c(ACT = hrc_act) - - real2 <- reduce_dims( - dfs = d2, dfs_name = "full2", totcode = tot2, hrcfiles = hrc2, - vars_to_merge = c("ACT", "SEX", "AGE"), - sep_dir = TRUE, hrc_dir = tempdir() - ) - local2 <- nb_tab_generated( - v1 = "ACT", v2 = "SEX", v3 = "AGE", - hrcfiles = hrc2, totcode = tot2, data = d2 - ) - - cat(" - Real count :", length(real2$tabs), "\n") - cat(" - Local pred :", local2, "\n") - cat(" - Exact match :", length(real2$tabs) == local2, "\n") - - # -------------------------------------------------------------------------- - # Scenario 3: 3 flat variables (already matched, but included for completeness) - # -------------------------------------------------------------------------- - cat("\n[Scenario 3] 3 flat variables (full factorial)\n") - - eco_mods <- c("Total", "E1", "E2") - d3 <- expand.grid( - SEX = sex_mods, - AGE = age_mods, - ECO = eco_mods, - V4 = v4_mods, - V5 = v5_mods, - stringsAsFactors = FALSE - ) - d3$VALUE <- 1 - - tot3 <- c(SEX = "Total", AGE = "Total", ECO = "Total", V4 = "Total", V5 = "Total") - hrc3 <- NULL - - real3 <- reduce_dims( - dfs = d3, dfs_name = "full3", totcode = tot3, hrcfiles = hrc3, - vars_to_merge = c("SEX", "AGE", "ECO"), - sep_dir = TRUE, hrc_dir = tempdir() - ) - local3 <- nb_tab_generated( - v1 = "SEX", v2 = "AGE", v3 = "ECO", - hrcfiles = hrc3, totcode = tot3, data = d3 - ) - - cat(" - Real count :", length(real3$tabs), "\n") - cat(" - Local pred :", local3, "\n") - cat(" - Exact match :", length(real3$tabs) == local3, "\n") - - cat("\n=======================================================================\n") - cat(" If all three scenarios show Exact match = TRUE,\n") - cat(" the nb_tab_generated formulas are fully correct.\n") - cat("=======================================================================\n") -} - -# Run the full factorial validation -verify_nb_tab_generated_full() # ok, tout est bon - - -# ------------------------------------------------------------------------- - -# ============================================================================= -# Validation des options heuristiques 'min' et 'max' (4D & 5D) -# ============================================================================= -cat("\n=======================================================================\n") -cat(" VALIDATION DES HEURISTIQUES : OPTIONS MIN ET MAX \n") -cat("=======================================================================\n") - -# --- Validation 4D Option MIN -validate("reduce_dims 4D - Option MIN", - rtauargus:::reduce_dims(dfs4, "tab_min4", tot4, hrc4, - nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir()), - reduce_dims(dfs4, "tab_min4", tot4, hrc4, - nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir())) - -# --- Validation 4D Option MAX -validate("reduce_dims 4D - Option MAX", - rtauargus:::reduce_dims(dfs4, "tab_max4", tot4, hrc4, - nb_tab_option = "max", sep_dir = TRUE, hrc_dir = tempdir()), - reduce_dims(dfs4, "tab_max4", tot4, hrc4, - nb_tab_option = "max", sep_dir = TRUE, hrc_dir = tempdir())) - -# --- Validation 5D Option MIN -validate("reduce_dims 5D - Option MIN", - rtauargus:::reduce_dims(dfs5, "tab_min5", tot5, hrc5, - nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir()), - reduce_dims(dfs5, "tab_min5", tot5, hrc5, - nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir())) - -# --- Validation 5D Option MAX -validate("reduce_dims 5D - Option MAX", - rtauargus:::reduce_dims(dfs5, "tab_max5", tot5, hrc5, - nb_tab_option = "max", sep_dir = TRUE, hrc_dir = tempdir()), - reduce_dims(dfs5, "tab_max5", tot5, hrc5, - nb_tab_option = "max", sep_dir = TRUE, hrc_dir = tempdir())) - -# --- Benchmark comparatif (Option MIN sur données 5D volumineuses) -bench("reduce_dims_5D_min_original", "reduce_dims_5D_min_optimise", - rtauargus:::reduce_dims(dfs5, "tab_min5", tot5, hrc5, - nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir()), - reduce_dims(dfs5, "tab_min5", tot5, hrc5, - nb_tab_option = "min", sep_dir = TRUE, hrc_dir = tempdir()), - times = 5) - - -# ------------------------------------------------------------------------- - -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" -options(rtauargus.tauargus_exe = loc_tauargus) - - -Sys.time() - -# ============================================================================= -# Test d'intégration de bout en bout avec tab_rtauargus4 (avec Tau-Argus) -# ============================================================================= -cat("\n=======================================================================\n") -cat(" TEST D'INTÉGRATION DE BOUT EN BOUT : tab_rtauargus4 \n") -cat("=======================================================================\n") - -# --- Préparation des variables requises par tab_rtauargus4 -# La fonction nécessite des colonnes pour la valeur, la fréquence et le secret primaire. -dfs4$freq <- 1 -dfs4$is_secret_prim <- FALSE - -# On force arbitrairement quelques cellules en secret primaire -dfs4$is_secret_prim[dfs4$ACT %in% c("A1", "A2") & dfs4$GEO == "G1"] <- TRUE - -dfs4_agg <- dfs4 %>% - group_by(across(all_of(names(tot4)))) %>% - summarise( - VALUE = sum(VALUE), - freq = sum(freq), - is_secret_prim = as.logical(max(is_secret_prim)), # TRUE si au moins une ligne est secrète - .groups = "drop" - ) - -# --- Vérification de la configuration de l'exécutable Tau-Argus -tau_exe <- getOption("rtauargus.tauargus_exe") - -if (is.null(tau_exe) || !file.exists(tau_exe)) { - cat("\n[INFO] L'exécutable Tau-Argus n'est pas configuré ou reste introuvable.\n") - cat("Pour lancer ce test d'intégration réel avec Tau-Argus, configurez son chemin :\n") - cat("options(rtauargus.tauargus_exe = \"C:/Chemin/Vers/TauArgus.exe\")\n\n") -} else { - cat("Exécutable Tau-Argus détecté :", tau_exe, "\n") - cat("Lancement des validations et benchmarks de bout en bout...\n") - - # Dossier de sortie temporaire pour les fichiers de travail de Tau-Argus - dir_output <- file.path(tempdir(), "tauargus_output") - if (!dir.exists(dir_output)) dir.create(dir_output, recursive = TRUE) - - # --- Validation logique (Version originale vs Version optimisée) - # On utilise la méthode de suppression rapide Hypercube "GH(1,100)" - validate( - "tab_rtauargus4 - 4D complet (Méthode Hypercube rapide GH)", - # Version originale du package installé - rtauargus::tab_rtauargus4( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_output, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - nb_tab_option = "smart", - limit = 50000, - dfs_name = "tab_4d_int" - ), - # Version locale optimisée (Sourced) - tab_rtauargus4( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_output, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - nb_tab_option = "smart", - limit = 50000, - dfs_name = "tab_4d_int" - ) - ) - - # --- Benchmark du flux complet (Écriture fichiers -> Appel Tau-Argus -> Restauration) - # On effectue 3 répétitions car l'appel externe à Tau-Argus et l'écriture disque - # imposent un temps de traitement incompressible. - bench( - "tab_rtauargus4_original_full", "tab_rtauargus4_optimise_full", - rtauargus::tab_rtauargus4( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_output, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - nb_tab_option = "smart", - limit = 50000, - dfs_name = "tab_4d_int" - ), - tab_rtauargus4( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_output, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - nb_tab_option = "smart", - limit = 50000, - dfs_name = "tab_4d_int" - ), - times = 2 - ) -} - -Sys.time() - -# ------------------------------------------------------------------------- - -create_test_5D_triplet <- function() { - # Variables hiérarchiques (exemple : ACT, GEO) - # ACT : Total_A -> A1, A2 (avec sous-niveaux A1_a, A1_b...) - hrc_act <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total_A", nodes = c("A1", "A2")) %>% - sdcHierarchies::hier_add(root = "A1", nodes = c("A1_a", "A1_b")) %>% - sdcHierarchies::hier_add(root = "A2", nodes = c("A2_a", "A2_b")) %>% - 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 <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total_G", nodes = c("G1", "G2")) %>% - sdcHierarchies::hier_add(root = "G1", nodes = c("G1_x", "G1_y")) %>% - sdcHierarchies::hier_add(root = "G2", nodes = c("G2_x", "G2_y")) %>% - 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) - - # Modalities pour chaque variable - act_mods <- c("Total_A", "A1", "A2", "A1_a", "A1_b", "A2_a", "A2_b") - geo_mods <- c("Total_G", "G1", "G2", "G1_x", "G1_y", "G2_x", "G2_y") - sex_mods <- c("Total_S", "F", "M") # variable plate 1 - age_mods <- c("Total_Age", "AGE1", "AGE2") # variable plate 2 (non fusionnée) - eco_mods <- c("Total_E", "E1", "E2") # variable plate 3 - - # Produit cartésien complet (toutes les combinaisons) - data <- expand.grid( - ACT = act_mods, - GEO = geo_mods, - SEX = sex_mods, - AGE = age_mods, - ECO = eco_mods, - stringsAsFactors = FALSE - ) - data$VALUE <- 1 - - list( - data = data, - hrc = c(ACT = hrc_act, GEO = hrc_geo), - tot = c(ACT = "Total_A", GEO = "Total_G", SEX = "Total_S", AGE = "Total_Age", ECO = "Total_E") - ) -} - -test <- create_test_5D_triplet() -dfs5_test <- test$data -hrc5_test <- test$hrc -tot5_test <- test$tot - -validate_triplet_predictions <- function(v1, v2, v3, dfs, totcode, hrcfiles) { - cat("\n--- Validation pour le triplet", v1, v2, v3, "---\n") - - # 1. Réduction réelle - res_real <- reduce_dims( - dfs = dfs, - dfs_name = "test", - totcode = totcode, - hrcfiles = hrcfiles, - vars_to_merge = c(v1, v2, v3), - sep_dir = TRUE, - hrc_dir = tempdir() - ) - real_sizes <- sort(sapply(res_real$tabs, nrow)) - real_count <- length(real_sizes) - - # 2. Prédiction version locale (celle que vous avez chargée) - local_pred <- length_tabs( - dfs = dfs, v1 = v1, v2 = v2, v3 = v3, - totcode = totcode, hrcfiles = hrcfiles - ) - local_sizes <- sort(unlist(local_pred)) - local_count <- length(local_sizes) - - # 3. Prédiction version package (originale) - pkg_pred <- rtauargus:::length_tabs( - dfs = dfs, v1 = v1, v2 = v2, v3 = v3, - totcode = totcode, hrcfiles = hrcfiles - ) - pkg_sizes <- sort(unlist(pkg_pred)) - pkg_count <- length(pkg_sizes) - - cat("\n Réel :", real_count, "tableaux, tailles :", paste(real_sizes, collapse = ",")) - cat("\n Local :", local_count, "tableaux, tailles :", paste(local_sizes, collapse = ",")) - cat("\n Package:", pkg_count, "tableaux, tailles :", paste(pkg_sizes, collapse = ",")) - - # Vérification - local_ok <- isTRUE(all.equal(real_sizes, local_sizes, check.attributes = FALSE)) - pkg_ok <- isTRUE(all.equal(real_sizes, pkg_sizes, check.attributes = FALSE)) - - cat("\n => Local correct :", local_ok, "| Package correct :", pkg_ok, "\n") - return(list(local = local_ok, pkg = pkg_ok)) -} - -# Cas 1 : deux hiérarchiques + une plate (ACT, GEO, SEX) -validate_triplet_predictions("ACT", "GEO", "SEX", dfs5_test, tot5_test, hrc5_test) - -# Cas 2 : une hiérarchique + deux plates (ACT, SEX, ECO) -validate_triplet_predictions("ACT", "SEX", "ECO", dfs5_test, tot5_test, hrc5_test) - -# Cas 3 : trois plates (SEX, AGE, ECO) -validate_triplet_predictions("SEX", "AGE", "ECO", dfs5_test, tot5_test, hrc5_test) - - -# ------------------------------------------------------------------------- - -# ============================================================================= -# Targeted validation and benchmark for split_tab -# ============================================================================= -cat("\n========== split_tab (Table Splitting) ==========\n") - -# To test split_tab, we first generate a baseline reduced dimension object -# with over_split = FALSE. This creates the exact data structure (res) -# that split_tab expects, allowing us to test it in isolation. -res_base_4D <- reduce_dims( - dfs = dfs4, - dfs_name = "tab_base", - totcode = tot4, - hrcfiles = hrc4, - over_split = FALSE, # Crucial: prevent split_tab from running inside reduce_dims - nb_tab_option = "min", - sep_dir = TRUE, - hrc_dir = tempdir() -) - -# Reconstruct the merged variable name from the baseline results (e.g., "ACT_GEO") -var_fusionnee <- paste(res_base_4D$fus_vars[1], res_base_4D$fus_vars[2], sep = res_base_4D$sep) - -# 1. Logical Validation: Ensure both functions yield mathematically identical lists of dataframes -# We set a low limit (200 rows) to force the splitting loop to run on multiple large tables -validate( - desc = "split_tab 4D (with a strict limit of 200 rows)", - expr_orig = rtauargus:::split_tab(res = res_base_4D, var_fus = var_fusionnee, limit = 200), - expr_opt = split_tab(res = res_base_4D, var_fus = var_fusionnee, limit = 200) -) - -# 2. Performance Benchmark: Measure execution times between the original and optimized versions -bench( - name_o = "split_tab_original", - name_n = "split_tab_optimise", - expr_o = rtauargus:::split_tab(res = res_base_4D, var_fus = var_fusionnee, limit = 200), - expr_n = split_tab(res = res_base_4D, var_fus = var_fusionnee, limit = 200), - times = 10) # 10 runs are sufficient to confirm the memory footprint and CPU speed difference - - -# ------------------------------------------------------------------------- - -# ============================================================================= -# Validation et Benchmark de restore_format (Original vs Optimisé) -# ============================================================================= - -# --- 1. Génération préalable des objets réduits avec reduce_dims -cat("\nGénération des objets réduits (reduce_dims 4D et 5D)...\n") - -res_4D <- reduce_dims( - dfs = dfs4, - dfs_name = "tab_4D", - totcode = tot4, - hrcfiles = hrc4, - nb_tab_option = "max", - sep_dir = TRUE, - hrc_dir = tempdir() -) - -res_5D <- reduce_dims( - dfs = dfs5, - dfs_name = "tab_5D", - totcode = tot5, - hrcfiles = hrc5, - nb_tab_option = "max", - sep_dir = TRUE, - hrc_dir = tempdir() -) - -# On renomme temporairement la fonction optimisée locale pour la distinguer du package installé -restore_format_local <- restore_format - -# --- 2. Fonction de validation de l'égalité logique des jeux de données -validate_restore <- function(desc, masq, res) { - cat("\n--- Validation logique :", desc, "---\n") - - # Version officielle installée du package - res_orig <- rtauargus::restore_format(masq = masq, res = res) - - # Nouvelle version locale optimisée - res_opt <- restore_format_local(masq = masq, res = res) - - # Standardisation (conversion en data.frame classique et nettoyage des rownames) - res_orig_clean <- as.data.frame(res_orig) - rownames(res_orig_clean) <- NULL - - res_opt_clean <- as.data.frame(res_opt) - rownames(res_opt_clean) <- NULL - - # Comparaison stricte du contenu des données - eq <- identical(res_orig_clean, res_opt_clean) - if (eq) { - cat("Résultats strictement identiques (après nettoyage des attributs R).\n") - } else { - cat("Résultats DIFFÉRENTS. Vérifiez la validité des découpages.\n") - } - return(eq) -} - -# Nombre de tables pour le cas 4D -length(res_4D$tabs) - -# Nombre de tables pour le cas 5D -length(res_5D$tabs) - -# Validation sur les structures 4D et 5D -v_4d <- validate_restore("restore_format 4D (Paires)", res_4D$tabs, res_4D) -v_5d <- validate_restore("restore_format 5D (Triplets/Paires)", res_5D$tabs, res_5D) - -# --- 3. Mesures de performances si la validation logique est validée -if (v_4d && v_5d) { - cat("\n=======================================================================\n") - cat(" BENCHMARKS COMPARATIFS : restore_format \n") - cat("=======================================================================\n") - - cat("\n--- Benchmark 1 : restore_format (Cas 4D - 50 000 lignes) ---\n") - bench_4D <- microbenchmark::microbenchmark( - original = rtauargus::restore_format(masq = res_4D$tabs, res = res_4D), - optimise = restore_format_local(masq = res_4D$tabs, res = res_4D), - times = 10 - ) - print(bench_4D, unit = "ms") - - cat("\n--- Benchmark 2 : restore_format (Cas 5D - 80 000 lignes) ---\n") - bench_5D <- microbenchmark::microbenchmark( - original = rtauargus::restore_format(masq = res_5D$tabs, res = res_5D), - optimise = restore_format_local(masq = res_5D$tabs, res = res_5D), - times = 10 - ) - print(bench_5D, unit = "ms") -} else { - cat("\n[ERREUR] Impossible de lancer le benchmark : les résultats divergent.\n") -} - - -# ------------------------------------------------------------------------- - -# ============================================================================= -# Validation et Benchmark de chose_sep (Original vs Optimisé) -# ============================================================================= -cat("\n=======================================================================\n") -cat(" VALIDATION ET BENCHMARK : chose_sep \n") -cat("=======================================================================\n") - -# 1. Création d'un grand jeu de données avec beaucoup de modalités distinctes -# En cumulant VAR1 à VAR4, nous obtenons environ 18 000 modalités uniques sur 100 000 observations. -set.seed(456) -n_obs <- 100000 -gros_df_modalites <- data.frame( - VAR1 = sample(paste0("M1_", 1:5000), n_obs, replace = TRUE), - VAR2 = sample(paste0("M2_", 10000:20000), n_obs, replace = TRUE), - VAR3 = sample(paste0("M3_", 1:2000), n_obs, replace = TRUE), - VAR4 = sample(paste0("M4_", 1:1000), n_obs, replace = TRUE), - stringsAsFactors = FALSE -) - -separateurs_candidats <- c("___", "_XXX_", "_YYY_", "_TTT_", "_UVW_") - -# 2. Validation logique : s'assurer que le séparateur trouvé est identique -cat("\n--- Validation logique de chose_sep ---\n") -sep_orig <- rtauargus:::chose_sep(gros_df_modalites, separateurs_candidats) -sep_opt <- chose_sep(gros_df_modalites, separateurs_candidats) - -if (identical(sep_orig, sep_opt)) { - cat("Résultats identiques : le séparateur sélectionné est '", sep_opt, "'\n", sep = "") - - # 3. Benchmark comparatif de performance - cat("\n--- Benchmark : chose_sep (18 000 modalités) ---\n") - bench_sep <- microbenchmark::microbenchmark( - original = rtauargus:::chose_sep(gros_df_modalites, separateurs_candidats), - optimise = chose_sep(gros_df_modalites, separateurs_candidats), - times = 5 # 5 répétitions suffisent car la version originale est longue à s'exécuter - ) - print(bench_sep, unit = "ms") - -} else { - cat("\n[ERREUR] Résultats DIFFÉRENTS. Vérifiez l'implémentation de votre version locale.\n") -} diff --git a/bench/bench_sort.R b/bench/bench_sort.R deleted file mode 100644 index 581023f..0000000 --- a/bench/bench_sort.R +++ /dev/null @@ -1,207 +0,0 @@ -# ============================================================================= -# bench_sort_table.R — Une seule session suffit (keep_history = FALSE) -# Compare sort_table = NULL / "ASC" / "DESC" -# ============================================================================= - -BENCH_DIR <- "Z:/benchmark_4d" -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" - -library(data.table); library(dplyr) -devtools::load_all("Z:/rtauargus") -options(rtauargus.tauargus_exe = loc_tauargus) - -load(file.path(BENCH_DIR, "input_data.RData")) # dfs4_agg, tot4, hrc4 - -# ============================================================================= -# UTILITAIRES -# ============================================================================= - -capture_gc <- function(label) { - g <- gc() - data.frame( - label = label, - type = rownames(g), - used_mb = g[, 2], - trigger_mb = g[, 4], - max_mb = g[, 6], - row.names = NULL - ) -} - -get_last_secret_col <- function(df) { - cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] - if (!length(cols)) return(NULL) - cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) -} - -get_secret_stats <- function(df, label) { - last_col <- get_last_secret_col(df) - final <- df[[last_col]] - prim <- df$is_secret_prim - sec <- final & !prim - valid <- !final - - data.frame( - label = label, - n_prim = sum(prim), - value_prim = sum(df$VALUE[prim], na.rm = TRUE), - n_sec = sum(sec), - value_sec = sum(df$VALUE[sec], na.rm = TRUE), - n_total_masque = sum(final), - value_total_masque = sum(df$VALUE[final], na.rm = TRUE), - n_valid = sum(valid), - value_valid = sum(df$VALUE[valid], na.rm = TRUE), - pct_masque_cells = round(100 * mean(final), 2), - pct_masque_value = round(100 * sum(df$VALUE[final], na.rm = TRUE) / - sum(df$VALUE, na.rm = TRUE), 2) - ) -} - -# Normalise un df pour comparaison cellule par cellule -normalize <- function(df, key_cols) { - df <- as.data.frame(df)[, c(key_cols, "final_secret")] - df <- df[do.call(order, df[key_cols]), ] - rownames(df) <- NULL - df -} - -# Extrait le masque final sous forme normalisée -extract_mask <- function(df, tot4) { - last_col <- get_last_secret_col(df) - df_min <- as.data.frame(df)[, c(names(tot4), last_col)] - names(df_min)[ncol(df_min)] <- "final_secret" - normalize(df_min, names(tot4)) -} - -# ============================================================================= -# PARAMÈTRES COMMUNS AUX 3 RUNS -# ============================================================================= - -common_args <- list( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - nb_tab_option = "max", - dfs_name = "tab_4d_int", - limit = 1000000L, - keep_history = FALSE -) - -variants <- list( - list(label = "sort_NULL", sort_table = NULL), - list(label = "sort_ASC", sort_table = "ASC"), - list(label = "sort_DESC", sort_table = "DESC") -) - -# Stockage des résultats en mémoire (~50 MB × 3 = négligeable) -results_raw <- list() -stats_list <- list() -timings_list <- list() -gc_list <- list() - -# ============================================================================= -# BOUCLE PRINCIPALE -# ============================================================================= - -for (v in variants) { - - cat("\n======================================================================\n") - cat(" Variant :", v$label, "\n") - cat("======================================================================\n") - - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) - dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) - - gc(reset = TRUE) - - t_v <- system.time({ - res_v <- do.call( - tab_rtauargus4, - c(common_args, list(dir_name = dir_v, sort_table = v$sort_table)) - ) - }) - - # Résultats bruts conservés en mémoire pour comparaison cellule par cellule - results_raw[[v$label]] <- res_v - - # Stats secret - stats_list[[v$label]] <- get_secret_stats(res_v, v$label) - - # Timing - timings_list[[v$label]] <- data.frame( - label = v$label, - elapsed = t_v["elapsed"], - user = t_v["user.self"], - sys = t_v["sys.self"] - ) - - # Mémoire (après la fin du run, gc() déclenché dans capture_gc) - gc_list[[v$label]] <- capture_gc(v$label) - - # Sauvegarde intermédiaire (sécurité en cas de crash session) - write.csv(stats_list[[v$label]], - file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), - row.names = FALSE) - write.csv(timings_list[[v$label]], - file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), - row.names = FALSE) - write.csv(gc_list[[v$label]], - file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), - row.names = FALSE) - - cat("✓", v$label, "terminé en", round(t_v["elapsed"], 1), "s\n") -} - -# ============================================================================= -# BILAN FINAL -# ============================================================================= - -cat("\n======================================================================\n") -cat(" BILAN COMPARATIF : IMPACT DE sort_table \n") -cat("======================================================================\n") - -cat("\n[1. Statistiques de secret]\n") -print(bind_rows(stats_list)) - -cat("\n[2. Timings (elapsed, secondes)]\n") -print(bind_rows(timings_list)) - -cat("\n[3. Pic mémoire Vcells (max_mb, MB)]\n") -gc_all <- bind_rows(gc_list) -print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) - -# ============================================================================= -# COMPARAISON CELLULE PAR CELLULE -# ============================================================================= - -cat("\n[4. Comparaison cellule par cellule des masques de secret final]\n") - -mask_null <- extract_mask(results_raw[["sort_NULL"]], tot4) -mask_asc <- extract_mask(results_raw[["sort_ASC"]], tot4) -mask_desc <- extract_mask(results_raw[["sort_DESC"]], tot4) - -cat("NULL == ASC :", identical(mask_null, mask_asc), "\n") -cat("NULL == DESC :", identical(mask_null, mask_desc), "\n") -cat("ASC == DESC :", identical(mask_asc, mask_desc), "\n") - -# Si des différences existent, les quantifier -if (!identical(mask_null, mask_asc)) { - n_diff <- sum(mask_null$final_secret != mask_asc$final_secret) - cat(" → Cellules différentes NULL vs ASC :", n_diff, - sprintf("(%.3f%%)\n", 100 * n_diff / nrow(mask_null))) -} -if (!identical(mask_null, mask_desc)) { - n_diff <- sum(mask_null$final_secret != mask_desc$final_secret) - cat(" → Cellules différentes NULL vs DESC :", n_diff, - sprintf("(%.3f%%)\n", 100 * n_diff / nrow(mask_null))) -} -if (!identical(mask_asc, mask_desc)) { - n_diff <- sum(mask_asc$final_secret != mask_desc$final_secret) - cat(" → Cellules différentes ASC vs DESC :", n_diff, - sprintf("(%.3f%%)\n", 100 * n_diff / nrow(mask_asc))) -} diff --git a/bench/bench_split_nodes.R b/bench/bench_split_nodes.R deleted file mode 100644 index 1b296b2..0000000 --- a/bench/bench_split_nodes.R +++ /dev/null @@ -1,115 +0,0 @@ -# Benchmarking and Verification script for Z:/rtauargus/R optimizations -library(microbenchmark) - -# ============================================================================== -# 1. Benchmark & Verification for Priority 1: Subsetting (from_4_to_3_case_1_hr logic) -# ============================================================================== -set.seed(42) -n_rows <- 1e5 -unique_codes <- paste0("CODE_", 1:50) -dfs_test <- data.frame( - v2 = sample(unique_codes, n_rows, replace = TRUE), - VALUE = runif(n_rows), - stringsAsFactors = FALSE -) -codes_split_test <- lapply(1:50, function(i) sample(unique_codes, 10)) - -# --- Package original logic --- -run_old_p1 <- function(dfs, codes_split) { - lapply(codes_split, function(codes) { - dfs[dfs$v2 %in% codes, , drop = FALSE] - }) -} - -# --- Package optimized logic --- -run_new_p1 <- function(dfs, codes_split) { - # OPTIMIZATION: Physically pre-index positions once - row_indices <- split(seq_len(nrow(dfs)), dfs$v2) - - lapply(codes_split, function(codes) { - # OPTIMIZATION: Combine indices and sort to preserve exact original row order - idx <- sort(unlist(row_indices[codes], use.names = FALSE)) - dfs[idx, , drop = FALSE] - }) -} - -# VERIFICATION: Assert that both implementations return 100% identical dataframes -res_old_p1 <- run_old_p1(dfs_test, codes_split_test) -res_new_p1 <- run_new_p1(dfs_test, codes_split_test) -p1_is_identical <- identical(res_old_p1, res_new_p1) -cat("Priority 1 (Subsetting): Are outputs identical?", p1_is_identical, "\n\n") - -benchmark_p1 <- microbenchmark( - "Old %in% subsetting" = { - run_old_p1(dfs_test, codes_split_test) - }, - "New Index-based (Sorted)" = { - run_new_p1(dfs_test, codes_split_test) - }, - times = 10 -) -print(benchmark_p1) -cat("\n----------------------------------------------------------------------\n\n") - - -# ============================================================================== -# 2. Benchmark & Verification for Priority 2: Stride-based extraction (separer4_3 logic) -# ============================================================================== -# Generate a realistic dataframe of 100,000 rows with a concatenated column -set.seed(42) -n_splits <- 1e5 -df_base <- data.frame( - v1_v2 = paste(sample(paste0("A", 1:500), n_splits, replace = TRUE), - sample(paste0("B", 1:500), n_splits, replace = TRUE), - sep = "_"), - OTHER_VAL = runif(n_splits), - stringsAsFactors = FALSE -) - -# --- Original separer4_3 function --- -separer4_3_old <- function(df, v1, v2, v1_v2, sep) { - splits <- strsplit(df[[v1_v2]], split = sep, fixed = TRUE) - mat <- matrix(unlist(splits, use.names = FALSE), ncol = 2, byrow = TRUE) - - df[[v1]] <- mat[, 1] - df[[v2]] <- mat[, 2] - df[[v1_v2]] <- NULL - - # Reorder columns - new_order <- c(v1, v2, setdiff(names(df), c(v1, v2))) - df[, new_order] -} - -# --- Optimized separer4_3 function --- -separer4_3_new <- function(df, v1, v2, v1_v2, sep) { - splits <- strsplit(df[[v1_v2]], split = sep, fixed = TRUE) - - # OPTIMIZATION: Stride-based extraction bypassing 2D matrix allocation - unlisted <- unlist(splits, use.names = FALSE) - n_rows <- length(splits) - - df[[v1]] <- unlisted[seq(1, by = 2, length.out = n_rows)] - df[[v2]] <- unlisted[seq(2, by = 2, length.out = n_rows)] - df[[v1_v2]] <- NULL - - # Reorder columns - new_order <- c(v1, v2, setdiff(names(df), c(v1, v2))) - df[, new_order] -} - -# VERIFICATION: Assert that both dataframes are 100% identical after columns splitting -df_old_res <- separer4_3_old(df_base, "v1", "v2", "v1_v2", "_") -df_new_res <- separer4_3_new(df_base, "v1", "v2", "v1_v2", "_") -p2_is_identical <- identical(df_old_res, df_new_res) -cat("Priority 2 (separer4_3): Are outputs identical?", p2_is_identical, "\n\n") - -benchmark_p2 <- microbenchmark( - "Old separer4_3 (Matrix)" = { - separer4_3_old(df_base, "v1", "v2", "v1_v2", "_") - }, - "New separer4_3 (Stride)" = { - separer4_3_new(df_base, "v1", "v2", "v1_v2", "_") - }, - times = 10 -) -print(benchmark_p2) diff --git a/bench/bench_tab_multimanager_bloc.R b/bench/bench_tab_multimanager_bloc.R deleted file mode 100644 index dfbf2bf..0000000 --- a/bench/bench_tab_multimanager_bloc.R +++ /dev/null @@ -1,834 +0,0 @@ -library(microbenchmark) -library(data.table) -library(purrr) -library(rlang) -library(dplyr) -library(sdcHierarchies) - -library(rtauargus) # package original -# on fait une copie de la fonction du package, car sera remplacé lors du load_all -tab_multi_manager_old <- rtauargus::tab_multi_manager - -# pour charger reduce_dims et le package rtauargus local -devtools::load_all("Z:/rtauargus") # path où est la version split_perf de github : https://github.com/InseeFrLab/rtauargus/tree/split_perf_improvement - -set.seed(42) - -# ============================================================================= -# 0. ÉTAPE PRÉALABLE : Création du jeu 5D et découpage par reduce_dims -# ============================================================================= -cat("======================================================================\n") -cat("0. INITIALISATION : Génération du jeu 5D et exécution de reduce_dims \n") -cat("======================================================================\n") - -# 1. Fonction create_big_5D corrigée (largeur de codes fixe) -create_big_5D <- function(n = 80000) { - set.seed(234) - - # Codes de largeur fixe pour CHAQUE niveau : - # Level 1 ACT: A01_0 (5 caracteres) - # Level 2 ACT: A01_1 (5 caracteres) - act_level1 <- sprintf("A%02d_0", 1:20) - act_level2 <- unlist(lapply(1:20, function(i) sprintf("A%02d_%d", i, 1:5))) - - # Level 1 GEO: GA_ (3 caracteres) - # Level 2 GEO: GA1 (3 caracteres) - geo_level1 <- c("GA_", "GB_") - geo_level2 <- c("GA1", "GA2", "GA3", "GB1", "GB2", "GB3") - - data <- data.frame( - ACT = sample(c("Total_A", act_level1, act_level2), n, replace = TRUE), - GEO = sample(c("Total_G", geo_level1, geo_level2), n, replace = TRUE), - SEX = sample(c("Total_S", "F0", "M0", "F1", "F2", "M1", "M2"), n, replace = TRUE), - AGE = sample(c("Ensemble", "AGE01", "AGE02", "AGE11", "AGE12", "AGE21", "AGE22"), n, replace = TRUE), - ECO = sample(c("PIB", "Ménages", "Entreprises"), n, replace = TRUE), - stringsAsFactors = FALSE - ) - data$VALUE <- 1 - - # Hiérarchie ACT - hrc_act <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total_A", nodes = act_level1) %>% - { - for (i in 1:20) { - root_node <- sprintf("A%02d_0", i) - children <- sprintf("A%02d_%d", i, 1:5) - . <- sdcHierarchies::hier_add(., root = root_node, nodes = children) - } - . - } %>% - 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) - - # Hiérarchie GEO - hrc_geo <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total_G", nodes = geo_level1) %>% - sdcHierarchies::hier_add(root = "GA_", nodes = c("GA1", "GA2", "GA3")) %>% - sdcHierarchies::hier_add(root = "GB_", nodes = c("GB1", "GB2", "GB3")) %>% - 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) - - list(data = data, - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), - totcode = c(SEX = "Total_S", AGE = "Ensemble", GEO = "Total_G", ACT = "Total_A", ECO = "PIB")) -} - -# 1. Création du jeu 5D -big5 <- create_big_5D(80000) -dfs5 <- big5$data - -# 2. AGRÉGATION PRÉALABLE DES DONNÉES (Pour obtenir un vrai tableau statistique de cellules uniques) -dfs5_agg <- dfs5 %>% - group_by(ACT, GEO, SEX, AGE, ECO) %>% - summarise( - VALUE = sum(VALUE), - freq = n(), - .groups = "drop" - ) - -cat("Nombre de lignes tableau avant reduce dims :", nrow(dfs5_agg), "\n") - - -dfs5_agg$is_secret_prim <- sample(c(TRUE, FALSE), nrow(dfs5_agg), replace = TRUE, prob = c(0.05, 0.95)) -dfs5_agg$secret_no_pl <- FALSE - -tot5 <- big5$totcode -hrc5 <- big5$hrcfiles - -cat("=== CONTENU DU FICHIER HRC GEO ===\n") -print(readLines(hrc5[["GEO"]])) - -cat("\n=== CONTENU DU FICHIER HRC ACT ===\n") -print(readLines(hrc5[["ACT"]])) - -# 3. Réduction de dimension sur les données agrégées -# res5 <- reduce_dims( -# dfs = dfs5_agg, -# dfs_name = "tab_5D", -# totcode = tot5, -# hrcfiles = hrc5, -# nb_tab_option = "smart", -# limit = 50000, -# over_split = TRUE, -# # nb_tab_option = "max", -# sep_dir = TRUE, -# hrc_dir = tempdir() -# ) - -res5 <- reduce_dims( - dfs = dfs5_agg, - dfs_name = "tab_5D", - totcode = tot5, - hrcfiles = hrc5, - vars_to_merge = c("ACT", "GEO", "SEX", "AGE"), # <-- Force 2 couples (ACT_GEO et SEX_AGE) - sep_dir = TRUE, - hrc_dir = tempdir() -) - -cat("Nombre de tableaux générés :", length(res5$tabs), "\n") - -list_tables_5d <- res5$tabs -list_expl_5d <- res5$vars - -all_expl_vars <- unique(unname(unlist(list_expl_5d))) -noms_tbx <- names(list_tables_5d) -noms_col_T <- stats::setNames(paste0("T_", noms_tbx), noms_tbx) - - - -# Bench bloc 1 ------------------------------------------------------------ - - -# Construction de table_majeure_list -table_majeure_list <- purrr::imap( - .x = list_tables_5d, - .f = function(tableau, nom_tab){ - tableau <- as.data.frame(tableau)[, c(list_expl_5d[[nom_tab]], "VALUE", "freq", "secret_no_pl", "is_secret_prim")] - - var_a_ajouter <- setdiff(all_expl_vars, names(tableau)) - for (nom_col in var_a_ajouter){ - tableau[[nom_col]] <- unname( - purrr::keep(res5$alt_totcode, function(x) nom_col %in% names(x))[[1]][nom_col] - ) - } - tableau[[noms_col_T[[nom_tab]]]] <- TRUE - - for (col in list_expl_5d[[nom_tab]]) { - tableau[[col]] <- as.character(tableau[[col]]) - } - return(tableau) - } -) - -by_vars <- purrr::reduce(purrr::map(table_majeure_list, names), intersect) - -# Helper de normalisation pour la comparaison exacte -normalize_for_compare <- function(df, key_cols) { - df <- as.data.frame(df) - df <- df[, order(names(df)), drop = FALSE] - df <- df[do.call(order, df[key_cols]), , drop = FALSE] - row.names(df) <- NULL - return(df) -} - -# --- CODE EXACT D'ORIGINE DU PACKAGE --- -run_old_block1 <- function(table_majeure_list, by_vars, noms_col_T) { - table_majeure <- purrr::reduce( - .x = table_majeure_list, - .f = merge, - by = by_vars, - all = TRUE - ) - - table_majeure$secret_no_pl_iter <- table_majeure$secret_no_pl - secret_no_pl_iter <- "secret_no_pl_iter" - - purrr::walk( - noms_col_T, - function(col_T){ - e_par <- rlang::env_parent() - e_par$table_majeure[[col_T]] <- ifelse( - is.na(e_par$table_majeure[[col_T]]), - FALSE, - e_par$table_majeure[[col_T]] - ) - } - ) - return(table_majeure) -} - -# --- CODE PROPOSÉ OPTIMISÉ --- -run_new_block1 <- function(table_majeure_list, by_vars, noms_col_T) { - dt_list <- lapply(table_majeure_list, data.table::as.data.table) - dt_all <- data.table::rbindlist(dt_list, use.names = TRUE, fill = TRUE) - table_majeure <- dt_all[, lapply(.SD, function(col) any(!is.na(col))), by = by_vars, .SDcols = noms_col_T] - data.table::setDT(table_majeure) - - table_majeure[, secret_no_pl_iter := secret_no_pl] - secret_no_pl_iter <- "secret_no_pl_iter" - - for (col_T in noms_col_T) { - data.table::set(table_majeure, i = which(is.na(table_majeure[[col_T]])), j = col_T, value = FALSE) - } - return(as.data.frame(table_majeure)) -} - -t_res_old_b1 <- system.time({ - res_old_b1 <- run_old_block1(table_majeure_list, by_vars, noms_col_T) -}) -cat("Temps res_old_b1 :\n") -print(t_res_old_b1) - -t_res_new_b1 <- system.time({ - res_new_b1 <- run_new_block1(table_majeure_list, by_vars, noms_col_T) -}) -cat("Temps res_new_b1 :\n") -print(t_res_new_b1) - -b1_is_identical <- identical( - normalize_for_compare(res_old_b1, by_vars), - normalize_for_compare(res_new_b1, by_vars) -) -cat("Nombre de lignes Original :", nrow(res_old_b1), "\n") -cat("Nombre de lignes Optimisé :", nrow(res_new_b1), "\n") -cat("Block 1 Verification: Are outputs 100% identical?", b1_is_identical, "\n\n") - -benchmark_b1 <- microbenchmark( - "Old: purrr::reduce(merge)" = run_old_block1(table_majeure_list, by_vars, noms_col_T), - "New: rbindlist + group-by" = run_new_block1(table_majeure_list, by_vars, noms_col_T), - times = 3 -) -print(benchmark_b1) -cat("\n----------------------------------------------------------------------\n\n") - - -# Bloc 2 ------------------------------------------------------------------ - -cat("======================================================================\n") -cat("2. BENCHMARK BLOCK 2: In-place table_majeure Update (Processing Phase)\n") -cat("======================================================================\n") - -# Prise de la table_majeure generee au Bloc 1 -tm_base <- res_old_b1 -nom_tab_1 <- noms_tbx[1] - -# Identification des lignes de la premiere sous-table et extraction de ses variables explicatives -active_idx <- which(tm_base[[paste0("T_", nom_tab_1)]]) -ex_var_1 <- list_expl_5d[[nom_tab_1]] - -# Simulation du resultat renvoye par Tau-Argus pour ce sous-tableau -res_tau <- tm_base[active_idx, ex_var_1, drop = FALSE] -set.seed(42) -res_tau$is_secret <- sample(c(TRUE, FALSE), length(active_idx), replace = TRUE, prob = c(0.2, 0.8)) - -# Noms des variables de secret pour l'iteration 1 -var_sec_apriori <- "is_secret_prim" -var_sec_new <- "is_secret_1" -secret_var_name <- "is_secret_prim" - -# Préparation préalable de table_majeure au format data.table -# Reflète fidèlement le déroulement réel où table_majeure est DÉJÀ un data.table dans la boucle -t_conv <- system.time({ - tm_dt_base <- data.table::as.data.table(tm_base) -}) - -cat("Temps de conversion data.frame -> data.table :\n") -print(t_conv) - -# --- CODE EXACT D'ORIGINE DU PACKAGE --- -run_old_block2 <- function(table_majeure, res, var_secret_apriori, var_secret, secret_var) { - table_majeure <- merge(table_majeure, res, all = TRUE) - table_majeure[[var_secret]] <- table_majeure$is_secret - table_majeure <- subset( - table_majeure, - select = setdiff(names(table_majeure), "is_secret") - ) - - table_majeure[[var_secret]] <- ifelse( - is.na(table_majeure[[var_secret]]), - table_majeure[[var_secret_apriori]], - table_majeure[[var_secret]] - ) - - table_majeure$secret_no_pl_iter <- ifelse( - table_majeure[[secret_var]], - table_majeure$secret_no_pl, - table_majeure[[var_secret]] - ) - return(table_majeure) -} - -# --- CODE PROPOSÉ OPTIMISÉ (data.table) --- -run_new_block2 <- function(table_majeure_dt, res, var_secret_apriori, var_secret, secret_var, all_expl, list_tot) { - - # NEW 2 : Seule une copie très légère de sécurité est faite pour éviter que les répétitions - # NEW 2 : du microbenchmark ne modifient l'objet initial entre deux répétitions - tm_dt <- data.table::copy(table_majeure_dt) - - # NEW 2 : Passage de res en data.table par référence (aligné sur le code réel) - res_dt <- data.table::as.data.table(res) - - # Correction mode générique : compléter res avec les variables explicatives absentes de res (fixées à leur total) - missing_expl <- setdiff(all_expl, names(res_dt)) - for (v in missing_expl) { - val_tot <- unname(purrr::keep(list_tot, function(x) v %in% names(x))[[1]][v]) - data.table::set(res_dt, j = v, value = as.character(val_tot)) - } - - # Initialisation de la colonne d'itération avec l'état précédent - tm_dt[, (var_secret) := get(var_secret_apriori)] - - # Mise à jour en place par référence sur all_expl_vars - tm_dt[res_dt, (var_secret) := i.is_secret, on = all_expl] - - # Mise à jour de la colonne de gestion du PL - tm_dt[, secret_no_pl_iter := data.table::fifelse(get(secret_var), secret_no_pl, get(var_secret))] - - return(as.data.frame(tm_dt)) -} - -# Exécution des deux versions -t_res_old_b2 <- system.time({ - res_old_b2 <- run_old_block2(tm_base, res_tau, var_sec_apriori, var_sec_new, secret_var_name) -}) -cat("Temps res_old_b2 :\n") -print(t_res_old_b2) - -# On passe tm_dt_base (déjà converti en data.table) à la version optimisée -t_res_new_b2<- system.time({ - res_new_b2 <- run_new_block2(tm_dt_base, res_tau, var_sec_apriori, var_sec_new, secret_var_name, all_expl_vars, res5$alt_totcode) -}) -cat("Temps res_new_b2 :\n") -print(t_res_new_b2) - - -# Vérification de l'égalité exacte des résultats -b2_is_identical <- identical( - normalize_for_compare(res_old_b2, by_vars), - normalize_for_compare(res_new_b2, by_vars) -) - -cat("Nombre de lignes Original :", nrow(res_old_b2), "\n") -cat("Nombre de lignes Optimisé :", nrow(res_new_b2), "\n") -cat("Block 2 Verification: Are outputs 100% identical?", b2_is_identical, "\n\n") - -# Benchmark de performance -benchmark_b2 <- microbenchmark( - "Old: merge + ifelse" = run_old_block2(tm_base, res_tau, var_sec_apriori, var_sec_new, secret_var_name), - - # NEW 2 : Le benchmark mesure la fonction opérant directement sur data.table - "New: in-place data.table" = run_new_block2(tm_dt_base, res_tau, var_sec_apriori, var_sec_new, secret_var_name, all_expl_vars, res5$alt_totcode), - times = 3 -) -print(benchmark_b2) -cat("\n----------------------------------------------------------------------\n\n") - - -# Bloc 3 ------------------------------------------------------------------ - -cat("======================================================================\n") -cat("3. BENCHMARK BLOCK 3: Common Cell Detection & Queue Update\n") -cat("======================================================================\n") - -# Prise de la table_majeure issue du Bloc 2 -tm_b3 <- res_old_b2 -nom_tab_1 <- noms_tbx[1] - -# On simule un changement de statut de secret sur 15 cellules du sous-tableau courant -active_idx <- which(tm_b3[[paste0("T_", nom_tab_1)]]) -tm_b3$is_secret_2 <- tm_b3$is_secret_1 -changed_rows <- active_idx[1:15] -tm_b3$is_secret_2[changed_rows] <- !tm_b3$is_secret_1[changed_rows] - -# Todolist et remainlist initiales fictives -todolist_init <- noms_tbx[1:3] -remainlist_init <- noms_tbx[4:length(noms_tbx)] - -var_sec_apriori <- "is_secret_1" -var_sec_new <- "is_secret_2" - -# --- CODE EXACT D'ORIGINE DU PACKAGE --- -run_old_block3 <- function(table_majeure, var_secret_apriori, var_secret, noms_col_T, num_tableau, all_expl, todolist, remainlist) { - lignes_modifs <- which(table_majeure[[var_secret_apriori]] != table_majeure[[var_secret]]) - - cur_tab <- paste0("T_", num_tableau) - other_tabs <- setdiff(noms_col_T, cur_tab) - cur_cells <- rowSums(table_majeure[, cur_tab, drop=FALSE]) - other_cells <- rowSums(table_majeure[, other_tabs, drop=FALSE]) - - common_cells_rows <- which(cur_cells == 1 & other_cells > 0) - common_cells <- table_majeure[common_cells_rows, , drop=FALSE] - - modified <- common_cells[common_cells[[var_secret_apriori]] != common_cells[[var_secret]], all_expl, drop=FALSE] - - noms_tbx_local <- names(noms_col_T) - for(tab in noms_tbx_local){ - nom_col_identifiante <- paste0("T_", tab) - if( !(tab %in% todolist) - & (any(table_majeure[[nom_col_identifiante]][lignes_modifs])) - ){ - todolist <- append(todolist, tab) - remainlist <- remainlist[remainlist != tab] - } - } - - return(list(modified = modified, todolist = todolist, remainlist = remainlist)) -} - -# --- CODE PROPOSÉ OPTIMISÉ (data.table) --- -run_new_block3 <- function(table_majeure, var_secret_apriori, var_secret, noms_col_T, num_tableau, all_expl, active_rows, todolist, remainlist) { - tm_dt <- data.table::as.data.table(table_majeure) - nom_col_identifiante <- paste0("T_", num_tableau) - all_col_T <- unname(noms_col_T) - - # Restricton stricte de la recherche aux seules lignes de la sous-table courante - idx_changed <- tm_dt[[var_secret_apriori]][active_rows] != tm_dt[[var_secret]][active_rows] - lignes_modifs <- active_rows[idx_changed] - - other_tabs <- setdiff(all_col_T, nom_col_identifiante) - common_modified_idx <- integer(0) - - if (length(lignes_modifs) > 0) { - if (length(other_tabs) > 0) { - # rowSums calcule uniquement sur les 15 lignes modifiees (au lieu des 41 817 lignes) - is_common <- rowSums(as.matrix(tm_dt[lignes_modifs, ..other_tabs])) > 0 - common_modified_idx <- lignes_modifs[is_common] - } - - noms_tbx_local <- names(noms_col_T) - for(tab in noms_tbx_local){ - nom_col_identifiante_tab <- paste0("T_", tab) - if( !(tab %in% todolist) - && any(tm_dt[[nom_col_identifiante_tab]][lignes_modifs]) - ){ - todolist <- c(todolist, tab) - remainlist <- remainlist[remainlist != tab] - } - } - } - - if (length(common_modified_idx) > 0) { - modified <- as.data.frame(tm_dt[common_modified_idx, ..all_expl]) - } else { - modified <- as.data.frame(tm_dt[0, ..all_expl]) - } - - return(list(modified = modified, todolist = todolist, remainlist = remainlist)) -} - -# Execution des deux versions -t_res_old_b3 <- system.time({ - res_old_b3 <- run_old_block3(tm_b3, var_sec_apriori, var_sec_new, noms_col_T, nom_tab_1, all_expl_vars, todolist_init, remainlist_init) -}) -cat("Temps t_res_old_b3 :\n") -print(t_res_old_b3) - -t_res_new_b3 <- system.time({ - res_new_b3 <- run_new_block3(tm_b3, var_sec_apriori, var_sec_new, noms_col_T, nom_tab_1, all_expl_vars, active_idx, todolist_init, remainlist_init) -}) -cat("Temps t_res_new_b3 :\n") -print(t_res_new_b3) - -# Verification de l'egalite exacte du tableau "modified" et de la file "todolist" -b3_mod_identical <- identical( - normalize_for_compare(res_old_b3$modified, all_expl_vars), - normalize_for_compare(res_new_b3$modified, all_expl_vars) -) -b3_todo_identical <- identical(res_old_b3$todolist, res_new_b3$todolist) - -cat("Block 3 Verification: Are modified cells 100% identical?", b3_mod_identical, "\n") -cat("Block 3 Verification: Are todolists 100% identical?", b3_todo_identical, "\n\n") - -# Benchmark de performance -benchmark_b3 <- microbenchmark( - "Old: rowSums on full 41k rows" = run_old_block3(tm_b3, var_sec_apriori, var_sec_new, noms_col_T, nom_tab_1, all_expl_vars, todolist_init, remainlist_init), - "New: rowSums on modified rows" = run_new_block3(tm_b3, var_sec_apriori, var_sec_new, noms_col_T, nom_tab_1, all_expl_vars, active_idx, todolist_init, remainlist_init), - times = 3 -) -print(benchmark_b3) -cat("\n----------------------------------------------------------------------\n\n") - -# Bloc 4 ------------------------------------------------------------------ - -cat("======================================================================\n") -cat("4. BENCHMARK BLOCK 4: Final Sub-table Assembly (Processing Phase)\n") -cat("======================================================================\n") - -# Prise de la table_majeure mise a jour issue du Bloc 3 -tm_b4 <- tm_b3 - -# --- CODE EXACT D'ORIGINE DU PACKAGE --- -run_old_block4 <- function(tbl_list, expl_list, tm) { - purrr::imap( - tbl_list, - function(tab, nom){ - expl_vars <- expl_list[[nom]] - tab_rows <- tm[[paste0("T_", nom)]] - secret_vars <- names(tm)[grep("^is_secret_[1-9]", names(tm))] - secret_vars <- secret_vars[order(as.integer(gsub("is_secret_", "", secret_vars)))] - res <- merge( - tab, - tm[tab_rows, c(expl_vars, secret_vars)], - all.x = TRUE, all.y = FALSE, by = expl_vars - ) - } - ) -} - -# --- CODE PROPOSÉ OPTIMISÉ (data.table) --- -run_new_block4 <- function(tbl_list, expl_list, tm) { - tm_dt <- data.table::as.data.table(tm) - secret_vars <- names(tm_dt)[grep("^is_secret_[1-9]", names(tm_dt))] - secret_vars <- secret_vars[order(as.integer(gsub("is_secret_", "", secret_vars)))] - - purrr::imap( - tbl_list, - function(tab, nom){ - expl_vars <- expl_list[[nom]] - tab_rows <- tm_dt[[paste0("T_", nom)]] - - sub_majeure <- tm_dt[tab_rows, c(expl_vars, secret_vars), with = FALSE] - - tab_is_dt <- data.table::is.data.table(tab) - # Copy si deja un data.table pour eviter toute mutation de memoire utilisateur - tab_dt <- if (tab_is_dt) data.table::copy(tab) else data.table::as.data.table(tab) - - # Sauvegarde des types d'origine - original_classes <- vapply(expl_vars, function(v) class(tab[[v]])[1], character(1)) - - for (v in expl_vars) { - if (v %in% names(tab_dt)) data.table::set(tab_dt, j = v, value = as.character(tab_dt[[v]])) - } - - res_dt <- merge(tab_dt, sub_majeure, by = expl_vars, all.x = TRUE, sort = FALSE) - - # Restauration des types d'origine (factor, integer, etc.) - for (v in expl_vars) { - cls <- original_classes[v] - if (cls == "factor") { - data.table::set(res_dt, j = v, value = factor(res_dt[[v]])) - } else if (cls == "integer") { - data.table::set(res_dt, j = v, value = as.integer(res_dt[[v]])) - } - } - - if (!tab_is_dt) { - return(as.data.frame(res_dt)) - } else { - return(res_dt) - } - } - ) -} - -# Execution des deux versions avec system.time -t_res_old_b4 <- system.time({ - res_old_b4 <- run_old_block4(list_tables_5d, list_expl_5d, tm_b4) -}) -cat("Temps t_res_old_b4 :\n") -print(t_res_old_b4) - -t_res_new_b4 <- system.time({ - res_new_b4 <- run_new_block4(list_tables_5d, list_expl_5d, tm_b4) -}) -cat("Temps t_res_new_b4 :\n") -print(t_res_new_b4) - -# Verification de l'egalite exacte pour chacun des sous-tableaux restitues -b4_results_identical <- vapply(seq_along(res_old_b4), function(i) { - nom_t <- names(res_old_b4)[i] - expl_v <- list_expl_5d[[nom_t]] - identical( - normalize_for_compare(res_old_b4[[i]], expl_v), - normalize_for_compare(res_new_b4[[i]], expl_v) - ) -}, logical(1)) - -cat("\nBlock 4 Verification: Are all output tables 100% identical?", all(b4_results_identical), "\n\n") - -# Benchmark de performance -benchmark_b4 <- microbenchmark( - "Old: sequential base merges" = run_old_block4(list_tables_5d, list_expl_5d, tm_b4), - "New: data.table merges" = run_new_block4(list_tables_5d, list_expl_5d, tm_b4), - times = 3 -) -print(benchmark_b4) -cat("\n----------------------------------------------------------------------\n\n") - -# Bloc 5 ------------------------------------------------------------------ - -cat("======================================================================\n") -cat("5. BENCHMARK BLOCK 5: Full End-to-End Multi-Iteration Integration Test \n") -cat("======================================================================\n") - -Sys.time() -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" -options(rtauargus.tauargus_exe = loc_tauargus) - -# 1. Reprise des sous-tables et ajout d'une variable de cout (Inclusion de cost_var) -list_tables_5d_cost <- lapply(list_tables_5d, function(df) { - df$cost_col <- round(runif(nrow(df), 1, 100)) - df -}) - -dir_old <- file.path(tempdir(), "test_old_real") -dir_new <- file.path(tempdir(), "test_new_real") -if (!dir.exists(dir_old)) dir.create(dir_old, recursive = TRUE) -if (!dir.exists(dir_new)) dir.create(dir_new, recursive = TRUE) - -# Initialisation des résultats -res_full_old <- NULL -t_full_old <- NULL -res_full_new <- NULL -t_full_new <- NULL - -# 2. Exécution version ORIGINALE ------------------------------------------- -cat("\nLancement de tab_multi_manager version ORIGINALE (Multi-itérations)...\n") -tryCatch({ - t_full_old <- system.time({ - res_full_old <- tab_multi_manager_old( - list_tables = list_tables_5d_cost, - list_explanatory_vars = list_expl_5d, - totcode = res5$totcode, - hrc = res5$hrc, - alt_totcode = res5$alt_totcode, - alt_hrc = res5$alt_hrc, - value = "VALUE", - freq = "freq", - secret_var = "is_secret_prim", - cost_var = "cost_col", - suppress = "GH(1,100)", # Hypercube rapide - dir_name = dir_old - ) - }) - cat("Temps version ORIGINALE :\n") - print(t_full_old) -}, error = function(e) { - cat("\n[ERREUR] Échec de tab_multi_manager_old :\n") - message(e$message) -}) - -# 3. Exécution version OPTIMISÉE ------------------------------------------ -cat("\nLancement de tab_multi_manager version OPTIMISÉE (Multi-itérations)...\n") -tryCatch({ - t_full_new <- system.time({ - res_full_new <- tab_multi_manager( - list_tables = list_tables_5d_cost, - list_explanatory_vars = list_expl_5d, - totcode = res5$totcode, - hrc = res5$hrc, - alt_totcode = res5$alt_totcode, - alt_hrc = res5$alt_hrc, - value = "VALUE", - freq = "freq", - secret_var = "is_secret_prim", - cost_var = "cost_col", - suppress = "GH(1,100)", # Hypercube rapide - dir_name = dir_new - ) - }) - cat("Temps version OPTIMISÉE :\n") - print(t_full_new) -}, error = function(e) { - cat("\n[ERREUR] Échec de tab_multi_manager :\n") - message(e$message) -}) - -# 4. VERIFICATION INTEGRALE ET RIGOUREUSE DE BOUT EN BOUT -if (!is.null(res_full_old) && !is.null(res_full_new)) { - - check_e2e <- vapply(seq_along(res_full_old), function(i) { - nom_t <- names(res_full_old)[i] - expl_v <- list_expl_5d[[nom_t]] - - df_o <- res_full_old[[i]] - df_n <- res_full_new[[i]] - - identical( - normalize_for_compare(df_o, expl_v), - normalize_for_compare(df_n, expl_v) - ) - }, logical(1)) - - cat("\n======================================================================\n") - cat("RÉSULTAT DU TEST D'INTÉGRATION GLOBAL (END-TO-END)\n") - cat("======================================================================\n") - cat("1. Nombre de tableaux traites (", length(res_full_old), ") : TRUE\n", sep = "") - cat("2. Egalite stricte de TOUTES les itérations et colonnes :", all(check_e2e), "\n") - - if (all(check_e2e)) { - cat("\n>>> SUCCÈS TOTAL : 100% d'équivalence logique sur toutes les itérations !\n") - cat(">>> Gain de temps global de bout en bout : x", round(t_full_old["elapsed"] / t_full_new["elapsed"], 1), "\n") - } else { - cat("\n>>> ERREUR : Divergence detectee dans les tables :", names(res_full_old)[!check_e2e], "\n") - } - -} else { - cat("\n======================================================================\n") - cat("COMPARAISON IMPOSSIBLE : Au moins une des deux fonctions a échoué.\n") - cat("======================================================================\n") -} - - -# Bloc 6 - unif_labels=FALSE ------------------------------------------------------------------ - -cat("======================================================================\n") -cat("6. BENCHMARK BLOCK 5: Full End-to-End Multi-Iteration Integration Test \n") -cat("======================================================================\n") - -Sys.time() -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" -options(rtauargus.tauargus_exe = loc_tauargus) - -# 1. Reprise des sous-tables et ajout d'une variable de cout (Inclusion de cost_var) -list_tables_5d_cost <- lapply(list_tables_5d, function(df) { - df$cost_col <- round(runif(nrow(df), 1, 100)) - df -}) - -dir_old <- file.path(tempdir(), "test_old_real") -dir_new <- file.path(tempdir(), "test_new_real") -if (!dir.exists(dir_old)) dir.create(dir_old, recursive = TRUE) -if (!dir.exists(dir_new)) dir.create(dir_new, recursive = TRUE) - -# Initialisation des résultats -res_full_old <- NULL -t_full_old <- NULL -res_full_new <- NULL -t_full_new <- NULL - -# 2. Exécution version ORIGINALE ------------------------------------------- -cat("\nLancement de tab_multi_manager version ORIGINALE (Multi-itérations)...\n") -tryCatch({ - t_full_old <- system.time({ - res_full_old <- tab_multi_manager_old( - list_tables = list_tables_5d_cost, - list_explanatory_vars = list_expl_5d, - totcode = res5$totcode, - hrc = res5$hrc, - alt_totcode = res5$alt_totcode, - alt_hrc = res5$alt_hrc, - value = "VALUE", - freq = "freq", - secret_var = "is_secret_prim", - cost_var = "cost_col", - suppress = "GH(1,100)", # Hypercube rapide - unif_labels = FALSE, - dir_name = dir_old - ) - }) - cat("Temps version ORIGINALE :\n") - print(t_full_old) -}, error = function(e) { - cat("\n[ERREUR] Échec de tab_multi_manager_old :\n") - message(e$message) -}) - -# 3. Exécution version OPTIMISÉE ------------------------------------------ -cat("\nLancement de tab_multi_manager version OPTIMISÉE (Multi-itérations)...\n") -tryCatch({ - t_full_new <- system.time({ - res_full_new <- tab_multi_manager( - list_tables = list_tables_5d_cost, - list_explanatory_vars = list_expl_5d, - totcode = res5$totcode, - hrc = res5$hrc, - alt_totcode = res5$alt_totcode, - alt_hrc = res5$alt_hrc, - value = "VALUE", - freq = "freq", - secret_var = "is_secret_prim", - cost_var = "cost_col", - suppress = "GH(1,100)", # Hypercube rapide - unif_labels = FALSE, - dir_name = dir_new - ) - }) - cat("Temps version OPTIMISÉE :\n") - print(t_full_new) -}, error = function(e) { - cat("\n[ERREUR] Échec de tab_multi_manager :\n") - message(e$message) -}) - -# 4. VERIFICATION INTEGRALE ET RIGOUREUSE DE BOUT EN BOUT -if (!is.null(res_full_old) && !is.null(res_full_new)) { - - check_e2e <- vapply(seq_along(res_full_old), function(i) { - nom_t <- names(res_full_old)[i] - expl_v <- list_expl_5d[[nom_t]] - - df_o <- res_full_old[[i]] - df_n <- res_full_new[[i]] - - identical( - normalize_for_compare(df_o, expl_v), - normalize_for_compare(df_n, expl_v) - ) - }, logical(1)) - - cat("\n======================================================================\n") - cat("RÉSULTAT DU TEST D'INTÉGRATION GLOBAL (END-TO-END)\n") - cat("======================================================================\n") - cat("1. Nombre de tableaux traites (", length(res_full_old), ") : TRUE\n", sep = "") - cat("2. Egalite stricte de TOUTES les itérations et colonnes :", all(check_e2e), "\n") - - if (all(check_e2e)) { - cat("\n>>> SUCCÈS TOTAL : 100% d'équivalence logique sur toutes les itérations !\n") - cat(">>> Gain de temps global de bout en bout : x", round(t_full_old["elapsed"] / t_full_new["elapsed"], 1), "\n") - } else { - cat("\n>>> ERREUR : Divergence detectee dans les tables :", names(res_full_old)[!check_e2e], "\n") - } - -} else { - cat("\n======================================================================\n") - cat("COMPARAISON IMPOSSIBLE : Au moins une des deux fonctions a échoué.\n") - cat("======================================================================\n") -} - diff --git a/bench/bench_tab_multimanager_rtauargus4.R b/bench/bench_tab_multimanager_rtauargus4.R deleted file mode 100644 index 5ea09c7..0000000 --- a/bench/bench_tab_multimanager_rtauargus4.R +++ /dev/null @@ -1,537 +0,0 @@ -library(microbenchmark) -library(data.table) -library(purrr) -library(rlang) -library(dplyr) -library(sdcHierarchies) - -library(rtauargus) - -# 1. Sauvegarde des fonctions du package original avant load_all -reduce_dims_old <- rtauargus:::reduce_dims -tab_multi_manager_old <- rtauargus::tab_multi_manager -tab_rtauargus4_old <- rtauargus::tab_rtauargus4 - - -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" -options(rtauargus.tauargus_exe = loc_tauargus) - -set.seed(42) - -# ============================================================================= -# PRÉPARATION DU JEU DE DONNÉES 4D AGRÉGÉ -# ============================================================================= -cat("======================================================================\n") -cat("TEST D'INTÉGRATION 4D : DÉCOMPOSITION DES TEMPS DE CALCUL \n") -cat("======================================================================\n") - -# --- 4D volumineux (ACT hiérarchique, GEO hiérarchique, SEX & AGE non hiérarchiques) -create_big_4D <- function( - n = 200000, - n_act_groups = 30, # Nombre de groupes d'activité (Niveau 1 ACT) - n_act_sub = 50, # Nombre de sous-niveaux par groupe d'activité (Niveau 2 ACT) - n_geo_regions = 50, # Nombre de régions (Niveau 1 GEO) - n_geo_sub = 50, # Nombre de sous-régions par région (Niveau 2 GEO) - n_sex = 2, # Nombre de modalités de SEX (ex: F, M si n_sex=2, sinon S01, S02...) - n_age = 4 # Nombre de modalités d'AGE (ex: AGE01 à AGE04) -) { - set.seed(123) - - # Calcul dynamique de la largeur des chiffres (Zero-padding) - w_act_g <- max(2, nchar(n_act_groups)) - w_act_s <- max(2, nchar(n_act_sub)) - w_geo_r <- max(2, nchar(n_geo_regions)) - w_geo_s <- max(2, nchar(n_geo_sub)) - w_age <- max(2, nchar(n_age)) - - fmt_act_g <- paste0("A%0", w_act_g, "d") - fmt_act_s <- paste0("A%0", w_act_g, "d_%0", w_act_s, "d") - - fmt_geo_r <- paste0("G%0", w_geo_r, "d") - fmt_geo_s <- paste0("G%0", w_geo_r, "d_%0", w_geo_s, "d") - - fmt_age <- paste0("AGE%0", w_age, "d") - - # 1. Définition des niveaux ACT - act_level1 <- sprintf(fmt_act_g, 1:n_act_groups) - act_level2 <- unlist(lapply(1:n_act_groups, function(i) sprintf(fmt_act_s, i, 1:n_act_sub))) - - # 2. Définition des niveaux GEO - geo_level1 <- sprintf(fmt_geo_r, 1:n_geo_regions) - geo_level2 <- unlist(lapply(1:n_geo_regions, function(i) sprintf(fmt_geo_s, i, 1:n_geo_sub))) - - # 3. Définition des modalités SEX (F, M si n_sex = 2, sinon S01, S02...) - sex_mods <- if (n_sex == 2) { - c("Total", "F", "M") - } else { - w_sex <- max(2, nchar(n_sex)) - c("Total", sprintf(paste0("S%0", w_sex, "d"), 1:n_sex)) - } - - # 4. Définition des modalités AGE (AGE01, AGE02...) - age_mods <- c("Total", sprintf(fmt_age, 1:n_age)) - - # 5. Génération du jeu de données - data <- data.frame( - ACT = sample(c("Total", act_level1, act_level2), n, replace = TRUE), - GEO = sample(c("Total", geo_level1, geo_level2), n, replace = TRUE), - SEX = sample(sex_mods, n, replace = TRUE), - AGE = sample(age_mods, n, replace = TRUE), - stringsAsFactors = FALSE - ) - data$VALUE <- 1 - - # Hiérarchie ACT - hrc_act <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total", nodes = act_level1) %>% - { - for (i in 1:n_act_groups) { - root_node <- sprintf(fmt_act_g, i) - children <- sprintf(fmt_act_s, i, 1:n_act_sub) - . <- sdcHierarchies::hier_add(., root = root_node, nodes = children) - } - . - } %>% - 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) - - # Hiérarchie GEO - hrc_geo <- tempfile(fileext = ".hrc") - sdcHierarchies::hier_create(root = "Total", nodes = geo_level1) %>% - { - for (i in 1:n_geo_regions) { - root_node <- sprintf(fmt_geo_r, i) - children <- sprintf(fmt_geo_s, i, 1:n_geo_sub) - . <- sdcHierarchies::hier_add(., root = root_node, nodes = children) - } - . - } %>% - 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) - - list(data = data, - hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), - totcode = c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total")) -} - -calc_4D_dimensions <- function( - n_act_groups = 7, # Nombre de groupes d'activité (Niveau 1 ACT) - n_act_sub = 11, # Nombre de sous-niveaux par groupe d'activité (Niveau 2 ACT) - n_geo_regions = 8, # Nombre de régions (Niveau 1 GEO) - n_geo_sub = 10, # Nombre de sous-régions par région (Niveau 2 GEO) - n_sex = 20, # Nombre de modalités fines de SEX - n_age = 15 # Nombre de modalités fines d'AGE -) { - # 1. Calcul du nombre total de modalités par variable (y compris les totaux) - n_mod_act <- (n_act_groups * n_act_sub) + n_act_groups + 1 - n_mod_geo <- (n_geo_regions * n_geo_sub) + n_geo_regions + 1 - n_mod_sex <- n_sex + 1 - n_mod_age <- n_age + 1 - - # 2. Calcul du nombre de sous-tableaux générés (Option MAX / découpage par noeuds) - # Formule : 2 x (noeuds ACT + Total) x (noeuds GEO + Total) - nb_tables <- 2 * (n_act_groups + 1) * (n_geo_regions + 1) - - # 3. Calcul du nombre total de croisements possibles dans la table 4D - nb_croisements <- n_mod_act * n_mod_geo * n_mod_sex * n_mod_age - - # Affichage structuré - cat("======================================================================\n") - cat(" ESTIMATION DE LA COMPLEXITÉ DU DÉCOUPAGE 4D \n") - cat("======================================================================\n") - cat("1. Nombre de sous-tableaux générés :", format(nb_tables, big.mark = " "), "\n") - cat("2. Nombre total de croisements :", format(nb_croisements, big.mark = " "), "\n\n") - cat("Détail des modalités par variable (Totaux inclus) :\n") - cat(" - ACT :", n_mod_act, "modalités (1 Total +", n_act_groups, "groupes +", n_act_groups * n_act_sub, "sous-niveaux)\n") - cat(" - GEO :", n_mod_geo, "modalités (1 Total +", n_geo_regions, "régions +", n_geo_regions * n_geo_sub, "sous-régions)\n") - cat(" - SEX :", n_mod_sex, "modalités (1 Total +", n_sex, "modalités fines)\n") - cat(" - AGE :", n_mod_age, "modalités (1 Total +", n_age, "modalités fines)\n") - cat("======================================================================\n") - - # Retourne les résultats sous forme de liste - invisible(list( - nb_tables = nb_tables, - nb_croisements = nb_croisements, - modalites = c(ACT = n_mod_act, GEO = n_mod_geo, SEX = n_mod_sex, AGE = n_mod_age) - )) -} - - -# 1. Génération des microdonnées 4D -big4 <- create_big_4D( - n = 50000000, - n_act_groups = 4, - n_act_sub = 11, - n_geo_regions = 5, - n_geo_sub = 10, - n_sex = 20, - n_age = 15 -) - -# Exécution avec vos valeurs par défaut -res <- calc_4D_dimensions( - n_act_groups = 4, - n_act_sub = 11, - n_geo_regions = 5, - n_geo_sub = 10, - n_sex = 20, - n_age = 15 -) - -dfs4 <- big4$data - -tot4 <- big4$totcode -hrc4 <- big4$hrcfiles - -# 2. AGRÉGATION : Elimination des doublons pour obtenir des cellules uniques -dfs4_agg <- dfs4 %>% - group_by(across(all_of(names(tot4)))) %>% - summarise( - VALUE = sum(VALUE), - freq = n(), - .groups = "drop" - ) - -# Libère la RAM inutile pendant le reste des benchmarks -rm(dfs4, big4); gc() - -# 3. POSE DU SECRET PRIMAIRE : 10% de secret aléatoire déterministe -set.seed(42) -prop_secret = 0.01 # proabilité qu'une cellule soit en secret primaire -dfs4_agg$is_secret_prim <- sample(c(TRUE, FALSE), nrow(dfs4_agg), replace = TRUE, prob = c(prop_secret, 1 - prop_secret)) -dfs4_agg$secret_no_pl <- FALSE - -# AFFICHAGE DU SECRET AVANT TAU-ARGUS -n_total_cellules <- nrow(dfs4_agg) -n_secret_primaire <- sum(dfs4_agg$is_secret_prim) - -cat("\n----------------------------------------------------------------------\n") -cat("=== BILAN DU SECRET PRIMAIRE (AVANT TAU-ARGUS) ===\n") -cat("Nombre total de cellules uniques dans la table 4D :", n_total_cellules, "\n") -cat("Nombre de cellules en secret primaire :", n_secret_primaire, - sprintf("(%.2f%%)\n", 100 * n_secret_primaire / n_total_cellules)) -cat("----------------------------------------------------------------------\n") - -dir_out_old <- file.path(tempdir(), "tau_4d_old") -dir_out_new <- file.path(tempdir(), "tau_4d_new") -if (!dir.exists(dir_out_old)) dir.create(dir_out_old, recursive = TRUE) -if (!dir.exists(dir_out_new)) dir.create(dir_out_new, recursive = TRUE) - - - -# ============================================================================= -# 1. MESURES SUR LA VERSION ORIGINALE (PACKAGE) -# ============================================================================= -cat("\n--- 1. VERSION ORIGINALE (PACKAGE) ---\n") - -# A1. Mesure isolée de reduce_dims originale -# t_red_old <- system.time({ -# res_red_old <- reduce_dims_old( -# dfs = dfs4_agg, dfs_name = "tab_4d_int", totcode = tot4, hrcfiles = hrc4, -# nb_tab_option = "smart", limit = 50000, over_split = TRUE, sep_dir = TRUE, -# hrc_dir = file.path(dir_out_old, "hrc") -# ) -# }) - -t_red_old <- system.time({ - res_red_old <- reduce_dims_old( - dfs = dfs4_agg, dfs_name = "tab_4d_int", totcode = tot4, hrcfiles = hrc4, - nb_tab_option = "max", sep_dir = TRUE, - hrc_dir = file.path(dir_out_old, "hrc") - ) -}) - -print(t_red_old) - -cat("Nombre de tableaux générés :", length(res_red_old$tabs), "\n") - -# Récupération de la taille (nombre de lignes) de chaque sous-tableau -tailles_tables <- sapply(res_red_old$tabs, nrow) -cat("Statistiques sur le nombre de lignes par tableau (Min, Q1, Médiane, Q3, Max) :\n") -print(summary(tailles_tables)) - -# A2. Mesure isolée de restore_format sur la sortie de reduce_dims -t_rest_old <- system.time({ - dummy_rest_old <- rtauargus::restore_format(masq = res_red_old$tabs, res = res_red_old) -}) - -print(t_rest_old) - -# B. Mesure du flux complet tab_rtauargus4 originale -# t_full_old <- system.time({ -# res_4d_old <- tab_rtauargus4_old( -# tabular = dfs4_agg, -# explanatory_vars = names(tot4), -# dir_name = dir_out_old, -# secret_var = "is_secret_prim", -# totcode = tot4, -# hrc = hrc4, -# value = "VALUE", -# freq = "freq", -# suppress = "GH(1,100)", -# nb_tab_option = "smart", -# limit = 50000, -# dfs_name = "tab_4d_int" -# ) -# }) - -t_full_old <- system.time({ - res_4d_old <- tab_rtauargus4_old( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_out_old, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - nb_tab_option = "max", - dfs_name = "tab_4d_int", - limit = 1000000L # très grand nombre, pour ne pas avoir d'oversplit - ) -}) - -print(t_full_old) - -# ============================================================================= -# 2. MESURES SUR LA VERSION OPTIMISÉE (LOCALE) -# ============================================================================= -cat("\n--- 2. VERSION OPTIMISÉE (LOCALE) ---\n") - -# Chargement du code local APRÈS l'exécution de la version originale -devtools::load_all("Z:/rtauargus") - -# ESSENTIEL : Redéfinir l'option Tau-Argus car load_all() l'a réinitialisée -options(rtauargus.tauargus_exe = loc_tauargus) - -# A1. Mesure isolée de reduce_dims optimisée -# t_red_new <- system.time({ -# res_red_new <- reduce_dims( -# dfs = dfs4_agg, dfs_name = "tab_4d_int", totcode = tot4, hrcfiles = hrc4, -# nb_tab_option = "smart", limit = 50000, over_split = TRUE, sep_dir = TRUE, -# hrc_dir = file.path(dir_out_new, "hrc") -# ) -# }) - -t_red_new <- system.time({ - res_red_new <- reduce_dims( - dfs = dfs4_agg, dfs_name = "tab_4d_int", totcode = tot4, hrcfiles = hrc4, - nb_tab_option = "max", sep_dir = TRUE, - hrc_dir = file.path(dir_out_new, "hrc") - ) -}) - -print(t_red_new) - -cat("Nombre de tableaux générés :", length(res_red_new$tabs), "\n") - -# Récupération de la taille (nombre de lignes) de chaque sous-tableau -tailles_tables <- sapply(res_red_new$tabs, nrow) -cat("Statistiques sur le nombre de lignes par tableau (Min, Q1, Médiane, Q3, Max) :\n") -print(summary(tailles_tables)) - -# A2. Mesure isolée de restore_format sur la sortie de reduce_dims -t_rest_new <- system.time({ - dummy_rest_new <- restore_format(masq = res_red_new$tabs, res = res_red_new) -}) - -print(t_rest_new) - -# B. Mesure du flux complet tab_rtauargus4 optimisée -# t_full_new <- system.time({ -# res_4d_new <- tab_rtauargus4( -# tabular = dfs4_agg, -# explanatory_vars = names(tot4), -# dir_name = dir_out_new, -# secret_var = "is_secret_prim", -# totcode = tot4, -# hrc = hrc4, -# value = "VALUE", -# freq = "freq", -# suppress = "GH(1,100)", -# nb_tab_option = "smart", -# limit = 50000, -# dfs_name = "tab_4d_int" -# ) -# }) - -t_full_new <- system.time({ - res_4d_new <- tab_rtauargus4( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_out_new, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - nb_tab_option = "max", - dfs_name = "tab_4d_int", - keep_history = TRUE, # pour conserver le comportement par défaut - limit = 1000000L # très grand nombre, pour ne pas avoir d'oversplit - ) -}) - -print(t_full_new) - -# ============================================================================= -# 3. BILAN DES SECRETS ET DÉCOMPOSITION DES TEMPS DE CALCUL -# ============================================================================= -cat("\n======================================================================\n") -cat("=== BILAN DU SECRET APPRÈS TAU-ARGUS ===\n") -cat("======================================================================\n") - -# Fonction d'extraction des métriques de secret -get_secret_stats <- function(df) { - # La dernière colonne is_secret_* contient le secret total final - sec_cols <- names(df)[grep("^is_secret_[1-9]", names(df))] - sec_cols <- sec_cols[order(as.integer(gsub("is_secret_", "", sec_cols)))] - last_col <- if(length(sec_cols) > 0) tail(sec_cols, 1) else "Status" - - tot_sec <- if(last_col == "Status") df$Status != "V" else df[[last_col]] - prim_sec <- df$is_secret_prim - sec_sec <- tot_sec & !prim_sec - - data.frame( - "Total_Cellules" = nrow(df), - "Secret_Primaire" = sum(prim_sec), - "Secret_Secondaire" = sum(sec_sec), - "Total_Masque" = sum(tot_sec), - "Pourcentage_Masque" = sprintf("%.2f%%", 100 * sum(tot_sec) / nrow(df)) - ) -} - -cat("\n[Statistiques du secret - Version Originale] :\n") -print(get_secret_stats(res_4d_old)) - -cat("\n[Statistiques du secret - Version Optimisée] :\n") -print(get_secret_stats(res_4d_new)) - -# Décomposition fine des temps -pure_multi_old <- t_full_old["elapsed"] - t_red_old["elapsed"] - t_rest_old["elapsed"] -pure_multi_new <- t_full_new["elapsed"] - t_red_new["elapsed"] - t_rest_new["elapsed"] - -cat("\n======================================================================\n") -cat(" BILAN COMPARATIF DES TEMPS (en secondes) \n") -cat("======================================================================\n") - -cat("\n[1. Temps Total tab_rtauargus4]\n") -cat(" - Original :", round(t_full_old["elapsed"], 2), "s | Optimisé :", round(t_full_new["elapsed"], 2), "s\n") - -cat("\n[2. Part reduce_dims (Amont)]\n") -cat(" - Original :", round(t_red_old["elapsed"], 2), "s | Optimisé :", round(t_red_new["elapsed"], 2), "s\n") - -cat("\n[3. Part restore_format (Aval)]\n") -cat(" - Original :", round(t_rest_old["elapsed"], 2), "s | Optimisé :", round(t_rest_new["elapsed"], 2), "s\n") - -cat("\n[4. Temps PUR tab_multi_manager (Moteur + Tau-Argus)]\n") -cat(" - Original :", round(pure_multi_old, 2), "s | Optimisé :", round(pure_multi_new, 2), "s\n") -cat(" - Gain net :", round(pure_multi_old - pure_multi_new, 2), "secondes économisées\n") - -# Égalité logique finale -normalize_for_compare <- function(df, key_cols) { - df <- as.data.frame(df) - df <- df[, order(names(df)), drop = FALSE] - df <- df[do.call(order, df[key_cols]), , drop = FALSE] - row.names(df) <- NULL - return(df) -} - -b4_is_identical <- identical( - normalize_for_compare(res_4d_old, names(tot4)), - normalize_for_compare(res_4d_new, names(tot4)) -) - -cat("\n======================================================================\n") -cat("Égalité stricte du tableau 4D final reconstitué :", b4_is_identical, "\n") -cat("======================================================================\n") - -# ============================================================================= -# 4. BENCHMARK COMPLÉMENTAIRE : KEEP_HISTORY = FALSE (EXÉCUTION SEULE) -# ============================================================================= -cat("\n======================================================================\n") -cat(" BENCHMARK COMPLÉMENTAIRE : EXÉCUTION AVEC KEEP_HISTORY = FALSE \n") -cat("======================================================================\n") - -dir_kh_false <- file.path(tempdir(), "tau_4d_kh_false") -if (!dir.exists(dir_kh_false)) dir.create(dir_kh_false, recursive = TRUE) - -cat("\n--- Exécution de la version optimisée avec keep_history = FALSE ---\n") -t_full_no_hist <- system.time({ - res_4d_no_hist <- tab_rtauargus4( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_kh_false, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - nb_tab_option = "max", - dfs_name = "tab_4d_int", - limit = 1000000L, - keep_history = FALSE - ) -}) - -print(t_full_no_hist) - -# ============================================================================= -# 5. VÉRIFICATION DE L'ÉGALITÉ ET COMPARISON : TRUE vs FALSE -# ============================================================================= -cat("\n======================================================================\n") -cat("=== COMPARISON KEEP_HISTORY = TRUE vs KEEP_HISTORY = FALSE ===\n") -cat("======================================================================\n") - -get_last_secret_col <- function(df) { - sec_cols <- names(df)[grep("^is_secret_[0-9]+$", names(df))] - if (length(sec_cols) == 0) return(NULL) - sec_cols[order(as.integer(gsub("is_secret_", "", sec_cols)))] |> tail(1) -} - -last_col_true <- get_last_secret_col(res_4d_new) -last_col_false <- get_last_secret_col(res_4d_no_hist) - -cat("Colonne de secret final (keep_history = TRUE) :", last_col_true, "\n") -cat("Colonne de secret final (keep_history = FALSE) :", last_col_false, "\n") - -cols_base <- c(names(tot4), "VALUE", "freq", "is_secret_prim", "secret_no_pl") - -df_true_sub <- res_4d_new[, c(cols_base, last_col_true)] -df_false_sub <- res_4d_no_hist[, c(cols_base, last_col_false)] - -colnames(df_true_sub)[ncol(df_true_sub)] <- "final_secret_mask" -colnames(df_false_sub)[ncol(df_false_sub)] <- "final_secret_mask" - -b_identical_history <- identical( - normalize_for_compare(df_true_sub, names(tot4)), - normalize_for_compare(df_false_sub, names(tot4)) -) - -cat("\n----------------------------------------------------------------------\n") -cat("Égalité stricte des masques de secret finaux :", b_identical_history, "\n") -cat("----------------------------------------------------------------------\n") - -cat("Cellules en secret secondaire (TRUE) :", sum(df_true_sub$final_secret_mask & !df_true_sub$is_secret_prim), "\n") -cat("Cellules en secret secondaire (FALSE) :", sum(df_false_sub$final_secret_mask & !df_false_sub$is_secret_prim), "\n") - -mem_true <- format(object.size(res_4d_new), units = "auto") -mem_false <- format(object.size(res_4d_no_hist), units = "auto") - -cat("\n[Bilan Mémoire R (object.size)] :\n") -cat(" - keep_history = TRUE (274 colonnes) :", mem_true, "\n") -cat(" - keep_history = FALSE ( 9 colonnes) :", mem_false, "\n") - -cat("\n[Bilan Temps d'exécution (Elapsed)] :\n") -cat(" - keep_history = TRUE :", round(t_full_new["elapsed"], 2), "s\n") -cat(" - keep_history = FALSE :", round(t_full_no_hist["elapsed"], 2), "s\n") -cat(" - Gain de temps :", round(t_full_new["elapsed"] - t_full_no_hist["elapsed"], 2), "s\n") diff --git a/bench/comp_limit_smart_4D.R b/bench/comp_limit_smart_4D.R deleted file mode 100644 index e5272c8..0000000 --- a/bench/comp_limit_smart_4D.R +++ /dev/null @@ -1,1195 +0,0 @@ -create_big_4D <- function( - n = 200000, - n_act_groups = 30, - n_act_sub = 50, - n_geo_regions = 50, - n_geo_sub = 50, - n_sex = 2, - n_age = 4, - add_dim5 = FALSE, - complete_grid = TRUE -){ - set.seed(123) - - w_act_g <- max(2, nchar(n_act_groups)) - w_act_s <- max(2, nchar(n_act_sub)) - w_geo_r <- max(2, nchar(n_geo_regions)) - w_geo_s <- max(2, nchar(n_geo_sub)) - w_age <- max(2, nchar(n_age)) - - fmt_act_g <- paste0("A%0", w_act_g, "d") - fmt_act_s <- paste0("A%0", w_act_g, "d_%0", w_act_s, "d") # typo corrigée - fmt_geo_r <- paste0("G%0", w_geo_r, "d") - fmt_geo_s <- paste0("G%0", w_geo_r, "d_%0", w_geo_s, "d") - fmt_age <- paste0("AGE%0", w_age, "d") - - act_level1 <- sprintf(fmt_act_g, 1:n_act_groups) - act_level2 <- unlist(lapply(1:n_act_groups, function(i) sprintf(fmt_act_s, i, 1:n_act_sub))) - geo_level1 <- sprintf(fmt_geo_r, 1:n_geo_regions) - geo_level2 <- unlist(lapply(1:n_geo_regions, function(i) sprintf(fmt_geo_s, i, 1:n_geo_sub))) - - sex_leaves <- if (n_sex == 2) c("F", "M") else { - w_sex <- max(2, nchar(n_sex)) - sprintf(paste0("S%0", w_sex, "d"), 1:n_sex) - } - age_leaves <- sprintf(fmt_age, 1:n_age) - - dim_vars <- if (add_dim5) c("ACT", "GEO", "SEX", "AGE", "ECO") - else c("ACT", "GEO", "SEX", "AGE") - - # ---- 1. Microdonnées FEUILLES uniquement -------------------------------- - dt <- data.table( - ACT = sample(act_level2, n, replace = TRUE), - GEO = sample(geo_level2, n, replace = TRUE), - SEX = sample(sex_leaves, n, replace = TRUE), - AGE = sample(age_leaves, n, replace = TRUE) - ) - if (add_dim5) dt[, ECO := sample(c("mod1", "mod2"), n, replace = TRUE)] - - # Agrégation feuilles : libère immédiatement les 50M lignes - dt_leaf <- dt[, .(VALUE = .N), by = dim_vars] - rm(dt); invisible(gc()) - - # ---- 2. Tables de correspondance hiérarchiques -------------------------- - # mk_map : leaf → {leaf, parent (si fourni), "Total"} - mk_map <- function(leaves, parents = NULL) { - rows <- list(data.table(from = leaves, to = leaves)) - if (!is.null(parents)) rows[[2]] <- data.table(from = leaves, to = parents) - rows[[length(rows) + 1]] <- data.table(from = leaves, to = "Total") - rbindlist(rows) - } - - map_act <- mk_map(act_level2, sub("_[0-9]+$", "", act_level2)) - map_geo <- mk_map(geo_level2, sub("_[0-9]+$", "", geo_level2)) - map_sex <- mk_map(sex_leaves) - map_age <- mk_map(age_leaves) - - # ---- 3. Expansion dimension par dimension (join data.table) ------------- - # Pour chaque dimension : on remplace la valeur feuille par TOUTES ses - # valeurs hiérarchiques (leaf, parent, Total) via un join one-to-many. - rollup_dim <- function(dt, col, map) { - # map[dt, ...] : right-join — pour chaque ligne de dt, trouve les - # correspondances dans map (3 ou 2 lignes par valeur feuille) - result <- map[dt, on = c(from = col), allow.cartesian = TRUE] - # result a : from | to | [autres colonnes de dt sauf col] - result[, (col) := to][, c("from", "to") := NULL] - result - } - - dt_exp <- rollup_dim(dt_leaf, "ACT", map_act) - dt_exp <- rollup_dim(dt_exp, "GEO", map_geo) - dt_exp <- rollup_dim(dt_exp, "SEX", map_sex) - dt_exp <- rollup_dim(dt_exp, "AGE", map_age) - - if (add_dim5) dt_exp <- rollup_dim(dt_exp, "ECO", mk_map(c("mod1", "mod2"))) - - rm(dt_leaf); invisible(gc()) - - # ---- 4. Agrégation finale ----------------------------------------------- - # À ce stade dt_exp a : 96 000 × 3 × 3 × 2 × 2 ≈ 3,5 M lignes (4D) - dfs_agg <- dt_exp[, .(VALUE = sum(VALUE)), by = dim_vars] - rm(dt_exp); invisible(gc()) - - # ---- 4b. COMPLÉTION DE LA GRILLE AVEC LES 0 (Si complete_grid = TRUE) --- - if (complete_grid) { - grid_all <- list( - ACT = unique(map_act$to), - GEO = unique(map_geo$to), - SEX = unique(map_sex$to), - AGE = unique(map_age$to) - ) - if (add_dim5) grid_all$ECO <- c("mod1", "mod2", "Total") - - # Produit cartésien de toutes les modalités (feuilles, parents, Total) - full_grid <- do.call(CJ, c(grid_all, list(sorted = FALSE))) - - # Jointure avec la grille complète et remplacement des NA par 0 - dfs_agg <- dfs_agg[full_grid, on = dim_vars] - dfs_agg[is.na(VALUE), VALUE := 0] - } - - # ---- 5. Fichiers .hrc --------------------------------------------------- - write_hrc <- function(hier, path) { - hier %>% - sdcHierarchies::hier_convert(as = "argus") %>% - dplyr::slice(-1) %>% - dplyr::mutate(levels = substring(paste0(level, name), 3)) %>% - dplyr::select(levels) %>% - write.table(file = path, row.names = FALSE, col.names = FALSE, quote = FALSE) - } - - hrc_act <- tempfile(fileext = ".hrc") - h_act <- sdcHierarchies::hier_create(root = "Total", nodes = act_level1) - for (i in seq_len(n_act_groups)) - h_act <- sdcHierarchies::hier_add(h_act, root = sprintf(fmt_act_g, i), - nodes = sprintf(fmt_act_s, i, 1:n_act_sub)) - write_hrc(h_act, hrc_act) - - hrc_geo <- tempfile(fileext = ".hrc") - h_geo <- sdcHierarchies::hier_create(root = "Total", nodes = geo_level1) - for (i in seq_len(n_geo_regions)) - h_geo <- sdcHierarchies::hier_add(h_geo, root = sprintf(fmt_geo_r, i), - nodes = sprintf(fmt_geo_s, i, 1:n_geo_sub)) - write_hrc(h_geo, hrc_geo) - - totcode <- if (add_dim5) - c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total", ECO = "Total") - else - c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total") - - list(data = dfs_agg, hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), totcode = totcode) -} - -# ============================================================================ = -# 00_setup_bench_options -# Génère données 5D pour le benchmark min/smart/max -# ============================================================================ = - -BENCH_DIR <- "Z:/benchmark_options_4D" -dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) - -library(data.table); library(dplyr); library(sdcHierarchies) - -set.seed(123) -big4 <- create_big_4D( - n = 500000, - n_act_groups = 8, n_act_sub = 7, - n_geo_regions = 7, n_geo_sub = 8, - n_sex = 5, n_age = 4, - add_dim5 = FALSE -) - -hrc4 <- c( - ACT = file.path(BENCH_DIR, "hrc", "hrc_ACT.hrc"), - GEO = file.path(BENCH_DIR, "hrc", "hrc_GEO.hrc") -) -file.copy(big4$hrcfiles["ACT"], hrc4["ACT"], overwrite = TRUE) -file.copy(big4$hrcfiles["GEO"], hrc4["GEO"], overwrite = TRUE) - -tot4 <- big4$totcode -# # 1. Filtrer les cellules à 0 inutiles (conserver uniquement VALUE > 0 ou secret primaire) -# dfs4_agg <- dfs4_agg %>% filter(VALUE > 0 | is_secret_prim) - -# 2. S'assurer du format data.frame classique -# dfs4_agg <- as.data.frame(big4$data) -dfs4_agg = big4$data - -dfs4_agg %>% tally() -dfs4_agg %>% arrange(VALUE) - -dfs4_agg %>% summarise(secret_prim = mean(as.integer(VALUE > 0 & VALUE <= 5))) - -dfs4_agg$is_secret_prim <- dfs4_agg$VALUE > 0 & dfs4_agg$VALUE <= 5 -dfs4_agg$secret_no_pl <- FALSE -dfs4_agg$freq <- dfs4_agg$VALUE - -cat("Nombre de cellules :", nrow(dfs4_agg), "\n") -cat("Secret primaire :", sum(dfs4_agg$is_secret_prim), - sprintf("(%.2f%%)\n", 100 * mean(dfs4_agg$is_secret_prim))) - -save(dfs4_agg, tot4, hrc4, - file = file.path(BENCH_DIR, "input_data_4d.RData")) -cat("Setup 5D OK →", BENCH_DIR, "\n") -cat("Redémarrer R, puis lancer bench_nb_tab_option.R\n") - -# ============================================================================ = -# bench_nb_tab_option.R ---- -# Compare nb_tab_option "min" / "smart" / "max" -# ============================================================================ = - -BENCH_DIR <- "Z:/benchmark_options_4D" -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" - -library(data.table); library(dplyr) -devtools::load_all("Z:/rtauargus") -options(rtauargus.tauargus_exe = loc_tauargus) - -load(file.path(BENCH_DIR, "input_data_4d.RData")) # dfs4_agg, tot4, hrc4 - -# ============================================================================ = -# UTILITAIRES ---- -# ============================================================================ = - -capture_gc <- function(label) { - g <- gc() - data.frame( - label = label, type = rownames(g), - used_mb = g[, 2], trigger_mb = g[, 4], max_mb = g[, 6], - row.names = NULL - ) -} - -# Fonction universelle pour récupérer le masque de secret final (compatible split_tab = TRUE et FALSE) -get_final_secret_vec <- function(df) { - # Cas 1 : colonnes du type is_secret_1, is_secret_2 (split_tab = TRUE) - cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] - if (length(cols) > 0) { - last_col <- cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) - return(as.logical(df[[last_col]])) - } - - # Cas 2 : colonne Status (split_tab = FALSE) - if ("Status" %in% names(df)) { - if (is.logical(df$Status)) { - return(df$Status) - } else { - # TauArgus : 'V' = Valide, 'A'/'B'/'D' = Masqué (primaire ou secondaire) - return(df$Status != "V") - } - } - - stop("Aucune colonne de secret valide (is_secret_N ou Status) n'a été trouvée dans le data.frame.") -} - -# Mise à jour de get_secret_stats (utilise désormais get_final_secret_vec) -get_secret_stats <- function(df, label) { - final <- get_final_secret_vec(df) - prim <- as.logical(df$is_secret_prim) - sec <- final & !prim - - data.frame( - label = label, - n_prim = sum(prim, na.rm = TRUE), - value_prim = sum(df$VALUE[prim], na.rm = TRUE), - n_sec = sum(sec, na.rm = TRUE), - value_sec = sum(df$VALUE[sec], na.rm = TRUE), - n_total_masque = sum(final, na.rm = TRUE), - value_total_masque = sum(df$VALUE[final], na.rm = TRUE), - pct_masque_cells = round(100 * mean(final, na.rm = TRUE), 2), - pct_masque_value = round(100 * sum(df$VALUE[final], na.rm = TRUE) / - sum(df$VALUE, na.rm = TRUE), 2) - ) -} - -# Mise à jour de extract_mask -extract_mask <- function(df, tot) { - final <- get_final_secret_vec(df) - df_min <- as.data.frame(df)[, names(tot), drop = FALSE] - df_min$final_secret <- final - df_min <- df_min[do.call(order, df_min[names(tot)]), ] - rownames(df_min) <- NULL - df_min -} - -# ============================================================================ = -# VARIANTS ---- -# ============================================================================ = - -# Pour "min" et "max", limit très grand = pas d'oversplit parasite -# Pour "smart", limit change de fonction du scénario -variants <- list( - list(label = "min", nb_tab_option = "min", limit = 1000000L), - #list(label = "smart_false_min", nb_tab_option = "smart", limit = 10000000L), - list(label = "smart_108000", nb_tab_option = "smart", limit = 108000L), - # list(label = "smart_80000", nb_tab_option = "smart", limit = 80000L), - # list(label = "smart_70000", nb_tab_option = "smart", limit = 70000L), - # list(label = "smart_50000", nb_tab_option = "smart", limit = 50000L), - list(label = "smart_15800", nb_tab_option = "smart", limit = 15800L), - # list(label = "smart_26000", nb_tab_option = "smart", limit = 26000L), - list(label = "smart_15600", nb_tab_option = "smart", limit = 15600L) - # list(label = "smart_false_max", nb_tab_option = "smart", limit = 1L), - # list(label = "max", nb_tab_option = "max", limit = 1000000L) -) - -# pre-run de reduce dims pour voir combien de tables génèrent les configs -# et si certaines sont redondantes entre elles (même résultat) -for (v in variants) { - - cat("\n======================================================================\n") - cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, - "| limit =", v$limit, ")\n") - cat("======================================================================\n") - - # --- Pré-mesure : nombre de sous-tables générées --- - # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. - # Overhead ~5-10s, négligeable face au run complet. - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs4_agg, - dfs_name = "tab_4d", - totcode = tot4, - hrcfiles = hrc4, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = TRUE # affichera le nombre de tables générées ainsi que leur distribution - ) - rm(res_count); gc() - -} - -# HYPBERCUBE -------------------------------------------------------------- - -results_raw <- list() -stats_list <- list() -timings_list <- list() -gc_list <- list() -ntables_list <- list() - -# ============================================================================ = -# BOUCLE PRINCIPALE -# ============================================================================ = - -for (v in variants) { - - cat("\n======================================================================\n") - cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, - "| limit =", v$limit, ")\n") - cat("======================================================================\n") - - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) - dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) - - # --- Pré-mesure : nombre de sous-tables générées --- - # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. - # Overhead ~5-10s, négligeable face au run complet. - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs4_agg, - dfs_name = "tab_4d", - totcode = tot4, - hrcfiles = hrc4, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = FALSE - ) - n_tables <- length(res_count$tabs) - tailles <- sapply(res_count$tabs, nrow) - - # cat(" Sous-tables générées :", n_tables, "\n") - # cat(" Lignes par sous-table :\n") - # print(summary(tailles)) - # cat("\n\n\n") - rm(res_count); gc() - - ntables_list[[v$label]] <- data.frame( - label = v$label, - n_tables = n_tables, - min_rows = if (length(tailles) > 0) min(tailles) else 0, - med_rows = if (length(tailles) > 0) median(tailles) else 0, - max_rows = if (length(tailles) > 0) max(tailles) else 0 - ) - - # --- Run complet --- - gc(reset = TRUE) - - t_v <- system.time({ - res_v <- tab_rtauargus4( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_v, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - nb_tab_option = v$nb_tab_option, - dfs_name = "tab_4d", - limit = v$limit, - keep_history = FALSE - ) - }) - - results_raw[[v$label]] <- res_v - stats_list[[v$label]] <- get_secret_stats(res_v, v$label) - timings_list[[v$label]] <- data.frame( - label = v$label, - elapsed = t_v["elapsed"], - user = t_v["user.self"], - sys = t_v["sys.self"] - ) - gc_list[[v$label]] <- capture_gc(v$label) - - # Sauvegarde intermédiaire (filet de sécurité) - write.csv(stats_list[[v$label]], - file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), - row.names = FALSE) - write.csv(timings_list[[v$label]], - file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), - row.names = FALSE) - write.csv(gc_list[[v$label]], - file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), - row.names = FALSE) - - # ======================================================================== = - # 📊 AFFICHAGE IMMÉDIAT EN CONSOLE - # ======================================================================== = - cat("\n----------------------------------------------------------------------\n") - cat(" 📊 RÉSULTATS OBTENUS POUR :", v$label, "\n") - cat("----------------------------------------------------------------------\n") - - cat("⏱️ [Timing] :\n") - print(timings_list[[v$label]]) - - cat("\n🔒 [Statistiques de secret] :\n") - print(stats_list[[v$label]]) - - cat("\n💾 [Mémoire (Vcells)] :\n") - print(gc_list[[v$label]] %>% filter(type == "Vcells")) - - cat("\n✓", v$label, "terminé avec succès en", round(t_v["elapsed"] / 60, 2), "minutes.\n") -} - -# ============================================================================ = -# RECHARGEMENT DES RÉSULTATS DEPUIS LE DISQUE -# ============================================================================ = - -results_raw <- list() -stats_list <- list() -timings_list <- list() -gc_list <- list() -ntables_list <- list() - -cat("Rechargement des fichiers CSV enregistrés...\n") - -for (v in variants) { - lbl <- v$label - - # 1. Lecture des fichiers CSV sauvegardés - file_secret <- file.path(BENCH_DIR, paste0("secret_", lbl, ".csv")) - file_timing <- file.path(BENCH_DIR, paste0("timing_", lbl, ".csv")) - file_gc <- file.path(BENCH_DIR, paste0("gc_", lbl, ".csv")) - - if (file.exists(file_secret)) stats_list[[lbl]] <- read.csv(file_secret) - if (file.exists(file_timing)) timings_list[[lbl]] <- read.csv(file_timing) - if (file.exists(file_gc)) gc_list[[lbl]] <- read.csv(file_gc) - - # 2. Recalcul rapide du nombre de sous-tables (reduce_dims seul est très rapide, ~5s) - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", lbl)) - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs4_agg, - dfs_name = "tab_4d", - totcode = tot4, - hrcfiles = hrc4, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = FALSE - ) - - n_tables <- length(res_count$tabs) - tailles <- sapply(res_count$tabs, nrow) - - ntables_list[[lbl]] <- data.frame( - label = lbl, - n_tables = n_tables, - min_rows = if (length(tailles) > 0) min(tailles) else 0, - med_rows = if (length(tailles) > 0) median(tailles) else 0, - max_rows = if (length(tailles) > 0) max(tailles) else 0 - ) - - rm(res_count); gc() -} - - -# ============================================================================ = -# BILAN FINAL -# ============================================================================ = - -cat("\n======================================================================\n") -cat(" BILAN COMPARATIF : min / smart_* / max \n") -cat("======================================================================\n") - -cat("\n[1. Nombre et dimensions des sous-tables générées]\n") -df_tables_summary <- bind_rows(ntables_list) %>% - rename( - `Variant` = label, - `Nb tables` = n_tables, - `Taille min (lignes)` = min_rows, - `Taille med (lignes)` = med_rows, - `Taille max (lignes)` = max_rows - ) -print(as.data.frame(df_tables_summary)) - -cat("\n[2. Timings (elapsed, secondes)]\n") -print(bind_rows(timings_list)) - -cat("\n[3. Pic mémoire Vcells]\n") -gc_all <- bind_rows(gc_list) -print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) - -cat("\n[4. Statistiques de secret]\n") -print(bind_rows(stats_list)) - -# # ============================================================================ = -# # COMPARAISON CELLULE PAR CELLULE -# # ============================================================================ = -# -# cat("\n[5. Comparaison des masques de secret final]\n") -# -# # mask_min <- extract_mask(results_raw[["min"]], tot4) -# # mask_smart <- extract_mask(results_raw[["smart"]], tot4) -# # mask_max <- extract_mask(results_raw[["max"]], tot4) -# -# # Extraction dynamique des masques pour TOUTES les variantes exécutées -# masks <- lapply(results_raw, extract_mask, tot4) -# -# compare_masks <- function(m1, m2, l1, l2) { -# if (identical(m1, m2)) { -# cat(l1, "==", l2, ": TRUE\n"); return(invisible(NULL)) -# } -# n_diff <- sum(m1$final_secret != m2$final_secret) -# cat(l1, "==", l2, ": FALSE —", -# n_diff, sprintf("cellules différentes (%.3f%%)\n", -# 100 * n_diff / nrow(m1))) -# } -# -# cat("\n--- Comparaison par rapport aux références (min & max) ---\n") -# -# ref_labels <- c("min", "max") -# other_labels <- setdiff(names(masks), ref_labels) -# -# # 1. Comparaison min vs max -# compare_masks(masks[["min"]], masks[["max"]], "min", "max") -# -# # 2. Comparaison de chaque smart_* contre min (on peut ajouter d'autres références au besoin) -# for (lbl in other_labels) { -# compare_masks(masks[["min"]], masks[[lbl]], "min", lbl) -# } - -# ============================================================================ = -# TEST INDÉPENDANT : split_tab = FALSE -# ============================================================================ = - -cat("\n======================================================================\n") -cat(" TEST INDÉPENDANT : tab_rtauargus (split_tab = FALSE)\n") -cat("======================================================================\n") - -dir_nosplit <- file.path(BENCH_DIR, "tauargus_no_split") -dir.create(file.path(dir_nosplit, "hrc"), recursive = TRUE, showWarnings = FALSE) - -gc(reset = TRUE) - -t_nosplit <- system.time({ - run_nosplit <- tryCatch({ - - res_nosplit <- tab_rtauargus( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_nosplit, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - split_tab = FALSE - ) - - list(status = "OK", data = res_nosplit) - - }, error = function(e) { - list(status = "ERROR", message = e$message) - }) -}) - -if (run_nosplit$status == "OK") { - cat("\n✓ Exécution split_tab = FALSE réussie !\n") - cat(" Temps d'exécution :", round(t_nosplit["elapsed"], 2), "secondes (", - round(t_nosplit["elapsed"] / 60, 2), "minutes )\n\n") - - stats_nosplit <- get_secret_stats(run_nosplit$data, "no_split") - cat(" Statistiques de secret (no_split) :\n") - print(stats_nosplit) - - # Sauvegarde séparée du résultat sans split - write.csv(stats_nosplit, file.path(BENCH_DIR, "secret_no_split.csv"), row.names = FALSE) - write.csv(data.frame(label = "no_split", elapsed = t_nosplit["elapsed"]), - file.path(BENCH_DIR, "timing_no_split.csv"), row.names = FALSE) - - # # Comparaison du masque sans split vs min - # if (!is.null(results_raw[["min"]])) { - # mask_min <- extract_mask(results_raw[["min"]], tot4) - # mask_nosplit <- extract_mask(run_nosplit$data, tot4) - # cat("\n Comparaison du masque 'no_split' vs 'min' :\n") - # compare_masks(mask_min, mask_nosplit, "min", "no_split") - # } - -} else { - cat("\n❌ ERREUR lors de l'exécution de split_tab = FALSE :\n") - cat(" Message :", run_nosplit$message, "\n") - cat(" Temps écoulé avant échec :", round(t_nosplit["elapsed"], 2), "secondes\n") -} - - -# MODULAR ----------------------------------------------------------------- -BENCH_DIR <- "Z:/benchmark_options_4D_MODULAR" -dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) - -results_raw_mod <- list() -stats_list_mod <- list() -timings_list_mod <- list() -gc_list_mod <- list() -ntables_list_mod <- list() - -# ============================================================================ = -# BOUCLE PRINCIPALE -# ============================================================================ = - -for (v in variants) { - - cat("\n======================================================================\n") - cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, - "| limit =", v$limit, ")\n") - cat("======================================================================\n") - - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) - dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) - - # --- Pré-mesure : nombre de sous-tables générées --- - # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. - # Overhead ~5-10s, négligeable face au run complet. - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs4_agg, - dfs_name = "tab_4d", - totcode = tot4, - hrcfiles = hrc4, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = FALSE - ) - n_tables <- length(res_count$tabs) - tailles <- sapply(res_count$tabs, nrow) - - # cat(" Sous-tables générées :", n_tables, "\n") - # cat(" Lignes par sous-table :\n") - # print(summary(tailles)) - # cat("\n\n\n") - rm(res_count); gc() - - ntables_list_mod[[v$label]] <- data.frame( - label = v$label, - n_tables = n_tables, - min_rows = if (length(tailles) > 0) min(tailles) else 0, - med_rows = if (length(tailles) > 0) median(tailles) else 0, - max_rows = if (length(tailles) > 0) max(tailles) else 0 - ) - - # --- Run complet --- - gc(reset = TRUE) - - t_v <- system.time({ - res_v <- tab_rtauargus4( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_v, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - nb_tab_option = v$nb_tab_option, - dfs_name = "tab_4d", - limit = v$limit, - keep_history = FALSE - ) - }) - - results_raw_mod[[v$label]] <- res_v - stats_list_mod[[v$label]] <- get_secret_stats(res_v, v$label) - timings_list_mod[[v$label]] <- data.frame( - label = v$label, - elapsed = t_v["elapsed"], - user = t_v["user.self"], - sys = t_v["sys.self"] - ) - gc_list_mod[[v$label]] <- capture_gc(v$label) - - # Sauvegarde intermédiaire (filet de sécurité) - write.csv(stats_list_mod[[v$label]], - file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), - row.names = FALSE) - write.csv(timings_list_mod[[v$label]], - file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), - row.names = FALSE) - write.csv(gc_list_mod[[v$label]], - file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), - row.names = FALSE) - - # ======================================================================== = - # 📊 AFFICHAGE IMMÉDIAT EN CONSOLE - # ======================================================================== = - cat("\n----------------------------------------------------------------------\n") - cat(" 📊 RÉSULTATS OBTENUS POUR :", v$label, "\n") - cat("----------------------------------------------------------------------\n") - - cat("⏱️ [Timing] :\n") - print(timings_list[[v$label]]) - - cat("\n🔒 [Statistiques de secret] :\n") - print(stats_list[[v$label]]) - - cat("\n💾 [Mémoire (Vcells)] :\n") - print(gc_list[[v$label]] %>% filter(type == "Vcells")) - - cat("\n✓", v$label, "terminé avec succès en", round(t_v["elapsed"] / 60, 2), "minutes.\n") -} - -# ============================================================================ = -# RECHARGEMENT DES RÉSULTATS DEPUIS LE DISQUE -# ============================================================================ = - -results_raw_mod <- list() -stats_list_mod <- list() -timings_list_mod <- list() -gc_list_mod <- list() -ntables_list_mod <- list() - -cat("Rechargement des fichiers CSV enregistrés...\n") - -for (v in variants) { - lbl <- v$label - - # 1. Lecture des fichiers CSV sauvegardés - file_secret <- file.path(BENCH_DIR, paste0("secret_", lbl, ".csv")) - file_timing <- file.path(BENCH_DIR, paste0("timing_", lbl, ".csv")) - file_gc <- file.path(BENCH_DIR, paste0("gc_", lbl, ".csv")) - - if (file.exists(file_secret)) stats_list_mod[[lbl]] <- read.csv(file_secret) - if (file.exists(file_timing)) timings_list_mod[[lbl]] <- read.csv(file_timing) - if (file.exists(file_gc)) gc_list_mod[[lbl]] <- read.csv(file_gc) - - # 2. Recalcul rapide du nombre de sous-tables (reduce_dims seul est très rapide, ~5s) - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", lbl)) - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs4_agg, - dfs_name = "tab_4d", - totcode = tot4, - hrcfiles = hrc4, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = FALSE - ) - - n_tables <- length(res_count$tabs) - tailles <- sapply(res_count$tabs, nrow) - - ntables_list_mod[[lbl]] <- data.frame( - label = lbl, - n_tables = n_tables, - min_rows = if (length(tailles) > 0) min(tailles) else 0, - med_rows = if (length(tailles) > 0) median(tailles) else 0, - max_rows = if (length(tailles) > 0) max(tailles) else 0 - ) - - rm(res_count); gc() -} - - -# ============================================================================ = -# BILAN FINAL -# ============================================================================ = - -cat("\n======================================================================\n") -cat(" BILAN COMPARATIF : min / smart_* / max \n") -cat("======================================================================\n") - -cat("\n[1. Nombre et dimensions des sous-tables générées]\n") -df_tables_summary <- bind_rows(ntables_list_mod) %>% - rename( - `Variant` = label, - `Nb tables` = n_tables, - `Taille min (lignes)` = min_rows, - `Taille med (lignes)` = med_rows, - `Taille max (lignes)` = max_rows - ) -print(as.data.frame(df_tables_summary)) - -cat("\n[2. Timings (elapsed, secondes)]\n") -print(bind_rows(timings_list_mod)) - -cat("\n[3. Pic mémoire Vcells]\n") -gc_all <- bind_rows(gc_list_mod) -print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) - -cat("\n[4. Statistiques de secret]\n") -print(bind_rows(stats_list_mod)) -# -# # ============================================================================ = -# # COMPARAISON CELLULE PAR CELLULE -# # ============================================================================ = -# -# cat("\n[5. Comparaison des masques de secret final]\n") -# -# # mask_min <- extract_mask(results_raw_mod[["min"]], tot4) -# # mask_smart <- extract_mask(results_raw_mod[["smart"]], tot4) -# # mask_max <- extract_mask(results_raw_mod[["max"]], tot4) -# -# # Extraction dynamique des masques pour TOUTES les variantes exécutées -# masks <- lapply(results_raw_mod, extract_mask, tot4) -# -# compare_masks <- function(m1, m2, l1, l2) { -# if (identical(m1, m2)) { -# cat(l1, "==", l2, ": TRUE\n"); return(invisible(NULL)) -# } -# n_diff <- sum(m1$final_secret != m2$final_secret) -# cat(l1, "==", l2, ": FALSE —", -# n_diff, sprintf("cellules différentes (%.3f%%)\n", -# 100 * n_diff / nrow(m1))) -# } -# -# cat("\n--- Comparaison par rapport aux références (min & max) ---\n") -# -# ref_labels <- c("min", "max") -# other_labels <- setdiff(names(masks), ref_labels) -# -# # 1. Comparaison min vs max -# compare_masks(masks[["min"]], masks[["max"]], "min", "max") -# -# # 2. Comparaison de chaque smart_* contre min (on peut ajouter d'autres références au besoin) -# for (lbl in other_labels) { -# compare_masks(masks[["min"]], masks[[lbl]], "min", lbl) -# } - -# ============================================================================ = -# TEST INDÉPENDANT : split_tab = FALSE -# ============================================================================ = - -cat("\n======================================================================\n") -cat(" TEST INDÉPENDANT : tab_rtauargus (split_tab = FALSE)\n") -cat("======================================================================\n") - -dir_nosplit <- file.path(BENCH_DIR, "tauargus_no_split") -dir.create(file.path(dir_nosplit, "hrc"), recursive = TRUE, showWarnings = FALSE) - -gc(reset = TRUE) - -t_nosplit <- system.time({ - run_nosplit <- tryCatch({ - - res_nosplit <- tab_rtauargus( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_nosplit, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - split_tab = FALSE - ) - - list(status = "OK", data = res_nosplit) - - }, error = function(e) { - list(status = "ERROR", message = e$message) - }) -}) - -if (run_nosplit$status == "OK") { - cat("\n✓ Exécution split_tab = FALSE réussie !\n") - cat(" Temps d'exécution :", round(t_nosplit["elapsed"], 2), "secondes (", - round(t_nosplit["elapsed"] / 60, 2), "minutes )\n\n") - - stats_nosplit <- get_secret_stats(run_nosplit$data, "no_split") - cat(" Statistiques de secret (no_split) :\n") - print(stats_nosplit) - - # Sauvegarde séparée du résultat sans split - write.csv(stats_nosplit, file.path(BENCH_DIR, "secret_no_split.csv"), row.names = FALSE) - write.csv(data.frame(label = "no_split", elapsed = t_nosplit["elapsed"]), - file.path(BENCH_DIR, "timing_no_split.csv"), row.names = FALSE) - - # # Comparaison du masque sans split vs min - # if (!is.null(results_raw_mod[["min"]])) { - # mask_min <- extract_mask(results_raw_mod[["min"]], tot4) - # mask_nosplit <- extract_mask(run_nosplit$data, tot4) - # cat("\n Comparaison du masque 'no_split' vs 'min' :\n") - # compare_masks(mask_min, mask_nosplit, "min", "no_split") - # } - -} else { - cat("\n❌ ERREUR lors de l'exécution de split_tab = FALSE :\n") - cat(" Message :", run_nosplit$message, "\n") - cat(" Temps écoulé avant échec :", round(t_nosplit["elapsed"], 2), "secondes\n") -} - - -# ============================================================================ = -# OPTIMAL --------------------------------------------------------------------- -# ============================================================================ = - -BENCH_DIR <- "Z:/benchmark_options_4D_OPTIMAL" -dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) - -results_raw_opt <- list() -stats_list_opt <- list() -timings_list_opt <- list() -gc_list_opt <- list() -ntables_list_opt <- list() - -# ============================================================================ = -# BOUCLE PRINCIPALE -# ============================================================================ = - -for (v in variants) { - - cat("\n======================================================================\n") - cat(" [OPTIMAL] Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, - "| limit =", v$limit, ")\n") - cat("======================================================================\n") - - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) - dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) - - # --- Pré-mesure : nombre de sous-tables générées --- - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs4_agg, - dfs_name = "tab_4d", - totcode = tot4, - hrcfiles = hrc4, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = FALSE - ) - n_tables <- length(res_count$tabs) - tailles <- sapply(res_count$tabs, nrow) - - rm(res_count); gc() - - ntables_list_opt[[v$label]] <- data.frame( - label = v$label, - n_tables = n_tables, - min_rows = if (length(tailles) > 0) min(tailles) else 0, - med_rows = if (length(tailles) > 0) median(tailles) else 0, - max_rows = if (length(tailles) > 0) max(tailles) else 0 - ) - - # --- Run complet --- - gc(reset = TRUE) - - t_v <- system.time({ - res_v <- tab_rtauargus4( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_v, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "OPT(1, 20)", - nb_tab_option = v$nb_tab_option, - dfs_name = "tab_4d", - limit = v$limit, - keep_history = FALSE - ) - }) - - results_raw_opt[[v$label]] <- res_v - stats_list_opt[[v$label]] <- get_secret_stats(res_v, v$label) - timings_list_opt[[v$label]] <- data.frame( - label = v$label, - elapsed = t_v["elapsed"], - user = t_v["user.self"], - sys = t_v["sys.self"] - ) - gc_list_opt[[v$label]] <- capture_gc(v$label) - - # Sauvegarde intermédiaire (filet de sécurité) - write.csv(stats_list_opt[[v$label]], - file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), - row.names = FALSE) - write.csv(timings_list_opt[[v$label]], - file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), - row.names = FALSE) - write.csv(gc_list_opt[[v$label]], - file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), - row.names = FALSE) - - # ======================================================================== = - # 📊 AFFICHAGE IMMÉDIAT EN CONSOLE - # ======================================================================== = - cat("\n----------------------------------------------------------------------\n") - cat(" 📊 RÉSULTATS OPTIMAL OBTENUS POUR :", v$label, "\n") - cat("----------------------------------------------------------------------\n") - - cat("⏱️ [Timing] :\n") - print(timings_list_opt[[v$label]]) - - cat("\n🔒 [Statistiques de secret] :\n") - print(stats_list_opt[[v$label]]) - - cat("\n💾 [Mémoire (Vcells)] :\n") - print(gc_list_opt[[v$label]] %>% filter(type == "Vcells")) - - cat("\n✓", v$label, "(Optimal) terminé avec succès en", round(t_v["elapsed"] / 60, 2), "minutes.\n") -} - - -# ============================================================================ = -# RECHARGEMENT DES RÉSULTATS DEPUIS LE DISQUE -# ============================================================================ = - -results_raw_opt <- list() -stats_list_opt <- list() -timings_list_opt <- list() -gc_list_opt <- list() -ntables_list_opt <- list() - -cat("Rechargement des fichiers CSV enregistrés (OPTIMAL)...\n") - -for (v in variants) { - lbl <- v$label - - # 1. Lecture des fichiers CSV sauvegardés - file_secret <- file.path(BENCH_DIR, paste0("secret_", lbl, ".csv")) - file_timing <- file.path(BENCH_DIR, paste0("timing_", lbl, ".csv")) - file_gc <- file.path(BENCH_DIR, paste0("gc_", lbl, ".csv")) - - if (file.exists(file_secret)) stats_list_opt[[lbl]] <- read.csv(file_secret) - if (file.exists(file_timing)) timings_list_opt[[lbl]] <- read.csv(file_timing) - if (file.exists(file_gc)) gc_list_opt[[lbl]] <- read.csv(file_gc) - - # 2. Recalcul rapide du nombre de sous-tables - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", lbl)) - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs4_agg, - dfs_name = "tab_4d", - totcode = tot4, - hrcfiles = hrc4, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = FALSE - ) - - n_tables <- length(res_count$tabs) - tailles <- sapply(res_count$tabs, nrow) - - ntables_list_opt[[lbl]] <- data.frame( - label = lbl, - n_tables = n_tables, - min_rows = if (length(tailles) > 0) min(tailles) else 0, - med_rows = if (length(tailles) > 0) median(tailles) else 0, - max_rows = if (length(tailles) > 0) max(tailles) else 0 - ) - - rm(res_count); gc() -} - - -# ============================================================================ = -# BILAN FINAL OPTIMAL -# ============================================================================ = - -cat("\n======================================================================\n") -cat(" BILAN COMPARATIF (OPTIMAL) : min / smart_* \n") -cat("======================================================================\n") - -cat("\n[1. Nombre et dimensions des sous-tables générées]\n") -df_tables_summary_opt <- bind_rows(ntables_list_opt) %>% - rename( - `Variant` = label, - `Nb tables` = n_tables, - `Taille min (lignes)` = min_rows, - `Taille med (lignes)` = med_rows, - `Taille max (lignes)` = max_rows - ) -print(as.data.frame(df_tables_summary_opt)) - -cat("\n[2. Timings (elapsed, secondes)]\n") -print(bind_rows(timings_list_opt)) - -cat("\n[3. Pic mémoire Vcells]\n") -gc_all_opt <- bind_rows(gc_list_opt) -print(gc_all_opt |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) - -cat("\n[4. Statistiques de secret]\n") -print(bind_rows(stats_list_opt)) - - -# ============================================================================ = -# TEST INDÉPENDANT : split_tab = FALSE (OPTIMAL) -# ============================================================================ = - -cat("\n======================================================================\n") -cat(" TEST INDÉPENDANT : tab_rtauargus (split_tab = FALSE, OPTIMAL)\n") -cat("======================================================================\n") - -dir_nosplit <- file.path(BENCH_DIR, "tauargus_no_split") -dir.create(file.path(dir_nosplit, "hrc"), recursive = TRUE, showWarnings = FALSE) - -gc(reset = TRUE) - -t_nosplit <- system.time({ - run_nosplit <- tryCatch({ - - res_nosplit <- tab_rtauargus( - tabular = dfs4_agg, - explanatory_vars = names(tot4), - dir_name = dir_nosplit, - secret_var = "is_secret_prim", - totcode = tot4, - hrc = hrc4, - value = "VALUE", - freq = "freq", - suppress = "OPT(1, 20)", # Optimal sans split - split_tab = FALSE - ) - - list(status = "OK", data = res_nosplit) - - }, error = function(e) { - list(status = "ERROR", message = e$message) - }) -}) - -if (run_nosplit$status == "OK") { - cat("\n✓ Exécution split_tab = FALSE (Optimal) réussie !\n") - cat(" Temps d'exécution :", round(t_nosplit["elapsed"], 2), "secondes (", - round(t_nosplit["elapsed"] / 60, 2), "minutes )\n\n") - - stats_nosplit <- get_secret_stats(run_nosplit$data, "no_split_opt") - cat(" Statistiques de secret (no_split OPTIMAL) :\n") - print(stats_nosplit) - - # Sauvegarde séparée du résultat sans split - write.csv(stats_nosplit, file.path(BENCH_DIR, "secret_no_split.csv"), row.names = FALSE) - write.csv(data.frame(label = "no_split_opt", elapsed = t_nosplit["elapsed"]), - file.path(BENCH_DIR, "timing_no_split.csv"), row.names = FALSE) - -} else { - cat("\n❌ ERREUR lors de l'exécution de split_tab = FALSE (Optimal) :\n") - cat(" Message :", run_nosplit$message, "\n") - cat(" Temps écoulé avant échec :", round(t_nosplit["elapsed"], 2), "secondes\n") -} diff --git a/bench/comp_limit_smart_5D.R b/bench/comp_limit_smart_5D.R deleted file mode 100644 index de00f88..0000000 --- a/bench/comp_limit_smart_5D.R +++ /dev/null @@ -1,707 +0,0 @@ -create_big_4D <- function( - n = 200000, - n_act_groups = 30, - n_act_sub = 50, - n_geo_regions = 50, - n_geo_sub = 50, - n_sex = 2, - n_age = 4, - add_dim5 = FALSE, - complete_grid = TRUE -){ - set.seed(123) - - w_act_g <- max(2, nchar(n_act_groups)) - w_act_s <- max(2, nchar(n_act_sub)) - w_geo_r <- max(2, nchar(n_geo_regions)) - w_geo_s <- max(2, nchar(n_geo_sub)) - w_age <- max(2, nchar(n_age)) - - fmt_act_g <- paste0("A%0", w_act_g, "d") - fmt_act_s <- paste0("A%0", w_act_g, "d_%0", w_act_s, "d") # typo corrigée - fmt_geo_r <- paste0("G%0", w_geo_r, "d") - fmt_geo_s <- paste0("G%0", w_geo_r, "d_%0", w_geo_s, "d") - fmt_age <- paste0("AGE%0", w_age, "d") - - act_level1 <- sprintf(fmt_act_g, 1:n_act_groups) - act_level2 <- unlist(lapply(1:n_act_groups, function(i) sprintf(fmt_act_s, i, 1:n_act_sub))) - geo_level1 <- sprintf(fmt_geo_r, 1:n_geo_regions) - geo_level2 <- unlist(lapply(1:n_geo_regions, function(i) sprintf(fmt_geo_s, i, 1:n_geo_sub))) - - sex_leaves <- if (n_sex == 2) c("F", "M") else { - w_sex <- max(2, nchar(n_sex)) - sprintf(paste0("S%0", w_sex, "d"), 1:n_sex) - } - age_leaves <- sprintf(fmt_age, 1:n_age) - - dim_vars <- if (add_dim5) c("ACT", "GEO", "SEX", "AGE", "ECO") - else c("ACT", "GEO", "SEX", "AGE") - - # ---- 1. Microdonnées FEUILLES uniquement -------------------------------- - dt <- data.table( - ACT = sample(act_level2, n, replace = TRUE), - GEO = sample(geo_level2, n, replace = TRUE), - SEX = sample(sex_leaves, n, replace = TRUE), - AGE = sample(age_leaves, n, replace = TRUE) - ) - if (add_dim5) dt[, ECO := sample(c("mod1", "mod2"), n, replace = TRUE)] - - # Agrégation feuilles : libère immédiatement les 50M lignes - dt_leaf <- dt[, .(VALUE = .N), by = dim_vars] - rm(dt); invisible(gc()) - - # ---- 2. Tables de correspondance hiérarchiques -------------------------- - # mk_map : leaf → {leaf, parent (si fourni), "Total"} - mk_map <- function(leaves, parents = NULL) { - rows <- list(data.table(from = leaves, to = leaves)) - if (!is.null(parents)) rows[[2]] <- data.table(from = leaves, to = parents) - rows[[length(rows) + 1]] <- data.table(from = leaves, to = "Total") - rbindlist(rows) - } - - map_act <- mk_map(act_level2, sub("_[0-9]+$", "", act_level2)) - map_geo <- mk_map(geo_level2, sub("_[0-9]+$", "", geo_level2)) - map_sex <- mk_map(sex_leaves) - map_age <- mk_map(age_leaves) - - # ---- 3. Expansion dimension par dimension (join data.table) ------------- - # Pour chaque dimension : on remplace la valeur feuille par TOUTES ses - # valeurs hiérarchiques (leaf, parent, Total) via un join one-to-many. - rollup_dim <- function(dt, col, map) { - # map[dt, ...] : right-join — pour chaque ligne de dt, trouve les - # correspondances dans map (3 ou 2 lignes par valeur feuille) - result <- map[dt, on = c(from = col), allow.cartesian = TRUE] - # result a : from | to | [autres colonnes de dt sauf col] - result[, (col) := to][, c("from", "to") := NULL] - result - } - - dt_exp <- rollup_dim(dt_leaf, "ACT", map_act) - dt_exp <- rollup_dim(dt_exp, "GEO", map_geo) - dt_exp <- rollup_dim(dt_exp, "SEX", map_sex) - dt_exp <- rollup_dim(dt_exp, "AGE", map_age) - - if (add_dim5) dt_exp <- rollup_dim(dt_exp, "ECO", mk_map(c("mod1", "mod2"))) - - rm(dt_leaf); invisible(gc()) - - # ---- 4. Agrégation finale ----------------------------------------------- - # À ce stade dt_exp a : 96 000 × 3 × 3 × 2 × 2 ≈ 3,5 M lignes (4D) - dfs_agg <- dt_exp[, .(VALUE = sum(VALUE)), by = dim_vars] - rm(dt_exp); invisible(gc()) - - # ---- 4b. COMPLÉTION DE LA GRILLE AVEC LES 0 (Si complete_grid = TRUE) --- - if (complete_grid) { - grid_all <- list( - ACT = unique(map_act$to), - GEO = unique(map_geo$to), - SEX = unique(map_sex$to), - AGE = unique(map_age$to) - ) - if (add_dim5) grid_all$ECO <- c("mod1", "mod2", "Total") - - # Produit cartésien de toutes les modalités (feuilles, parents, Total) - full_grid <- do.call(CJ, c(grid_all, list(sorted = FALSE))) - - # Jointure avec la grille complète et remplacement des NA par 0 - dfs_agg <- dfs_agg[full_grid, on = dim_vars] - dfs_agg[is.na(VALUE), VALUE := 0] - } - - # ---- 5. Fichiers .hrc --------------------------------------------------- - write_hrc <- function(hier, path) { - hier %>% - sdcHierarchies::hier_convert(as = "argus") %>% - dplyr::slice(-1) %>% - dplyr::mutate(levels = substring(paste0(level, name), 3)) %>% - dplyr::select(levels) %>% - write.table(file = path, row.names = FALSE, col.names = FALSE, quote = FALSE) - } - - hrc_act <- tempfile(fileext = ".hrc") - h_act <- sdcHierarchies::hier_create(root = "Total", nodes = act_level1) - for (i in seq_len(n_act_groups)) - h_act <- sdcHierarchies::hier_add(h_act, root = sprintf(fmt_act_g, i), - nodes = sprintf(fmt_act_s, i, 1:n_act_sub)) - write_hrc(h_act, hrc_act) - - hrc_geo <- tempfile(fileext = ".hrc") - h_geo <- sdcHierarchies::hier_create(root = "Total", nodes = geo_level1) - for (i in seq_len(n_geo_regions)) - h_geo <- sdcHierarchies::hier_add(h_geo, root = sprintf(fmt_geo_r, i), - nodes = sprintf(fmt_geo_s, i, 1:n_geo_sub)) - write_hrc(h_geo, hrc_geo) - - totcode <- if (add_dim5) - c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total", ECO = "Total") - else - c(SEX = "Total", AGE = "Total", GEO = "Total", ACT = "Total") - - list(data = dfs_agg, hrcfiles = c(ACT = hrc_act, GEO = hrc_geo), totcode = totcode) -} -# ============================================================================= -# 00_setup_bench_options -# Génère données 5D pour le benchmark min/smart/max -# ============================================================================= - -BENCH_DIR <- "Z:/rtauargus/benchmark_options_5D" -dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) - -library(data.table); library(dplyr); library(sdcHierarchies) - -set.seed(123) -big5 <- create_big_4D( - n = 900000, - n_act_groups = 4, n_act_sub = 5, - n_geo_regions = 5, n_geo_sub = 6, - n_sex = 10, n_age = 15, - add_dim5 = TRUE -) - -hrc5 <- c( - ACT = file.path(BENCH_DIR, "hrc", "hrc_ACT.hrc"), - GEO = file.path(BENCH_DIR, "hrc", "hrc_GEO.hrc") -) -file.copy(big5$hrcfiles["ACT"], hrc5["ACT"], overwrite = TRUE) -file.copy(big5$hrcfiles["GEO"], hrc5["GEO"], overwrite = TRUE) - -tot5 <- big5$totcode - -dfs5_agg = big5$data - -dfs5_agg %>% tally() -dfs5_agg %>% arrange(VALUE) - -dfs5_agg %>% summarise(secret_prim = mean(as.integer(VALUE > 0 & VALUE <= 3))) - -dfs5_agg$is_secret_prim <- dfs5_agg$VALUE > 0 & dfs5_agg$VALUE <= 3 -dfs5_agg$secret_no_pl <- FALSE -dfs5_agg$freq <- dfs5_agg$VALUE - -cat("Nombre de cellules :", nrow(dfs5_agg), "\n") -cat("Secret primaire :", sum(dfs5_agg$is_secret_prim), - sprintf("(%.2f%%)\n", 100 * mean(dfs5_agg$is_secret_prim))) - -save(dfs5_agg, tot5, hrc5, - file = file.path(BENCH_DIR, "input_data_5d.RData")) -cat("Setup 5D OK →", BENCH_DIR, "\n") -cat("Redémarrer R, puis lancer bench_nb_tab_option.R\n") - -# ============================================================================= -# bench_nb_tab_option.R -# Compare nb_tab_option "min" / "smart" / "max" -# ============================================================================= - -BENCH_DIR <- "benchmark_options_5D" -loc_tauargus <- "Y:/Logiciels/TauArgus/TauArgus4.2.2b1/TauArgus.exe" - -library(data.table); library(dplyr) -devtools::load_all("Z:/rtauargus") -options(rtauargus.tauargus_exe = loc_tauargus) - -load(file.path(BENCH_DIR, "input_data_5d.RData")) # dfs5_agg, tot5, hrc5 - -# ============================================================================= -# UTILITAIRES -# ============================================================================= - -capture_gc <- function(label) { - g <- gc() - data.frame( - label = label, type = rownames(g), - used_mb = g[, 2], trigger_mb = g[, 4], max_mb = g[, 6], - row.names = NULL - ) -} - -get_last_secret_col <- function(df) { - cols <- names(df)[grepl("^is_secret_[0-9]+$", names(df))] - if (!length(cols)) return(NULL) - cols[order(as.integer(sub("is_secret_", "", cols)))] |> tail(1) -} - -get_secret_stats <- function(df, label) { - last_col <- get_last_secret_col(df) - final <- df[[last_col]] - prim <- df$is_secret_prim - sec <- final & !prim - data.frame( - label = label, - n_prim = sum(prim), - value_prim = sum(df$VALUE[prim], na.rm = TRUE), - n_sec = sum(sec), - value_sec = sum(df$VALUE[sec], na.rm = TRUE), - n_total_masque = sum(final), - value_total_masque = sum(df$VALUE[final], na.rm = TRUE), - pct_masque_cells = round(100 * mean(final), 2), - pct_masque_value = round(100 * sum(df$VALUE[final], na.rm = TRUE) / - sum(df$VALUE, na.rm = TRUE), 2) - ) -} - -extract_mask <- function(df, tot) { - last_col <- get_last_secret_col(df) - df_min <- as.data.frame(df)[, c(names(tot), last_col)] - names(df_min)[ncol(df_min)] <- "final_secret" - df_min <- df_min[do.call(order, df_min[names(tot)]), ] - rownames(df_min) <- NULL - df_min -} - -# ============================================================================= -# VARIANTS -# ============================================================================= - -explore_reduce_dims(dfs = dfs5_agg, - totcode = tot5, - hrcfiles = hrc5) - -# Pour "min" et "max", limit très grand = pas d'oversplit parasite -# Pour "smart", limit change de fonction du scénario -variants <- list( - list(label = "smart_100000", nb_tab_option = "smart", limit = 100000L), - list(label = "smart_45000", nb_tab_option = "smart", limit = 45000L), - list(label = "smart_20000", nb_tab_option = "smart", limit = 20000L), - list(label = "smart_18000", nb_tab_option = "smart", limit = 18000L), - list(label = "smart_13000", nb_tab_option = "smart", limit = 13000L) -) - -# pre-run de reduce dims pour voir combien de tables génèrent les configs -# et si certaines sont redondantes entre elles (même résultat) -for (v in variants) { - - cat("\n======================================================================\n") - cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, - "| limit =", v$limit, ")\n") - cat("======================================================================\n") - - # --- Pré-mesure : nombre de sous-tables générées --- - # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. - # Overhead ~5-10s, négligeable face au run complet. - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs5_agg, - dfs_name = "tab_5d", - totcode = tot5, - hrcfiles = hrc5, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = TRUE # affichera le nombre de tables générées ainsi que leur distribution - ) - rm(res_count); gc() - -} - - -# HYPERCUBE------------------------------------------------------------------------- -BENCH_DIR <- "Z:/benchmark_options_5D_HYPERCUBE" -dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) - -results_raw <- list() -stats_list <- list() -timings_list <- list() -gc_list <- list() -ntables_list <- list() - -# ============================================================================= -# BOUCLE PRINCIPALE -# ============================================================================= - -for (v in variants) { - - cat("\n======================================================================\n") - cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, - "| limit =", v$limit, ")\n") - cat("======================================================================\n") - - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) - dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) - - # --- Pré-mesure : nombre de sous-tables générées --- - # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. - # Overhead ~5-10s, négligeable face au run complet. - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs5_agg, - dfs_name = "tab_5d", - totcode = tot5, - hrcfiles = hrc5, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = FALSE - ) - n_tables <- length(res_count$tabs) - tailles <- sapply(res_count$tabs, nrow) - - rm(res_count); gc() - - ntables_list[[v$label]] <- data.frame( - label = v$label, - n_tables = n_tables, - min_rows = if (length(tailles) > 0) min(tailles) else 0, - med_rows = if (length(tailles) > 0) median(tailles) else 0, - max_rows = if (length(tailles) > 0) max(tailles) else 0 - ) - - # --- Run complet --- - gc(reset = TRUE) - - t_v <- system.time({ - res_v <- tab_rtauargus4( - tabular = dfs5_agg, - explanatory_vars = names(tot5), - dir_name = dir_v, - secret_var = "is_secret_prim", - totcode = tot5, - hrc = hrc5, - value = "VALUE", - freq = "freq", - suppress = "GH(1,100)", - nb_tab_option = v$nb_tab_option, - dfs_name = "tab_5d", - limit = v$limit, - keep_history = FALSE - ) - }) - - results_raw[[v$label]] <- res_v - stats_list[[v$label]] <- get_secret_stats(res_v, v$label) - timings_list[[v$label]] <- data.frame( - label = v$label, - elapsed = t_v["elapsed"], - user = t_v["user.self"], - sys = t_v["sys.self"] - ) - gc_list[[v$label]] <- capture_gc(v$label) - - # Sauvegarde intermédiaire (filet de sécurité) - write.csv(stats_list[[v$label]], - file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), - row.names = FALSE) - write.csv(timings_list[[v$label]], - file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), - row.names = FALSE) - write.csv(gc_list[[v$label]], - file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), - row.names = FALSE) - - # ======================================================================== = - # 📊 AFFICHAGE IMMÉDIAT EN CONSOLE - # ======================================================================== = - cat("\n----------------------------------------------------------------------\n") - cat(" 📊 RÉSULTATS OBTENUS POUR :", v$label, "\n") - cat("----------------------------------------------------------------------\n") - - cat("⏱️ [Timing] :\n") - print(timings_list[[v$label]]) - - cat("\n🔒 [Statistiques de secret] :\n") - print(stats_list[[v$label]]) - - cat("\n💾 [Mémoire (Vcells)] :\n") - print(gc_list[[v$label]] %>% filter(type == "Vcells")) - - cat("\n✓", v$label, "terminé avec succès en", round(t_v["elapsed"] / 60, 2), "minutes.\n") -} - -# ============================================================================= -# RECHARGEMENT DES RÉSULTATS DEPUIS LE DISQUE -# ============================================================================= - -results_raw <- list() -stats_list <- list() -timings_list <- list() -gc_list <- list() -ntables_list <- list() - -cat("Rechargement des fichiers CSV enregistrés...\n") - -for (v in variants) { - lbl <- v$label - - # 1. Lecture des fichiers CSV sauvegardés - file_secret <- file.path(BENCH_DIR, paste0("secret_", lbl, ".csv")) - file_timing <- file.path(BENCH_DIR, paste0("timing_", lbl, ".csv")) - file_gc <- file.path(BENCH_DIR, paste0("gc_", lbl, ".csv")) - - if (file.exists(file_secret)) stats_list[[lbl]] <- read.csv(file_secret) - if (file.exists(file_timing)) timings_list[[lbl]] <- read.csv(file_timing) - if (file.exists(file_gc)) gc_list[[lbl]] <- read.csv(file_gc) - - # 2. Recalcul rapide du nombre de sous-tables (reduce_dims seul est très rapide, ~5s) - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", lbl)) - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs5_agg, - dfs_name = "tab_5d", - totcode = tot5, - hrcfiles = hrc5, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = FALSE - ) - - n_tables <- length(res_count$tabs) - tailles <- sapply(res_count$tabs, nrow) - - ntables_list[[lbl]] <- data.frame( - label = lbl, - n_tables = n_tables, - min_rows = if (length(tailles) > 0) min(tailles) else 0, - med_rows = if (length(tailles) > 0) median(tailles) else 0, - max_rows = if (length(tailles) > 0) max(tailles) else 0 - ) - - rm(res_count); gc() -} - - -# ============================================================================= -# BILAN FINAL -# ============================================================================= - -cat("\n======================================================================\n") -cat(" BILAN COMPARATIF : min / smart_* / max \n") -cat("======================================================================\n") - -cat("\n[1. Nombre et dimensions des sous-tables générées]\n") -df_tables_summary <- bind_rows(ntables_list) %>% - rename( - `Variant` = label, - `Nb tables` = n_tables, - `Taille min (lignes)` = min_rows, - `Taille med (lignes)` = med_rows, - `Taille max (lignes)` = max_rows - ) -print(as.data.frame(df_tables_summary)) - -cat("\n[2. Timings (elapsed, secondes)]\n") -print(bind_rows(timings_list)) - -cat("\n[3. Pic mémoire Vcells]\n") -gc_all <- bind_rows(gc_list) -print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) - -cat("\n[4. Statistiques de secret]\n") -print(bind_rows(stats_list)) - -# MODULAR ------------------------------------------------------------------------- - -BENCH_DIR <- "Z:/benchmark_options_5D_MODULAR" -dir.create(file.path(BENCH_DIR, "hrc"), recursive = TRUE, showWarnings = FALSE) - -results_raw_mod <- list() -stats_list_mod <- list() -timings_list_mod <- list() -gc_list_mod <- list() -ntables_list_mod <- list() - -# ============================================================================= -# BOUCLE PRINCIPALE -# ============================================================================= - -for (v in variants[1]) { - - cat("\n======================================================================\n") - cat(" Variant :", v$label, "(nb_tab_option =", v$nb_tab_option, - "| limit =", v$limit, ")\n") - cat("======================================================================\n") - - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", v$label)) - dir.create(file.path(dir_v, "hrc"), recursive = TRUE, showWarnings = FALSE) - - # --- Pré-mesure : nombre de sous-tables générées --- - # Appel isolé à reduce_dims pour capturer n_tables avant le run complet. - # Overhead ~5-10s, négligeable face au run complet. - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs5_agg, - dfs_name = "tab_5d", - totcode = tot5, - hrcfiles = hrc5, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = FALSE - ) - n_tables <- length(res_count$tabs) - tailles <- sapply(res_count$tabs, nrow) - - rm(res_count); gc() - - ntables_list_mod[[v$label]] <- data.frame( - label = v$label, - n_tables = n_tables, - min_rows = if (length(tailles) > 0) min(tailles) else 0, - med_rows = if (length(tailles) > 0) median(tailles) else 0, - max_rows = if (length(tailles) > 0) max(tailles) else 0 - ) - - # --- Run complet --- - gc(reset = TRUE) - - t_v <- system.time({ - res_v <- tab_rtauargus4( - tabular = dfs5_agg, - explanatory_vars = names(tot5), - dir_name = dir_v, - secret_var = "is_secret_prim", - totcode = tot5, - hrc = hrc5, - value = "VALUE", - freq = "freq", - nb_tab_option = v$nb_tab_option, - dfs_name = "tab_5d", - limit = v$limit, - keep_history = FALSE - ) - }) - - results_raw_mod[[v$label]] <- res_v - stats_list_mod[[v$label]] <- get_secret_stats(res_v, v$label) - timings_list_mod[[v$label]] <- data.frame( - label = v$label, - elapsed = t_v["elapsed"], - user = t_v["user.self"], - sys = t_v["sys.self"] - ) - gc_list_mod[[v$label]] <- capture_gc(v$label) - - # Sauvegarde intermédiaire (filet de sécurité) - write.csv(stats_list_mod[[v$label]], - file.path(BENCH_DIR, paste0("secret_", v$label, ".csv")), - row.names = FALSE) - write.csv(timings_list_mod[[v$label]], - file.path(BENCH_DIR, paste0("timing_", v$label, ".csv")), - row.names = FALSE) - write.csv(gc_list_mod[[v$label]], - file.path(BENCH_DIR, paste0("gc_", v$label, ".csv")), - row.names = FALSE) - - # ======================================================================== = - # 📊 AFFICHAGE IMMÉDIAT EN CONSOLE - # ======================================================================== = - cat("\n----------------------------------------------------------------------\n") - cat(" 📊 RÉSULTATS OBTENUS POUR :", v$label, "\n") - cat("----------------------------------------------------------------------\n") - - cat("⏱️ [Timing] :\n") - print(timings_list_mod[[v$label]]) - - cat("\n🔒 [Statistiques de secret] :\n") - print(stats_list_mod[[v$label]]) - - cat("\n💾 [Mémoire (Vcells)] :\n") - print(gc_list_mod[[v$label]] %>% filter(type == "Vcells")) - - cat("\n✓", v$label, "terminé avec succès en", round(t_v["elapsed"] / 60, 2), "minutes.\n") -} - -# ============================================================================= -# RECHARGEMENT DES RÉSULTATS DEPUIS LE DISQUE -# ============================================================================= - -results_raw_mod <- list() -stats_list_mod <- list() -timings_list_mod <- list() -gc_list_mod <- list() -ntables_list_mod <- list() - -cat("Rechargement des fichiers CSV enregistrés...\n") - -for (v in variants) { - lbl <- v$label - - # 1. Lecture des fichiers CSV sauvegardés - file_secret <- file.path(BENCH_DIR, paste0("secret_", lbl, ".csv")) - file_timing <- file.path(BENCH_DIR, paste0("timing_", lbl, ".csv")) - file_gc <- file.path(BENCH_DIR, paste0("gc_", lbl, ".csv")) - - if (file.exists(file_secret)) stats_list_mod[[lbl]] <- read.csv(file_secret) - if (file.exists(file_timing)) timings_list_mod[[lbl]] <- read.csv(file_timing) - if (file.exists(file_gc)) gc_list_mod[[lbl]] <- read.csv(file_gc) - - # 2. Recalcul rapide du nombre de sous-tables (reduce_dims seul est très rapide, ~5s) - dir_v <- file.path(BENCH_DIR, paste0("tauargus_", lbl)) - dir_count <- file.path(dir_v, "count_hrc") - dir.create(dir_count, recursive = TRUE, showWarnings = FALSE) - - res_count <- reduce_dims( - dfs = dfs5_agg, - dfs_name = "tab_5d", - totcode = tot5, - hrcfiles = hrc5, - nb_tab_option = v$nb_tab_option, - limit = v$limit, - over_split = TRUE, - sep_dir = TRUE, - hrc_dir = dir_count, - verbose = FALSE - ) - - n_tables <- length(res_count$tabs) - tailles <- sapply(res_count$tabs, nrow) - - ntables_list_mod[[lbl]] <- data.frame( - label = lbl, - n_tables = n_tables, - min_rows = if (length(tailles) > 0) min(tailles) else 0, - med_rows = if (length(tailles) > 0) median(tailles) else 0, - max_rows = if (length(tailles) > 0) max(tailles) else 0 - ) - - rm(res_count); gc() -} - - -# ============================================================================= -# BILAN FINAL -# ============================================================================= - -cat("\n======================================================================\n") -cat(" BILAN COMPARATIF : min / smart_* / max \n") -cat("======================================================================\n") - -cat("\n[1. Nombre et dimensions des sous-tables générées]\n") -df_tables_summary <- bind_rows(ntables_list_mod) %>% - rename( - `Variant` = label, - `Nb tables` = n_tables, - `Taille min (lignes)` = min_rows, - `Taille med (lignes)` = med_rows, - `Taille max (lignes)` = max_rows - ) -print(as.data.frame(df_tables_summary)) - -cat("\n[2. Timings (elapsed, secondes)]\n") -print(bind_rows(timings_list_mod)) - -cat("\n[3. Pic mémoire Vcells]\n") -gc_all <- bind_rows(gc_list_mod) -print(gc_all |> filter(type == "Vcells") |> select(label, used_mb, max_mb)) - -cat("\n[4. Statistiques de secret]\n") -print(bind_rows(stats_list_mod)) - - - From e324d240ae6db9cd30b027afb27c1cda0bbe955f Mon Sep 17 00:00:00 2001 From: Clara Baudry Date: Wed, 19 Aug 2026 19:26:48 +0200 Subject: [PATCH 06/16] fix: same term in multiple equations --- R/identify_hrc_with_eq.R | 2 +- tests/testthat/test_analyse_metadata.R | 47 ++++++++++++++++++++++++++ 2 files changed, 48 insertions(+), 1 deletion(-) diff --git a/R/identify_hrc_with_eq.R b/R/identify_hrc_with_eq.R index 0bc342a..6f78179 100644 --- a/R/identify_hrc_with_eq.R +++ b/R/identify_hrc_with_eq.R @@ -399,7 +399,7 @@ regroup_tables <- function(df_group, spanning_combination_group) { df_group |> filter(table_name %in% tables_complete) |> left_join(spanning_by_table |> select(table_name, spanning_key), by = "table_name") |> - group_by(across(-c(table_name, side, var_mapped, indicator))) |> + group_by(across(-c(table_name, side, var_mapped, indicator, eq_name))) |> summarise( table_name = paste(sort(unique(table_name)), collapse = "."), indicator = last(unit), diff --git a/tests/testthat/test_analyse_metadata.R b/tests/testthat/test_analyse_metadata.R index 61fbc67..894e2d5 100644 --- a/tests/testthat/test_analyse_metadata.R +++ b/tests/testthat/test_analyse_metadata.R @@ -394,3 +394,50 @@ test_that("pas_meme_var_crois_2", { } ) +# Two equations linked by one indicator ---------------------------------------- +meta <- metadata_pizza_lettuce |> + filter(hrc_indicator == "hrc_lettuce") + +meta <- bind_rows( + meta, + meta |> + dplyr::slice(1:2) |> + mutate(indicator = c("to_bat1", "to_bat2"), + table_name = c("T1", "T2")) +) |> + mutate(hrc_indicator = NA_character_) + +df_eq_lettuce_included <- data.frame( + eq_name = c("eq1","eq2"), + eq_indicator = c("to_lettuce = to_batavia + to_arugula", + "to_batavia = to_bat1 + to_bat2"), + unit = c("EUR","EUR"), + stringsAsFactors = FALSE +) + +answer <- data.frame( + cluster = rep("france_entreprises_2023.EUR"), + table_name = c("T1.T11.T7.T9","T10.T12.T2.T8"), + field = rep("france_entreprises_2023"), + indicator = c("to_batavia","to_batavia"), + spanning_1 = c("HRC_NAF","HRC_NAF"), + spanning_2 = c("size","cj"), + spanning_3 = c("EQ1_EQ2^h","EQ1_EQ2^h"), + hrc_spanning_1 = c("hrc_naf","hrc_naf"), + hrc_spanning_2 = NA_character_, + hrc_spanning_3 = c("hrc_EQ1_EQ2.totcode.to_batavia","hrc_EQ1_EQ2.totcode.to_batavia") +) + +test_that("eqs_linked_by_one_indicator", { + expect_warning( + expect_equal( + analyse_metadata(df_metadata = meta,df_eq_indicator = df_eq_lettuce_included), + answer + ), + "hrc_indicator column will be ignored" + ) + +} +) + + From 75c9576ca747140720b11614443a42d30637fe7d Mon Sep 17 00:00:00 2001 From: Clara Baudry Date: Mon, 24 Aug 2026 18:42:10 +0200 Subject: [PATCH 07/16] feat: change format_template() nb modalities in the spanning name not in the hrc name --- DESCRIPTION | 2 +- R/format_template.R | 10 ++++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6e584f6..85ebabe 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: rtauargus Type: Package Title: Using Tau-Argus from R Language: fr -Version: 1.3.5 +Version: 1.3.6 Depends: R (>= 4.1.0) Imports: purrr (>= 0.2), diff --git a/R/format_template.R b/R/format_template.R index ba48d0c..7d598a8 100644 --- a/R/format_template.R +++ b/R/format_template.R @@ -215,6 +215,7 @@ format_template <- function(data,indicator_column,spanning_var_tot,field_columns FALSE } }) + spanning_description <- purrr::imap_dfr( tables_crossing_variables, ~ { @@ -223,12 +224,13 @@ format_template <- function(data,indicator_column,spanning_var_tot,field_columns paste0("hrc_", tolower(names(.x)), "_", sapply(.x, function(col) length(unique(col)))), names(.x) ) - # Extract variable names and formatted counts - variable_names <- names(formatted_counts) # Spanning variables - hrc_values <- formatted_counts # Corresponding hrc values + + nb_modalities <- sapply(.x, function(col) length(unique(col))) + variable_names <- paste0(names(nb_modalities),"_",nb_modalities) # Spanning variables + hrc_values <- paste0("hrc_", tolower(names(.x))) # Corresponding hrc values unique_modalities <- setNames( sapply(.x, function(col) unique(col), simplify = FALSE), - formatted_counts + hrc_values ) # Create a dynamic data frame data.frame( From 24956314c0ba06a347a00b94a296abecf87bd016 Mon Sep 17 00:00:00 2001 From: Clara Baudry Date: Tue, 25 Aug 2026 17:37:19 +0200 Subject: [PATCH 08/16] fix: take hrc_field into account for identify_hrc() --- R/identify_hrc.R | 37 +++++++++++++++++++------- tests/testthat/test_analyse_metadata.R | 29 ++++++++++++++++++++ 2 files changed, 57 insertions(+), 9 deletions(-) diff --git a/R/identify_hrc.R b/R/identify_hrc.R index 5638ebc..a73469d 100644 --- a/R/identify_hrc.R +++ b/R/identify_hrc.R @@ -48,24 +48,43 @@ identify_hrc <- function(df_metadata_long){ table_name = df_spannings$table_name ) %>% unique() df_spannings <- df_spannings %>% select(-spanning_old) - if(all(is.na(df_spannings$hrc_indicator))){ # condition for hierarchies on indicators - df_indicators <- df_spannings - return(list(df_indicators,df_variable_info)) - } else { - df_indicators <- df_spannings %>% + + # Hierachies on indicators + if (any(!is.na(df_spannings$hrc_indicator))) { + df_hrc_indicator <- df_spannings %>% filter(!is.na(hrc_indicator)) %>% - dplyr::group_by(table_name) %>% + group_by(table_name) %>% summarise( field = last(field), hrc_field = last(hrc_field), - spanning = paste0(toupper(last(hrc_indicator)),"^h"), + spanning = paste0(toupper(last(hrc_indicator)), "^h"), hrc_spanning = last(hrc_indicator), indicator = last(indicator), hrc_indicator = last(hrc_indicator) ) %>% bind_rows(df_spannings, .) %>% arrange(table_name) - list_hrc_identified = list(df_indicators,df_variable_info) - return(list_hrc_identified) + } else { + df_hrc_indicator <- df_spannings + } + # Hierarchies on fields + if (any(!is.na(df_spannings$hrc_field))) { + df_hrc_field <- df_hrc_indicator %>% + filter(!is.na(hrc_field)) %>% + group_by(table_name) %>% + summarise( + field = last(hrc_field), + hrc_field = last(hrc_field), + spanning = paste0(toupper(last(hrc_field)), "^h"), + hrc_spanning = last(hrc_spanning), + indicator = last(indicator), + hrc_indicator = last(hrc_indicator) + ) %>% + bind_rows(df_hrc_indicator, .) %>% + arrange(table_name) + } else { + df_hrc_field <- df_hrc_indicator } + + list(df_hrc_field,df_variable_info) } diff --git a/tests/testthat/test_analyse_metadata.R b/tests/testthat/test_analyse_metadata.R index 894e2d5..d830a68 100644 --- a/tests/testthat/test_analyse_metadata.R +++ b/tests/testthat/test_analyse_metadata.R @@ -94,6 +94,35 @@ test_that("hierarchies on indicators", { } ) +# check that the hierarchies on fields are handled properly -------------------- +answer <- data.frame( + cluster = "hrc_geo.to_pizza", + table_name = "T1.T2.T3", + field = "france_entreprises_2023", + indicator = "to_pizza", + spanning_1 = "size", + spanning_2 = "HRC_GEO^h", + hrc_spanning_1 = NA_character_, + hrc_spanning_2 = NA_character_ +) + +test_that("hierarchies on fields", { + + meta <- data.frame( + table_name = paste0("T", 1:3), + field = c("france_entreprises_2023","metro_entreprises_2023","dom_entreprises_2023"), + hrc_field = "hrc_geo", + indicator = "to_pizza", + hrc_indicator = NA_character_, + spanning_1 = "size", + hrc_spanning_1 = NA_character_ + ) + + expect_equal(analyse_metadata(meta),answer) +} +) + + ############################################################### TABLE INCLUSIONS # two tables included in each other answer <- data.frame( From 4400110446fccecdc9fd2f11b3d2f24b7e3e6f4b Mon Sep 17 00:00:00 2001 From: Clara Baudry Date: Tue, 25 Aug 2026 18:48:32 +0200 Subject: [PATCH 09/16] fix: take hrc_field into account for identify_hrc_with_eq() --- R/identify_hrc_with_eq.R | 23 +++++++++++++++++- tests/testthat/test_analyse_metadata.R | 33 ++++++++++++++++++++++++++ 2 files changed, 55 insertions(+), 1 deletion(-) diff --git a/R/identify_hrc_with_eq.R b/R/identify_hrc_with_eq.R index 6f78179..fb148e1 100644 --- a/R/identify_hrc_with_eq.R +++ b/R/identify_hrc_with_eq.R @@ -100,7 +100,7 @@ identify_hrc_with_eq <- function(df_metadata_long,df_eq_indicator){ dplyr::filter(!is.na(rhs)) %>% dplyr::mutate( total = trimws(as.character(total)), - rhs = trimws(as.character(rhs)) + rhs = trimws(as.character(rhs)) ) %>% dplyr::distinct() %>% left_join(alt_map, by = c("eq_name", "total")) %>% @@ -152,6 +152,27 @@ identify_hrc_with_eq <- function(df_metadata_long,df_eq_indicator){ hrc_indicator = ifelse(indicator %in% unique(equations_long$var), NA, hrc_indicator) ) + if (any(!is.na(df_spannings$hrc_field))) { + df_spannings <- df_spannings %>% + mutate( + field = ifelse(is.na(hrc_field), field, toupper(hrc_field))) + + spanning_field_rows <- df_spannings %>% + filter(!is.na(hrc_field)) %>% + group_by(table_name) %>% + summarise( + field = last(hrc_field), + hrc_field = last(hrc_field), + spanning = paste0(toupper(last(hrc_field)), "^h"), + hrc_spanning = last(hrc_spanning), + indicator = last(indicator), + hrc_indicator = last(hrc_indicator) + ) + + df_spannings <- bind_rows(df_spannings, spanning_field_rows) %>% + arrange(table_name) + } + df_spannings_eq <- df_spannings %>% mutate(across(dplyr::where(is.character), ~ gsub("[^[:alnum:]_]", "", .))) %>% left_join(equations_long_full, by = c("indicator" = "var")) diff --git a/tests/testthat/test_analyse_metadata.R b/tests/testthat/test_analyse_metadata.R index d830a68..86e2711 100644 --- a/tests/testthat/test_analyse_metadata.R +++ b/tests/testthat/test_analyse_metadata.R @@ -469,4 +469,37 @@ test_that("eqs_linked_by_one_indicator", { } ) +# the hrc on fields are handled properly --------------------------------------- +answer <- data.frame( + cluster = "hrc_geo.EUR", + table_name = "T1.T2.T3", + field = "hrc_geo", + indicator = "to_lettuce", + spanning_1 = "HRC_GEOh", + spanning_2 = "size", + spanning_3 = "EQ1^h", + hrc_spanning_1 = NA_character_, + hrc_spanning_2 = NA_character_, + hrc_spanning_3 = "hrc_EQ1.totcode.to_lettuce" +) + +test_that("hierarchies on fields with eq on indicators", { + + meta <- data.frame( + table_name = paste0("T", 1:3), + field = c("france_entreprises_2023","metro_entreprises_2023","dom_entreprises_2023"), + hrc_field = "hrc_geo", + indicator = c("to_lettuce","to_batavia","to_arugula"), + hrc_indicator = NA_character_, + spanning_1 = "size", + hrc_spanning_1 = NA_character_ + ) + expect_warning( + expect_equal(analyse_metadata(meta,df_eq_lettuce_1),answer), + "hrc_indicator column will be ignored" + ) +} +) + + From 04e16f96f34135fb152ef8ae69c75aeb301b3e6c Mon Sep 17 00:00:00 2001 From: Clara Baudry Date: Wed, 26 Aug 2026 11:36:45 +0200 Subject: [PATCH 10/16] fix: name of the hrc_spanning of the spanning created from the hrc_field --- R/identify_hrc.R | 2 +- tests/testthat/test_analyse_metadata.R | 32 ++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 1 deletion(-) diff --git a/R/identify_hrc.R b/R/identify_hrc.R index a73469d..0f1bc3b 100644 --- a/R/identify_hrc.R +++ b/R/identify_hrc.R @@ -76,7 +76,7 @@ identify_hrc <- function(df_metadata_long){ field = last(hrc_field), hrc_field = last(hrc_field), spanning = paste0(toupper(last(hrc_field)), "^h"), - hrc_spanning = last(hrc_spanning), + hrc_spanning = last(hrc_field), indicator = last(indicator), hrc_indicator = last(hrc_indicator) ) %>% diff --git a/tests/testthat/test_analyse_metadata.R b/tests/testthat/test_analyse_metadata.R index 86e2711..57989a3 100644 --- a/tests/testthat/test_analyse_metadata.R +++ b/tests/testthat/test_analyse_metadata.R @@ -122,6 +122,38 @@ test_that("hierarchies on fields", { } ) +# check that the hierarchies on fields and on indicators ----------------------- +answer <- data.frame( + cluster = "hrc_geo.hrc_salades", + table_name = "T1.T2.T3", + field = "france_entreprises_2023", + indicator = "SALADES", + spanning_1 = "size", + spanning_2 = "HRC_SALADES^h", + spanning_3 = "HRC_GEO^h", + hrc_spanning_1 = NA_character_, + hrc_spanning_2 = "hrc_salades", + hrc_spanning_3 = "hrc_geo" +) + +test_that("hierarchies on fields", { + + meta <- data.frame( + table_name = paste0("T", 1:3), + field = c("france_entreprises_2023","metro_entreprises_2023","dom_entreprises_2023"), + hrc_field = "hrc_geo", + indicator = c("to_batavia","to_arugula","to_lettuce"), + hrc_indicator = "hrc_salades", + spanning_1 = "size", + hrc_spanning_1 = NA_character_ + ) + + expect_equal(analyse_metadata(meta),answer) +} +) + + + ############################################################### TABLE INCLUSIONS # two tables included in each other From c20bc5aea4542ff74047c66b547e8de68a36c0b4 Mon Sep 17 00:00:00 2001 From: Clara Baudry Date: Wed, 26 Aug 2026 12:15:10 +0200 Subject: [PATCH 11/16] feat: transform in NA --- R/wide_to_long.R | 1 + tests/testthat/test_analyse_metadata.R | 6 ++---- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/R/wide_to_long.R b/R/wide_to_long.R index ea0b4cc..e41ab40 100644 --- a/R/wide_to_long.R +++ b/R/wide_to_long.R @@ -30,6 +30,7 @@ #' wide_to_long <- function(df_metadata){ df_metadata_long <- df_metadata %>% + mutate(across(where(is.character), ~dplyr::na_if(.x, ""))) %>% pivot_longer(cols = starts_with("spanning"), names_to = "spanning_name", values_to = "spanning") %>% diff --git a/tests/testthat/test_analyse_metadata.R b/tests/testthat/test_analyse_metadata.R index 57989a3..3c230d9 100644 --- a/tests/testthat/test_analyse_metadata.R +++ b/tests/testthat/test_analyse_metadata.R @@ -103,7 +103,7 @@ answer <- data.frame( spanning_1 = "size", spanning_2 = "HRC_GEO^h", hrc_spanning_1 = NA_character_, - hrc_spanning_2 = NA_character_ + hrc_spanning_2 = "hrc_geo" ) test_that("hierarchies on fields", { @@ -136,7 +136,7 @@ answer <- data.frame( hrc_spanning_3 = "hrc_geo" ) -test_that("hierarchies on fields", { +test_that("hierarchies on fields and indicators", { meta <- data.frame( table_name = paste0("T", 1:3), @@ -153,8 +153,6 @@ test_that("hierarchies on fields", { ) - - ############################################################### TABLE INCLUSIONS # two tables included in each other answer <- data.frame( From c1b89e1040f379f7ba0b2417608ce8e3acf11b25 Mon Sep 17 00:00:00 2001 From: julienjamme Date: Thu, 27 Aug 2026 19:37:55 +0200 Subject: [PATCH 12/16] fix summarize_secret for tab_multi_manager --- NAMESPACE | 98 +++++++++++++++++++++++------------------ R/summarize_secret.R | 6 +-- man/summarize_secret.Rd | 2 +- 3 files changed, 59 insertions(+), 47 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 9b39347..c7946eb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,51 +42,63 @@ export(write_hrc) export(write_hrc2) import(data.table, except = transpose) import(utils) -importFrom(dplyr,"%>%") -importFrom(dplyr,across) -importFrom(dplyr,all_of) -importFrom(dplyr,arrange) -importFrom(dplyr,bind_rows) -importFrom(dplyr,case_when) -importFrom(dplyr,distinct) -importFrom(dplyr,everything) -importFrom(dplyr,filter) -importFrom(dplyr,group_by) -importFrom(dplyr,last_col) -importFrom(dplyr,left_join) -importFrom(dplyr,mutate) -importFrom(dplyr,n) -importFrom(dplyr,n_distinct) -importFrom(dplyr,pull) -importFrom(dplyr,rename) -importFrom(dplyr,rename_with) -importFrom(dplyr,row_number) -importFrom(dplyr,rowwise) -importFrom(dplyr,select) -importFrom(dplyr,summarise) -importFrom(dplyr,tibble) -importFrom(dplyr,ungroup) -importFrom(dplyr,where) -importFrom(igraph,graph_from_data_frame) -importFrom(igraph,which_mutual) -importFrom(lifecycle,badge) -importFrom(lifecycle,deprecated) -importFrom(purrr,compact) -importFrom(purrr,discard) -importFrom(purrr,imap_dfr) -importFrom(purrr,list_c) -importFrom(purrr,map) -importFrom(purrr,map2) -importFrom(purrr,map_at) -importFrom(purrr,transpose) +importFrom(dplyr, + "%>%", + across, + all_of, + arrange, + bind_rows, + case_when, + distinct, + everything, + filter, + group_by, + last_col, + left_join, + mutate, + n, + n_distinct, + pull, + rename, + rename_with, + row_number, + rowwise, + select, + summarise, + tibble, + ungroup, + where +) +importFrom(igraph, + graph_from_data_frame, + which_mutual +) +importFrom(lifecycle, + badge, + deprecated +) +importFrom(purrr, + compact, + discard, + imap_dfr, + list_c, + map, + map2, + map_at, + transpose +) importFrom(rlang,.data) -importFrom(sdcHierarchies,hier_convert) -importFrom(sdcHierarchies,hier_import) +importFrom(sdcHierarchies, + hier_convert, + hier_import +) importFrom(stats,setNames) importFrom(stringr,str_detect) -importFrom(tidyr,nest) -importFrom(tidyr,pivot_longer) -importFrom(tidyr,unnest) -importFrom(tidyr,unnest_wider) +importFrom(tidyr, + nest, + pivot_longer, + unnest, + unnest_wider +) importFrom(utils,combn) importFrom(zoo,na.locf) diff --git a/R/summarize_secret.R b/R/summarize_secret.R index 5a2d83c..2e28d12 100644 --- a/R/summarize_secret.R +++ b/R/summarize_secret.R @@ -1,7 +1,7 @@ #' Provide the summary of the suppression pattern from a rtauargus result #' #' @param res_tau either the data.frame resulting from tab_rtauargus run or -#' the list of data.frame resulting from tab_multimanager run +#' the list of data.frame resulting from tab_multi_manager run #' @param var the quantitative variable name to use for values stats of suppression #' (default to `NULL` that is the stats are only computed depending on the number of cells ) #' @param secret_var the name of the variable indicating the primary suppressed cells @@ -77,8 +77,8 @@ summarize_secret <- function(res_tau, var = NULL, secret_var = "is_secret_prim") dplyr::mutate( status = case_when( is_secret_prim ~ "primary suppr.", - final_status_ta != "V" ~ "secondary suppr.", - TRUE ~ "published" + (final_status_ta == "V") | (final_status_ta == FALSE) ~ "published", + TRUE ~ "secondary suppr." )) |> dplyr::mutate(status = factor( status, diff --git a/man/summarize_secret.Rd b/man/summarize_secret.Rd index 876f857..4d038f1 100644 --- a/man/summarize_secret.Rd +++ b/man/summarize_secret.Rd @@ -8,7 +8,7 @@ summarize_secret(res_tau, var = NULL, secret_var = "is_secret_prim") } \arguments{ \item{res_tau}{either the data.frame resulting from tab_rtauargus run or -the list of data.frame resulting from tab_multimanager run} +the list of data.frame resulting from tab_multi_manager run} \item{var}{the quantitative variable name to use for values stats of suppression (default to \code{NULL} that is the stats are only computed depending on the number of cells )} From afc29f0366110024691c240384c70099a8c23b2f Mon Sep 17 00:00:00 2001 From: Pomel Wistan Date: Thu, 3 Sep 2026 11:09:04 +0200 Subject: [PATCH 13/16] Attempt so solve issue #57 --- R/sp_tab_rtauargus.R | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/R/sp_tab_rtauargus.R b/R/sp_tab_rtauargus.R index d997b64..f3e63c3 100644 --- a/R/sp_tab_rtauargus.R +++ b/R/sp_tab_rtauargus.R @@ -173,6 +173,14 @@ tab_rtauargus4 <- function( cat("\nReducing dims...\n",dfs_name,"\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]] + list_tables <- reduce_dims( dfs = tabular, dfs_name = dfs_name, @@ -218,11 +226,22 @@ 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) 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. From 8c2688c1498d8c93d94ec6357f43fc3b13461786 Mon Sep 17 00:00:00 2001 From: Pomel Wistan Date: Thu, 3 Sep 2026 14:04:46 +0200 Subject: [PATCH 14/16] Fix non defaut value of secret_var when summarize_secret() is used with tab_multimanager --- R/summarize_secret.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summarize_secret.R b/R/summarize_secret.R index 2e28d12..133d55d 100644 --- a/R/summarize_secret.R +++ b/R/summarize_secret.R @@ -118,7 +118,7 @@ summarize_secret <- function(res_tau, var = NULL, secret_var = "is_secret_prim") } - return( purrr::map(res_tau, summarize_secret, var = var) ) + return( purrr::map(res_tau, summarize_secret, var = var, secret_var = secret_var) ) } From 59dc100af77f253e76b021bef1676da83635da50 Mon Sep 17 00:00:00 2001 From: Pomel Wistan Date: Thu, 3 Sep 2026 15:24:23 +0200 Subject: [PATCH 15/16] add compact_verbose support By defaut, detailled for rtauargus(4), compact for multitab --- R/multitable.R | 2 ++ R/sp_tab_rtauargus.R | 40 ++++++++++++++++++++++++++++++++++++++-- R/tab_rtauargus.R | 3 +++ 3 files changed, 43 insertions(+), 2 deletions(-) diff --git a/R/multitable.R b/R/multitable.R index fc7222b..53ec001 100644 --- a/R/multitable.R +++ b/R/multitable.R @@ -145,6 +145,8 @@ tab_multi_manager <- function( 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 diff --git a/R/sp_tab_rtauargus.R b/R/sp_tab_rtauargus.R index f3e63c3..4cb37ae 100644 --- a/R/sp_tab_rtauargus.R +++ b/R/sp_tab_rtauargus.R @@ -66,6 +66,9 @@ auto_limit <- function(dfs, totcode, hrcfiles = NULL) { #' (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 @@ -139,6 +142,7 @@ tab_rtauargus4 <- function( limit = NULL, dfs_name = 'tab', sort_table = NULL, + compact_verbose = FALSE, ... ){ @@ -159,6 +163,15 @@ tab_rtauargus4 <- function( # Reduce dims for 4 or 5 dimensions table if (length(explanatory_vars) %in% c(4, 5)) { + # 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"]])) { @@ -171,7 +184,9 @@ tab_rtauargus4 <- function( } } - cat("\nReducing dims...\n",dfs_name,"\n\n") + 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 @@ -181,6 +196,15 @@ tab_rtauargus4 <- function( # 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, dfs_name = dfs_name, @@ -190,10 +214,18 @@ tab_rtauargus4 <- function( nb_tab_option = nb_tab_option, limit = limit, over_split = FALSE, - verbose = TRUE, # to generalize later + 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)) @@ -231,6 +263,10 @@ tab_rtauargus4 <- function( 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) diff --git a/R/tab_rtauargus.R b/R/tab_rtauargus.R index 21bd786..c1cda6c 100644 --- a/R/tab_rtauargus.R +++ b/R/tab_rtauargus.R @@ -210,6 +210,7 @@ tab_rtauargus <- function( 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)) @@ -442,6 +443,8 @@ tab_rtauargus2 <- function( 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 From 28e0ff50e600df94513ed3f7b86938a982b379a4 Mon Sep 17 00:00:00 2001 From: julienjamme Date: Fri, 4 Sep 2026 18:11:28 +0200 Subject: [PATCH 16/16] check package --- NAMESPACE | 1 - _pkgdown.yml | 1 + man/tab_rtauargus4.Rd | 5 +++++ 3 files changed, 6 insertions(+), 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index a3c5c56..eacf1d6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -83,7 +83,6 @@ importFrom(sdcHierarchies, hier_import ) importFrom(stats,setNames) -importFrom(stringr,str_detect) importFrom(tidyr, nest, pivot_longer, diff --git a/_pkgdown.yml b/_pkgdown.yml index 95cd36f..6704809 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -83,6 +83,7 @@ reference: - split_in_clusters - tab_to_treat - wide_to_long + - explore_reduce_dims articles: - title: Work with tabular data (Advised) navbar: tabular-wise diff --git a/man/tab_rtauargus4.Rd b/man/tab_rtauargus4.Rd index 663354f..3bbdb60 100644 --- a/man/tab_rtauargus4.Rd +++ b/man/tab_rtauargus4.Rd @@ -24,6 +24,7 @@ tab_rtauargus4( limit = NULL, dfs_name = "tab", sort_table = NULL, + compact_verbose = FALSE, ... ) } @@ -132,6 +133,10 @@ If \code{"ASC"}, sub-tables are processed in ascending order of their total cell \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{compact_verbose}{logical, default \code{FALSE}. +Whether to display a compact single-line summary for dimension reduction +instead of detailed progress logs (recommended for multi-table workflows).} + \item{...}{additional parameters} } \value{