Stats secret

DESCRIPTION

@@ -74,4 +74,4 @@ URL: https://inseefrlab.github.io/rtauargus,
 BugReports: https://github.com/inseefrlab/rtauargus/issues
 Roxygen: list(markdown = TRUE)
 StagedInstall: no
-Config/roxygen2/version: 8.0.0
+Config/roxygen2/version: 8.1.0

NAMESPACE

@@ -28,6 +28,7 @@ export(run_arb)
 export(sp_format)
 export(split_dataframe)
 export(split_in_clusters)
+export(summarize_secret)
 export(tab_arb)
 export(tab_multi_manager)
 export(tab_rda)
@@ -46,19 +47,24 @@ 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)
@@ -68,6 +74,7 @@ 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)

R/globals.R

@@ -6,5 +6,6 @@ utils::globalVariables(
     "starts_with","spanning_name","hrc_spanning_name","eq_indicator","rhs","total","term_number",
     "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",".")
+    "totcode","all_combinations","covered_sides","VALUE", "status", "nb_cells",
+    "value",".")
 )

R/multitable.R

@@ -122,6 +122,7 @@ tab_multi_manager <- function(
     ip_start = 10,
     ip_end = 0,
     num_iter_max = 10,
+    summary_secret = FALSE,
     split_tab = FALSE,
     nb_tab_option = "smart",
     limit = 14700,
@@ -506,24 +507,10 @@ tab_multi_manager <- function(
       )
     }
   )
-  last_secret <- paste0("is_secret_", num_iter_all)
 
