From 3ce2bb0ef3a5e7db276dcf23ccfa00594074da64 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jungyeon=20Choi=20=EC=B5=9C=EC=A0=95=EC=97=B0?= Date: Tue, 14 Oct 2025 13:22:07 +0200 Subject: [PATCH 1/6] add formatting functionality --- R/masking-functions.R | 184 ++++++++++++++++++++++++++++++------------ 1 file changed, 131 insertions(+), 53 deletions(-) diff --git a/R/masking-functions.R b/R/masking-functions.R index 5494ae6..2a18639 100644 --- a/R/masking-functions.R +++ b/R/masking-functions.R @@ -1,3 +1,23 @@ +#' @description +#' Format numbers by adding thousand separators +#' and rounding to a relevant decimal +#' @param vec a numeric or integer vector +#' @param big_mark_seperator a separator for every thousand +#' @param rounding_digits a number of decimal digits to show +format_num <- function(vec, + big_mark_seperator = "", + rounding_digits = 2) { + if (is.integer(vec)) vec <- formatC(vec, big.mark = big_mark_seperator) + if (is.numeric(vec)) { + vec <- formatC(vec, + big.mark = big_mark_seperator, + format = "f", + digits = rounding_digits + ) + } + return(vec) +} + #' Helper: check if the value for the count is equal to one of the exception values #' (i.e., not a valid positive count) #' @@ -37,11 +57,16 @@ is_exception <- function(value){ mask_vector <- function(input_vector, threshold = 5, rounding_digits = 2, + big_mark_seperator = "", output_warnings = TRUE, percentage = FALSE, total = NULL){ - + # Allow a wide format data frame or data table input by changing into a matrix + if(is.data.frame(input_vector)|data.table::is.data.table(input_vector)){ + input_vector <- t(input_vector)[,1] + } + ###### 1. IDENTIFY COUNTS AND INGORE EXCEPTIONS ##### # Flag positive integers (equivalently, non-exceptions values) positive_counts_indices <- !sapply(input_vector, is_exception) @@ -53,14 +78,23 @@ mask_vector <- function(input_vector, # If not provided, compute total as the sum of each category if(is.null(total)){ - total <- sum(counts) + total <- sum(counts) } # Create string to replace masked values below the threshold. String is different depending on whether result is # integers or percentages. if(percentage){ - below_threshold_pcn_lower <- round((1/total)*100, digits = rounding_digits) - below_threshold_pcn_upper <- round(((threshold-1)/total)*100, digits = rounding_digits) + below_threshold_pcn_lower <- format_num( + (1/total)*100, + big_mark_seperator = big_mark_seperator, + rounding_digits = rounding_digits + ) + below_threshold_pcn_upper <- format_num( + ((threshold-1)/total)*100, + big_mark_seperator = big_mark_seperator, + rounding_digits = rounding_digits + ) + below_threshold_sub <- paste0('[',below_threshold_pcn_lower, '-' , below_threshold_pcn_upper, ']') } else { below_threshold_sub <- paste0('[1-', threshold-1, ']') @@ -71,12 +105,19 @@ mask_vector <- function(input_vector, # Handle inputs of length 1: types TF or cat with one category ## If the input is an exception left as is - if(length(input_vector) == 1 & is_exception(input_vector[1])) return(input_vector) + if(length(input_vector) == 1 & is_exception(input_vector[1])) { + return(formatC(input_vector, big.mark = big_mark_seperator)) + } + ## Input may be of length >1, even if there is only one non-exception value ## In that case, apply proper masking to that count and leave other values as is if(length(counts) == 1 & is.null(total)){ # Substitute count according to rule - input_vector[positive_counts_indices] <- ifelse(counts < threshold, below_threshold_sub, counts) + input_vector[positive_counts_indices] <- ifelse( + counts < threshold, + below_threshold_sub, + formatC(counts, big.mark = big_mark_seperator) + ) return(input_vector) } @@ -101,7 +142,7 @@ mask_vector <- function(input_vector, # Compute number of masked values, needed for both warnings and computing bounds of masked interval n_masked <- sum(naively_masked_logical) - + # Interval masking is only applied when both conditions are true: # 1) not all values are naively masked # 2) at least one value is naively masked, i.e., not all values are unmasked (in which case nothing is necessary) @@ -177,20 +218,50 @@ mask_vector <- function(input_vector, effective.lower.int <- max(theoretical.lower.int, threshold) ####### MASK INTERVAL ########## - ### First, generate string for substitution. ## String depends on whether output is percentage or integers if(percentage == TRUE){ - interval_mask_sub_lower <- round((effective.lower.int/total)*100, digits = rounding_digits) - interval_mask_sub_upper <- round((theoretical.upper.int/total)*100, digits = rounding_digits) + interval_mask_sub_lower <- format_num( + (effective.lower.int/total)*100, + big_mark_seperator = big_mark_seperator, + rounding_digits = rounding_digits + ) + interval_mask_sub_upper <- format_num( + (theoretical.upper.int/total)*100, + big_mark_seperator = big_mark_seperator, + rounding_digits = rounding_digits + ) interval_mask_sub <- paste0('[', interval_mask_sub_lower, '-', interval_mask_sub_upper, ']') } else { - interval_mask_sub <- paste0('[',effective.lower.int, '-', theoretical.upper.int, ']') + interval_mask_sub <- paste0( + '[', + formatC(effective.lower.int, big.mark = big_mark_seperator), + '-', + formatC(theoretical.upper.int, big.mark = big_mark_seperator), + ']' + ) } ### Then, substitute value in masked counts - masked_counts[interval_masked_index] <- interval_mask_sub - + if(percentage){ + masked_counts <- ifelse( + masked_counts %in% masked_counts[interval_masked_index], + interval_mask_sub, + format_num( + masked_counts, + big_mark_seperator =big_mark_seperator, + rounding_digits = rounding_digits + ) + ) + } else { + masked_counts <- ifelse( + # for the values to be masked + seq_along(masked_counts) %in% interval_masked_index, + # replace them with the matching ones saved in 'interval_masked_index' + interval_mask_sub[match(seq_along(masked_counts), interval_masked_index)], + masked_counts + ) + } } ###### 4.2. APPLY 'NAIVE' MASKING @@ -235,7 +306,7 @@ mask_vector <- function(input_vector, # If they add up to something lower, this will be within the interval ## Note: if all values are naively masked, the original values need to add up exactly to the total. - + if(any(not_naively_masked_logical)) { maximum_to_split <- total - sum(not_masked_values) - effective.lower.int} @@ -257,7 +328,14 @@ mask_vector <- function(input_vector, n_impossible <- length(combinations_grid$possible[combinations_grid$possible == 'Impossible']) n <- length(combinations_grid$possible) - perc_impossible <- paste0(round((n_impossible/n)*100,digits = rounding_digits), '%') + perc_impossible <- paste0( + format_num( + (n_impossible/n)*100, + big_mark_seperator = big_mark_seperator, + rounding_digits = rounding_digits + ), + '%' + ) warning(paste0('This table may not be safe. Of all possible combinations of naively masked values, ', perc_impossible, ' original value combinations can be excluded')) @@ -290,7 +368,7 @@ mask_vector_wrapper <- function(tableout, threshold = 5, count.names = c('V1_CONTROL', 'V1_EXPOSED'), pct.names = c('V2_CONTROL', 'V2_EXPOSED'), table_metadata){ - + tableout <- as.data.frame(tableout) table_metada <- as.data.frame(table_metadata) # Gen index in metadata table and output table @@ -331,9 +409,9 @@ mask_vector_wrapper <- function(tableout, threshold = 5, # Iterate over variable index and mask each vector/variable for(i in seq_along(variables_index)){ - # if(i == 4){browser()} + # if(i == 4){browser()} var_index <- variables_index[i] # Get the variable name. Note some might be repeated (same value, but different index) - + # Filter table to only that category tableout_reduced <- tableout |> dplyr::filter(index == var_index) @@ -343,7 +421,7 @@ mask_vector_wrapper <- function(tableout, threshold = 5, # For TF or cat with one category, the total is not computed, but taken from row 1 is_TF <- tableout_reduced$type[1] == 'TF' - + if(is_TF | nrow(tableout_reduced) == 1){ total_count1 <- as.numeric(tableout[1, count.names[1]]) # because total is in row 1 total_count2 <- as.numeric(tableout[1, count.names[2]]) @@ -353,40 +431,40 @@ mask_vector_wrapper <- function(tableout, threshold = 5, } if(type_should_be_masked){ - # Extract vector of category couns for exposed and control groups, exposed - counts.1 <- as.numeric(tableout_reduced[[count.names[1]]]) - counts.2 <- as.numeric(tableout_reduced[[count.names[2]]]) - - # Apply interval mask function - masked.counts.1 <- mask_vector(counts.1, threshold = threshold, - rounding_digits = rounding_digits, - output_warnings = output_warnings, - total = total_count1) - masked.counts.2 <- mask_vector(counts.2, threshold = threshold, - rounding_digits = rounding_digits, - output_warnings = output_warnings, - total = total_count2) - masked.pcts.1 <- mask_vector(counts.1, threshold = threshold, - rounding_digits = rounding_digits, - output_warnings = output_warnings, - total = total_count1, - percentage = TRUE) - masked.pcts.2 <- mask_vector(counts.2, threshold = threshold, - output_warnings = output_warnings, - rounding_digits = rounding_digits, - total = total_count2, - percentage = TRUE) - - # Get row indices of first and last ocurrence of the variable in the - # original descriptibles table - first_index <- which(tableout$index == var_index)[1] - last_index <- utils::tail(which(tableout$index == var_index), n = 1) - - # Replace appropriate rows and columns, based on index of variable ocurrence and column names - tableout[first_index:last_index, count.names[1]] <- masked.counts.1 - tableout[first_index:last_index, count.names[2]] <- masked.counts.2 - tableout[first_index:last_index, pct.names[1]] <- masked.pcts.1 - tableout[first_index:last_index, pct.names[2]] <- masked.pcts.2 + # Extract vector of category couns for exposed and control groups, exposed + counts.1 <- as.numeric(tableout_reduced[[count.names[1]]]) + counts.2 <- as.numeric(tableout_reduced[[count.names[2]]]) + + # Apply interval mask function + masked.counts.1 <- mask_vector(counts.1, threshold = threshold, + rounding_digits = rounding_digits, + output_warnings = output_warnings, + total = total_count1) + masked.counts.2 <- mask_vector(counts.2, threshold = threshold, + rounding_digits = rounding_digits, + output_warnings = output_warnings, + total = total_count2) + masked.pcts.1 <- mask_vector(counts.1, threshold = threshold, + rounding_digits = rounding_digits, + output_warnings = output_warnings, + total = total_count1, + percentage = TRUE) + masked.pcts.2 <- mask_vector(counts.2, threshold = threshold, + output_warnings = output_warnings, + rounding_digits = rounding_digits, + total = total_count2, + percentage = TRUE) + + # Get row indices of first and last ocurrence of the variable in the + # original descriptibles table + first_index <- which(tableout$index == var_index)[1] + last_index <- utils::tail(which(tableout$index == var_index), n = 1) + + # Replace appropriate rows and columns, based on index of variable ocurrence and column names + tableout[first_index:last_index, count.names[1]] <- masked.counts.1 + tableout[first_index:last_index, count.names[2]] <- masked.counts.2 + tableout[first_index:last_index, pct.names[1]] <- masked.pcts.1 + tableout[first_index:last_index, pct.names[2]] <- masked.pcts.2 } } # drop index column From 553f3f80241cda23505132670a714bdedcd1e7f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jungyeon=20Choi=20=EC=B5=9C=EC=A0=95=EC=97=B0?= Date: Wed, 15 Oct 2025 10:54:29 +0200 Subject: [PATCH 2/6] create a wrapper function mask_row_table also add a condition to return formatting outputs when there is nothing to mask --- R/masking-functions.R | 83 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 75 insertions(+), 8 deletions(-) diff --git a/R/masking-functions.R b/R/masking-functions.R index 2a18639..88a089f 100644 --- a/R/masking-functions.R +++ b/R/masking-functions.R @@ -62,11 +62,6 @@ mask_vector <- function(input_vector, percentage = FALSE, total = NULL){ - # Allow a wide format data frame or data table input by changing into a matrix - if(is.data.frame(input_vector)|data.table::is.data.table(input_vector)){ - input_vector <- t(input_vector)[,1] - } - ###### 1. IDENTIFY COUNTS AND INGORE EXCEPTIONS ##### # Flag positive integers (equivalently, non-exceptions values) positive_counts_indices <- !sapply(input_vector, is_exception) @@ -74,13 +69,28 @@ mask_vector <- function(input_vector, counts <- as.numeric(input_vector[positive_counts_indices]) # Masking is applied to numerical counts. Exception values are left unchanged. - ##### 2. CREATE STRING TO SUBSTITUTE VALUES BELOW THRESHOLD - # If not provided, compute total as the sum of each category if(is.null(total)){ total <- sum(counts) } + # IF nothing to be masked, return input_vector with formatting. + # This ensure vectors that need a masking procedure will be in a string format. + if(all(input_vector >= threshold | input_vector < 1)){ + if(percentage){ + return( + format_num( + (input_vector/total)*100, + big_mark_seperator = big_mark_seperator, + rounding_digits = rounding_digits + ) + ) + } else { + return(formatC(input_vector, big.mark = big_mark_seperator)) + } + } + + ##### 2. CREATE STRING TO SUBSTITUTE VALUES BELOW THRESHOLD # Create string to replace masked values below the threshold. String is different depending on whether result is # integers or percentages. if(percentage){ @@ -101,7 +111,7 @@ mask_vector <- function(input_vector, } - ###### 3. HANDLE INPUTS OF LENGTH 1 + ###### 3. HANDLE INPUTS OF LENGTH 1 # Handle inputs of length 1: types TF or cat with one category ## If the input is an exception left as is @@ -365,6 +375,7 @@ mask_vector <- function(input_vector, mask_vector_wrapper <- function(tableout, threshold = 5, output_warnings = FALSE, rounding_digits = 2, + big_mark_seperator = "", count.names = c('V1_CONTROL', 'V1_EXPOSED'), pct.names = c('V2_CONTROL', 'V2_EXPOSED'), table_metadata){ @@ -438,19 +449,23 @@ mask_vector_wrapper <- function(tableout, threshold = 5, # Apply interval mask function masked.counts.1 <- mask_vector(counts.1, threshold = threshold, rounding_digits = rounding_digits, + big_mark_seperator = big_mark_seperator, output_warnings = output_warnings, total = total_count1) masked.counts.2 <- mask_vector(counts.2, threshold = threshold, rounding_digits = rounding_digits, + big_mark_seperator = big_mark_seperator, output_warnings = output_warnings, total = total_count2) masked.pcts.1 <- mask_vector(counts.1, threshold = threshold, rounding_digits = rounding_digits, + big_mark_seperator = big_mark_seperator, output_warnings = output_warnings, total = total_count1, percentage = TRUE) masked.pcts.2 <- mask_vector(counts.2, threshold = threshold, output_warnings = output_warnings, + big_mark_seperator = big_mark_seperator, rounding_digits = rounding_digits, total = total_count2, percentage = TRUE) @@ -472,3 +487,55 @@ mask_vector_wrapper <- function(tableout, threshold = 5, return(tableout) } + + + +#' @description +#' A wrapper function for mask_vector() that allows a wide format data frame +#' or data table input and apply masking across a set of columns for every row. +#' The output returns the input data of the same format with the specified columns masked. +#' +#' @param input_row_table a data set where each column contains a variable to be masked +#' @param maskcols a string vector with the column names for the variables that +#' should be masked together for the secondary data disclosure + +mask_row_table <- function(input_row_table, + maskcols = c(), + threshold = 5, + rounding_digits = 2, + big_mark_seperator = "", + output_warnings = TRUE, + percentage = FALSE, + total = NULL){ + + # check the input format + if(!(is.data.frame(input_row_table)| + data.table::is.data.table(input_row_table))) { + stop("Your input for masking is not a data.frame or data.table.") + } + + # ensure data.table format + thisdat <- data.table::data.table(input_row_table) + + # mask across the columns for each row + thisdat[ + , (maskcols) := + data.table::as.data.table( + t(apply(.SD, 1, function(row) + mask_vector(row, + threshold = threshold, + rounding_digits = rounding_digits, + big_mark_seperator = big_mark_seperator, + output_warnings = output_warnings, + total = NULL) + ) + ) + ), .SDcols = maskcols] + + # covert to data.frame if the input was not data.table. + if(!data.table::is.data.table(input_row_table)){ + thisdat <- data.frame(thisdat) + } + + return(print(thisdat)) +} From 8889300698f682a8e46f0bd42293121ca39d2468 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jungyeon=20Choi=20=EC=B5=9C=EC=A0=95=EC=97=B0?= Date: Wed, 15 Oct 2025 16:48:12 +0200 Subject: [PATCH 3/6] add missing percentage argument --- R/masking-functions.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/masking-functions.R b/R/masking-functions.R index 88a089f..b95e276 100644 --- a/R/masking-functions.R +++ b/R/masking-functions.R @@ -526,6 +526,7 @@ mask_row_table <- function(input_row_table, threshold = threshold, rounding_digits = rounding_digits, big_mark_seperator = big_mark_seperator, + percentage = percentage, output_warnings = output_warnings, total = NULL) ) From 2f703280942463bcceb2a131a1b8d1885a1c23be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jungyeon=20Choi=20=EC=B5=9C=EC=A0=95=EC=97=B0?= Date: Wed, 15 Oct 2025 16:52:59 +0200 Subject: [PATCH 4/6] option to change column names --- R/masking-functions.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/masking-functions.R b/R/masking-functions.R index b95e276..5e3bae4 100644 --- a/R/masking-functions.R +++ b/R/masking-functions.R @@ -501,6 +501,7 @@ mask_vector_wrapper <- function(tableout, threshold = 5, mask_row_table <- function(input_row_table, maskcols = c(), + newcolnames = NULL, threshold = 5, rounding_digits = 2, big_mark_seperator = "", @@ -533,6 +534,10 @@ mask_row_table <- function(input_row_table, ) ), .SDcols = maskcols] + if(!is.null(newcolnames)){ + data.table::setnames(thisdat, maskcols, newcolnames) + } + # covert to data.frame if the input was not data.table. if(!data.table::is.data.table(input_row_table)){ thisdat <- data.frame(thisdat) From 18ca1b013c1f4332edcd46a1bda9d8475d512e70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jungyeon=20Choi=20=EC=B5=9C=EC=A0=95=EC=97=B0?= Date: Thu, 16 Oct 2025 01:16:13 +0200 Subject: [PATCH 5/6] when 0, do not show trailing 0 in decimals --- R/masking-functions.R | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/R/masking-functions.R b/R/masking-functions.R index 5e3bae4..f1557fd 100644 --- a/R/masking-functions.R +++ b/R/masking-functions.R @@ -9,10 +9,12 @@ format_num <- function(vec, rounding_digits = 2) { if (is.integer(vec)) vec <- formatC(vec, big.mark = big_mark_seperator) if (is.numeric(vec)) { - vec <- formatC(vec, - big.mark = big_mark_seperator, - format = "f", - digits = rounding_digits + vec <- ifelse(vec == 0, + "0", + formatC(vec, + big.mark = big_mark_seperator, + format = "f", + digits = rounding_digits) ) } return(vec) @@ -529,7 +531,8 @@ mask_row_table <- function(input_row_table, big_mark_seperator = big_mark_seperator, percentage = percentage, output_warnings = output_warnings, - total = NULL) + total = NULL, + print = TRUE) ) ) ), .SDcols = maskcols] @@ -543,5 +546,5 @@ mask_row_table <- function(input_row_table, thisdat <- data.frame(thisdat) } - return(print(thisdat)) + if(print) print(thisdat) else invisible(thisdat) } From 03bdec77b47ea2c81bf3d0bee05478319d873b59 Mon Sep 17 00:00:00 2001 From: Carlos <85176234+CarlosPoses@users.noreply.github.com> Date: Mon, 26 Jan 2026 16:28:47 +0100 Subject: [PATCH 6/6] test expect character expected value of mask_vector is character now, so reflected in tests --- tests/testthat/test-interval-masking.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-interval-masking.R b/tests/testthat/test-interval-masking.R index 23d933d..227de91 100644 --- a/tests/testthat/test-interval-masking.R +++ b/tests/testthat/test-interval-masking.R @@ -23,7 +23,7 @@ test_that("masking a numerical vector returns correct output", { expect_equal(mask_vector(c(0, 1,2,1,1), threshold = 7, output_warnings = F), c(0,'[1-6]', '[1-6]', '[1-6]', '[1-6]')) # No count needs to be masked - expect_equal(mask_vector(c(6, 97, 100)), c(6,97,100)) + expect_equal(mask_vector(c(6, 97, 100)), as.character(c(6,97,100))) })