journal_add_break_line <- (journal){
sep_char_jour <- "-----------------------------------------"
(sep_char_jour, = journal, fill = , = )
}
journal_add_line <- (journal,){
(, = journal, fill = , = )
}
#' Manages the secondary secret of a list of tables
#' @inheritParams tab_rtauargus
#' @param list_tables named list of `data.frame` or `data.table` representing the tables to protect
#' @param list_explanatory_vars named list of character vectors of explanatory
#' variables of each table mentionned in list_tables. Names of the list are the same as of the list of tables.
#' @param alt_hrc named list for alternative hierarchies (useful for non nested-hierarchies)
#' @param alt_totcode named list for alternative codes
#' @param ip_start integer: Interval protection level to apply at first treatment of each table
#' @param ip_end integer: Interval protection level to apply at other treatments
#' @param num_iter_max integer: Maximum of treatments to do on each table (default to 10)
#' @param ... other arguments of `tab_rtauargus2()`
#'
#' @return original list of tables. Secret Results of each iteration is added to each table.
#' For example, the result of first iteration is called 'is_secret_1' in each table.
#' It's a boolean variable, whether the cell has to be masked or not.
#'
#' @seealso `tab_rtauargus2`
#'
#' @examples
#' library(rtauargus)
#' library(dplyr)
#' data(turnover_act_size)
#' data(turnover_act_cj)
#' data(activity_corr_table)
#'
#' #0-Making hrc file of business sectors ----
#' hrc_file_activity <- activity_corr_table %>%
#' write_hrc2(file_name = "hrc/activity")
#'
#' #1-Prepare data ----
#' #Indicate whether each cell complies with the primary rules
#' #Boolean variable created is TRUE if the cell doesn't comply.
#' #Here the frequency rule is freq in (0;3)
#' #and the dominance rule is NK(1,85)
#' list_data_2_tabs <- list(
#' act_size = turnover_act_size,
#' act_cj = turnover_act_cj
#' ) %>%
#' purrr::map(
#' function(df){
#' df %>%
#' mutate(
#' is_secret_freq = N_OBS > 0 & N_OBS < 3,
#' is_secret_dom = ifelse(MAX == 0, FALSE, MAX/TOT>0.85),
#' is_secret_prim = is_secret_freq | is_secret_dom
#' )
#' }
#' )
#' \dontrun{
#' options(
#' rtauargus.tauargus_exe =
#' "Y:/Logiciels/TauArgus/TauArgus4.2.3/TauArgus.exe"
#' )
#' res_1 <- tab_multi_manager(
#' list_tables = list_data_2_tabs,
#' list_explanatory_vars = list(
#' act_size = c("ACTIVITY", "SIZE"),
#' act_cj = c("ACTIVITY", "CJ")
#' ),
#' hrc = c(ACTIVITY = hrc_file_activity),
#' dir_name = "tauargus_files",
#' value = "TOT",
#' freq = "N_OBS",
#' secret_var = "is_secret_prim",
#' totcode = "Total"
#' )
#'
#'
#' # With the reduction dimensions feature
#'
#' data("datatest1")
#' data("datatest2")
#'
#' datatest2b <- datatest2 %>%
#' filter(cj == "Total", treff == "Total", type_distrib == "Total") %>%
#' select(-cj, -treff, -type_distrib)
#'
#' str(datatest2b)
#'
#' res <- tab_multi_manager(
#' list_tables = list(d1 = datatest1, d2 = datatest2b),
#' list_explanatory_vars = list(
#' d1 = names(datatest1)[1:4],
#' d2 = names(datatest2b)[1:2]
#' ),
#' dir_name = "tauargus_files",
#' value = "pizzas_tot_abs",
#' freq = "nb_obs_rnd",
#' secret_var = "is_secret_prim",
#' totcode = "Total",
#' split_tab = TRUE
#' )
#'
#' }
#'
#' @importFrom rlang .data
#'
#' @export
<- (
list_tables,
list_explanatory_vars,
dir_name = ,
hrc = ,
alt_hrc = ,
totcode = ("rtauargus.totcode"),
alt_totcode = ,
value = "value",
freq = "freq",
secret_var = "is_secret_prim",
cost_var = ,
suppress = "MOD(1,5,1,0,0)",
ip_start = 10,
ip_end = 0,
num_iter_max = 10,
split_tab = ,
nb_tab_option = "smart",
limit = 14700,
){
start_time <- ()
dir_name <- ((dir_name)) () dir_name
(dir_name, recursive = , showWarnings = )
func_to_call <- "tab_rtauargus2"
.dots = ()
params <- param_function(((=func_to_call)), .dots)
params$dir_name = dir_name
params$cost_var = cost_var
params$value = value
params$freq = freq
params$suppress = suppress
params$suppress = suppress
params$split_tab = split_tab
params$nb_tab_option = nb_tab_option
params$limit = limit
n_tbx = (list_tables) # nombre de tableaux
(n_tbx == 0){
("Your list of tables is empty !")
}
(n_tbx == 1){
("To protect a single table, please use the function `tab_rtauargus`.")
}
(((list_tables))){
(list_tables) <- ("tab", 1:n_tbx)
(list_explanatory_vars) <- ("tab", 1:n_tbx)
}
noms_tbx <- (list_tables)
all_expl_vars <- (((list_explanatory_vars)))
( (!(hrc)) & (hrc)) hrc <- (hrc)
( (!(hrc)) & (((hrc)) == 0)){
("hrc must have names corresponding to the adequate explanatory variables")
}
((((hrc), all_expl_vars)) > 0){
("some names in hrc argument are not mentionned in list_explanatory_vars")
}
(!(alt_hrc)){
((((alt_hrc)) == 0)){
("alt_hrc must have names corresponding to the adequate tables names")
}
((((alt_hrc), noms_tbx)) > 0){
("some names in alt_hrc argument are not mentionned in list_tables")
}
}
(!(alt_totcode)){
((((alt_totcode)) == 0)){
("alt_totcode must have names corresponding to the adequate tables names")
}
((((alt_totcode), noms_tbx)) > 0){
("some names in alt_totcode argument are not mentionned in list_tables")
}
}
# list_totcode management
# first case : list_totcode is one length-character vector :
# all the expl variables in all the tables have the same value to refer to the total
((totcode)){
((totcode) == 1){
list_totcode <- purrr::map(
list_explanatory_vars,
(nom_tab){
::(
(totcode, (nom_tab)),
nom_tab
)
}
)
} ((totcode) == (all_expl_vars)){
(((totcode))){
("totcode of length > 1 must have names (explanatory_vars)")
}{
(!(((totcode)) == (all_expl_vars))){
("Names of explanatory vars mentioned in totcode are not consistent with those used in list_explanatory_vars")
}{
list_totcode <- purrr::map(
list_explanatory_vars,
(nom_vars){
totcode[nom_vars]
}
)
}
}
}{
("totcode has to be a character vector of length 1 or a named vector of length equal to the number of unique explanatory vars")
}
}{
("totcode has to be a character vector of length 1 or a named vector of length equal to the number of unique explanatory vars")
}
purrr::walk(
(alt_totcode),
(tab){
purrr::walk(
(alt_totcode[tab]]),
() list_totcode[tab]][var]] <<- alt_totcode[tab]][var]]
)
}
)
noms_vars_init <- ()
for (tab list_tables){
noms_vars_init <- (noms_vars_init, (tab))
}
noms_vars_init <- noms_vars_init!(noms_vars_init)]
noms_col_T <- ::(("T_", noms_tbx), noms_tbx)
table_majeure <- purrr::imap(
.x = list_tables,
.f = (tableau,nom_tab){
(!(cost_var)){
cost_var_tab <- (cost_var %in% (tableau)) cost_var
}{
cost_var_tab <-
}
secret_var_tab <- (!(params$secret_no_pl)) (secret_var,params$secret_no_pl) secret_var
tableau <- (tableau), (list_explanatory_vars[nom_tab]], value, freq, cost_var_tab, secret_var_tab)]
(!(params$secret_no_pl)){
(tableau)[names(tableau) == params$secret_no_pl] = "secret_no_pl"
} {
tableau$secret_no_pl <-
}
var_a_ajouter <- (all_expl_vars, (tableau))
for (nom_col var_a_ajouter){
tableau[nom_col]] <- (
purrr::keep(
list_totcode, (x) nom_col %in% (x)
)[1]][nom_col]
)
}
tableau[noms_col_T[nom_tab]]]] <-
((tableau))
}
)
# by_vars = setdiff(unique(unlist(purrr::map(table_majeure, names))), noms_col_T)
by_vars = purrr::reduce(purrr::map(table_majeure, ), )
table_majeure <- purrr::reduce(
.x = table_majeure,
.f = ,
= by_vars,
=
)
table_majeure$secret_no_pl_iter <- table_majeure$secret_no_pl
secret_no_pl_iter <- "secret_no_pl_iter"
purrr::walk(
noms_col_T,
(col_T){
e_par <- rlang::env_parent()
e_par$table_majeure[col_T]] <- (
(e_par$table_majeure[col_T]]),
,
e_par$table_majeure[col_T]]
)
}
)
# Uniformisation des libelles des variables explicatives
# res_unif <- uniformize_labels(table_majeure, all_expl_vars, hrc, list_totcode)
# table_majeure <- res_unif$data
# hrc_unif <- res_unif$hrc_unif
list_hrc <- purrr::map(
list_explanatory_vars,
(nom_vars){
purrr::discard(hrc[nom_vars], ) %>% ()
}
)
list_hrc <- purrr::map(list_hrc, (l) ((l) == 0) l)
purrr::walk(
(alt_hrc),
(tab){
purrr::walk(
(alt_hrc[tab]]),
() list_hrc[tab]][var]] <<- alt_hrc[tab]][var]]
)
}
)
# listes de travail
has_primary_secret <- purrr::map_lgl(
list_tables,
(tab){
(tab[secret_var]]) != 0
}
)
((has_primary_secret) == 0){
("None of the tables have any primary secret cells")
(list_tables)
}
todolist <- noms_tbx[has_primary_secret][1]
remainlist <- noms_tbx[has_primary_secret]-1]
num_iter_par_tab = ::((0, (list_tables)), noms_tbx)
num_iter_par_tab!has_primary_secret] <- 1
num_iter_all = 0
# common_cells_modified <- as.data.frame(matrix(ncol = length(all_expl_vars)+1))
# names(common_cells_modified) <- c(all_expl_vars, "iteration")
n_common_cells_modified <- 0
journal <- (dir_name,"journal.txt")
((journal)) ((journal))
journal_add_line(journal, "Start time:", (start_time, "%Y-%m-%d %H:%M:%S"))
journal_add_break_line(journal)
journal_add_line(journal, "Function called to protect the tables:", func_to_call)
journal_add_line(journal, "Interval Protection Level for primary secret cells:", ip_start)
journal_add_line(journal, "Interval Protection Level for other iterations:", ip_end)
journal_add_line(journal, "Nb of tables to treat: ", n_tbx)
journal_add_break_line(journal)
journal_add_line(journal, "Tables to treat:", noms_tbx)
journal_add_break_line(journal)
journal_add_line(journal, "All explanatory variables:", all_expl_vars)
journal_add_break_line(journal)
journal_add_line(journal, "Initialisation work completed")
journal_add_break_line(journal)
journal_add_break_line(journal)
((todolist) > 0 & (num_iter_par_tab <= num_iter_max)){
num_iter_all <- num_iter_all + 1
num_tableau <- todolist[1]
num_iter_par_tab[num_tableau] <- num_iter_par_tab[num_tableau] + 1
("--- Current table to treat: ", num_tableau, "---\n")
nom_col_identifiante <- ("T_", num_tableau)
tableau_a_traiter <- (table_majeure[nom_col_identifiante]])
if (num_iter_all == 1){
var_secret_apriori <- secret_var
} {
var_secret_apriori <- ("is_secret_", num_iter_all-1, collapse = "")
}
vrai_tableau <- table_majeure[tableau_a_traiter,]
ex_var <- list_explanatory_vars[num_tableau]]
vrai_tableau <- vrai_tableau,(ex_var, value, freq,var_secret_apriori,secret_no_pl_iter, cost_var)]
# Other settings of the function to make secret ----
params$tabular = vrai_tableau
params$files_name = num_tableau
params$explanatory_vars = ex_var
params$totcode = list_totcode[num_tableau]]
params$hrc = list_hrc[num_tableau]]
params$secret_var = var_secret_apriori
params$secret_no_pl = secret_no_pl_iter
params$suppress = (
(suppress,1,3) == "MOD" & num_iter_par_tab[num_tableau] != 1
){
# if modular deactivation of singleton and multisingleton after the first iteration
(
(
((suppress, = ",")[1]][1:2], ("0",3)), collapse = ","
),
")"
)
}{
suppress
}
params$ip = (num_iter_par_tab[num_tableau] == 1) ip_start ip_end
# params$safety_rules <- "MAN(0)"
res <- (func_to_call, params)
res$is_secret <- res$Status != "V"
# Statistiques
prim_stat <- (res$Status == "B", na.rm = )
sec_stat <- (res$Status == "D", na.rm = )
valid_stat <- (res$Status == "V", na.rm = )
denom_stat <- (res)
res <- (res, select = ((res), "Status"))
var_secret <- ("is_secret_", num_iter_all)
table_majeure <- (table_majeure, res, = )
table_majeure[var_secret]] <- table_majeure$is_secret
table_majeure <- (
table_majeure,
select = ((table_majeure), "is_secret")
)
table_majeure[var_secret]] <- (
(table_majeure[var_secret]]),
table_majeure[var_secret_apriori]],
table_majeure[var_secret]]
)
table_majeure$secret_no_pl_iter <- (
table_majeure[secret_var]],
table_majeure$secret_no_pl,
table_majeure[var_secret]]
) #TODO A REVOIR PR CORRIGER LES PL
lignes_modifs <- (table_majeure[var_secret_apriori]] != table_majeure[var_secret]])
cur_tab <- ("T_", num_tableau)
common_cells <- (
purrr::map_dfr(
(noms_col_T, cur_tab),
(col_T){
table_majeure[table_majeure[col_T]] & table_majeure[cur_tab]],]
}
)
)
# update of common cells that have been modified
modified <- common_cells[common_cells[var_secret_apriori]] != common_cells[var_secret]],all_expl_vars]
# modified <- if(sum(is.na(modified))>0) modified[1,][-1,] else modified
((modified) > 0){
modified <- (modified, iteration = num_iter_all)
common_cells_modified <- (n_common_cells_modified == 0) modified (common_cells_modified, modified)
n_common_cells_modified <- n_common_cells_modified + (modified)
}
(tab noms_tbx){
nom_col_identifiante <- ("T_", tab)
( !(tab %in% todolist)
& ((table_majeure[nom_col_identifiante]][lignes_modifs]))
){
todolist <- (todolist,tab)
remainlist <- remainlist[remainlist != tab]
}
}
todolist <- todolist-1]
((todolist) == 0){
((remainlist) > 0){
todolist <- remainlist[1]
remainlist <- remainlist-1]
}
}
journal_add_line(journal, num_iter_all, "-Treatment of table", num_tableau)
journal_add_break_line(journal)
journal_add_line(journal, "New cells status counts: ")
journal_add_line(journal, "- apriori (primary) secret:", prim_stat, "(", (prim_stat/denom_stat*100,1), "%)")
journal_add_line(journal, "- secondary secret:", sec_stat , "(", (sec_stat/denom_stat*100,1), "%)")
journal_add_line(journal, "- valid cells:", valid_stat, "(", (valid_stat/denom_stat*100,1), "%)")
journal_add_break_line(journal)
journal_add_line(journal, "Nb of new common cells hit by the secret:", (modified))
journal_add_break_line(journal)
journal_add_break_line(journal)
}
# Reconstruire la liste des tableaux d'entrée
liste_tbx_res <- purrr::imap(
list_tables,
(tab,nom){
expl_vars <- list_explanatory_vars[nom]]
tab_rows <- table_majeure[paste0("T_", nom)]]
secret_vars <- (table_majeure)[grep("^is_secret_[1-9]", (table_majeure))]
secret_vars <- secret_vars[order((("is_secret_", "", secret_vars)))]
res <- (
tab,
table_majeure[tab_rows, (expl_vars, secret_vars)],
all.x = , all.y = , = expl_vars
)
}
)
last_secret <- ("is_secret_", num_iter_all)
<- purrr::imap_dfr(
liste_tbx_res,
(tab, ){
tab$primary_secret <- tab[secret_var]]
tab$total_secret <- tab[last_secret]]
tab$secondary_secret <- tab$total_secret & !tab$primary_secret
tab$valid_cells <- !tab$total_secret
res <- (
tab_name = ,
primary_secret = (tab$primary_secret),
secondary_secret = (tab$secondary_secret),
total_secret = (tab$total_secret),
valid_cells = (tab$valid_cells)
)
}
)
purrr::iwalk(
num_iter_par_tab,
(num,tab){
journal_add_line(
journal,
"End of iterating after", num, "iterations for", tab
)
}
)
journal_add_break_line(journal)
journal_add_line(journal, "Final Summary")
journal_add_break_line(journal)
journal_add_line(journal, "Secreted cells counts per table")
journal_add_break_line(journal)
purrr::walk(
noms_tbx,
(tab){
journal_add_line(
journal,
"---TAB ", tab, " ---"
)
<- ([stats$tab_name == tab,-1,=])
(gdata::write.fwf(, = , = , = journal, = ))
journal_add_break_line(journal)
}
)
journal_add_break_line(journal)
journal_add_line(journal, "Common cells hit by the secret:")
(n_common_cells_modified > 0){
(gdata::write.fwf(common_cells_modified, = journal, = ))
}
journal_add_break_line(journal)
journal_add_line(journal, "End time: ", ((), "%Y-%m-%d %H:%M:%S"))
journal_add_break_line(journal)
(liste_tbx_res)
}