-  stats <- purrr::imap_dfr(
-    liste_tbx_res,
-    function(tab, name){
-      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 <- data.frame(
-        tab_name = name,
-        primary_secret = sum(tab$primary_secret),
-        secondary_secret = sum(tab$secondary_secret),
-        total_secret = sum(tab$total_secret),
-        valid_cells = sum(tab$valid_cells)
-      )
-    }
-  )
+  stats_out <- summarize_secret(liste_tbx_res, var = value, secret_var = secret_var)
+
+  last_secret <- paste0("is_secret_", num_iter_all)
 
   purrr::iwalk(
     num_iter_par_tab,
@@ -539,15 +526,15 @@ tab_multi_manager <- function(
   journal_add_break_line(journal)
   journal_add_line(journal, "Secreted cells counts per table")
   journal_add_break_line(journal)
-  purrr::walk(
-    noms_tbx,
-    function(tab){
+  purrr::iwalk(
+    stats_out,
+    function(tab_stats, tab_name){
       journal_add_line(
         journal,
-        "---TAB ", tab, " ---"
+        "---TAB ", tab_name, " ---"
       )
-      df <- t(stats[stats$tab_name == tab,-1,drop=FALSE])
-      suppressWarnings(gdata::write.fwf(df, rownames = TRUE, colnames = FALSE, file = journal, append = TRUE))
+      # df <- t(stats[stats$tab_name == tab,-1,drop=FALSE])
+      suppressWarnings(gdata::write.fwf(tab_stats, rownames = TRUE, colnames = TRUE, file = journal, append = TRUE))
       journal_add_break_line(journal)
     }
   )
@@ -560,5 +547,14 @@ tab_multi_manager <- function(
   journal_add_line(journal, "End time: ", format(Sys.time(), "%Y-%m-%d  %H:%M:%S"))
   journal_add_break_line(journal)
 
-  return(liste_tbx_res)
+
+  if(summary_secret){
+
+    return( append(liste_tbx_res, list(stats = stats_out)) )
+
+  }else{
+
+    return(liste_tbx_res)
+  }
+
 }

R/summarize_secret.R

@@ -0,0 +1,125 @@
+#' 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
+#' @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
+#' @returns data.frame or list of data.frames
+#' @export
+#'
+#' @examples
+#'\dontrun{
+#' library(dplyr)
+#' data(turnover_act_size)
+#'
+#' # Prepare data with primary secret ----
+#' turnover_act_size <- turnover_act_size %>%
+#'   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
+#'   )
+#'
+#' # Make hrc file of business sectors ----
+#' data(activity_corr_table)
+#' hrc_file_activity <- activity_corr_table %>%
+#'   write_hrc2(file_name = "hrc/activity")
+#'
+#' # Compute the secondary secret ----
+#' options(
+#'   rtauargus.tauargus_exe =
+#'     "Y:/Logiciels/TauArgus/TauArgus4.2.3/TauArgus.exe"
+#' )
+#'
+#' res <- tab_rtauargus(
+#'   tabular = turnover_act_size,
+#'   files_name = "turn_act_size",
+#'   dir_name = "tauargus_files",
+#'   explanatory_vars = c("ACTIVITY", "SIZE"),
+#'   hrc = c(ACTIVITY = hrc_file_activity),
+#'   totcode = c(ACTIVITY = "Total", SIZE = "Total"),
+#'   secret_var = "is_secret_prim",
+#'   value = "TOT",
+#'   freq = "N_OBS",
+#'   verbose = FALSE
+#' )
+#'
+#' summarize_secret(res, "TOT")
+#' summarize_secret(res)
+#' }
+#' @importFrom dplyr case_when
+#' @importFrom dplyr last_col
+#' @importFrom dplyr tibble
+#' @importFrom dplyr rename_with
+#' @importFrom dplyr n
+#' @importFrom purrr list_c
+summarize_secret <- function(res_tau, var = NULL, secret_var = "is_secret_prim"){
+
+  if( is.data.frame(res_tau) ) {
+
+    if( !is.null(var)  &&  ! var %in% names(res_tau) ){
+
+      stop("The variable has to be present in the data.frame")
+
+    }
+
+    if( ! secret_var %in% names(res_tau) ){
+
+      stop("The primary secret variable has to be present in the data.frame")
+
+    }
+
+    tab_mod <- res_tau %>%
+      {if( ! is.null(var) ) dplyr::rename_with(., ~"VALUE", all_of(var)) else .} |>
+      dplyr::rename_with(~"final_status_ta", last_col()) |>
+      dplyr::rename_with(~"is_secret_prim", all_of(secret_var)) |>
+      dplyr::mutate(
+        status = case_when(
+          is_secret_prim  ~ "primary suppr.",
+          final_status_ta != "V" ~ "secondary suppr.",
+          TRUE ~ "published"
+        )) |>
+      dplyr::mutate(status = factor(
+        status,
+        levels = c("primary suppr.", "secondary suppr.", "published", "total"),
+        ordered = TRUE)
+      )
+
+    stats <- tab_mod |>
+      group_by(status) %>%
+      {if( ! is.null(var) ) dplyr::summarise(., nb_cells = n(), value = sum(VALUE) ) else dplyr::summarise(., nb_cells = n()) } |>
+      dplyr::bind_rows(
+        dplyr::tibble(
+          status = "total",
+          tab_mod %>% {if( ! is.null(var) ) dplyr::summarise(., nb_cells = n(), value = sum(VALUE)) else dplyr::summarise(., nb_cells = n()) }
+        )
+      ) |>
+      mutate(pourc_cells = round( nb_cells/nb_cells[status == "total"]*100, 2 ) ) %>%
+      {if( ! is.null(var) ) dplyr::mutate(., round( pourc_value = value/value[status == "total"]*100, 2 ) ) else . }
+
+    return(stats)
+
+  }else if( any(! purrr::map(res_tau, is.data.frame) |> purrr::list_c()) ){
+
+    stop("res_tau has to be a data.frame or a list of data.frames")
+
+  }else{
+
+    if( !( is.null(var) ) & any(! purrr::map(res_tau, \(t) var %in% names(t)) |> purrr::list_c()) ){
+
+      stop("The variable has to be present in each of the dataframes")
+
+    }
+
+    if( any(! purrr::map(res_tau, \(t) secret_var %in% names(t)) |> purrr::list_c()) ){
+
+      stop("The primary secret variable has to be present in the data.frame")
+
+    }
+
+    return( purrr::map(res_tau, summarize_secret, var = var) )
+
+  }
+
+}

R/tab_rtauargus.R

@@ -11,6 +11,7 @@
 #' All files will have the same name, only their extension will be different.
 #' @param dir_name string indicated the path of the directory in which to save
 #' all the files (.rda, .hst, .txt, .arb, .csv) generated by the function.
+#' @param summary_secret If `TRUE`, a statistical summary of the suppression is provided along with the masked data.
 #' @param unif_labels boolean, if explanatory variables have to be standardized
 #' @param split_tab `r lifecycle::badge("experimental")` boolean,
 #' whether to reduce dimension to 3 while treating a table of dimension 4 or 5
@@ -31,12 +32,16 @@
 #' for the treatment of tabular.
 #'
 #' @return
-#' If output_type equals to 4 and split_tab = FALSE,
+#' If output_type equals to 4 and summary_secret = FALSE and split_tab = FALSE,
 #' then the original tabular is returned with a new
 #' column called Status, indicating the status of the cell coming from Tau-Argus :
 #' "A" for a primary secret due to frequency rule, "B" for a primary secret due
 #' to dominance rule, "D" for secondary secret and "V" for no secret cell.
 #'
+#' If summary_secret = TRUE,
+#' then the function returns a list of two data.frames,
+#' including the masked data (`mask`) and the stats data (`stats`).
+#'
 #' If split_tab = TRUE,
 #' then the original tabular is returned with some new columns which are boolean
 #' variables indicating the status of a cell at each iteration of the protection
@@ -45,7 +50,8 @@
 #' final status of the suppression process of the original table.
 #'
 #' If `split_tab = FALSE` and  `output_type` doesn't equal to `4`,
-#' then the raw result from tau-argus is returned.
+#' then the raw result from tau-argus is written as a csv file in `dir_name`
+#' directory and `NULL` is returned to R.
 #'
 #' @section Standardization of explanatory variables and hierarchies:
 #'
@@ -127,6 +133,7 @@ tab_rtauargus <- function(
     maxscore = NULL,
     suppress = "MOD(1,5,1,0,0)",
     safety_rules = paste0("MAN(",ip,")"),
+    summary_secret = FALSE,
     show_batch_console = FALSE,
     output_type = 4,
     output_options = "",
@@ -289,7 +296,7 @@ and the process may take longer.")
   param_run$show_batch_console <- show_batch_console
 
   # appel
-  res <- do.call(run_arb, param_run)
+  invisible( do.call(run_arb, param_run) )
 
   # RESULTAT .............................
   if(output_type == 4){
@@ -316,16 +323,16 @@ and the process may take longer.")
       row.names = FALSE
     )
 
-    return(mask)
-
-  }else{
-    if(unif_labels){
-      res <- cbind.data.frame(
-        apply(res[,explanatory_vars,drop=FALSE], 2, rev_var_pour_tau_argus),
-        res[, !names(res) %in% explanatory_vars]
+    if(summary_secret){
+      return(
+        list(
+          mask = mask,
+          stats = summarize_secret(mask, var = value, secret_var = secret_var)
+        )
       )
+    }else{
+      return(mask)
     }
-    return(res)
   }
 
 }
@@ -442,6 +449,7 @@ tab_rtauargus2 <- function(
   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$summary_secret = FALSE
   params$show_batch_console = FALSE
   params$output_type = 4
   params$output_options = ""