Nothing
R/GaussSuppression.R
In SSBtools: Algorithms and Tools for Tabular Statistics and Hierarchical Computations
Defines functions
Order_singleton_num
FindDiffMatrix
DummyDuplicatedSpec
Scale2one
ReduceGreatestDivisor
decide_dimensional_check
AnyProportionalGaussInt_OLD
GaussSuppression1
SecondaryFinal
GaussSuppression
Documented in
GaussSuppression
#' Secondary suppression by Gaussian elimination
#'
#' Sequentially the secondary suppression candidates (columns in x) are used to reduce the x-matrix by Gaussian elimination.
#' Candidates who completely eliminate one or more primary suppressed cells (columns in x) are omitted and made secondary suppressed.
#' This ensures that the primary suppressed cells do not depend linearly on the non-suppressed cells.
#' How to order the input candidates is an important choice.
#' The singleton problem and the related problem of zeros are also handled.
#'
#' It is possible to specify too many (all) indices as `candidates`.
#' Indices specified as `primary` or `hidded` will be removed.
#' Hidden indices (not candidates or primary) refer to cells that will not be published, but do not need protection.
#'
#' * **Singleton methods for frequency tables:**
#' All singleton methods, except `"sub2Sum"` and the \code{\link{NumSingleton}} methods, have been implemented with frequency tables in mind.
#' The singleton method `"subSum"` makes new virtual primary suppressed cells, which are the sum of the singletons
#' within each group. The `"subSpace"` method is conservative and ignores the singleton dimensions when looking for
#' linear dependency. The default method, `"anySum"`, is between the other two. Instead of making virtual cells of
#' sums within groups, the aim is to handle all possible sums, also across groups. In addition, `"subSumSpace"` and
#' `"subSumAny"` are possible methods, primarily for testing. These methods are similar to `"subSpace"` and `"anySum"`,
#' and additional cells are created as in `"subSum"`. It is believed that the extra cells are redundant.
#' Note that in order to give information about unsafe cells, `"anySum"` is internally changed to `"subSumAny"` when there are forced cells.
#' All the above methods assume that any published singletons are primary suppressed.
#' If this is not the case, either `"anySumNOTprimary"` or `"anySum0"` must be used.
#' Notably, `"anySum0"` is an enhancement of `"anySumNOTprimary"` for situations where zeros are singletons.
#' Using that method avoids suppressing a zero marginal along with only one of its children.
#' * **Singleton methods for magnitude tables:**
#' The singleton method `"sub2Sum"` makes new virtual primary suppressed cells, which are the sum of two inner cells.
#' This is done when a group contains exactly two primary suppressed inner cells provided that at least one of them is singleton.
#' This was the first method implemented. Other magnitude methods follow the coding according to \code{\link{NumSingleton}}.
#' The `"sub2Sum"` method is equivalent to `"numFFT"`.
#' Also note that `"num"`, `"numFFF"` and `"numFTF"` are equivalent to `"none"`.
#' * **Combined:**
#' For advanced use, `singleton` can be a two-element list with names `"freq"` and `"num"`.
#' Then `singletonMethod` must be a corresponding named two-element vector.
#' For example: `singletonMethod = c(freq = "anySumNOTprimary", num = "sub2Sum")`
#'
#'
#' @param x Matrix that relates cells to be published or suppressed to inner cells. yPublish = crossprod(x,yInner)
#' @param candidates Indices of candidates for secondary suppression
#' @param primary Indices of primary suppressed cells
#' @param forced Indices forced to be not suppressed. `forced` has precedence over `primary`. See `whenPrimaryForced` below.
#' @param hidden Indices to be removed from the above `candidates` input (see details)
#' @param singleton Logical or integer vector of length `nrow(x)` specifying inner cells for singleton handling.
#' Normally, for frequency tables, this means cells with 1s when 0s are non-suppressed and cells with 0s when 0s are suppressed.
#' For some singleton methods, integer values representing the unique magnitude table contributors are needed.
#' For all other singleton methods, only the values after conversion with `as.logical` matter.
#' @param singletonMethod Method for handling the problem of singletons and zeros:
#' `"anySum"` (default), `"anySum0"`, `"anySumNOTprimary"`, `"subSum"`, `"subSpace"`, `"sub2Sum"`, `"none"`
#' or a \code{\link{NumSingleton}} method (see details).
#' @param printInc Printing "..." to console when TRUE
#' @param tolGauss A tolerance parameter for sparse Gaussian elimination and linear dependency. This parameter is used only in cases where integer calculation cannot be used.
#' @param whenEmptySuppressed Function to be called when empty input to primary suppressed cells is problematic. Supply NULL to do nothing.
#' @param whenEmptyUnsuppressed Function to be called when empty input to candidate cells may be problematic. Supply NULL to do nothing.
#' @param whenPrimaryForced Function to be called if any forced cells are primary suppressed (suppression will be ignored). Supply NULL to do nothing.
#' The same function will also be called when there are forced cells marked as singletons (will be ignored).
#' @param removeDuplicated Specifies whether to remove duplicated columns and rows in `x` before running the main algorithm.
#' Removing duplicates results in a faster algorithm while generally maintaining the same results.
#' In some cases, singleton handling for magnitude tables may be affected.
#' In such cases, singleton handling will generally be improved.
#' Singletons are considered when removing duplicate rows, so not all duplicates are removed.
#' The available options for `removeDuplicated` are as follows:
#'
#' * `TRUE` (default): Removes both duplicate columns and rows.
#' * `FALSE`: No removal of duplicates.
#' * `"cols"`: Removes only duplicate columns.
#' * `"rows"`: Removes only duplicate rows.
#' * `"rows2"`: Removes only duplicate non-singleton rows in a way that preserves singleton handling.
#' * Combined possibilities: Variants can be combined with "_". For example,
#' `"cols_rows"` is equivalent to `TRUE`,
#' and `"cols_rows2"` represents an alternative variant. Combining `"rows"` and `"rows2"` is possible, but superfluous calculations are then performed.
#' * `"test"`: A special variant for testing purposes. The four configurations `TRUE`, `FALSE`, `"cols_rows2"`, and `"rows"` are executed.
#' @param iFunction A function to be called during the iterations. See the default function, \code{\link{GaussIterationFunction}}, for description of parameters.
#' @param iWait The minimum number of seconds between each call to `iFunction`.
#' Whenever `iWait<Inf`, `iFunction` will also be called after last iteration.
#' @param xExtraPrimary Extra x-matrix that defines extra primary suppressed cells in addition to those defined by other inputs.
#' @param unsafeAsNegative When `TRUE`, unsafe primary cells due to forced cells are included in the output vector as negative indices.
#' @param printXdim When set to `TRUE`, the `printInc` parameter is also automatically set to `TRUE`.
#' Additionally, the dimensions of the `x` matrix are printed twice:
#' first, the dimensions of the input `x`, potentially extended with `xExtraPrimary`;
#' second, the dimensions after applying `singletonMethod` and `removeDuplicated`.
#' @param cell_grouping Numeric vector indicating suppression group membership.
#' Cells with the same non-zero value belong to the same suppression group,
#' meaning they will be suppressed or non-suppressed together.
#' A value of 0 indicates that the cell is not a member of any suppression group.
#' @param table_id A parameter that can be provided in addition to `cell_grouping` to reduce computation time,
#' when `x` is a block-diagonal matrix. Each block represents a separate table, and `table_id`
#' indicates table affiliation.
#' Note: no check is performed to verify that `table_id` corresponds to the block structure of `x`.
#' @param auto_anySumNOTprimary When `TRUE` (default), the `singletonMethod` `"anySumNOTprimary"` may be
#' forced if a check indicates that singletons are not primary suppressed.
#' Set this to `FALSE` in cases where the `x` matrix has already undergone
#' duplicate row removal, as the check may then produce incorrect results.
#'
#' @param ... Extra unused parameters
#'
#' @return Secondary suppression indices
#' @importFrom Matrix colSums t Matrix bdiag
#' @export
#'
#' @references
#' Langsrud, Ø. (2024):
#' \dQuote{Secondary Cell Suppression by Gaussian Elimination: An Algorithm Suitable for Handling Issues with Zeros and Singletons}.
#' Presented at: \emph{Privacy in statistical databases}, Antibes, France. September 25-27, 2024.
#' \doi{10.1007/978-3-031-69651-0_6}
#'
#'
#' @examples
#' # Input data
#' df <- data.frame(values = c(1, 1, 1, 5, 5, 9, 9, 9, 9, 9, 0, 0, 0, 7, 7),
#' var1 = rep(1:3, each = 5),
#' var2 = c("A", "B", "C", "D", "E"), stringsAsFactors = FALSE)
#'
#' # Make output data frame and x
#' fs <- FormulaSums(df, values ~ var1 * var2, crossTable = TRUE, makeModelMatrix = TRUE)
#' x <- fs$modelMatrix
#' datF <- data.frame(fs$crossTable, values = as.vector(fs$allSums))
#'
#' # Add primary suppression
#' datF$primary <- datF$values
#' datF$primary[datF$values < 5 & datF$values > 0] <- NA
#' datF$suppressedA <- datF$primary
#' datF$suppressedB <- datF$primary
#' datF$suppressedC <- datF$primary
#'
#' # zero secondary suppressed
#' datF$suppressedA[GaussSuppression(x, primary = is.na(datF$primary))] <- NA
#'
#' # zero not secondary suppressed by first in ordering
#' datF$suppressedB[GaussSuppression(x, c(which(datF$values == 0), which(datF$values > 0)),
#' primary = is.na(datF$primary))] <- NA
#'
#' # with singleton
#' datF$suppressedC[GaussSuppression(x, c(which(datF$values == 0), which(datF$values > 0)),
#' primary = is.na(datF$primary), singleton = df$values == 1)] <- NA
#'
#' datF
#'
#'
#'
#' #### with cell_grouping
#'
#' candidates <- c(which(datF$values == 0), which(datF$values > 0))
#' primary <- 10:12
#' cell_grouping <- rep(0, 24)
#'
#' # same as without cell_grouping
#' GaussSuppression(x, candidates, primary, cell_grouping = cell_grouping)
#'
#' cell_grouping[c(16, 20:21)] <- 1
#' cell_grouping[c(10, 4)] <- 2 # 10 is primary
#'
#' GaussSuppression(x, candidates, primary, cell_grouping = cell_grouping)
#'
GaussSuppression <- function(x, candidates = 1:ncol(x), primary = NULL, forced = NULL, hidden = NULL,
singleton = rep(FALSE, nrow(x)), singletonMethod = "anySum", printInc = TRUE, tolGauss = (.Machine$double.eps)^(1/2),
whenEmptySuppressed = warning,
whenEmptyUnsuppressed = message,
whenPrimaryForced = warning,
removeDuplicated = TRUE,
iFunction = GaussIterationFunction, iWait = Inf,
xExtraPrimary = NULL,
unsafeAsNegative = FALSE,
printXdim = FALSE,
cell_grouping = NULL,
table_id = NULL,
auto_anySumNOTprimary = TRUE,
...) {
if (identical(removeDuplicated, "test")){
sysCall <- match.call()
parentFrame <- parent.frame()
cat("\n ---------------- removeDuplicated = TRUE --------------------------\n")
sysCall["removeDuplicated"] <- TRUE
outTRUE <- eval(sysCall, envir = parentFrame)
cat("\n ---------------- removeDuplicated = FALSE --------------------------\n")
sysCall["removeDuplicated"] <- FALSE
outFALSE <- eval(sysCall, envir = parentFrame)
cat('\n ---------------- removeDuplicated = "cols_rows2" -------------------\n')
sysCall["removeDuplicated"] <- "cols_rows2"
out_cols_rows2 <- eval(sysCall, envir = parentFrame)
cat('\n ---------------- removeDuplicated = "rows" -------------------------\n')
sysCall["removeDuplicated"] <- "rows"
out_rows <- eval(sysCall, envir = parentFrame)
if(!isTRUE(all.equal(outTRUE, out_rows)) | !isTRUE(all.equal(outFALSE, out_cols_rows2))) {
stop("removeDuplicated test: all.equal problem")
}
if(!isTRUE(all.equal(outTRUE, outFALSE))){
message("removeDuplicated test: removeDuplicatedRows matters")
}
return(outTRUE)
}
if (is.logical(primary))
primary <- which(primary)
else
primary <- unique(primary)
ncol_x_input <- ncol(x)
if (!is.null(xExtraPrimary)) {
# primary has already been converted to indexes
primary <- c(primary, ncol(x) + seq_len(ncol(xExtraPrimary)))
# forced and hidden can be untreated since conversion to indexes below
x <- cbind(x, xExtraPrimary)
}
ncol_x_with_xExtraPrimary <- ncol(x)
if (printXdim) {
printInc <- TRUE
cat("<", nrow(x), "*", ncol(x), ">", sep = "")
flush.console()
}
if (!length(primary))
return(integer(0))
if (is.logical(candidates))
candidates <- which(candidates)
else
candidates <- unique(candidates)
if (is.logical(hidden))
hidden <- which(hidden)
else
hidden <- unique(hidden)
if (is.logical(forced))
forced <- which(forced)
else forced <- unique(forced)
if (length(hidden))
candidates <- candidates[!(candidates %in% hidden)]
if (!is.null(whenPrimaryForced)) {
if (any(primary %in% forced)) {
whenPrimaryForced("Primary suppression of forced cells ignored")
}
}
# With cell_grouping some secondary cell may be found directly, and not within gauss.
# a: primary cell in same group
# b: primary cell in same group after removeDuplicatedCols applied
secondary_from_cell_grouping_a <- integer(0)
secondary_from_cell_grouping_b <- integer(0)
if (!is.null(cell_grouping)) {
if(length(cell_grouping) != ncol(x)) {
stop("Wrong length of cell_grouping")
}
if (!is.null(table_id)) {
if(length(table_id) != length(cell_grouping)) {
stop("Wrong length of table_id")
}
}
cell_grouping_00 <- cell_grouping != 0
cell_grouping_00[cell_grouping_00][colSums(abs(x[, cell_grouping_00, drop = FALSE])) != 0] <- FALSE
if (any(cell_grouping_00)) {
cell_grouping[cell_grouping_00] <- 0L
warning("cell_grouping of cells with empty input ignored")
}
if (any(cell_grouping != 0)) {
primary_ensured <- ensure_consistency_from_cell_grouping(cell_grouping, primary)
if (length(primary_ensured[[2]])) {
primary <- primary_ensured[[1]]
secondary_from_cell_grouping_a <- primary_ensured[[2]]
}
}
}
unsafePrimary <- integer(0)
removeDuplicatedCols <- FALSE
removeDuplicatedRows <- FALSE
removeDuplicatedRows2 <- FALSE
if (!isFALSE(removeDuplicated)) {
if (is.character(removeDuplicated)) {
removeDuplicated <- tolower(strsplit(removeDuplicated, split = "_", fixed = TRUE)[[1]])
if (any(!(removeDuplicated %in% c("cols", "rows", "rows2")))) {
stop('"removeDuplicated" as character can only consist of "cols", "rows", "rows2", "test", or their combinations.')
}
removeDuplicatedCols <- "cols" %in% removeDuplicated
removeDuplicatedRows <- "rows" %in% removeDuplicated
removeDuplicatedRows2 <- "rows2" %in% removeDuplicated
} else {
removeDuplicatedCols <- TRUE
removeDuplicatedRows <- TRUE
}
}
if (removeDuplicatedCols) {
# idxDD <- DummyDuplicated(x, idx = TRUE, rnd = TRUE)
idxDD <- DummyDuplicatedSpec(x, candidates, primary, forced)
idxDDunique <- unique(idxDD)
if (length(idxDDunique) == length(idxDD)) {
removeDuplicatedCols <- FALSE
} else {
if (length(forced)) { # Needed for warning
primary <- primary[!(primary %in% forced)]
}
idNew <- rep(0L, ncol(x))
idNew[idxDDunique] <- seq_len(length(idxDDunique))
candidatesOld <- candidates
primaryOld <- primary
primary <- idNew[unique(idxDD[primary])]
candidates <- idNew[unique(idxDD[candidates])]
forced <- idNew[unique(idxDD[forced])]
x <- x[, idxDDunique, drop = FALSE]
if (!is.null(cell_grouping)) {
cell_grouping <- update_cell_grouping_from_duplicated(cell_grouping, idxDD, idxDDunique)
cell_grouping <- cell_grouping[idxDDunique]
table_id <- table_id[idxDDunique]
}
if (any(primary %in% forced)) {
unsafePrimary <- c(unsafePrimary, primary[primary %in% forced]) # c(... since maybe future extension
unsafePrimaryAsFinal <- -SecondaryFinal(secondary = -unsafePrimary, primary = integer(0), idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = primaryOld)
unsafeOrinary <- unsafePrimaryAsFinal[unsafePrimaryAsFinal <= ncol_x_input]
unsafeExtra <- unsafePrimaryAsFinal[unsafePrimaryAsFinal > ncol_x_input]
if (length(unsafeExtra)) {
s <- paste0(length(unsafePrimaryAsFinal), " (", length(unsafeOrinary), " ordinary, ", length(unsafeExtra), " extra)")
} else {
s <- length(unsafeOrinary)
}
warning(paste(s, "unsafe primary cells due to forced cells when evaluating duplicates")) # Forced cells -> All primary cells are not safe (duplicated)
}
}
}
if (!is.null(cell_grouping)) {
cell_grouping <- repeated_as_integer(cell_grouping)
if (!any(cell_grouping)) {
cell_grouping <- NULL
table_id <- NULL
} else {
forced <- ensure_consistency_from_cell_grouping(cell_grouping, forced)[[1]]
primary_ensured <- ensure_consistency_from_cell_grouping(cell_grouping, primary)
if (length(primary_ensured[[2]])) {
primary <- primary_ensured[[1]]
secondary_from_cell_grouping_b <- primary_ensured[[2]]
}
candidates <- order_candidates_by_cell_grouping(candidates, cell_grouping)
}
}
if (!removeDuplicatedCols) {
idxDD <- NULL
idxDDunique <- NULL
candidatesOld <- NULL
primaryOld <- NULL
}
candidates <- candidates[!(candidates %in% primary)]
nForced <- length(forced)
if (nForced) {
primary <- primary[!(primary %in% forced)]
candidates <- candidates[!(candidates %in% forced)]
candidates <- c(forced, candidates)
}
if(is.null(singleton)){
singleton <- rep(FALSE, nrow(x))
}
if (is.list(singleton)){
if(!identical(as.vector(sort(names(singleton))), c("freq", "num"))){
stop('names of singleton when list must be "freq" and "num"')
}
if(!identical(as.vector(sort(names(singleton))), c("freq", "num"))){
stop('names of singletonMethod when several must be "freq" and "num"')
}
singleton_num <- singleton[["num"]]
singleton <- as.logical(singleton[["freq"]])
singletonMethod_num <- singletonMethod[["num"]]
singletonMethod <- singletonMethod[["freq"]]
} else {
if (is.logical(singleton)) {
if(length(singleton) == 1L){
singleton <- rep(singleton, nrow(x))
}
}
if(is.integer(singleton)){
singleton_num <- singleton
singleton <- as.logical(singleton)
} else {
singleton_num <- singleton
}
if (!is.logical(singleton)) {
stop("singleton must be logical or integer")
}
if (singletonMethod %in% c("sub2Sum") | !is.null(NumSingleton(singletonMethod))) {
singletonMethod_num <- singletonMethod
singletonMethod <- "none"
} else {
singletonMethod_num <- "none"
}
}
if (is.integer(singleton_num)) {
if (min(singleton_num) < 0) {
stop("integer singletons must be nonzero")
}
}
if(length(singleton) != nrow(x) | length(singleton_num) != nrow(x)){
stop("length(singleton) must be nrow(x)")
}
#if (is.function(singletonMethod)) { # Alternative function possible
# return(singletonMethod(x, candidates, primary, printInc, singleton = singleton, nForced = nForced))
#}
if (!(singletonMethod %in% c("subSum", "subSpace", "anySum", "anySumOld", "anySum0", "anySumNOTprimary", "anySumNOTprimaryOld", "subSumSpace", "subSumAny", "none"))) {
stop("wrong singletonMethod")
}
if (singletonMethod_num == "sub2Sum") {
singletonMethod_num <- "numFFT"
}
#if (singletonMethod_num == "sub2SumUnique") {
# singletonMethod_num <- "numFTT"
#}
if (singletonMethod_num == "none") {
singletonMethod_num <- "num"
}
if (is.null(NumSingleton(singletonMethod_num))) {
stop("wrong singletonMethod")
}
if(length(primary) &!is.null(whenEmptySuppressed)){
if(min(colSums(abs(x[, primary, drop = FALSE]))) == 0){
whenEmptySuppressed("Suppressed cells with empty input will not be protected. Extend input data with zeros?")
}
}
secondary <- GaussSuppression1(x, candidates, primary, printInc, singleton = singleton, nForced = nForced,
singletonMethod = singletonMethod, singletonMethod_num = singletonMethod_num, singleton_num = singleton_num, tolGauss=tolGauss,
iFunction = iFunction, iWait = iWait,
main_primary = primary, idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = primaryOld,
ncol_x_input = ncol_x_input, ncol_x_with_xExtraPrimary = ncol_x_with_xExtraPrimary,
whenPrimaryForced = whenPrimaryForced,
removeDuplicatedRows = removeDuplicatedRows, removeDuplicatedRows2 = removeDuplicatedRows2,
printXdim = printXdim,
cell_grouping = cell_grouping, table_id = table_id,
auto_anySumNOTprimary = auto_anySumNOTprimary,
...)
unsafePrimary <- c(unsafePrimary, -secondary[secondary < 0])
secondary <- secondary[secondary > 0]
if(length(secondary) & !is.null(whenEmptyUnsuppressed)){
lateUnsuppressed <- candidates[SeqInc(1L + min(match(secondary, candidates)), length(candidates))]
lateUnsuppressed <- lateUnsuppressed[!(lateUnsuppressed %in% secondary)]
if(length(lateUnsuppressed)){
if(min(colSums(abs(x[, lateUnsuppressed, drop = FALSE]))) == 0){
whenEmptyUnsuppressed("Cells with empty input will never be secondary suppressed. Extend input data with zeros?")
}
}
}
if (length(secondary_from_cell_grouping_b)) {
secondary <- sort(c(secondary, secondary_from_cell_grouping_b))
unsafePrimary <- unsafePrimary[!(unsafePrimary %in% secondary_from_cell_grouping_b)]
}
if(unsafeAsNegative){
secondary <- c(secondary, -unsafePrimary)
}
secondary <- SecondaryFinal(secondary = secondary, primary = primary, idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = primaryOld)
if (length(secondary_from_cell_grouping_a)) {
secondary <- c(secondary, secondary_from_cell_grouping_a)
s_pos = secondary > 0
secondary <- c(sort(secondary[s_pos]), sort(secondary[!s_pos]))
secondary <- secondary[!duplicated(abs(secondary))]
}
return(secondary)
#}
#stop("wrong singletonMethod")
}
# Function to handle removeDuplicatedCols
SecondaryFinal <- function(secondary, primary, idxDD, idxDDunique, candidatesOld, primaryOld) {
if (is.null(idxDD)) {
return(secondary)
}
unsafePrimary <- -secondary[secondary < 0]
secondary <- secondary[secondary > 0]
ma <- match(idxDD[candidatesOld], c(idxDDunique[secondary], idxDDunique[primary]))
secondary <- candidatesOld[!is.na(ma)]
secondary <- secondary[!(secondary %in% primaryOld)]
if (!length(unsafePrimary)) {
return(secondary)
}
unsafePrimaryA <- unsafePrimary[unsafePrimary <= length(idxDDunique)]
unsafePrimaryB <- unsafePrimary[unsafePrimary > length(idxDDunique)]
ma <- match(idxDD[primaryOld], idxDDunique[unsafePrimaryA])
unsafePrimaryA <- primaryOld[!is.na(ma)]
unsafePrimaryB <- unsafePrimaryB - length(idxDDunique) + length(idxDD)
unsafePrimary <- c(unsafePrimaryA, unsafePrimaryB)
c(secondary, -unsafePrimary)
}
GaussSuppression1 <- function(x, candidates, primary, printInc, singleton, nForced, singletonMethod, singletonMethod_num, singleton_num, tolGauss, testMaxInt = 0, allNumeric = FALSE,
iFunction, iWait,
main_primary, idxDD, idxDDunique, candidatesOld, primaryOld, # main_primary also since primary may be changed
ncol_x_input, ncol_x_with_xExtraPrimary, whenPrimaryForced,
removeDuplicatedRows, removeDuplicatedRows2,
printXdim,
cell_grouping, table_id,
auto_anySumNOTprimary,
...) {
# Trick: GaussSuppressionPrintInfo <- message
PrintInfo <- get0("GaussSuppressionPrintInfo",ifnotfound = function(x) NULL)
gaussSave2enVirOnmEnt <- get0("gaussSave2enVirOnmEnt", ifnotfound = NULL)
if (!is.environment(gaussSave2enVirOnmEnt)) {
gaussSave2enVirOnmEnt <- NULL
}
n2e <- is.null(gaussSave2enVirOnmEnt)
if (!is.numeric(iWait)) {
iWait <- Inf
} else {
if (is.na(iWait)) iWait <- Inf
}
if (!is.function(iFunction)) iWait <- Inf
use_iFunction <- iWait < Inf
if (use_iFunction) {
sys_time <- Sys.time()
}
unsafePrimary <- integer(0)
# testMaxInt is parameter for testing
# The Integer overflow situation will be forced when testMaxInt is exceeded
DoTestMaxInt = testMaxInt > 0
# allNumeric is parameter for testing
# All calculations use numeric algorithm when TRUE
if(allNumeric){
Matrix2listInt <- SSBtools::Matrix2list
}
if (printInc) {
singletonMethod_print <- c(singletonMethod, singletonMethod_num)
singletonMethod_print <- c(singletonMethod_print[!(singletonMethod_print %in% c("none", "num"))])
if (!length(singletonMethod_print)) {
singletonMethod_print <- "none"
}
singletonMethod_print <- paste(singletonMethod_print, collapse = "_")
cat(paste0("GaussSuppression_", singletonMethod_print))
flush.console()
}
numSingleton <- NumSingleton(singletonMethod_num)
if (numSingleton[["singleton2Primary"]] == "T") {
singleton2Primary <- TRUE
forceSingleton2Primary <- TRUE
} else {
singleton2Primary <- numSingleton[["singleton2Primary"]] == "t"
forceSingleton2Primary <- FALSE
}
integerUnique <- as.logical(numSingleton[["integerUnique"]])
if (is.na(integerUnique)) { # When 't'
integerUnique <- is.integer(singleton_num)
}
if (integerUnique & !is.integer(singleton_num)) {
stop("singleton as integer needed")
}
if (!integerUnique & is.integer(singleton_num)) {
singleton_num <- as.logical(singleton_num)
}
numSingleton_elimination_ <- numSingleton[["elimination"]]
numRevealsMessage <- numSingleton_elimination_ == "f"
allow_GAUSS_DUPLICATES <- numSingleton_elimination_ %in% LETTERS
numSingleton_elimination_ <- toupper(numSingleton_elimination_)
numSingletonElimination <- numSingleton_elimination_ != "F"
if (numSingletonElimination) {
numRevealsMessage <- get0("force_numRevealsMessage", ifnotfound = FALSE)
}
WhenProblematicSingletons <- NULL
if (numSingleton_elimination_ == "M") WhenProblematicSingletons <- message
if (numSingleton_elimination_ == "W") WhenProblematicSingletons <- warning
if (numRevealsMessage) WhenProblematicSingletons <- message
# F -> 0, t -> 1, T -> 2
numSingleton_combinations <- 2L * as.integer(as.logical(numSingleton[["combinations"]]))
if (is.na(numSingleton_combinations)) {
numSingleton_combinations <- 1L
}
if (!numSingletonElimination & numSingleton_combinations) {
warning('No effect of "combinations" (5th character) whithout "elimination" (4th character).')
}
sub2Sum <- as.logical(numSingleton[["sum2"]])
if (is.na(sub2Sum)) { # When 'H'
sub2Sum <- TRUE
hierarchySearch <- TRUE
} else {
hierarchySearch <- FALSE
}
if (singletonMethod == "none") {
singleton <- FALSE
}
if (singletonMethod_num %in% c("none", "num")) {
singleton_num <- FALSE
}
forceForcedNotSingletonNum <- (nForced > 0) & any(singleton_num)
forceForcedNotSingletonFreq <- (nForced > 0) & any(singleton)
if (forceForcedNotSingletonNum | forceForcedNotSingletonFreq) {
cS1 <- which(colSums(x) == 1)
cS1 <- cS1[cS1 %in% candidates[seq_len(nForced)]]
if (length(cS1)) {
cS1rS <- rowSums(x[, cS1, drop = FALSE]) > 0
if (forceForcedNotSingletonNum & any(singleton_num & cS1rS)) {
if (!is.null(whenPrimaryForced)) {
whenPrimaryForced("Singleton marking of forced cells ignored (num)")
}
singleton_num[cS1rS] <- FALSE # this is ok when integer: -> 0L
}
if (forceForcedNotSingletonFreq & any(singleton & cS1rS)) {
if (!is.null(whenPrimaryForced)) {
whenPrimaryForced("Singleton marking of forced cells ignored (freq)")
}
singleton[cS1rS] <- FALSE
}
}
}
if (singletonMethod %in% c("anySumOld", "anySumNOTprimaryOld")) {
singletonMethod <- sub("Old", "", singletonMethod)
sign_here <- function(x) x
} else {
sign_here <- sign
}
singletonNOTprimary <- FALSE
anySum0 <- singletonMethod == "anySum0"
if (singletonMethod == "anySumNOTprimary" | anySum0) {
singletonMethod <- "anySum"
singletonNOTprimary <- TRUE
} else {
if (auto_anySumNOTprimary & any(singleton)) {
colSums_x <- colSums(x)
singletonZ <- (colSums(x[singleton, , drop = FALSE]) == 1 & colSums_x == 1)
singletonNOTprimary <- (sum(singletonZ) > sum(singletonZ[primary]))
}
if (singletonNOTprimary) {
if (singletonMethod != "anySum")
stop('singletonMethod must be "anySumNOTprimary" or "anySum0" when singletons not primary suppressed')
warning('singletonMethod is changed to "anySumNOTprimary"')
}
}
if (!is.null(cell_grouping)) {
if (grepl("Space", singletonMethod) | singletonNOTprimary) {
stop("Chosen singletonMethod combined with cell_grouping is currently not implemented")
}
}
parentChildSingleton <- NULL
keepSecondary <- integer(0) # To store A indices that will proceed the elimination process
# after they are found to be secondary suppressed
if (singletonNOTprimary) {
if (anySum0) {
parentChildSingleton <- FindParentChildSingleton(x, candidates, primary, singleton, ncol_x_input, idxDD)
# easy1 <- parentChildSingleton$all1 # Simplification in ParentChildExtension.
easy1 <- TRUE # This seems fine when anySum02primary is TRUE
if (!is.null(parentChildSingleton)) {
anySum0easy1 <- get0("anySum0easy1", ifnotfound = NULL) # It might appear that easy1 affects the result and not just speed.
if (!is.null(anySum0easy1)) { # This could be cases with invisible/hidden childs.
if (!is.na(anySum0easy1)) { # It is believed that easy1 = TRUE is the best method in terms of protection anyway.
easy1 <- anySum0easy1 # But it may still be best to turn it off to avoid the possibility of unsafe
} # secondary suppressions in rare cases.
cat(paste0("_easy1_=_", easy1)) # This is the rationale for the default value. (but now changed due to anySum02primary, see above)
} # With "anySum0easy1" it is possible to test.
anySum02primary <- get0("anySum02primary", ifnotfound = TRUE)
if (!anySum02primary) {
cat(paste0("_2primary_=_", anySum02primary))
}
anySum0maxiter <- get0("anySum0maxiter", ifnotfound = 99)
if (anySum0maxiter != 99) {
cat(paste0("_maxiter_=_", anySum0maxiter))
}
anySum0conservative <- get0("anySum0conservative", ifnotfound = TRUE)
if (!anySum0conservative) {
cat(paste0("_conservative_=_", anySum0conservative))
}
}
}
}
if (is.null(parentChildSingleton)) {
anySum0 <- FALSE
}
if (!anySum0) {
anySum0conservative <- FALSE
}
# In order to give information about unsafe cells, "anySum" is internally changed to "subSumAny" when there are forced cells.
if (!singletonNOTprimary & singletonMethod == "anySum" & nForced > 0) {
singletonMethod <- "subSumAny"
}
if (removeDuplicatedRows) {
# Duplicated non-singleton rows are removed.
row_filter <- rep(TRUE, nrow(x))
if (any(singleton)) {
row_filter[singleton] <- FALSE
}
if (any(singleton_num)) {
row_filter[as.logical(singleton_num)] <- FALSE
}
if (any(row_filter)) {
row_filter[row_filter] <- DummyDuplicated(x[row_filter, , drop = FALSE], idx = FALSE, rows = TRUE, rnd = TRUE)
if (any(!row_filter)) {
if (any(singleton)) {
singleton <- singleton[!row_filter]
}
if (any(singleton_num)) {
singleton_num <- singleton_num[!row_filter]
}
x <- x[!row_filter, , drop = FALSE]
}
}
# Duplicated singleton (for frequency tables) rows are removed.
if (any(singleton)) {
row_filter <- singleton
row_filter[row_filter] <- DummyDuplicated(x[row_filter, , drop = FALSE], idx = FALSE, rows = TRUE, rnd = TRUE)
if (any(row_filter)) {
x <- x[!row_filter, , drop = FALSE]
singleton <- singleton[!row_filter]
if (any(singleton_num))
singleton_num <- singleton_num[!row_filter]
}
}
# Some duplicated singleton (for magnitude tables) rows are removed.
if (any(singleton_num)) {
row_filter <- as.logical(singleton_num)
dd_idx <- DummyDuplicated(x[row_filter, , drop = FALSE], idx = TRUE, rows = TRUE, rnd = TRUE)
# First remove duplicates seen from both singleton integers and rows of x
# After this, the remaining problem is the same, whether singleton_num is logical or integer.
if (!is.logical(singleton_num)) {
duplicated2 <- duplicated(cbind(dd_idx, singleton_num[row_filter]))
row_filter[row_filter] <- duplicated2
if (any(row_filter)) {
x <- x[!row_filter, , drop = FALSE]
singleton_num <- singleton_num[!row_filter]
if (any(singleton))
singleton <- singleton[!row_filter]
dd_idx <- dd_idx[!duplicated2]
}
row_filter <- as.logical(singleton_num)
}
# A group of replicated rows with more than three contributors is not
# related to singleton disclosures protected by any of the methods.
# Singleton marking can be removed,
# and duplicates can also be eliminated.
# Note that removing duplicates while retaining singleton marking will
# result in incorrect calculations of the number of unique contributors.
table_dd_idx <- table_all_integers(dd_idx, max(dd_idx))
least3 <- dd_idx %in% which(table_dd_idx > 2)
if (any(least3)) {
row_filter[row_filter] <- least3
dd_idx <- dd_idx[least3]
duplicated4 <- duplicated(dd_idx)
singleton_num[row_filter] <- FALSE # i.e. set 0 when not logical
row_filter[row_filter] <- duplicated4
x <- x[!row_filter, , drop = FALSE]
singleton_num <- singleton_num[!row_filter]
if (any(singleton))
singleton <- singleton[!row_filter]
}
}
# Checks for errors in the code above
if (any(singleton))
if (length(singleton) != nrow(x))
stop("removeDuplicatedRows failed")
if (any(singleton_num))
if (length(singleton_num) != nrow(x))
stop("removeDuplicatedRows failed")
}
##
## START extending x based on singleton
##
input_ncol_x <- ncol(x)
relevant_ncol_x <- ncol(x)
# make new primary suppressed subSum-cells
if (sub2Sum | singleton2Primary | forceSingleton2Primary) {
if (any(singleton_num)) {
singleton_num_logical <- as.logical(singleton_num)
if (singleton2Primary) { # Change from if(forceSingleton2Primary)
cS1 <- which(colSums(x) == 1)
cS1 <- cS1[!(cS1 %in% primary)]
if (length(cS1)) {
cS1 <- cS1[colSums(x[singleton_num_logical, cS1, drop = FALSE]) == 1]
}
if (length(cS1)) {
if (forceSingleton2Primary) { # Now forceSingleton2Primary used instead of above
primary <- c(primary, cS1)
PrintInfo("forceSingleton2Primary is used")
}
} else {
forceSingleton2Primary <- TRUE # When known that forceSingleton2Primary=TRUE give same result as FALSE (useful later)
}
}
if (singleton2Primary) {
singletonNotInPublish <- singleton_num_logical
singletonNotInPublish[rowSums(x[, primary[colSums(x[, primary, drop = FALSE]) == 1], drop = FALSE]) > 0] <- FALSE # singletonNotInPublish[innerprimary] <- FALSE
if (any(singletonNotInPublish)) {
PrintInfo("singleton2Primary is used")
pZ <- Matrix(0, length(singletonNotInPublish), sum(singletonNotInPublish))
pZ[cbind(which(singletonNotInPublish), seq_len(sum(singletonNotInPublish)))] <- 1
primary <- c(primary, NCOL(x) + seq_len(NCOL(pZ))) # same code as below
x <- cbind(x, pZ) # ---- // -----
}
}
relevant_ncol_x <- ncol(x)
if (sub2Sum) {
pZs <- x * singleton_num_logical
pZ <- x * (rowSums(x[, primary[colSums(x[, primary, drop = FALSE]) == 1], drop = FALSE]) > 0) # x * innerprimary
pZ[ , primary] <- 0 # Not relevant when already suppressed
if (integerUnique) {
if (!is.integer(singleton_num)) {
stop("singleton as integer needed, but something is wrong since this check has been done earlier")
}
relevant_unique_index <- -seq_len(nrow(x)) # negative is guaranteed different from singleton_num
relevant_unique_index[singleton_num_logical] <- singleton_num[singleton_num_logical]
colSums_pZ_g_1 <- colSums(pZ) > 1
if (any(colSums_pZ_g_1)) { # with this, DummyApply problem when onlys zeros in pZ also avoided
cols_g_2 <- DummyApply(pZ, relevant_unique_index, function(x) length(unique(x))) > 2
colSums_pZ_requirement <- !cols_g_2 & colSums_pZ_g_1
} else {
colSums_pZ_requirement <- colSums_pZ_g_1
cols_g_2 <- FALSE
}
# colSums(pZ) > 1 since primary already exists when colSums(pZ) == 1
# =2 before "&" here similar to =2 in sub2Sum:
# * two primary suppressed inner cells provided that at least one of them is singleton (colSums(pZs) > 0)
# * Difference is that same singleton counted as 1
# =1 before "&" here is extra
# * All primary suppressed inner cells in group are same singleton and counted as 1
# * The sum of this group needs protection
# =0 before "&" here
# * will never happen when colSums(pZ) > 1)
#
freq_max_singleton <- max(table(singleton_num[singleton_num_logical]))
} else { # not integerUnique
colSums_pZ_requirement <- colSums(pZ) == 2
if (hierarchySearch) {
cols_g_2 <- colSums(pZ) > 2
}
freq_max_singleton <- 1L
}
if (hierarchySearch) {
if (any(cols_g_2)) {
cols_g_2 <- which(cols_g_2)
PrintInfo(paste("freq_max_singleton for FindDiffMatrix:", freq_max_singleton))
diffMatrix <- FindDiffMatrix(x[, primary[colSums(x[, primary, drop = FALSE]) > 1], drop = FALSE], # primary with more than 1, =1 already treated
pZ[, cols_g_2, drop = FALSE], # (x * innerprimary) with more than 2
freq_max_singleton)
colnames(diffMatrix) <- cols_g_2[as.integer(colnames(diffMatrix))] # now colnames correspond to pZ columns
# Is there any difference column that corresponds to a unique contributor? The code below tries to answer.
if (ncol(diffMatrix)) {
diffMatrix <- diffMatrix[, colSums(diffMatrix[!singleton_num_logical, , drop = FALSE]) == 0, drop = FALSE]
diffMatrix <- diffMatrix[singleton_num_logical, , drop = FALSE]
if (ncol(diffMatrix)) {
colSums_diffMatrix_is1 <- colSums(diffMatrix) == 1
if (any(colSums_diffMatrix_is1)) {
PrintInfo("hierarchySearch is used in the standard way")
colSums_pZ_requirement[as.integer(colnames(diffMatrix)[colSums_diffMatrix_is1])] <- TRUE
diffMatrix <- diffMatrix[, !colSums_diffMatrix_is1, drop = FALSE]
}
if (integerUnique & ncol(diffMatrix)) {
cols_eq_1 <- DummyApply(diffMatrix, relevant_unique_index[singleton_num_logical], function(x) length(unique(x))) == 1
if (any(cols_eq_1)) {
PrintInfo("hierarchySearch is used in combination with integerUnique")
colSums_pZ_requirement[as.integer(colnames(diffMatrix)[cols_eq_1])] <- TRUE
}
}
}
}
}
}
colZ <- ((colSums(pZs) > 0) & colSums_pZ_requirement)
} else {
colZ <- FALSE # This is not logical, but due to code change
}
if (any(colZ)) {
pZ <- pZ[, colZ, drop = FALSE]
nodupl <- which(!DummyDuplicated(pZ, rnd = TRUE)) # nodupl <- which(!duplicated(as.matrix(t(pZ))))
pZ <- pZ[, nodupl, drop = FALSE]
primary <- c(primary, NCOL(x) + seq_len(NCOL(pZ)))
x <- cbind(x, pZ)
}
}
}
if (!all(SeqInc(input_ncol_x + 1L, input_ncol_x) %in% primary)) {
stop("extending x based on singleton failed")
}
# make new primary suppressed subSum-cells
if (grepl("subSum", singletonMethod)) {
if (any(singleton)) {
pZ <- x * singleton
colZ <- colSums(pZ) > 1
if (any(colZ)) { # Same code below
pZ <- pZ[, colZ, drop = FALSE]
nodupl <- which(!DummyDuplicated(pZ, rnd = TRUE)) # which(!duplicated(as.matrix(t(pZ))))
pZ <- pZ[, nodupl, drop = FALSE]
primary <- c(primary, NCOL(x) + seq_len(NCOL(pZ)))
x <- cbind(x, pZ)
}
}
if (singletonMethod == "subSum")
singleton <- FALSE
}
keep_all_singleton_primary <- TRUE
if (keep_all_singleton_primary) {
ddx <- rep(FALSE, ncol(x))
ddx[primary] <- DummyDuplicated(x[, primary, drop = FALSE], rnd = TRUE)
ddx[seq_len(input_ncol_x)] <- FALSE
if (any(ddx)) {
x <- x[, !ddx]
primary <- primary[seq_len(length(primary) - sum(ddx))]
PrintInfo("duplicates found")
}
} else {
ddx <- DummyDuplicated(x, rnd = TRUE)
ddx[seq_len(input_ncol_x)] <- FALSE
if (any(ddx)) {
x <- x[, !ddx]
primary <- primary[seq_len(length(primary) - sum(ddx))]
PrintInfo("duplicates found")
}
}
##
## END extending x based on singleton
##
# Exact copy of code above: Duplicated non-singleton rows are removed.
# Alternative after "extending x based on singleton"
if (removeDuplicatedRows2) {
row_filter <- rep(TRUE, nrow(x))
if (any(singleton)) {
row_filter[singleton] <- FALSE
}
if (any(singleton_num)) {
row_filter[as.logical(singleton_num)] <- FALSE
}
if (any(row_filter)) {
row_filter[row_filter] <- DummyDuplicated(x[row_filter, , drop = FALSE], idx = FALSE, rows = TRUE, rnd = TRUE)
if (any(!row_filter)) {
if (any(singleton)) {
singleton <- singleton[!row_filter]
}
if (any(singleton_num)) {
singleton_num <- singleton_num[!row_filter]
}
x <- x[!row_filter, , drop = FALSE]
}
}
}
if (printXdim) {
cat("<", nrow(x), "*", ncol(x), ">", sep = "")
flush.console()
}
n_relevant_primary <- sum(primary <= relevant_ncol_x)
if (!any(singleton))
singleton <- NULL
# Ensure that 'singleton_num' is no longer used when When there are no singletons.
# Note: If 'singleton_num' contains only FALSE or 0, it may have an incorrect length.
# This can happen if its length is 1
# or if it was not updated correctly due to removeDuplicatedRows
if (!any(singleton_num)) {
numSingletonElimination <- FALSE
numRevealsMessage <- FALSE
}
# Change to unique integers. Other uses of singleton_num are finished
if ((numSingletonElimination|numRevealsMessage) & is.logical(singleton_num)) {
singleton_num[singleton_num] <- seq_len(sum(singleton_num))
}
force_GAUSS_DUPLICATES <- get0("force_GAUSS_DUPLICATES", ifnotfound = FALSE)
order_GAUSS_DUPLICATES <- get0("order_GAUSS_DUPLICATES", ifnotfound = TRUE)
force_dimensional_check <- get0("foRce_dimensional_check", ifnotfound = FALSE)
if (!n2e) {
orderA <- seq_len(nrow(x))
}
if (numSingletonElimination|numRevealsMessage) {
# singleton_num as rows, primary as columns
sspp <- fac2sparse(singleton_num[singleton_num > 0]) %*% x[singleton_num > 0, primary[seq_len(n_relevant_primary)], drop = FALSE]
# Indices of primary originated from unique singleton
uniqueSingletonPrimary <- which(colSums(sign(sspp)) == 1)
if (order_GAUSS_DUPLICATES) {
order_singleton_num <- Order_singleton_num(singleton_num)
} else {
order_singleton_num <- order(singleton_num)
}
x <- x[order_singleton_num, , drop = FALSE]
singleton_num <- singleton_num[order_singleton_num]
if (!is.null(singleton)) {
singleton <- singleton[order_singleton_num]
}
if (!n2e) {
orderA <- order_singleton_num
}
}
order_singleton_num <- NULL
if (!is.null(singleton)) {
ordSingleton <- order(singleton)
singleton <- singleton[ordSingleton]
maTRUE <- match(TRUE, singleton)
if (!is.na(maTRUE)) {
ordyB <- ordSingleton[seq_len(maTRUE - 1)]
maxInd <- maTRUE - 1
} else {
ordyB <- ordSingleton
maxInd <- length(singleton)
}
# maxInd made for subSpace, maxInd2 needed by anySum
maxInd2 <- maxInd
# Removes cells that are handled by anySum/subSpace anyway
# In order to give correct information about unsafe cells, do not remove when there are forced cells.
if (!singletonNOTprimary & nForced == 0) {
if (!grepl("subSum", singletonMethod)) {
primary <- primary[colSums(x[ordyB, primary, drop = FALSE]) != 0]
}
}
A <- Matrix2listInt(x[ordSingleton, candidates, drop = FALSE])
if (!n2e) {
orderA <- orderA[ordSingleton]
}
if (grepl("Space", singletonMethod)) {
B <- Matrix2listInt(x[ordyB, primary, drop = FALSE])
order_singleton_num <- ordyB
if (!n2e) {
orderB <- orderA[ordyB]
}
} else {
B <- Matrix2listInt(x[ordSingleton, primary, drop = FALSE])
maxInd <- nrow(x)
order_singleton_num <- ordSingleton
if (!n2e) {
orderB <- orderA[ordSingleton]
}
}
} else {
A <- Matrix2listInt(x[, candidates, drop = FALSE])
B <- Matrix2listInt(x[, primary, drop = FALSE])
maxInd <- nrow(x)
if (!n2e) {
orderB <- orderA
}
}
############################################################
# cell_grouping is changed to cell_grouping[candidates]
############################################################
if (!is.null(cell_grouping)) {
cell_grouping <- cell_grouping[candidates]
if (!is.null(table_id)) {
table_id <- table_id[candidates]
}
}
if (numSingletonElimination|numRevealsMessage) {
#singleton-integer-value when primary originated from unique singleton
primarySingletonNum <- rep(0, length(primary))
for (i in uniqueSingletonPrimary) {
primarySingletonNum[i] <- singleton_num[B$r[[i]][1]]
}
if (!is.null(order_singleton_num)) {
singleton_num <- singleton_num[order_singleton_num]
}
}
m <- nrow(x)
n <- length(A$r)
nB <- length(B$r)
secondary <- rep(FALSE, n)
if (printInc) {
cat(": ")
flush.console()
}
ii <- 1L
nrA <- rep(NA_integer_, n)
nrB <- rep(NA_integer_, nB)
# To store cumulative factors from ReduceGreatestDivisor
# Used to rescale when switching to numeric algorithm (caused by integer overflow).
kk_2_factorsA <- rep(1, n)
kk_2_factorsB <- rep(1, nB)
subUsed <- rep(FALSE, m) # needed by anySum
dot <- "."
# dot will change to "-" when integer overflow occur (then numeric algorithm)
dash <- c("-", "=") # dot <- dash[N_GAUSS_DUPLICATES]
# when N_GAUSS_DUPLICATES==2 dot will change to ":" or "=" (integer overflow)
###################################################################################################
# START - define AnyProportionalGaussInt
# when !numSingletonElimination:
# old function outside this function is used (see below)
# Since function defined inside, it is possible to "cheat" and avoid extra input-parameters.
# Now primarySingletonNum and numSingletonElimination avoided
#
# This function reuses code from old branch “Feature/safety-range”.
# Comments about rangeValues/rangeLimits are from this old code.
# It is possible to further develop this within this new function.
#####################################################################################################
Check_s_unique <- function(s_unique, i) {
if (length(s_unique) > 1) {
return(FALSE)
}
if (length(s_unique) == 0) {
return(TRUE)
}
if (s_unique == 0) {
return(FALSE)
}
if (s_unique == primarySingletonNum[i]) {
return(FALSE)
}
1L
}
AnyProportionalGaussInt_NEW <- function(r, x, rB, xB, tolGauss, kk_2_factorsB, singleton_num = NULL) {
n <- length(r)
if (!n) {
return(TRUE) # Empty 'A-input' regarded as proportional
}
if (numSingleton_combinations) {
if (numSingletonElimination) {
s_unique <- unique(singleton_num[r])
if (length(s_unique) <= numSingleton_combinations) {
if (min(s_unique) > 0) {
return(1L)
}
}
}
}
for (i in seq_along(rB)) {
numSingletonEliminationCheck <- numSingletonElimination
if(i > n_relevant_primary){
numSingletonEliminationCheck <- FALSE
}
ni <- length(xB[[i]])
if (ni) { # Empty 'B-input' not regarded as proportional
doCheck <- FALSE
if (ni == n) {
if (identical(r, rB[[i]])) { # Same as in old function
doCheck <- TRUE
x_here <- x
xBi_here <- xB[[i]]
if (numSingletonEliminationCheck) {
#restLimit <- rangeLimits[i] # This is new
s_unique <- integer(0)
r_in_rB <- rep(TRUE, length(r))
rB_in_r <- r_in_rB
} else {
#restLimit <- 0
}
}
}
if (!doCheck) {
if (numSingletonEliminationCheck) {
r_in_rB <- r %in% rB[[i]]
if (any(r_in_rB)) {
r_in_rB <- r %in% rB[[i]]
rB_in_r <- rB[[i]] %in% r
rdiff <- c(r[!r_in_rB], rB[[i]][!rB_in_r]) # elements not common
# sum_rdiff <- sum(rangeValues[rdiff])
s_unique <- unique(singleton_num[rdiff])
x_here <- x[r_in_rB] # x reduced to common elements
xBi_here <- xB[[i]][rB_in_r] # xB[[i]] reduced to common elements
#restLimit <- rangeLimits[i] - sum_rdiff
#doCheck <- restLimit >= 0 # New when non-NULL rangeLimits
#doCheck <- (length(s_unique) <= 1) & (min(s_unique) > 0)
doCheck <- Check_s_unique(s_unique, i)
}
}
}
if (doCheck) {
if (n == 1L)
return(doCheck)
if (identical(x_here, xBi_here))
return(doCheck)
if (identical(-x_here, xBi_here))
return(doCheck)
cx1xBi1 <- c(x_here[1], xBi_here[1])
if (is.integer(cx1xBi1)) {
kk <- ReduceGreatestDivisor(cx1xBi1)
suppressWarnings({
kk_2_x <- kk[2] * x_here
kk_1_xB_i <- kk[1] * xBi_here
})
if (anyNA(kk_2_x) | anyNA(kk_1_xB_i)) {
kk <- as.numeric(kk)
kk_2_x <- kk[2] * x_here
kk_1_xB_i <- kk[1] * xBi_here
}
if (identical(kk_2_x, kk_1_xB_i))
return(doCheck)
if (is.numeric(kk)) {
if (all(abs(xBi_here - kk_2_x/kk[1]) < tolGauss))
return(doCheck)
}
if (numSingletonEliminationCheck) { #if (restLimit) { # Same logical vectors again when TRUE not returned and when rangeLimits used (simplification possible)
if (!is.numeric(kk)) {
rrest <- (r[r_in_rB])[kk_2_x != kk_1_xB_i]
} else {
rrest <- (r[r_in_rB])[!(abs(xBi_here - kk_2_x/kk[1]) < tolGauss)]
}
s_unique <- unique(c(s_unique, singleton_num[rrest]))
check_s_unique <- Check_s_unique(s_unique, i)
if (check_s_unique) { #if ((length(s_unique) <= 1) & (min(s_unique) > 0)) {
return(check_s_unique) # New possible TRUE-return caused by rangeLimits
}
}
} else {
# Possible code here to look at distribution of numeric computing errors
# aabb <- abs((xB[[i]] - (cx1xBi1[2]/cx1xBi1[1]) * x)/kk_2_factorsB[i])
# aabb <- aabb[aabb > 0 & aabb < 1e-04]
if (all(abs(xBi_here - (cx1xBi1[2]/cx1xBi1[1]) * x_here) < tolGauss * abs(kk_2_factorsB[i])))
return(doCheck)
if (numSingletonEliminationCheck) {# if (restLimit) {
rrest <- (r[r_in_rB])[!(abs(xBi_here - (cx1xBi1[2]/cx1xBi1[1]) * x_here) < tolGauss * abs(kk_2_factorsB[i]))]
s_unique <- unique(c(s_unique, singleton_num[rrest]))
# if (sum(rangeValues[rrest]) < restLimit) {
check_s_unique <- Check_s_unique(s_unique, i)
if (check_s_unique) { #if ((length(s_unique) <= 1) & (min(s_unique) > 0)) {
return(check_s_unique) # New possible TRUE-return caused by rangeLimits (as above)
}
}
}
}
}
}
FALSE
}
if (force_GAUSS_DUPLICATES) {
if (!numSingletonElimination) {
singleton_num <- rep(0L, m)
numSingletonElimination <- TRUE
}
}
if (numSingletonElimination) {
#AnyProportionalGaussInt <- AnyProportionalGaussInt_NEW
AnyProportionalGaussInt <- function(...){
anyP <- AnyProportionalGaussInt_NEW(A$r[[j]], A$x[[j]], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB, singleton_num = singleton_num)
if (anyP) return(anyP)
if (N_GAUSS_DUPLICATES == 1) {
return(anyP)
}
anyP <- AnyProportionalGaussInt_NEW(A_DUPLICATE$r[[j]], A_DUPLICATE$x[[j]], B_DUPLICATE$r, B_DUPLICATE$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB_DUPLICATE, singleton_num = singleton_num_DUPLICATE)
if (anyP) return(anyP)
if (singleton_num[A_DUPLICATE$r[[j]]][1] & length(A_DUPLICATE$r[[j]]) > 1) {
r <- c(SeqInc(2, length(A_DUPLICATE$r[[j]])), 1L)
anyP <- AnyProportionalGaussInt_NEW(A_DUPLICATE$r[[j]][r], A_DUPLICATE$x[[j]][r], B_DUPLICATE$r, B_DUPLICATE$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB_DUPLICATE, singleton_num = singleton_num_DUPLICATE)
}
anyP
}
} else {
if (get0("testAnyProportionalGaussInt", ifnotfound = FALSE)) {
AnyProportionalGaussInt <- function(...) {
apgiOLD <- AnyProportionalGaussInt_OLD(...)
apgiNEW <- AnyProportionalGaussInt_NEW(...)
if (apgiOLD != apgiNEW) {
stop("AnyProportionalGaussInt NEW/OLD problem")
}
apgiOLD
}
} else {
AnyProportionalGaussInt <- AnyProportionalGaussInt_OLD
}
}
#####################################################################
# END - define AnyProportionalGaussInt
#####################################################################
eliminatedRows <- rep(FALSE, m)
MessageProblematicSingletons <- function() { # internal function since used twice below
if (!n2e) {
gaussenv <- as.list(parent.frame())
list2env(list(gaussenv = gaussenv), envir = gaussSave2enVirOnmEnt)
}
if (!is.null(WhenProblematicSingletons) & (numSingletonElimination|numRevealsMessage)) {
if (!numRevealsMessage) {
rowsP <- which(eliminatedRows & as.logical(singleton_num))
singleP <- singleton_num[rowsP]
if (N_GAUSS_DUPLICATES == 2) {
rows2 <- DUPLICATE_order_singleton_num[which(eliminatedRows_DUPLICATE & as.logical(singleton_num_DUPLICATE))]
rowsP <- rowsP[rowsP %in% rows2]
singleP <- singleP[singleP %in% singleton_num[rows2]]
}
n_unique <- length(unique(singleton_num[as.logical(singleton_num)]))
singleP <- unique(singleP)
if (!forceSingleton2Primary) {
if (length(singleP)) {
WhenProblematicSingletons(paste(sum(length(singleP)), "out of", n_unique, "unique singletons problematic. Whether reveals exist is not calculated."))
}
}
} else {
if (!forceSingleton2Primary) {
message('Actual reveals cannot be calculated. See ?NumSingleton. Try T as "1st character"?')
} else {
singleP <- unique(singleton_num[as.logical(singleton_num)])
n_unique <- length(singleP)
}
}
if (forceSingleton2Primary) {
if (length(singleP)) {
eliminatedBySingleton <- rep(FALSE, length(singleP))
for (i in seq_len(n_relevant_primary)) {
if (!length(B$r[[i]])) { # Avoid special situation
primarySingletonNum[i] <- 0
}
}
B$r <- B$r[seq_len(n_relevant_primary)]
B$x <- B$x[seq_len(n_relevant_primary)]
primarySingletonNum <- primarySingletonNum[seq_len(n_relevant_primary)]
kk_2_factorsB <- kk_2_factorsB[seq_len(n_relevant_primary)]
for (i in seq_along(singleP)) {
p <- primarySingletonNum == singleP[i]
eliminatedBySingleton[i] <- AnyEliminatedByMultiple(list(r = B$r[p], x = B$x[p]),
list(r = B$r[!p], x = B$x[!p]),
kk_2_factorsB[p], kk_2_factorsB[!p],
singleton = singleton,
DoTestMaxInt = DoTestMaxInt, tolGauss = tolGauss,
N_GAUSS_DUPLICATES = N_GAUSS_DUPLICATES, dash = dash,
maxInd = maxInd, testMaxInt = testMaxInt)
}
if (sum(eliminatedBySingleton)) {
WhenProblematicSingletons(paste(sum(eliminatedBySingleton), "out of", n_unique, "unique singletons can reveal primary cells."))
}
}
}
}
NULL
}
N_GAUSS_DUPLICATES <- 1
if (!n2e) {
startA <- A
startB <- B
}
j_values_cell_grouping <- integer(0)
# The main Gaussian elimination loop
# Code made for speed, not readability
for (j in seq_len(n)) {
if (printInc)
if (j%%max(1, n%/%25) == 0) {
cat(dot)
flush.console()
}
if (nForced > 0 & j == 1) {
is0Br <- sapply(B$r, length) == 0
}
if (nForced > 0 & ((j == (nForced + 1)) |((ii > m) & (j <= nForced)))) {
is0Br_ <- sapply(B$r, length) == 0
if (any(is0Br != is0Br_)) {
unsafePrimary <- c(unsafePrimary, primary[is0Br != is0Br_]) # c(... since maybe future extension
unsafePrimaryAsFinal <- -SecondaryFinal(secondary = -unsafePrimary, primary = integer(0), idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = primaryOld)
unsafeOrinary <- unsafePrimaryAsFinal[unsafePrimaryAsFinal <= ncol_x_input]
unsafeExtra <- unsafePrimaryAsFinal[unsafePrimaryAsFinal > ncol_x_input & unsafePrimaryAsFinal <= ncol_x_with_xExtraPrimary]
unsafeSingleton <- unsafePrimaryAsFinal[unsafePrimaryAsFinal > ncol_x_with_xExtraPrimary]
if (length(unsafeExtra)+length(unsafeSingleton)) {
s <- paste0(length(unsafePrimaryAsFinal), " (", length(unsafeOrinary), " ordinary, ", length(unsafeExtra), " extra, ", length(unsafeSingleton), " singleton)")
} else {
s <- length(unsafeOrinary)
}
warning(paste(s, "unsafe primary cells due to forced cells")) # Forced cells -> All primary cells are not safe
}
}
if (!is.null(cell_grouping) & nForced > 0 & j == (nForced + 1)) {
is0Ar <- sapply(A$r, length) == 0
cell_grouping_not_eliminated <- unique(cell_grouping[!is0Ar])
cell_grouping_not_eliminated <- cell_grouping_not_eliminated[cell_grouping_not_eliminated > 0]
cell_grouping_eliminated <- unique(cell_grouping[is0Ar])
cell_grouping_eliminated <- cell_grouping_eliminated[cell_grouping_eliminated > 0]
cell_grouping_problematic <- cell_grouping_eliminated[cell_grouping_eliminated %in% cell_grouping_not_eliminated]
cell_grouping[cell_grouping %in% cell_grouping_eliminated] <- 0L
if (length(cell_grouping_problematic)) {
warning("some cell grouping ignored due to forced celles")
cell_grouping <- repeated_as_integer(cell_grouping)
}
}
if (ii > m){
if (printInc) {
cat("\n")
flush.console()
}
MessageProblematicSingletons()
return(c(candidates[secondary], -unsafePrimary))
}
if (!is.null(cell_grouping)) if (!(j %in% j_values_cell_grouping)) if (j > nForced) if (length(A$r[[j]])) {
if (cell_grouping[j]) {
check_a <- which(cell_grouping == cell_grouping[j])
check_b <- j + which(!(cell_grouping[-seq_len(j)] %in% c(0L, cell_grouping[j])))
if (check_a[1] < j) {
stop("Something wrong in cell_grouping algorithm")
}
} else {
check_a <- j
check_b <- j + which(cell_grouping[-seq_len(j)] != 0)
}
pgi <- rep(TRUE, length(check_a) -1)
pgi_gr <- cell_grouping[check_a]
pgi_gr <- pgi_gr[pgi_gr != 0]
dimensional_check <- is.null(table_id)
if (length(check_b)) {
pgi <- c(pgi, rep(FALSE, length(check_b)))
pgi_new <- FALSE
# pgi2 <- AnyProportionalGaussInt_OLD_ALL(A$r[[check_a]], A$x[[check_a]], A$r[check_b], A$x[check_b], tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsA[check_b])
pgi2 <- AnyEliminatedByMultiple(list(r = A$r[check_a], x = A$x[check_a]), list(r = A$r[check_b], x = A$x[check_b]),
kk_2_factorsA[check_a], kk_2_factorsA[check_b], singleton = singleton, DoTestMaxInt = DoTestMaxInt, tolGauss = tolGauss,
N_GAUSS_DUPLICATES = 1, dash = "x", maxInd = maxInd, testMaxInt = testMaxInt, return_all = TRUE)
check_extra <- FALSE
pgi_tid_old <- NULL
while (any(pgi2) | any(pgi_new) | check_extra) {
if (any(pgi2)) {
check_extra <- TRUE
pgi[!pgi] <- pgi2
pgi_gr <- unique(c(pgi_gr, cell_grouping[c(check_a[-1], check_b)[pgi]]))
pgi_new <- pgi_new | (cell_grouping[check_b] %in% pgi_gr) & !(pgi[SeqInc(length(check_a), length(pgi))])
pgi_tid <- table_id[c(j, c(check_a[-1], check_b)[pgi])]
dimensional_check <- decide_dimensional_check(dimensional_check, pgi_tid, pgi_tid_old)
pgi_tid_old <- pgi_tid
}
pgi2 <- FALSE
if (any(pgi_new)) {
check_extra <- TRUE
w1 <- which(pgi_new)[1]
pgi_new[w1] <- FALSE
pgi[SeqInc(length(check_a), length(pgi))][w1] <- TRUE ###################
pgi_tid <- table_id[c(j, c(check_a[-1], check_b)[pgi])]
dimensional_check <- decide_dimensional_check(dimensional_check, pgi_tid, pgi_tid_old)
pgi_tid_old <- pgi_tid
check_a1 <- check_b[w1]
check_b1 <- check_b[!(pgi[SeqInc(length(check_a), length(pgi))])] ############ check_b[!pgi]
if (length(A$r[[check_a1]])) {
if (length(check_b1)) {
pgi2 <- AnyProportionalGaussInt_OLD_ALL(A$r[[check_a1]], A$x[[check_a1]], A$r[check_b1], A$x[check_b1], tolGauss = tolGauss,
kk_2_factorsB = kk_2_factorsA[check_b1])
}
} else {
warning("length(A$r[[check_a1]] is 0")
}
}
if (!any(pgi2) & !any(pgi_new) & check_extra) {
if ((force_dimensional_check | dimensional_check)) {
check_a1 <- c(check_a, check_b[(pgi[SeqInc(length(check_a), length(pgi))])])
check_b1 <- check_b[!(pgi[SeqInc(length(check_a), length(pgi))])]
pgi2 <- AnyEliminatedByMultiple(list(r = A$r[check_a1], x = A$x[check_a1]), list(r = A$r[check_b1], x = A$x[check_b1]),
kk_2_factorsA[check_a1], kk_2_factorsA[check_b1], singleton = singleton, DoTestMaxInt = DoTestMaxInt, tolGauss = tolGauss,
N_GAUSS_DUPLICATES = 1, dash = "*", maxInd = maxInd, testMaxInt = testMaxInt, return_all = TRUE)
if (any(pgi2)) {
PrintInfo("dimensional_check 1 case found")
if(!dimensional_check){
stop("dimensional_check PROBLEM 1")
}
}
} else {
pgi2 <- FALSE
}
check_extra <- FALSE
}
}
}
if (any(pgi)) {
pgi2 <- rep(FALSE, length(cell_grouping) - j)
pgi2[c(check_a[-1], check_b)[pgi] - j] <- TRUE # use other var name than pgi2?
new_j_order <- j + c(which(pgi2), which(!pgi2))
cell_grouping[-seq_len(j)] <- cell_grouping[new_j_order]
if (!is.null(table_id)) {
table_id[-seq_len(j)] <- table_id[new_j_order]
}
if(any(cell_grouping[SeqInc(j + 1, j + sum(pgi))] %in% cell_grouping[SeqInc(j + sum(pgi) +1, length(cell_grouping))])){
message(j)
stop("Something wrong in cell_grouping algorithm")
}
cell_grouping[SeqInc(j, j + sum(pgi))] <- pgi_gr[1] # All set to same group
check_cell_grouping_within_gauss(cell_grouping)
candidates[-seq_len(j)] <- candidates[new_j_order]
A$r[-seq_len(j)] <- A$r[new_j_order]
A$x[-seq_len(j)] <- A$x[new_j_order]
kk_2_factorsA[-seq_len(j)] <- kk_2_factorsA[new_j_order]
if (N_GAUSS_DUPLICATES == 2) {
A_DUPLICATE$r[-seq_len(j)] <- A_DUPLICATE$r[new_j_order]
A_DUPLICATE$x[-seq_len(j)] <- A_DUPLICATE$x[new_j_order]
kk_2_factorsA_DUPLICATE[-seq_len(j)] <- kk_2_factorsA_DUPLICATE[new_j_order]
}
}
}
if (length(A$r[[j]])) {
if(numSingletonElimination)
if((allow_GAUSS_DUPLICATES & singleton_num[A$r[[j]][1]]) | force_GAUSS_DUPLICATES)
if(N_GAUSS_DUPLICATES==1){
A_DUPLICATE <- A
B_DUPLICATE <- B
eliminatedRows_DUPLICATE <- eliminatedRows
kk_2_factorsA_DUPLICATE <- kk_2_factorsA
kk_2_factorsB_DUPLICATE <- kk_2_factorsB
eliminatedRows_DUPLICATE <- eliminatedRows
DUPLICATE_order_singleton_num <- seq_len(m)
singleton_logical <- as.logical(singleton_num)
above_maxInd <- rep(FALSE, m)
above_maxInd[SeqInc(maxInd + 1, m)] <- TRUE
DUPLICATE_order_singleton_num[singleton_logical & above_maxInd] <- rev(DUPLICATE_order_singleton_num[singleton_logical & above_maxInd])
DUPLICATE_order_singleton_num[singleton_logical & !above_maxInd] <- rev(DUPLICATE_order_singleton_num[singleton_logical & !above_maxInd])
if (force_GAUSS_DUPLICATES) { # reverse other cells as well
DUPLICATE_order_singleton_num[!singleton_logical & above_maxInd] <- rev(DUPLICATE_order_singleton_num[!singleton_logical & above_maxInd])
DUPLICATE_order_singleton_num[!singleton_logical & !above_maxInd] <- rev(DUPLICATE_order_singleton_num[!singleton_logical & !above_maxInd])
}
singleton_num_DUPLICATE <- singleton_num[DUPLICATE_order_singleton_num]
A_DUPLICATE <- A
if (n2e) {
j_here <- j
} else {
j_here <- 1L
}
for(i in SeqInc(j_here, n)){
if(any( singleton_logical[A$r[[i]]]) | force_GAUSS_DUPLICATES){
A_DUPLICATE$r[[i]] <- DUPLICATE_order_singleton_num[A$r[[i]]]
r <- order(A_DUPLICATE$r[[i]])
A_DUPLICATE$r[[i]] <- A_DUPLICATE$r[[i]][r]
A_DUPLICATE$x[[i]] <- A_DUPLICATE$x[[i]][r]
}
}
B_DUPLICATE <- B
for(i in seq_len(nB)){
if(any( singleton_logical[B$r[[i]]]) | force_GAUSS_DUPLICATES){
B_DUPLICATE$r[[i]] <- DUPLICATE_order_singleton_num[B$r[[i]]]
r <- order(B_DUPLICATE$r[[i]])
B_DUPLICATE$r[[i]] <- B_DUPLICATE$r[[i]][r]
B_DUPLICATE$x[[i]] <- B_DUPLICATE$x[[i]][r]
}
}
N_GAUSS_DUPLICATES <- 2
if (dot == ".") {
dot <- ":"
} else {
dot <- dash[N_GAUSS_DUPLICATES]
}
}
reduced <- FALSE
if (j > nForced) {
if (!is.null(cell_grouping)) if (!(j %in% j_values_cell_grouping)) {
j_values_cell_grouping <- integer(0)
}
if (!is.null(cell_grouping) & !length(j_values_cell_grouping)) {
if (cell_grouping[j]) {
n_cell_grouping <- 1
cgj <- j + 1
while (cell_grouping[cgj] == cell_grouping[j]) {
n_cell_grouping <- n_cell_grouping + 1
cgj <- cgj + 1
if (cgj > length(cell_grouping)) {
break
}
}
j_values_cell_grouping <- j - 1L + seq_len(n_cell_grouping)
isSecondary_values <- vector("list", n_cell_grouping)
}
}
if (j %in% j_values_cell_grouping) {
if (j == j_values_cell_grouping[1]) {
j_values_loop <- j_values_cell_grouping
} else {
j_values_loop <- integer(0)
}
} else {
j_values_loop <- j
}
j_correct_value <- j
# The loop, for(j in j_values_loop), is designed so that the same code is run during j_values_cell_grouping as during normal execution.
# Regarding the error message above; stop("Chosen singletonMethod combined with cell_grouping is currently not implemented")
# This is about reduction being done inside the loop below. This needs to be checked more closely how to implement.
if (length(j_values_cell_grouping) & length(j_values_loop)) {
subUsed_old <- subUsed
}
for(j in j_values_loop) {
if (is.null(singleton)) {
isSecondary <- AnyProportionalGaussInt(A$r[[j]], A$x[[j]], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB)
} else {
subSubSec <- A$r[[j]][1] > maxInd2
if (grepl("Space", singletonMethod)) {
okArj <- A$r[[j]] <= maxInd
#isSecondary <- subSubSec | (AnyProportionalGaussInt(A$r[[j]][okArj], A$x[[j]][okArj], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB))
isSecondary <- subSubSec
if (!isSecondary) {
isSecondary <- AnyProportionalGaussInt(A$r[[j]][okArj], A$x[[j]][okArj], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB)
}
} else {
if (subSubSec & !anySum0conservative) {
if (length(unique(sign_here(A$x[[j]]))) > 1) { # Old version when sign_here = function(x) x, old text: # Not proportional to original sum,
if (!any(subUsed[A$r[[j]]])) { # but can't be sure after gaussian elimination of another "Not proportional to sum".
subSubSec <- FALSE # To be sure, non-overlapping restriction introduced (subUsed)
subUsed[A$r[[j]]] <- TRUE
} else {
# if(printInc) # "Can't-be-sure-suppression" if "AnyProportionalGaussInt(.." is FALSE
# # More advanced method may improve
}
}
}
secondaryTRUE <- TRUE
if (subSubSec & singletonNOTprimary) {
r_here <- A$r[[j]]
length_Arj <- length(r_here)
if (anySum0) {
r_here <- ParentChildExtension(r_here, A$r, B$r, parentChildSingleton, easy1, anySum0maxiter)
if (anySum02primary & length(r_here) > length_Arj) {
secondaryTRUE <- 1L # To be sure, secondary made primary when anySum0 matters
}
}
if (!Any0GaussInt(r_here, B$r)) {
for (I_GAUSS_DUPLICATES in 1:N_GAUSS_DUPLICATES){
if(I_GAUSS_DUPLICATES == 2){
A_TEMP <- A
B_TEMP <- B
eliminatedRows_TEMP <- eliminatedRows
singleton_num_TEMP <- singleton_num
A <- A_DUPLICATE
B <- B_DUPLICATE
eliminatedRows <- eliminatedRows_DUPLICATE
singleton_num <- singleton_num_DUPLICATE
}
subSubSec <- FALSE
for (i in c(keepSecondary, SeqInc(j + 1L, n))) {
j_in_i <- A$r[[i]] %in% r_here
if (all(j_in_i)) {
A$r[[i]] <- integer(0)
A$x[[i]] <- integer(0)
} else {
if (any(j_in_i)) {
A$r[[i]] <- A$r[[i]][!j_in_i]
A$x[[i]] <- A$x[[i]][!j_in_i]
}
}
}
for (i in seq_len(nB)) {
j_in_i <- B$r[[i]] %in% r_here
if (any(j_in_i)) {
B$r[[i]] <- B$r[[i]][!j_in_i]
B$x[[i]] <- B$x[[i]][!j_in_i]
}
}
if (n2e) {
A$r[[j]] <- integer(0)
A$x[[j]] <- integer(0)
}
isSecondary <- FALSE
eliminatedRows[r_here] <- TRUE
if(I_GAUSS_DUPLICATES == 2){
A_DUPLICATE <- A
B_DUPLICATE <- B
eliminatedRows_DUPLICATE <- eliminatedRows
singleton_num_DUPLICATE <- singleton_num
A <- A_TEMP
B <- B_TEMP
eliminatedRows <- eliminatedRows_TEMP
singleton_num <- singleton_num_TEMP
}
} # end for (I_GAUSS_DUPLICATES in 1:N_GAUSS_DUPLICATES){
reduced <- TRUE
} else {
isSecondary <- secondaryTRUE
}
} else {
#isSecondary <- subSubSec | (AnyProportionalGaussInt(A$r[[j]], A$x[[j]], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB))
isSecondary <- subSubSec
if (!isSecondary) {
isSecondary <- AnyProportionalGaussInt(A$r[[j]], A$x[[j]], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB)
}
}
}
}
if (length(j_values_cell_grouping)) {
isSecondary_values[[j - j_correct_value + 1L]] = isSecondary
}
}
if (length(j_values_cell_grouping) & length(j_values_loop)) {
if (any(as.logical(isSecondary_values))) {
secondary_from_loop = TRUE
} else {
if (length(j_values_loop) == 1) {
warning("Not expected that length(j_values_loop) == 1")
}
if ((force_dimensional_check | dimensional_check) & length(j_values_loop) > 1) {
secondary_from_loop = AnyEliminatedByMultiple(list(r = A$r[j_values_loop], x = A$x[j_values_loop]),
B,
kk_2_factorsA[j_values_loop], kk_2_factorsB,
singleton = singleton,
DoTestMaxInt = DoTestMaxInt, tolGauss = tolGauss,
N_GAUSS_DUPLICATES = 1, dash = "+",
maxInd = maxInd, testMaxInt = testMaxInt)
if(secondary_from_loop) {
PrintInfo("dimensional_check 2 case found")
if(!dimensional_check){
stop("dimensional_check PROBLEM 2")
}
}
} else {
secondary_from_loop <- FALSE
}
}
if (secondary_from_loop) {
isSecondary_values <- lapply(isSecondary_values, function(element) if (!element) {
1L # That is, FALSE is set to 1L
} else {
element
})
subUsed <- subUsed_old # revert no longer subUsed since secondary instead
}
}
if (length(j_values_cell_grouping)) {
j <- j_correct_value
isSecondary <- isSecondary_values[[match(j, j_values_cell_grouping)]]
}
}
else {
isSecondary <- FALSE
}
if (!isSecondary) {
if (!reduced) {
ind <- A$r[[j]][1]
#eliminatedRows[ind] <- TRUE
for (I_GAUSS_DUPLICATES in 1:N_GAUSS_DUPLICATES){
if(I_GAUSS_DUPLICATES == 2){
A_TEMP <- A
B_TEMP <- B
eliminatedRows_TEMP <- eliminatedRows
singleton_num_TEMP <- singleton_num
kk_2_factorsA_TEMP <- kk_2_factorsA
kk_2_factorsB_TEMP <- kk_2_factorsB
A <- A_DUPLICATE
B <- B_DUPLICATE
eliminatedRows <- eliminatedRows_DUPLICATE
singleton_num <- singleton_num_DUPLICATE
kk_2_factorsA <- kk_2_factorsA_DUPLICATE
kk_2_factorsB <- kk_2_factorsB_DUPLICATE
ind <- A$r[[j]][1]
#eliminatedRows[ind] <- TRUE
}
eliminatedRows[ind] <- TRUE
nrA[] <- NA_integer_
nrB[] <- NA_integer_
for (i in c(keepSecondary, SeqInc(j + 1L, n)))
nrA[i] <- match(ind, A$r[[i]])
for (i in seq_len(nB))
nrB[i] <- match(ind, B$r[[i]])
Arj <- A$r[[j]][-1L]
Axj <- A$x[[j]][-1L]
Axj1 <- A$x[[j]][1L]
if (n2e) {
A$r[[j]] <- integer(0) # NA_integer_
A$x[[j]] <- integer(0) # NA_integer_
}
if (length(Arj) == 0L) {
for (i in which(!is.na(nrA))) {
if(length(A$r[[i]]) == 1L){
A$r[[i]] <- integer(0)
A$x[[i]] <- integer(0)
} else {
A$r[[i]] <- A$r[[i]][-nrA[i]]
A$x[[i]] <- A$x[[i]][-nrA[i]]
if (Scale2one(A$x[[i]])) {
A$x[[i]][] <- 1L
kk_2_factorsA[i] <- 1
}
}
}
} else {
for (i in which(!is.na(nrA))) {
if (length(A$x[[i]]) == 1L) {
A$r[[i]] <- Arj
A$x[[i]] <- Axj
kk_2_factorsA[i] <- kk_2_factorsA[j] # Factors are inherited when all values are inherited
} else {
ai <- Arj
bi <- A$r[[i]][-nrA[i]]
ma <- match(ai, bi)
isnama <- is.na(ma)
ma_isnama <- ma[!isnama]
di <- c(bi, ai[isnama])
if (abs(A$x[[i]][nrA[i]]) == abs(Axj1)) {
suppressWarnings({
if (A$x[[i]][nrA[i]] == Axj1) {
dx <- c(A$x[[i]][-nrA[i]], -Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - Axj[!isnama]
} else {
dx <- c(A$x[[i]][-nrA[i]], Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] + Axj[!isnama]
}
if (DoTestMaxInt) {
if (!anyNA(dx)) {
if (max(dx) > testMaxInt) {
dx[1] <- NA
warning("testMaxInt exceeded")
}
}
}
})
if (anyNA(dx))
{
dot <- dash[N_GAUSS_DUPLICATES] # dot <- "-"
if (A$x[[i]][nrA[i]] == Axj1) {
dx <- as.numeric(c(A$x[[i]][-nrA[i]], -Axj[isnama]))
dx[ma_isnama] <- dx[ma_isnama] - Axj[!isnama]
} else {
dx <- as.numeric(c(A$x[[i]][-nrA[i]], Axj[isnama]))
dx[ma_isnama] <- dx[ma_isnama] + Axj[!isnama]
}
dx <- dx/kk_2_factorsA[i] # rescale needed since change to numeric
kk_2_factorsA[i] <- 1
} else {
if(!is.integer(dx)){
if(is.integer(A$x[[i]])){ # Change to numeric caused by Axj, rescale needed here also
dx <- dx/kk_2_factorsA[i]
kk_2_factorsA[i] <- 1
}
}
}
} else {
kk <- ReduceGreatestDivisor(c(A$x[[i]][nrA[i]], Axj1))
if(is.integer(kk)){
kk_2_factorsA[i] <- kk[2] * kk_2_factorsA[i]
}
suppressWarnings({
dx <- c(kk[2] * A$x[[i]][-nrA[i]], -kk[1] * Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - kk[1] * Axj[!isnama]
if (DoTestMaxInt) {
if (!anyNA(dx)) {
if (max(dx) > testMaxInt) {
dx[1] <- NA
warning("testMaxInt exceeded")
}
}
}
})
if (anyNA(dx))
{
dot <- dash[N_GAUSS_DUPLICATES] # dot <- "-"
kk <- as.numeric(kk)
dx <- c(kk[2] * A$x[[i]][-nrA[i]], -kk[1] * Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - kk[1] * Axj[!isnama]
dx <- dx/kk_2_factorsA[i] # rescale needed since change to numeric
kk_2_factorsA[i] <- 1
} else {
if(!is.integer(dx)){
if(is.integer(A$x[[i]])){ # Change to numeric caused by Axj, rescale needed here also
dx <- dx/kk_2_factorsA[i]
kk_2_factorsA[i] <- 1
}
}
}
}
if(is.integer(dx)){
rows <- (dx != 0L)
} else {
rows <- (abs(dx) >= tolGauss)
}
di <- di[rows]
dx <- dx[rows]
r <- order(di)
A$r[[i]] <- di[r]
A$x[[i]] <- dx[r]
if (Scale2one(A$x[[i]])) {
A$x[[i]][] <- 1L
kk_2_factorsA[i] <- 1
}
}
}
}
if (!is.null(singleton)) {
okInd <- (Arj <= maxInd)
Arj <- Arj[okInd]
Axj <- Axj[okInd]
}
if (length(Arj) == 0L) {
for (i in which(!is.na(nrB))) {
B$r[[i]] <- B$r[[i]][-nrB[i]]
B$x[[i]] <- B$x[[i]][-nrB[i]]
if (Scale2one(B$x[[i]])) {
B$x[[i]][] <- 1L
kk_2_factorsB[i] <- 1
}
}
} else {
for (i in which(!is.na(nrB))) {
if (length(B$x[[i]]) == 1L) {
B$r[[i]] <- Arj
B$x[[i]] <- Axj
kk_2_factorsB[i] <- kk_2_factorsA[j] # Factors are inherited when all values are inherited
} else {
ai <- Arj
bi <- B$r[[i]][-nrB[i]]
ma <- match(ai, bi)
isnama <- is.na(ma)
ma_isnama <- ma[!isnama]
di <- c(bi, ai[isnama])
if (abs(B$x[[i]][nrB[i]]) == abs(Axj1)) {
suppressWarnings({
if (B$x[[i]][nrB[i]] == Axj1) {
dx <- c(B$x[[i]][-nrB[i]], -Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - Axj[!isnama]
} else {
dx <- c(B$x[[i]][-nrB[i]], Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] + Axj[!isnama]
}
if (DoTestMaxInt) {
if (!anyNA(dx)) {
if (max(dx) > testMaxInt) {
dx[1] <- NA
warning("testMaxInt exceeded")
}
}
}
})
if (anyNA(dx))
{
dot <- dash[N_GAUSS_DUPLICATES] # dot <- "-"
if (B$x[[i]][nrB[i]] == Axj1) {
dx <- as.numeric(c(B$x[[i]][-nrB[i]], -Axj[isnama]))
dx[ma_isnama] <- dx[ma_isnama] - Axj[!isnama]
} else {
dx <- as.numeric(c(B$x[[i]][-nrB[i]], Axj[isnama]))
dx[ma_isnama] <- dx[ma_isnama] + Axj[!isnama]
}
dx <- dx/kk_2_factorsB[i]
kk_2_factorsB[i] <- 1
}
else {
if(!is.integer(dx)){
if(is.integer(B$x[[i]])){
dx <- dx/kk_2_factorsB[i]
kk_2_factorsB[i] <- 1
}
}
}
} else {
kk <- ReduceGreatestDivisor(c(B$x[[i]][nrB[i]], Axj1))
if(is.integer(kk)){
kk_2_factorsB[i] <- kk[2] * kk_2_factorsB[i]
}
suppressWarnings({
dx <- c(kk[2] * B$x[[i]][-nrB[i]], -kk[1] * Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - kk[1] * Axj[!isnama]
if (DoTestMaxInt) {
if (!anyNA(dx)) {
if (max(dx) > testMaxInt) {
dx[1] <- NA
warning("testMaxInt exceeded")
}
}
}
})
if (anyNA(dx))
{
dot <- dash[N_GAUSS_DUPLICATES] # dot <- "-"
kk <- as.numeric(kk)
dx <- c(kk[2] * B$x[[i]][-nrB[i]], -kk[1] * Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - kk[1] * Axj[!isnama]
dx <- dx/kk_2_factorsB[i]
kk_2_factorsB[i] <- 1
} else {
if(!is.integer(dx)){
if(is.integer(B$x[[i]])){
dx <- dx/kk_2_factorsB[i]
kk_2_factorsB[i] <- 1
}
}
}
}
if(is.integer(dx)){
rows <- (dx != 0L)
} else {
rows <- (abs(dx) >= tolGauss)
}
if(!length(rows)){
stop("Suppression method failed")
}
di <- di[rows]
dx <- dx[rows]
r <- order(di)
B$r[[i]] <- di[r]
B$x[[i]] <- dx[r]
if (Scale2one(B$x[[i]])) {
B$x[[i]][] <- 1L
kk_2_factorsB[i] <- 1
}
}
}
}
if(I_GAUSS_DUPLICATES == 2){
A_DUPLICATE <- A
B_DUPLICATE <- B
eliminatedRows_DUPLICATE <- eliminatedRows
singleton_num_DUPLICATE <- singleton_num
kk_2_factorsA_DUPLICATE <- kk_2_factorsA
kk_2_factorsB_DUPLICATE <- kk_2_factorsB
A <- A_TEMP
B <- B_TEMP
eliminatedRows <- eliminatedRows_TEMP
singleton_num <- singleton_num_TEMP
kk_2_factorsA <- kk_2_factorsA_TEMP
kk_2_factorsB <- kk_2_factorsB_TEMP
}
} # end for (I_GAUSS_DUPLICATES in 1:N_GAUSS_DUPLICATES){
}
ii <- ii + 1L
} else {
if (!is.logical(isSecondary)) { # Special AnyProportionalGaussInt output
B$r <- c(B$r, A$r[j])
B$x <- c(B$x, A$x[j])
kk_2_factorsB <- c(kk_2_factorsB, kk_2_factorsA[j])
if (N_GAUSS_DUPLICATES == 2) {
B_DUPLICATE$r <- c(B_DUPLICATE$r, A_DUPLICATE$r[j])
B_DUPLICATE$x <- c(B_DUPLICATE$x, A_DUPLICATE$x[j])
kk_2_factorsB_DUPLICATE <- c(kk_2_factorsB_DUPLICATE, kk_2_factorsA_DUPLICATE[j])
}
nB <- nB + 1L
}
if (j %in% parentChildSingleton$uniqueA) {
keepSecondary <- c(keepSecondary, j)
} else {
A$r[[j]] <- integer(0)
A$x[[j]] <- integer(0)
if (N_GAUSS_DUPLICATES == 2) {
A_DUPLICATE$r[[j]] <- integer(0)
A_DUPLICATE$x[[j]] <- integer(0)
}
}
secondary[j] <- TRUE
}
}
if (use_iFunction) {
sys_time2 <- Sys.time()
if (ii-1L == m) {
j_ <- n
} else {
j_ <- j
}
if (j_ == n) {
iWait <- 0
}
if (as.numeric(difftime(sys_time2, sys_time), units = "secs") >= iWait){
sys_time <- sys_time2
false_ <- !secondary
allEmptyDecided <- TRUE
if(allEmptyDecided){
false_[SeqInc(j_+1,n)] <- (lengths(A$r) == 0)[SeqInc(j_+1,n)]
na_ <- !(secondary | false_)
} else { # old code
false_[SeqInc(j_+1,n)] <- FALSE
na_ <- !secondary
na_[SeqInc(1,j_)] <- FALSE
}
iFunction(i = j_, I = n, j = ii-1L, J = m,
true = SecondaryFinal(secondary = candidates[secondary], primary = main_primary, idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = primaryOld),
false = SecondaryFinal(secondary = candidates[false_], primary = integer(0), idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = integer(0)),
na = SecondaryFinal(secondary = candidates[na_], primary = integer(0), idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = integer(0)),
...)
}
}
}
if (printInc) {
cat("\n")
flush.console()
}
MessageProblematicSingletons()
if (!is.null(cell_grouping)) {
unique_cell_grouping <- c(unique(cell_grouping[secondary]), unique(cell_grouping[!secondary]))
unique_cell_grouping <- unique_cell_grouping[unique_cell_grouping != 0]
if (anyDuplicated(unique_cell_grouping)) {
warning("Inconsistent suppression seen early")
}
}
c(candidates[secondary], -unsafePrimary)
}
AnyProportionalGaussInt_OLD <- function(r, x, rB, xB, tolGauss, kk_2_factorsB) {
n <- length(r)
if(!n){
return(TRUE) # Empty "A-input" regarded as proportional
}
for (i in seq_along(rB)) {
ni <- length(xB[[i]])
if (ni) { # Empty "B-input" not regarded as proportional
if (ni == n) {
if (identical(r, rB[[i]])) {
if (n==1L)
return(TRUE)
if (identical(x, xB[[i]]))
return(TRUE)
if (identical(-x, xB[[i]]))
return(TRUE)
cx1xBi1 <- c(x[1], xB[[i]][1])
if(is.integer(cx1xBi1)){
kk <- ReduceGreatestDivisor(cx1xBi1)
suppressWarnings({
kk_2_x <- kk[2] * x
kk_1_xB_i <- kk[1] * xB[[i]]
})
if(anyNA(kk_2_x) | anyNA(kk_1_xB_i)){
kk <- as.numeric(kk)
kk_2_x <- kk[2] * x
kk_1_xB_i <- kk[1] * xB[[i]]
}
if (identical(kk_2_x, kk_1_xB_i))
return(TRUE)
if(is.numeric(kk)){
if( all(abs( xB[[i]] - kk_2_x/kk[1]) < tolGauss))
return(TRUE)
}
}
else {
#if (FALSE) {
#
# Possible code here to look at distribution of numeric computing errors
#
# aabb <- abs((xB[[i]] - (cx1xBi1[2]/cx1xBi1[1]) * x)/kk_2_factorsB[i])
# aabb <- aabb[aabb > 0 & aabb < 1e-04]
#}
if( all(abs( xB[[i]] - (cx1xBi1[2]/cx1xBi1[1])* x) < tolGauss*abs(kk_2_factorsB[i]) ) )
return(TRUE)
}
}
}
}
}
FALSE
}
# Helper function used above
# If new columns are added to an existing table_id,
# then there is reason to believe that the problem is
# not unidimensional (within table_id) and additional checks are needed.
decide_dimensional_check <- function(dimensional_check, pgi_tid, pgi_tid_old) {
if (dimensional_check) {
return(TRUE)
}
if (is.null(pgi_tid_old)) {
return(FALSE)
}
tt_tid_new <- table(pgi_tid)
tt_tid_old <- table(pgi_tid_old)
if (any(tt_tid_new[names(tt_tid_old)] - tt_tid_old)) {
return(TRUE)
}
FALSE
}
# Reduce by Greatest common divisor (when integer input)
ReduceGreatestDivisor <- function(ab) {
if(!is.integer(ab)){
return(c(ab[1]/ab[2], 1))
}
a <- ab[1]
b <- ab[2]
while (TRUE) {
r <- a%%b
a <- b
if (!r)
return(ab%/%b)
b <- r
}
stop("Something wrong")
}
Scale2one <- function(x) {
if (!length(x))
return(FALSE)
if (x[1] == 1L)
return(FALSE)
if (length(x) == 1L)
return(TRUE)
identical(min(x), max(x))
}
# Special version of DummyDuplicated(x, idx = TRUE, rnd = TRUE)
# Some 0’s changed to other values
DummyDuplicatedSpec <- function(x, candidates, primary, forced) {
xtu <- XprodRnd(x = x, duplic = FALSE, idx = FALSE, seed = 123)
if(length(primary)) xtu[primary][xtu[primary] == 0] <- -1L # negative values are unused
if(length(forced)) xtu[forced][xtu[forced] == 0] <- -2L
# to ensure whenEmptyUnsuppressed message as without removeDuplicated
cand0 <- candidates[xtu[candidates] == 0]
cand0 <- cand0[!(cand0 %in% primary)]
cand0 <- cand0[!(cand0 %in% forced)]
cand0 <- cand0[length(cand0)]
xtu[cand0] <- -3L
match(xtu, xtu)
}
# # Test using GaussSuppression that DummyDuplicatedSpec works as expected
# library(GaussSuppression)
# z3 <- SSBtoolsData("z3")
# set.seed(102)
# a <- GaussSuppressionFromData(z3[100:300, ], 1:6, 7, candidates = sample(1350), forced = sample(1350, size = 50), primary = sample(1350, size = 300),
# singletonMethod = "none", whenEmptyUnsuppressed = warning)
# aw <- length(warnings())
# set.seed(102)
# b <- GaussSuppressionFromData(z3[100:300, ], 1:6, 7, candidates = sample(1350), forced = sample(1350, size = 50), primary = sample(1350, size = 300),
# singletonMethod = "none", whenEmptyUnsuppressed = warning, removeDuplicated = FALSE)
# bw <- length(warnings())
#
# # TRUE TRUE
# identical(a, b)
# identical(c(aw, bw), 4:3)
# Some of the code is similar to GaussSuppression:::FindDifferenceCells
# Example: mm <- ModelMatrix(SSBtoolsData("sprt_emp_withEU")[1:6, 1:2])
# FindDiffMatrix(mm[, 5:6], mm[, c(1, 5)])
FindDiffMatrix <- function(x, y = x, max_colSums_diff = Inf) {
xty <- As_TsparseMatrix(crossprod(x, y))
colSums_y_xty_j_1 <- colSums(y)[xty@j + 1]
# finds children in x and parents in y
r <- colSums(x)[xty@i + 1] == xty@x &
colSums_y_xty_j_1 != xty@x &
(colSums_y_xty_j_1 - xty@x) <= max_colSums_diff
child <- xty@i[r] + 1L
parent <- xty@j[r] + 1L
diff_matrix <- y[, parent, drop = FALSE] -
x[, child, drop = FALSE]
colnames(diff_matrix) <- parent
diff_matrix
}
#High frequency unique values ordered last
Order_singleton_num <- function(x) {
y <- x[x > 0]
tt <- table(y)
z <- rep(0, length(x))
z[x > 0] <- tt[as.character(y)]
order(z, x)
}
Try the SSBtools package in your browser
Any scripts or data that you put into this service are public.
SSBtools documentation built on June 19, 2025, 5:07 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions Order_singleton_num FindDiffMatrix DummyDuplicatedSpec Scale2one ReduceGreatestDivisor decide_dimensional_check AnyProportionalGaussInt_OLD GaussSuppression1 SecondaryFinal GaussSuppression
Documented in GaussSuppression
#' Secondary suppression by Gaussian elimination
#'
#' Sequentially the secondary suppression candidates (columns in x) are used to reduce the x-matrix by Gaussian elimination.
#' Candidates who completely eliminate one or more primary suppressed cells (columns in x) are omitted and made secondary suppressed.
#' This ensures that the primary suppressed cells do not depend linearly on the non-suppressed cells.
#' How to order the input candidates is an important choice.
#' The singleton problem and the related problem of zeros are also handled.
#'
#' It is possible to specify too many (all) indices as `candidates`.
#' Indices specified as `primary` or `hidded` will be removed.
#' Hidden indices (not candidates or primary) refer to cells that will not be published, but do not need protection.
#'
#' * **Singleton methods for frequency tables:**
#' All singleton methods, except `"sub2Sum"` and the \code{\link{NumSingleton}} methods, have been implemented with frequency tables in mind.
#' The singleton method `"subSum"` makes new virtual primary suppressed cells, which are the sum of the singletons
#' within each group. The `"subSpace"` method is conservative and ignores the singleton dimensions when looking for
#' linear dependency. The default method, `"anySum"`, is between the other two. Instead of making virtual cells of
#' sums within groups, the aim is to handle all possible sums, also across groups. In addition, `"subSumSpace"` and
#' `"subSumAny"` are possible methods, primarily for testing. These methods are similar to `"subSpace"` and `"anySum"`,
#' and additional cells are created as in `"subSum"`. It is believed that the extra cells are redundant.
#' Note that in order to give information about unsafe cells, `"anySum"` is internally changed to `"subSumAny"` when there are forced cells.
#' All the above methods assume that any published singletons are primary suppressed.
#' If this is not the case, either `"anySumNOTprimary"` or `"anySum0"` must be used.
#' Notably, `"anySum0"` is an enhancement of `"anySumNOTprimary"` for situations where zeros are singletons.
#' Using that method avoids suppressing a zero marginal along with only one of its children.
#' * **Singleton methods for magnitude tables:**
#' The singleton method `"sub2Sum"` makes new virtual primary suppressed cells, which are the sum of two inner cells.
#' This is done when a group contains exactly two primary suppressed inner cells provided that at least one of them is singleton.
#' This was the first method implemented. Other magnitude methods follow the coding according to \code{\link{NumSingleton}}.
#' The `"sub2Sum"` method is equivalent to `"numFFT"`.
#' Also note that `"num"`, `"numFFF"` and `"numFTF"` are equivalent to `"none"`.
#' * **Combined:**
#' For advanced use, `singleton` can be a two-element list with names `"freq"` and `"num"`.
#' Then `singletonMethod` must be a corresponding named two-element vector.
#' For example: `singletonMethod = c(freq = "anySumNOTprimary", num = "sub2Sum")`
#'
#'
#' @param x Matrix that relates cells to be published or suppressed to inner cells. yPublish = crossprod(x,yInner)
#' @param candidates Indices of candidates for secondary suppression
#' @param primary Indices of primary suppressed cells
#' @param forced Indices forced to be not suppressed. `forced` has precedence over `primary`. See `whenPrimaryForced` below.
#' @param hidden Indices to be removed from the above `candidates` input (see details)
#' @param singleton Logical or integer vector of length `nrow(x)` specifying inner cells for singleton handling.
#' Normally, for frequency tables, this means cells with 1s when 0s are non-suppressed and cells with 0s when 0s are suppressed.
#' For some singleton methods, integer values representing the unique magnitude table contributors are needed.
#' For all other singleton methods, only the values after conversion with `as.logical` matter.
#' @param singletonMethod Method for handling the problem of singletons and zeros:
#' `"anySum"` (default), `"anySum0"`, `"anySumNOTprimary"`, `"subSum"`, `"subSpace"`, `"sub2Sum"`, `"none"`
#' or a \code{\link{NumSingleton}} method (see details).
#' @param printInc Printing "..." to console when TRUE
#' @param tolGauss A tolerance parameter for sparse Gaussian elimination and linear dependency. This parameter is used only in cases where integer calculation cannot be used.
#' @param whenEmptySuppressed Function to be called when empty input to primary suppressed cells is problematic. Supply NULL to do nothing.
#' @param whenEmptyUnsuppressed Function to be called when empty input to candidate cells may be problematic. Supply NULL to do nothing.
#' @param whenPrimaryForced Function to be called if any forced cells are primary suppressed (suppression will be ignored). Supply NULL to do nothing.
#' The same function will also be called when there are forced cells marked as singletons (will be ignored).
#' @param removeDuplicated Specifies whether to remove duplicated columns and rows in `x` before running the main algorithm.
#' Removing duplicates results in a faster algorithm while generally maintaining the same results.
#' In some cases, singleton handling for magnitude tables may be affected.
#' In such cases, singleton handling will generally be improved.
#' Singletons are considered when removing duplicate rows, so not all duplicates are removed.
#' The available options for `removeDuplicated` are as follows:
#'
#' * `TRUE` (default): Removes both duplicate columns and rows.
#' * `FALSE`: No removal of duplicates.
#' * `"cols"`: Removes only duplicate columns.
#' * `"rows"`: Removes only duplicate rows.
#' * `"rows2"`: Removes only duplicate non-singleton rows in a way that preserves singleton handling.
#' * Combined possibilities: Variants can be combined with "_". For example,
#' `"cols_rows"` is equivalent to `TRUE`,
#' and `"cols_rows2"` represents an alternative variant. Combining `"rows"` and `"rows2"` is possible, but superfluous calculations are then performed.
#' * `"test"`: A special variant for testing purposes. The four configurations `TRUE`, `FALSE`, `"cols_rows2"`, and `"rows"` are executed.
#' @param iFunction A function to be called during the iterations. See the default function, \code{\link{GaussIterationFunction}}, for description of parameters.
#' @param iWait The minimum number of seconds between each call to `iFunction`.
#' Whenever `iWait<Inf`, `iFunction` will also be called after last iteration.
#' @param xExtraPrimary Extra x-matrix that defines extra primary suppressed cells in addition to those defined by other inputs.
#' @param unsafeAsNegative When `TRUE`, unsafe primary cells due to forced cells are included in the output vector as negative indices.
#' @param printXdim When set to `TRUE`, the `printInc` parameter is also automatically set to `TRUE`.
#' Additionally, the dimensions of the `x` matrix are printed twice:
#' first, the dimensions of the input `x`, potentially extended with `xExtraPrimary`;
#' second, the dimensions after applying `singletonMethod` and `removeDuplicated`.
#' @param cell_grouping Numeric vector indicating suppression group membership.
#' Cells with the same non-zero value belong to the same suppression group,
#' meaning they will be suppressed or non-suppressed together.
#' A value of 0 indicates that the cell is not a member of any suppression group.
#' @param table_id A parameter that can be provided in addition to `cell_grouping` to reduce computation time,
#' when `x` is a block-diagonal matrix. Each block represents a separate table, and `table_id`
#' indicates table affiliation.
#' Note: no check is performed to verify that `table_id` corresponds to the block structure of `x`.
#' @param auto_anySumNOTprimary When `TRUE` (default), the `singletonMethod` `"anySumNOTprimary"` may be
#' forced if a check indicates that singletons are not primary suppressed.
#' Set this to `FALSE` in cases where the `x` matrix has already undergone
#' duplicate row removal, as the check may then produce incorrect results.
#'
#' @param ... Extra unused parameters
#'
#' @return Secondary suppression indices
#' @importFrom Matrix colSums t Matrix bdiag
#' @export
#'
#' @references
#' Langsrud, Ø. (2024):
#' \dQuote{Secondary Cell Suppression by Gaussian Elimination: An Algorithm Suitable for Handling Issues with Zeros and Singletons}.
#' Presented at: \emph{Privacy in statistical databases}, Antibes, France. September 25-27, 2024.
#' \doi{10.1007/978-3-031-69651-0_6}
#'
#'
#' @examples
#' # Input data
#' df <- data.frame(values = c(1, 1, 1, 5, 5, 9, 9, 9, 9, 9, 0, 0, 0, 7, 7),
#' var1 = rep(1:3, each = 5),
#' var2 = c("A", "B", "C", "D", "E"), stringsAsFactors = FALSE)
#'
#' # Make output data frame and x
#' fs <- FormulaSums(df, values ~ var1 * var2, crossTable = TRUE, makeModelMatrix = TRUE)
#' x <- fs$modelMatrix
#' datF <- data.frame(fs$crossTable, values = as.vector(fs$allSums))
#'
#' # Add primary suppression
#' datF$primary <- datF$values
#' datF$primary[datF$values < 5 & datF$values > 0] <- NA
#' datF$suppressedA <- datF$primary
#' datF$suppressedB <- datF$primary
#' datF$suppressedC <- datF$primary
#'
#' # zero secondary suppressed
#' datF$suppressedA[GaussSuppression(x, primary = is.na(datF$primary))] <- NA
#'
#' # zero not secondary suppressed by first in ordering
#' datF$suppressedB[GaussSuppression(x, c(which(datF$values == 0), which(datF$values > 0)),
#' primary = is.na(datF$primary))] <- NA
#'
#' # with singleton
#' datF$suppressedC[GaussSuppression(x, c(which(datF$values == 0), which(datF$values > 0)),
#' primary = is.na(datF$primary), singleton = df$values == 1)] <- NA
#'
#' datF
#'
#'
#'
#' #### with cell_grouping
#'
#' candidates <- c(which(datF$values == 0), which(datF$values > 0))
#' primary <- 10:12
#' cell_grouping <- rep(0, 24)
#'
#' # same as without cell_grouping
#' GaussSuppression(x, candidates, primary, cell_grouping = cell_grouping)
#'
#' cell_grouping[c(16, 20:21)] <- 1
#' cell_grouping[c(10, 4)] <- 2 # 10 is primary
#'
#' GaussSuppression(x, candidates, primary, cell_grouping = cell_grouping)
#'
GaussSuppression <- function(x, candidates = 1:ncol(x), primary = NULL, forced = NULL, hidden = NULL,
singleton = rep(FALSE, nrow(x)), singletonMethod = "anySum", printInc = TRUE, tolGauss = (.Machine$double.eps)^(1/2),
whenEmptySuppressed = warning,
whenEmptyUnsuppressed = message,
whenPrimaryForced = warning,
removeDuplicated = TRUE,
iFunction = GaussIterationFunction, iWait = Inf,
xExtraPrimary = NULL,
unsafeAsNegative = FALSE,
printXdim = FALSE,
cell_grouping = NULL,
table_id = NULL,
auto_anySumNOTprimary = TRUE,
...) {
if (identical(removeDuplicated, "test")){
sysCall <- match.call()
parentFrame <- parent.frame()
cat("\n ---------------- removeDuplicated = TRUE --------------------------\n")
sysCall["removeDuplicated"] <- TRUE
outTRUE <- eval(sysCall, envir = parentFrame)
cat("\n ---------------- removeDuplicated = FALSE --------------------------\n")
sysCall["removeDuplicated"] <- FALSE
outFALSE <- eval(sysCall, envir = parentFrame)
cat('\n ---------------- removeDuplicated = "cols_rows2" -------------------\n')
sysCall["removeDuplicated"] <- "cols_rows2"
out_cols_rows2 <- eval(sysCall, envir = parentFrame)
cat('\n ---------------- removeDuplicated = "rows" -------------------------\n')
sysCall["removeDuplicated"] <- "rows"
out_rows <- eval(sysCall, envir = parentFrame)
if(!isTRUE(all.equal(outTRUE, out_rows)) | !isTRUE(all.equal(outFALSE, out_cols_rows2))) {
stop("removeDuplicated test: all.equal problem")
}
if(!isTRUE(all.equal(outTRUE, outFALSE))){
message("removeDuplicated test: removeDuplicatedRows matters")
}
return(outTRUE)
}
if (is.logical(primary))
primary <- which(primary)
else
primary <- unique(primary)
ncol_x_input <- ncol(x)
if (!is.null(xExtraPrimary)) {
# primary has already been converted to indexes
primary <- c(primary, ncol(x) + seq_len(ncol(xExtraPrimary)))
# forced and hidden can be untreated since conversion to indexes below
x <- cbind(x, xExtraPrimary)
}
ncol_x_with_xExtraPrimary <- ncol(x)
if (printXdim) {
printInc <- TRUE
cat("<", nrow(x), "*", ncol(x), ">", sep = "")
flush.console()
}
if (!length(primary))
return(integer(0))
if (is.logical(candidates))
candidates <- which(candidates)
else
candidates <- unique(candidates)
if (is.logical(hidden))
hidden <- which(hidden)
else
hidden <- unique(hidden)
if (is.logical(forced))
forced <- which(forced)
else forced <- unique(forced)
if (length(hidden))
candidates <- candidates[!(candidates %in% hidden)]
if (!is.null(whenPrimaryForced)) {
if (any(primary %in% forced)) {
whenPrimaryForced("Primary suppression of forced cells ignored")
}
}
# With cell_grouping some secondary cell may be found directly, and not within gauss.
# a: primary cell in same group
# b: primary cell in same group after removeDuplicatedCols applied
secondary_from_cell_grouping_a <- integer(0)
secondary_from_cell_grouping_b <- integer(0)
if (!is.null(cell_grouping)) {
if(length(cell_grouping) != ncol(x)) {
stop("Wrong length of cell_grouping")
}
if (!is.null(table_id)) {
if(length(table_id) != length(cell_grouping)) {
stop("Wrong length of table_id")
}
}
cell_grouping_00 <- cell_grouping != 0
cell_grouping_00[cell_grouping_00][colSums(abs(x[, cell_grouping_00, drop = FALSE])) != 0] <- FALSE
if (any(cell_grouping_00)) {
cell_grouping[cell_grouping_00] <- 0L
warning("cell_grouping of cells with empty input ignored")
}
if (any(cell_grouping != 0)) {
primary_ensured <- ensure_consistency_from_cell_grouping(cell_grouping, primary)
if (length(primary_ensured[[2]])) {
primary <- primary_ensured[[1]]
secondary_from_cell_grouping_a <- primary_ensured[[2]]
}
}
}
unsafePrimary <- integer(0)
removeDuplicatedCols <- FALSE
removeDuplicatedRows <- FALSE
removeDuplicatedRows2 <- FALSE
if (!isFALSE(removeDuplicated)) {
if (is.character(removeDuplicated)) {
removeDuplicated <- tolower(strsplit(removeDuplicated, split = "_", fixed = TRUE)[[1]])
if (any(!(removeDuplicated %in% c("cols", "rows", "rows2")))) {
stop('"removeDuplicated" as character can only consist of "cols", "rows", "rows2", "test", or their combinations.')
}
removeDuplicatedCols <- "cols" %in% removeDuplicated
removeDuplicatedRows <- "rows" %in% removeDuplicated
removeDuplicatedRows2 <- "rows2" %in% removeDuplicated
} else {
removeDuplicatedCols <- TRUE
removeDuplicatedRows <- TRUE
}
}
if (removeDuplicatedCols) {
# idxDD <- DummyDuplicated(x, idx = TRUE, rnd = TRUE)
idxDD <- DummyDuplicatedSpec(x, candidates, primary, forced)
idxDDunique <- unique(idxDD)
if (length(idxDDunique) == length(idxDD)) {
removeDuplicatedCols <- FALSE
} else {
if (length(forced)) { # Needed for warning
primary <- primary[!(primary %in% forced)]
}
idNew <- rep(0L, ncol(x))
idNew[idxDDunique] <- seq_len(length(idxDDunique))
candidatesOld <- candidates
primaryOld <- primary
primary <- idNew[unique(idxDD[primary])]
candidates <- idNew[unique(idxDD[candidates])]
forced <- idNew[unique(idxDD[forced])]
x <- x[, idxDDunique, drop = FALSE]
if (!is.null(cell_grouping)) {
cell_grouping <- update_cell_grouping_from_duplicated(cell_grouping, idxDD, idxDDunique)
cell_grouping <- cell_grouping[idxDDunique]
table_id <- table_id[idxDDunique]
}
if (any(primary %in% forced)) {
unsafePrimary <- c(unsafePrimary, primary[primary %in% forced]) # c(... since maybe future extension
unsafePrimaryAsFinal <- -SecondaryFinal(secondary = -unsafePrimary, primary = integer(0), idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = primaryOld)
unsafeOrinary <- unsafePrimaryAsFinal[unsafePrimaryAsFinal <= ncol_x_input]
unsafeExtra <- unsafePrimaryAsFinal[unsafePrimaryAsFinal > ncol_x_input]
if (length(unsafeExtra)) {
s <- paste0(length(unsafePrimaryAsFinal), " (", length(unsafeOrinary), " ordinary, ", length(unsafeExtra), " extra)")
} else {
s <- length(unsafeOrinary)
}
warning(paste(s, "unsafe primary cells due to forced cells when evaluating duplicates")) # Forced cells -> All primary cells are not safe (duplicated)
}
}
}
if (!is.null(cell_grouping)) {
cell_grouping <- repeated_as_integer(cell_grouping)
if (!any(cell_grouping)) {
cell_grouping <- NULL
table_id <- NULL
} else {
forced <- ensure_consistency_from_cell_grouping(cell_grouping, forced)[[1]]
primary_ensured <- ensure_consistency_from_cell_grouping(cell_grouping, primary)
if (length(primary_ensured[[2]])) {
primary <- primary_ensured[[1]]
secondary_from_cell_grouping_b <- primary_ensured[[2]]
}
candidates <- order_candidates_by_cell_grouping(candidates, cell_grouping)
}
}
if (!removeDuplicatedCols) {
idxDD <- NULL
idxDDunique <- NULL
candidatesOld <- NULL
primaryOld <- NULL
}
candidates <- candidates[!(candidates %in% primary)]
nForced <- length(forced)
if (nForced) {
primary <- primary[!(primary %in% forced)]
candidates <- candidates[!(candidates %in% forced)]
candidates <- c(forced, candidates)
}
if(is.null(singleton)){
singleton <- rep(FALSE, nrow(x))
}
if (is.list(singleton)){
if(!identical(as.vector(sort(names(singleton))), c("freq", "num"))){
stop('names of singleton when list must be "freq" and "num"')
}
if(!identical(as.vector(sort(names(singleton))), c("freq", "num"))){
stop('names of singletonMethod when several must be "freq" and "num"')
}
singleton_num <- singleton[["num"]]
singleton <- as.logical(singleton[["freq"]])
singletonMethod_num <- singletonMethod[["num"]]
singletonMethod <- singletonMethod[["freq"]]
} else {
if (is.logical(singleton)) {
if(length(singleton) == 1L){
singleton <- rep(singleton, nrow(x))
}
}
if(is.integer(singleton)){
singleton_num <- singleton
singleton <- as.logical(singleton)
} else {
singleton_num <- singleton
}
if (!is.logical(singleton)) {
stop("singleton must be logical or integer")
}
if (singletonMethod %in% c("sub2Sum") | !is.null(NumSingleton(singletonMethod))) {
singletonMethod_num <- singletonMethod
singletonMethod <- "none"
} else {
singletonMethod_num <- "none"
}
}
if (is.integer(singleton_num)) {
if (min(singleton_num) < 0) {
stop("integer singletons must be nonzero")
}
}
if(length(singleton) != nrow(x) | length(singleton_num) != nrow(x)){
stop("length(singleton) must be nrow(x)")
}
#if (is.function(singletonMethod)) { # Alternative function possible
# return(singletonMethod(x, candidates, primary, printInc, singleton = singleton, nForced = nForced))
#}
if (!(singletonMethod %in% c("subSum", "subSpace", "anySum", "anySumOld", "anySum0", "anySumNOTprimary", "anySumNOTprimaryOld", "subSumSpace", "subSumAny", "none"))) {
stop("wrong singletonMethod")
}
if (singletonMethod_num == "sub2Sum") {
singletonMethod_num <- "numFFT"
}
#if (singletonMethod_num == "sub2SumUnique") {
# singletonMethod_num <- "numFTT"
#}
if (singletonMethod_num == "none") {
singletonMethod_num <- "num"
}
if (is.null(NumSingleton(singletonMethod_num))) {
stop("wrong singletonMethod")
}
if(length(primary) &!is.null(whenEmptySuppressed)){
if(min(colSums(abs(x[, primary, drop = FALSE]))) == 0){
whenEmptySuppressed("Suppressed cells with empty input will not be protected. Extend input data with zeros?")
}
}
secondary <- GaussSuppression1(x, candidates, primary, printInc, singleton = singleton, nForced = nForced,
singletonMethod = singletonMethod, singletonMethod_num = singletonMethod_num, singleton_num = singleton_num, tolGauss=tolGauss,
iFunction = iFunction, iWait = iWait,
main_primary = primary, idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = primaryOld,
ncol_x_input = ncol_x_input, ncol_x_with_xExtraPrimary = ncol_x_with_xExtraPrimary,
whenPrimaryForced = whenPrimaryForced,
removeDuplicatedRows = removeDuplicatedRows, removeDuplicatedRows2 = removeDuplicatedRows2,
printXdim = printXdim,
cell_grouping = cell_grouping, table_id = table_id,
auto_anySumNOTprimary = auto_anySumNOTprimary,
...)
unsafePrimary <- c(unsafePrimary, -secondary[secondary < 0])
secondary <- secondary[secondary > 0]
if(length(secondary) & !is.null(whenEmptyUnsuppressed)){
lateUnsuppressed <- candidates[SeqInc(1L + min(match(secondary, candidates)), length(candidates))]
lateUnsuppressed <- lateUnsuppressed[!(lateUnsuppressed %in% secondary)]
if(length(lateUnsuppressed)){
if(min(colSums(abs(x[, lateUnsuppressed, drop = FALSE]))) == 0){
whenEmptyUnsuppressed("Cells with empty input will never be secondary suppressed. Extend input data with zeros?")
}
}
}
if (length(secondary_from_cell_grouping_b)) {
secondary <- sort(c(secondary, secondary_from_cell_grouping_b))
unsafePrimary <- unsafePrimary[!(unsafePrimary %in% secondary_from_cell_grouping_b)]
}
if(unsafeAsNegative){
secondary <- c(secondary, -unsafePrimary)
}
secondary <- SecondaryFinal(secondary = secondary, primary = primary, idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = primaryOld)
if (length(secondary_from_cell_grouping_a)) {
secondary <- c(secondary, secondary_from_cell_grouping_a)
s_pos = secondary > 0
secondary <- c(sort(secondary[s_pos]), sort(secondary[!s_pos]))
secondary <- secondary[!duplicated(abs(secondary))]
}
return(secondary)
#}
#stop("wrong singletonMethod")
}
# Function to handle removeDuplicatedCols
SecondaryFinal <- function(secondary, primary, idxDD, idxDDunique, candidatesOld, primaryOld) {
if (is.null(idxDD)) {
return(secondary)
}
unsafePrimary <- -secondary[secondary < 0]
secondary <- secondary[secondary > 0]
ma <- match(idxDD[candidatesOld], c(idxDDunique[secondary], idxDDunique[primary]))
secondary <- candidatesOld[!is.na(ma)]
secondary <- secondary[!(secondary %in% primaryOld)]
if (!length(unsafePrimary)) {
return(secondary)
}
unsafePrimaryA <- unsafePrimary[unsafePrimary <= length(idxDDunique)]
unsafePrimaryB <- unsafePrimary[unsafePrimary > length(idxDDunique)]
ma <- match(idxDD[primaryOld], idxDDunique[unsafePrimaryA])
unsafePrimaryA <- primaryOld[!is.na(ma)]
unsafePrimaryB <- unsafePrimaryB - length(idxDDunique) + length(idxDD)
unsafePrimary <- c(unsafePrimaryA, unsafePrimaryB)
c(secondary, -unsafePrimary)
}
GaussSuppression1 <- function(x, candidates, primary, printInc, singleton, nForced, singletonMethod, singletonMethod_num, singleton_num, tolGauss, testMaxInt = 0, allNumeric = FALSE,
iFunction, iWait,
main_primary, idxDD, idxDDunique, candidatesOld, primaryOld, # main_primary also since primary may be changed
ncol_x_input, ncol_x_with_xExtraPrimary, whenPrimaryForced,
removeDuplicatedRows, removeDuplicatedRows2,
printXdim,
cell_grouping, table_id,
auto_anySumNOTprimary,
...) {
# Trick: GaussSuppressionPrintInfo <- message
PrintInfo <- get0("GaussSuppressionPrintInfo",ifnotfound = function(x) NULL)
gaussSave2enVirOnmEnt <- get0("gaussSave2enVirOnmEnt", ifnotfound = NULL)
if (!is.environment(gaussSave2enVirOnmEnt)) {
gaussSave2enVirOnmEnt <- NULL
}
n2e <- is.null(gaussSave2enVirOnmEnt)
if (!is.numeric(iWait)) {
iWait <- Inf
} else {
if (is.na(iWait)) iWait <- Inf
}
if (!is.function(iFunction)) iWait <- Inf
use_iFunction <- iWait < Inf
if (use_iFunction) {
sys_time <- Sys.time()
}
unsafePrimary <- integer(0)
# testMaxInt is parameter for testing
# The Integer overflow situation will be forced when testMaxInt is exceeded
DoTestMaxInt = testMaxInt > 0
# allNumeric is parameter for testing
# All calculations use numeric algorithm when TRUE
if(allNumeric){
Matrix2listInt <- SSBtools::Matrix2list
}
if (printInc) {
singletonMethod_print <- c(singletonMethod, singletonMethod_num)
singletonMethod_print <- c(singletonMethod_print[!(singletonMethod_print %in% c("none", "num"))])
if (!length(singletonMethod_print)) {
singletonMethod_print <- "none"
}
singletonMethod_print <- paste(singletonMethod_print, collapse = "_")
cat(paste0("GaussSuppression_", singletonMethod_print))
flush.console()
}
numSingleton <- NumSingleton(singletonMethod_num)
if (numSingleton[["singleton2Primary"]] == "T") {
singleton2Primary <- TRUE
forceSingleton2Primary <- TRUE
} else {
singleton2Primary <- numSingleton[["singleton2Primary"]] == "t"
forceSingleton2Primary <- FALSE
}
integerUnique <- as.logical(numSingleton[["integerUnique"]])
if (is.na(integerUnique)) { # When 't'
integerUnique <- is.integer(singleton_num)
}
if (integerUnique & !is.integer(singleton_num)) {
stop("singleton as integer needed")
}
if (!integerUnique & is.integer(singleton_num)) {
singleton_num <- as.logical(singleton_num)
}
numSingleton_elimination_ <- numSingleton[["elimination"]]
numRevealsMessage <- numSingleton_elimination_ == "f"
allow_GAUSS_DUPLICATES <- numSingleton_elimination_ %in% LETTERS
numSingleton_elimination_ <- toupper(numSingleton_elimination_)
numSingletonElimination <- numSingleton_elimination_ != "F"
if (numSingletonElimination) {
numRevealsMessage <- get0("force_numRevealsMessage", ifnotfound = FALSE)
}
WhenProblematicSingletons <- NULL
if (numSingleton_elimination_ == "M") WhenProblematicSingletons <- message
if (numSingleton_elimination_ == "W") WhenProblematicSingletons <- warning
if (numRevealsMessage) WhenProblematicSingletons <- message
# F -> 0, t -> 1, T -> 2
numSingleton_combinations <- 2L * as.integer(as.logical(numSingleton[["combinations"]]))
if (is.na(numSingleton_combinations)) {
numSingleton_combinations <- 1L
}
if (!numSingletonElimination & numSingleton_combinations) {
warning('No effect of "combinations" (5th character) whithout "elimination" (4th character).')
}
sub2Sum <- as.logical(numSingleton[["sum2"]])
if (is.na(sub2Sum)) { # When 'H'
sub2Sum <- TRUE
hierarchySearch <- TRUE
} else {
hierarchySearch <- FALSE
}
if (singletonMethod == "none") {
singleton <- FALSE
}
if (singletonMethod_num %in% c("none", "num")) {
singleton_num <- FALSE
}
forceForcedNotSingletonNum <- (nForced > 0) & any(singleton_num)
forceForcedNotSingletonFreq <- (nForced > 0) & any(singleton)
if (forceForcedNotSingletonNum | forceForcedNotSingletonFreq) {
cS1 <- which(colSums(x) == 1)
cS1 <- cS1[cS1 %in% candidates[seq_len(nForced)]]
if (length(cS1)) {
cS1rS <- rowSums(x[, cS1, drop = FALSE]) > 0
if (forceForcedNotSingletonNum & any(singleton_num & cS1rS)) {
if (!is.null(whenPrimaryForced)) {
whenPrimaryForced("Singleton marking of forced cells ignored (num)")
}
singleton_num[cS1rS] <- FALSE # this is ok when integer: -> 0L
}
if (forceForcedNotSingletonFreq & any(singleton & cS1rS)) {
if (!is.null(whenPrimaryForced)) {
whenPrimaryForced("Singleton marking of forced cells ignored (freq)")
}
singleton[cS1rS] <- FALSE
}
}
}
if (singletonMethod %in% c("anySumOld", "anySumNOTprimaryOld")) {
singletonMethod <- sub("Old", "", singletonMethod)
sign_here <- function(x) x
} else {
sign_here <- sign
}
singletonNOTprimary <- FALSE
anySum0 <- singletonMethod == "anySum0"
if (singletonMethod == "anySumNOTprimary" | anySum0) {
singletonMethod <- "anySum"
singletonNOTprimary <- TRUE
} else {
if (auto_anySumNOTprimary & any(singleton)) {
colSums_x <- colSums(x)
singletonZ <- (colSums(x[singleton, , drop = FALSE]) == 1 & colSums_x == 1)
singletonNOTprimary <- (sum(singletonZ) > sum(singletonZ[primary]))
}
if (singletonNOTprimary) {
if (singletonMethod != "anySum")
stop('singletonMethod must be "anySumNOTprimary" or "anySum0" when singletons not primary suppressed')
warning('singletonMethod is changed to "anySumNOTprimary"')
}
}
if (!is.null(cell_grouping)) {
if (grepl("Space", singletonMethod) | singletonNOTprimary) {
stop("Chosen singletonMethod combined with cell_grouping is currently not implemented")
}
}
parentChildSingleton <- NULL
keepSecondary <- integer(0) # To store A indices that will proceed the elimination process
# after they are found to be secondary suppressed
if (singletonNOTprimary) {
if (anySum0) {
parentChildSingleton <- FindParentChildSingleton(x, candidates, primary, singleton, ncol_x_input, idxDD)
# easy1 <- parentChildSingleton$all1 # Simplification in ParentChildExtension.
easy1 <- TRUE # This seems fine when anySum02primary is TRUE
if (!is.null(parentChildSingleton)) {
anySum0easy1 <- get0("anySum0easy1", ifnotfound = NULL) # It might appear that easy1 affects the result and not just speed.
if (!is.null(anySum0easy1)) { # This could be cases with invisible/hidden childs.
if (!is.na(anySum0easy1)) { # It is believed that easy1 = TRUE is the best method in terms of protection anyway.
easy1 <- anySum0easy1 # But it may still be best to turn it off to avoid the possibility of unsafe
} # secondary suppressions in rare cases.
cat(paste0("_easy1_=_", easy1)) # This is the rationale for the default value. (but now changed due to anySum02primary, see above)
} # With "anySum0easy1" it is possible to test.
anySum02primary <- get0("anySum02primary", ifnotfound = TRUE)
if (!anySum02primary) {
cat(paste0("_2primary_=_", anySum02primary))
}
anySum0maxiter <- get0("anySum0maxiter", ifnotfound = 99)
if (anySum0maxiter != 99) {
cat(paste0("_maxiter_=_", anySum0maxiter))
}
anySum0conservative <- get0("anySum0conservative", ifnotfound = TRUE)
if (!anySum0conservative) {
cat(paste0("_conservative_=_", anySum0conservative))
}
}
}
}
if (is.null(parentChildSingleton)) {
anySum0 <- FALSE
}
if (!anySum0) {
anySum0conservative <- FALSE
}
# In order to give information about unsafe cells, "anySum" is internally changed to "subSumAny" when there are forced cells.
if (!singletonNOTprimary & singletonMethod == "anySum" & nForced > 0) {
singletonMethod <- "subSumAny"
}
if (removeDuplicatedRows) {
# Duplicated non-singleton rows are removed.
row_filter <- rep(TRUE, nrow(x))
if (any(singleton)) {
row_filter[singleton] <- FALSE
}
if (any(singleton_num)) {
row_filter[as.logical(singleton_num)] <- FALSE
}
if (any(row_filter)) {
row_filter[row_filter] <- DummyDuplicated(x[row_filter, , drop = FALSE], idx = FALSE, rows = TRUE, rnd = TRUE)
if (any(!row_filter)) {
if (any(singleton)) {
singleton <- singleton[!row_filter]
}
if (any(singleton_num)) {
singleton_num <- singleton_num[!row_filter]
}
x <- x[!row_filter, , drop = FALSE]
}
}
# Duplicated singleton (for frequency tables) rows are removed.
if (any(singleton)) {
row_filter <- singleton
row_filter[row_filter] <- DummyDuplicated(x[row_filter, , drop = FALSE], idx = FALSE, rows = TRUE, rnd = TRUE)
if (any(row_filter)) {
x <- x[!row_filter, , drop = FALSE]
singleton <- singleton[!row_filter]
if (any(singleton_num))
singleton_num <- singleton_num[!row_filter]
}
}
# Some duplicated singleton (for magnitude tables) rows are removed.
if (any(singleton_num)) {
row_filter <- as.logical(singleton_num)
dd_idx <- DummyDuplicated(x[row_filter, , drop = FALSE], idx = TRUE, rows = TRUE, rnd = TRUE)
# First remove duplicates seen from both singleton integers and rows of x
# After this, the remaining problem is the same, whether singleton_num is logical or integer.
if (!is.logical(singleton_num)) {
duplicated2 <- duplicated(cbind(dd_idx, singleton_num[row_filter]))
row_filter[row_filter] <- duplicated2
if (any(row_filter)) {
x <- x[!row_filter, , drop = FALSE]
singleton_num <- singleton_num[!row_filter]
if (any(singleton))
singleton <- singleton[!row_filter]
dd_idx <- dd_idx[!duplicated2]
}
row_filter <- as.logical(singleton_num)
}
# A group of replicated rows with more than three contributors is not
# related to singleton disclosures protected by any of the methods.
# Singleton marking can be removed,
# and duplicates can also be eliminated.
# Note that removing duplicates while retaining singleton marking will
# result in incorrect calculations of the number of unique contributors.
table_dd_idx <- table_all_integers(dd_idx, max(dd_idx))
least3 <- dd_idx %in% which(table_dd_idx > 2)
if (any(least3)) {
row_filter[row_filter] <- least3
dd_idx <- dd_idx[least3]
duplicated4 <- duplicated(dd_idx)
singleton_num[row_filter] <- FALSE # i.e. set 0 when not logical
row_filter[row_filter] <- duplicated4
x <- x[!row_filter, , drop = FALSE]
singleton_num <- singleton_num[!row_filter]
if (any(singleton))
singleton <- singleton[!row_filter]
}
}
# Checks for errors in the code above
if (any(singleton))
if (length(singleton) != nrow(x))
stop("removeDuplicatedRows failed")
if (any(singleton_num))
if (length(singleton_num) != nrow(x))
stop("removeDuplicatedRows failed")
}
##
## START extending x based on singleton
##
input_ncol_x <- ncol(x)
relevant_ncol_x <- ncol(x)
# make new primary suppressed subSum-cells
if (sub2Sum | singleton2Primary | forceSingleton2Primary) {
if (any(singleton_num)) {
singleton_num_logical <- as.logical(singleton_num)
if (singleton2Primary) { # Change from if(forceSingleton2Primary)
cS1 <- which(colSums(x) == 1)
cS1 <- cS1[!(cS1 %in% primary)]
if (length(cS1)) {
cS1 <- cS1[colSums(x[singleton_num_logical, cS1, drop = FALSE]) == 1]
}
if (length(cS1)) {
if (forceSingleton2Primary) { # Now forceSingleton2Primary used instead of above
primary <- c(primary, cS1)
PrintInfo("forceSingleton2Primary is used")
}
} else {
forceSingleton2Primary <- TRUE # When known that forceSingleton2Primary=TRUE give same result as FALSE (useful later)
}
}
if (singleton2Primary) {
singletonNotInPublish <- singleton_num_logical
singletonNotInPublish[rowSums(x[, primary[colSums(x[, primary, drop = FALSE]) == 1], drop = FALSE]) > 0] <- FALSE # singletonNotInPublish[innerprimary] <- FALSE
if (any(singletonNotInPublish)) {
PrintInfo("singleton2Primary is used")
pZ <- Matrix(0, length(singletonNotInPublish), sum(singletonNotInPublish))
pZ[cbind(which(singletonNotInPublish), seq_len(sum(singletonNotInPublish)))] <- 1
primary <- c(primary, NCOL(x) + seq_len(NCOL(pZ))) # same code as below
x <- cbind(x, pZ) # ---- // -----
}
}
relevant_ncol_x <- ncol(x)
if (sub2Sum) {
pZs <- x * singleton_num_logical
pZ <- x * (rowSums(x[, primary[colSums(x[, primary, drop = FALSE]) == 1], drop = FALSE]) > 0) # x * innerprimary
pZ[ , primary] <- 0 # Not relevant when already suppressed
if (integerUnique) {
if (!is.integer(singleton_num)) {
stop("singleton as integer needed, but something is wrong since this check has been done earlier")
}
relevant_unique_index <- -seq_len(nrow(x)) # negative is guaranteed different from singleton_num
relevant_unique_index[singleton_num_logical] <- singleton_num[singleton_num_logical]
colSums_pZ_g_1 <- colSums(pZ) > 1
if (any(colSums_pZ_g_1)) { # with this, DummyApply problem when onlys zeros in pZ also avoided
cols_g_2 <- DummyApply(pZ, relevant_unique_index, function(x) length(unique(x))) > 2
colSums_pZ_requirement <- !cols_g_2 & colSums_pZ_g_1
} else {
colSums_pZ_requirement <- colSums_pZ_g_1
cols_g_2 <- FALSE
}
# colSums(pZ) > 1 since primary already exists when colSums(pZ) == 1
# =2 before "&" here similar to =2 in sub2Sum:
# * two primary suppressed inner cells provided that at least one of them is singleton (colSums(pZs) > 0)
# * Difference is that same singleton counted as 1
# =1 before "&" here is extra
# * All primary suppressed inner cells in group are same singleton and counted as 1
# * The sum of this group needs protection
# =0 before "&" here
# * will never happen when colSums(pZ) > 1)
#
freq_max_singleton <- max(table(singleton_num[singleton_num_logical]))
} else { # not integerUnique
colSums_pZ_requirement <- colSums(pZ) == 2
if (hierarchySearch) {
cols_g_2 <- colSums(pZ) > 2
}
freq_max_singleton <- 1L
}
if (hierarchySearch) {
if (any(cols_g_2)) {
cols_g_2 <- which(cols_g_2)
PrintInfo(paste("freq_max_singleton for FindDiffMatrix:", freq_max_singleton))
diffMatrix <- FindDiffMatrix(x[, primary[colSums(x[, primary, drop = FALSE]) > 1], drop = FALSE], # primary with more than 1, =1 already treated
pZ[, cols_g_2, drop = FALSE], # (x * innerprimary) with more than 2
freq_max_singleton)
colnames(diffMatrix) <- cols_g_2[as.integer(colnames(diffMatrix))] # now colnames correspond to pZ columns
# Is there any difference column that corresponds to a unique contributor? The code below tries to answer.
if (ncol(diffMatrix)) {
diffMatrix <- diffMatrix[, colSums(diffMatrix[!singleton_num_logical, , drop = FALSE]) == 0, drop = FALSE]
diffMatrix <- diffMatrix[singleton_num_logical, , drop = FALSE]
if (ncol(diffMatrix)) {
colSums_diffMatrix_is1 <- colSums(diffMatrix) == 1
if (any(colSums_diffMatrix_is1)) {
PrintInfo("hierarchySearch is used in the standard way")
colSums_pZ_requirement[as.integer(colnames(diffMatrix)[colSums_diffMatrix_is1])] <- TRUE
diffMatrix <- diffMatrix[, !colSums_diffMatrix_is1, drop = FALSE]
}
if (integerUnique & ncol(diffMatrix)) {
cols_eq_1 <- DummyApply(diffMatrix, relevant_unique_index[singleton_num_logical], function(x) length(unique(x))) == 1
if (any(cols_eq_1)) {
PrintInfo("hierarchySearch is used in combination with integerUnique")
colSums_pZ_requirement[as.integer(colnames(diffMatrix)[cols_eq_1])] <- TRUE
}
}
}
}
}
}
colZ <- ((colSums(pZs) > 0) & colSums_pZ_requirement)
} else {
colZ <- FALSE # This is not logical, but due to code change
}
if (any(colZ)) {
pZ <- pZ[, colZ, drop = FALSE]
nodupl <- which(!DummyDuplicated(pZ, rnd = TRUE)) # nodupl <- which(!duplicated(as.matrix(t(pZ))))
pZ <- pZ[, nodupl, drop = FALSE]
primary <- c(primary, NCOL(x) + seq_len(NCOL(pZ)))
x <- cbind(x, pZ)
}
}
}
if (!all(SeqInc(input_ncol_x + 1L, input_ncol_x) %in% primary)) {
stop("extending x based on singleton failed")
}
# make new primary suppressed subSum-cells
if (grepl("subSum", singletonMethod)) {
if (any(singleton)) {
pZ <- x * singleton
colZ <- colSums(pZ) > 1
if (any(colZ)) { # Same code below
pZ <- pZ[, colZ, drop = FALSE]
nodupl <- which(!DummyDuplicated(pZ, rnd = TRUE)) # which(!duplicated(as.matrix(t(pZ))))
pZ <- pZ[, nodupl, drop = FALSE]
primary <- c(primary, NCOL(x) + seq_len(NCOL(pZ)))
x <- cbind(x, pZ)
}
}
if (singletonMethod == "subSum")
singleton <- FALSE
}
keep_all_singleton_primary <- TRUE
if (keep_all_singleton_primary) {
ddx <- rep(FALSE, ncol(x))
ddx[primary] <- DummyDuplicated(x[, primary, drop = FALSE], rnd = TRUE)
ddx[seq_len(input_ncol_x)] <- FALSE
if (any(ddx)) {
x <- x[, !ddx]
primary <- primary[seq_len(length(primary) - sum(ddx))]
PrintInfo("duplicates found")
}
} else {
ddx <- DummyDuplicated(x, rnd = TRUE)
ddx[seq_len(input_ncol_x)] <- FALSE
if (any(ddx)) {
x <- x[, !ddx]
primary <- primary[seq_len(length(primary) - sum(ddx))]
PrintInfo("duplicates found")
}
}
##
## END extending x based on singleton
##
# Exact copy of code above: Duplicated non-singleton rows are removed.
# Alternative after "extending x based on singleton"
if (removeDuplicatedRows2) {
row_filter <- rep(TRUE, nrow(x))
if (any(singleton)) {
row_filter[singleton] <- FALSE
}
if (any(singleton_num)) {
row_filter[as.logical(singleton_num)] <- FALSE
}
if (any(row_filter)) {
row_filter[row_filter] <- DummyDuplicated(x[row_filter, , drop = FALSE], idx = FALSE, rows = TRUE, rnd = TRUE)
if (any(!row_filter)) {
if (any(singleton)) {
singleton <- singleton[!row_filter]
}
if (any(singleton_num)) {
singleton_num <- singleton_num[!row_filter]
}
x <- x[!row_filter, , drop = FALSE]
}
}
}
if (printXdim) {
cat("<", nrow(x), "*", ncol(x), ">", sep = "")
flush.console()
}
n_relevant_primary <- sum(primary <= relevant_ncol_x)
if (!any(singleton))
singleton <- NULL
# Ensure that 'singleton_num' is no longer used when When there are no singletons.
# Note: If 'singleton_num' contains only FALSE or 0, it may have an incorrect length.
# This can happen if its length is 1
# or if it was not updated correctly due to removeDuplicatedRows
if (!any(singleton_num)) {
numSingletonElimination <- FALSE
numRevealsMessage <- FALSE
}
# Change to unique integers. Other uses of singleton_num are finished
if ((numSingletonElimination|numRevealsMessage) & is.logical(singleton_num)) {
singleton_num[singleton_num] <- seq_len(sum(singleton_num))
}
force_GAUSS_DUPLICATES <- get0("force_GAUSS_DUPLICATES", ifnotfound = FALSE)
order_GAUSS_DUPLICATES <- get0("order_GAUSS_DUPLICATES", ifnotfound = TRUE)
force_dimensional_check <- get0("foRce_dimensional_check", ifnotfound = FALSE)
if (!n2e) {
orderA <- seq_len(nrow(x))
}
if (numSingletonElimination|numRevealsMessage) {
# singleton_num as rows, primary as columns
sspp <- fac2sparse(singleton_num[singleton_num > 0]) %*% x[singleton_num > 0, primary[seq_len(n_relevant_primary)], drop = FALSE]
# Indices of primary originated from unique singleton
uniqueSingletonPrimary <- which(colSums(sign(sspp)) == 1)
if (order_GAUSS_DUPLICATES) {
order_singleton_num <- Order_singleton_num(singleton_num)
} else {
order_singleton_num <- order(singleton_num)
}
x <- x[order_singleton_num, , drop = FALSE]
singleton_num <- singleton_num[order_singleton_num]
if (!is.null(singleton)) {
singleton <- singleton[order_singleton_num]
}
if (!n2e) {
orderA <- order_singleton_num
}
}
order_singleton_num <- NULL
if (!is.null(singleton)) {
ordSingleton <- order(singleton)
singleton <- singleton[ordSingleton]
maTRUE <- match(TRUE, singleton)
if (!is.na(maTRUE)) {
ordyB <- ordSingleton[seq_len(maTRUE - 1)]
maxInd <- maTRUE - 1
} else {
ordyB <- ordSingleton
maxInd <- length(singleton)
}
# maxInd made for subSpace, maxInd2 needed by anySum
maxInd2 <- maxInd
# Removes cells that are handled by anySum/subSpace anyway
# In order to give correct information about unsafe cells, do not remove when there are forced cells.
if (!singletonNOTprimary & nForced == 0) {
if (!grepl("subSum", singletonMethod)) {
primary <- primary[colSums(x[ordyB, primary, drop = FALSE]) != 0]
}
}
A <- Matrix2listInt(x[ordSingleton, candidates, drop = FALSE])
if (!n2e) {
orderA <- orderA[ordSingleton]
}
if (grepl("Space", singletonMethod)) {
B <- Matrix2listInt(x[ordyB, primary, drop = FALSE])
order_singleton_num <- ordyB
if (!n2e) {
orderB <- orderA[ordyB]
}
} else {
B <- Matrix2listInt(x[ordSingleton, primary, drop = FALSE])
maxInd <- nrow(x)
order_singleton_num <- ordSingleton
if (!n2e) {
orderB <- orderA[ordSingleton]
}
}
} else {
A <- Matrix2listInt(x[, candidates, drop = FALSE])
B <- Matrix2listInt(x[, primary, drop = FALSE])
maxInd <- nrow(x)
if (!n2e) {
orderB <- orderA
}
}
############################################################
# cell_grouping is changed to cell_grouping[candidates]
############################################################
if (!is.null(cell_grouping)) {
cell_grouping <- cell_grouping[candidates]
if (!is.null(table_id)) {
table_id <- table_id[candidates]
}
}
if (numSingletonElimination|numRevealsMessage) {
#singleton-integer-value when primary originated from unique singleton
primarySingletonNum <- rep(0, length(primary))
for (i in uniqueSingletonPrimary) {
primarySingletonNum[i] <- singleton_num[B$r[[i]][1]]
}
if (!is.null(order_singleton_num)) {
singleton_num <- singleton_num[order_singleton_num]
}
}
m <- nrow(x)
n <- length(A$r)
nB <- length(B$r)
secondary <- rep(FALSE, n)
if (printInc) {
cat(": ")
flush.console()
}
ii <- 1L
nrA <- rep(NA_integer_, n)
nrB <- rep(NA_integer_, nB)
# To store cumulative factors from ReduceGreatestDivisor
# Used to rescale when switching to numeric algorithm (caused by integer overflow).
kk_2_factorsA <- rep(1, n)
kk_2_factorsB <- rep(1, nB)
subUsed <- rep(FALSE, m) # needed by anySum
dot <- "."
# dot will change to "-" when integer overflow occur (then numeric algorithm)
dash <- c("-", "=") # dot <- dash[N_GAUSS_DUPLICATES]
# when N_GAUSS_DUPLICATES==2 dot will change to ":" or "=" (integer overflow)
###################################################################################################
# START - define AnyProportionalGaussInt
# when !numSingletonElimination:
# old function outside this function is used (see below)
# Since function defined inside, it is possible to "cheat" and avoid extra input-parameters.
# Now primarySingletonNum and numSingletonElimination avoided
#
# This function reuses code from old branch “Feature/safety-range”.
# Comments about rangeValues/rangeLimits are from this old code.
# It is possible to further develop this within this new function.
#####################################################################################################
Check_s_unique <- function(s_unique, i) {
if (length(s_unique) > 1) {
return(FALSE)
}
if (length(s_unique) == 0) {
return(TRUE)
}
if (s_unique == 0) {
return(FALSE)
}
if (s_unique == primarySingletonNum[i]) {
return(FALSE)
}
1L
}
AnyProportionalGaussInt_NEW <- function(r, x, rB, xB, tolGauss, kk_2_factorsB, singleton_num = NULL) {
n <- length(r)
if (!n) {
return(TRUE) # Empty 'A-input' regarded as proportional
}
if (numSingleton_combinations) {
if (numSingletonElimination) {
s_unique <- unique(singleton_num[r])
if (length(s_unique) <= numSingleton_combinations) {
if (min(s_unique) > 0) {
return(1L)
}
}
}
}
for (i in seq_along(rB)) {
numSingletonEliminationCheck <- numSingletonElimination
if(i > n_relevant_primary){
numSingletonEliminationCheck <- FALSE
}
ni <- length(xB[[i]])
if (ni) { # Empty 'B-input' not regarded as proportional
doCheck <- FALSE
if (ni == n) {
if (identical(r, rB[[i]])) { # Same as in old function
doCheck <- TRUE
x_here <- x
xBi_here <- xB[[i]]
if (numSingletonEliminationCheck) {
#restLimit <- rangeLimits[i] # This is new
s_unique <- integer(0)
r_in_rB <- rep(TRUE, length(r))
rB_in_r <- r_in_rB
} else {
#restLimit <- 0
}
}
}
if (!doCheck) {
if (numSingletonEliminationCheck) {
r_in_rB <- r %in% rB[[i]]
if (any(r_in_rB)) {
r_in_rB <- r %in% rB[[i]]
rB_in_r <- rB[[i]] %in% r
rdiff <- c(r[!r_in_rB], rB[[i]][!rB_in_r]) # elements not common
# sum_rdiff <- sum(rangeValues[rdiff])
s_unique <- unique(singleton_num[rdiff])
x_here <- x[r_in_rB] # x reduced to common elements
xBi_here <- xB[[i]][rB_in_r] # xB[[i]] reduced to common elements
#restLimit <- rangeLimits[i] - sum_rdiff
#doCheck <- restLimit >= 0 # New when non-NULL rangeLimits
#doCheck <- (length(s_unique) <= 1) & (min(s_unique) > 0)
doCheck <- Check_s_unique(s_unique, i)
}
}
}
if (doCheck) {
if (n == 1L)
return(doCheck)
if (identical(x_here, xBi_here))
return(doCheck)
if (identical(-x_here, xBi_here))
return(doCheck)
cx1xBi1 <- c(x_here[1], xBi_here[1])
if (is.integer(cx1xBi1)) {
kk <- ReduceGreatestDivisor(cx1xBi1)
suppressWarnings({
kk_2_x <- kk[2] * x_here
kk_1_xB_i <- kk[1] * xBi_here
})
if (anyNA(kk_2_x) | anyNA(kk_1_xB_i)) {
kk <- as.numeric(kk)
kk_2_x <- kk[2] * x_here
kk_1_xB_i <- kk[1] * xBi_here
}
if (identical(kk_2_x, kk_1_xB_i))
return(doCheck)
if (is.numeric(kk)) {
if (all(abs(xBi_here - kk_2_x/kk[1]) < tolGauss))
return(doCheck)
}
if (numSingletonEliminationCheck) { #if (restLimit) { # Same logical vectors again when TRUE not returned and when rangeLimits used (simplification possible)
if (!is.numeric(kk)) {
rrest <- (r[r_in_rB])[kk_2_x != kk_1_xB_i]
} else {
rrest <- (r[r_in_rB])[!(abs(xBi_here - kk_2_x/kk[1]) < tolGauss)]
}
s_unique <- unique(c(s_unique, singleton_num[rrest]))
check_s_unique <- Check_s_unique(s_unique, i)
if (check_s_unique) { #if ((length(s_unique) <= 1) & (min(s_unique) > 0)) {
return(check_s_unique) # New possible TRUE-return caused by rangeLimits
}
}
} else {
# Possible code here to look at distribution of numeric computing errors
# aabb <- abs((xB[[i]] - (cx1xBi1[2]/cx1xBi1[1]) * x)/kk_2_factorsB[i])
# aabb <- aabb[aabb > 0 & aabb < 1e-04]
if (all(abs(xBi_here - (cx1xBi1[2]/cx1xBi1[1]) * x_here) < tolGauss * abs(kk_2_factorsB[i])))
return(doCheck)
if (numSingletonEliminationCheck) {# if (restLimit) {
rrest <- (r[r_in_rB])[!(abs(xBi_here - (cx1xBi1[2]/cx1xBi1[1]) * x_here) < tolGauss * abs(kk_2_factorsB[i]))]
s_unique <- unique(c(s_unique, singleton_num[rrest]))
# if (sum(rangeValues[rrest]) < restLimit) {
check_s_unique <- Check_s_unique(s_unique, i)
if (check_s_unique) { #if ((length(s_unique) <= 1) & (min(s_unique) > 0)) {
return(check_s_unique) # New possible TRUE-return caused by rangeLimits (as above)
}
}
}
}
}
}
FALSE
}
if (force_GAUSS_DUPLICATES) {
if (!numSingletonElimination) {
singleton_num <- rep(0L, m)
numSingletonElimination <- TRUE
}
}
if (numSingletonElimination) {
#AnyProportionalGaussInt <- AnyProportionalGaussInt_NEW
AnyProportionalGaussInt <- function(...){
anyP <- AnyProportionalGaussInt_NEW(A$r[[j]], A$x[[j]], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB, singleton_num = singleton_num)
if (anyP) return(anyP)
if (N_GAUSS_DUPLICATES == 1) {
return(anyP)
}
anyP <- AnyProportionalGaussInt_NEW(A_DUPLICATE$r[[j]], A_DUPLICATE$x[[j]], B_DUPLICATE$r, B_DUPLICATE$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB_DUPLICATE, singleton_num = singleton_num_DUPLICATE)
if (anyP) return(anyP)
if (singleton_num[A_DUPLICATE$r[[j]]][1] & length(A_DUPLICATE$r[[j]]) > 1) {
r <- c(SeqInc(2, length(A_DUPLICATE$r[[j]])), 1L)
anyP <- AnyProportionalGaussInt_NEW(A_DUPLICATE$r[[j]][r], A_DUPLICATE$x[[j]][r], B_DUPLICATE$r, B_DUPLICATE$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB_DUPLICATE, singleton_num = singleton_num_DUPLICATE)
}
anyP
}
} else {
if (get0("testAnyProportionalGaussInt", ifnotfound = FALSE)) {
AnyProportionalGaussInt <- function(...) {
apgiOLD <- AnyProportionalGaussInt_OLD(...)
apgiNEW <- AnyProportionalGaussInt_NEW(...)
if (apgiOLD != apgiNEW) {
stop("AnyProportionalGaussInt NEW/OLD problem")
}
apgiOLD
}
} else {
AnyProportionalGaussInt <- AnyProportionalGaussInt_OLD
}
}
#####################################################################
# END - define AnyProportionalGaussInt
#####################################################################
eliminatedRows <- rep(FALSE, m)
MessageProblematicSingletons <- function() { # internal function since used twice below
if (!n2e) {
gaussenv <- as.list(parent.frame())
list2env(list(gaussenv = gaussenv), envir = gaussSave2enVirOnmEnt)
}
if (!is.null(WhenProblematicSingletons) & (numSingletonElimination|numRevealsMessage)) {
if (!numRevealsMessage) {
rowsP <- which(eliminatedRows & as.logical(singleton_num))
singleP <- singleton_num[rowsP]
if (N_GAUSS_DUPLICATES == 2) {
rows2 <- DUPLICATE_order_singleton_num[which(eliminatedRows_DUPLICATE & as.logical(singleton_num_DUPLICATE))]
rowsP <- rowsP[rowsP %in% rows2]
singleP <- singleP[singleP %in% singleton_num[rows2]]
}
n_unique <- length(unique(singleton_num[as.logical(singleton_num)]))
singleP <- unique(singleP)
if (!forceSingleton2Primary) {
if (length(singleP)) {
WhenProblematicSingletons(paste(sum(length(singleP)), "out of", n_unique, "unique singletons problematic. Whether reveals exist is not calculated."))
}
}
} else {
if (!forceSingleton2Primary) {
message('Actual reveals cannot be calculated. See ?NumSingleton. Try T as "1st character"?')
} else {
singleP <- unique(singleton_num[as.logical(singleton_num)])
n_unique <- length(singleP)
}
}
if (forceSingleton2Primary) {
if (length(singleP)) {
eliminatedBySingleton <- rep(FALSE, length(singleP))
for (i in seq_len(n_relevant_primary)) {
if (!length(B$r[[i]])) { # Avoid special situation
primarySingletonNum[i] <- 0
}
}
B$r <- B$r[seq_len(n_relevant_primary)]
B$x <- B$x[seq_len(n_relevant_primary)]
primarySingletonNum <- primarySingletonNum[seq_len(n_relevant_primary)]
kk_2_factorsB <- kk_2_factorsB[seq_len(n_relevant_primary)]
for (i in seq_along(singleP)) {
p <- primarySingletonNum == singleP[i]
eliminatedBySingleton[i] <- AnyEliminatedByMultiple(list(r = B$r[p], x = B$x[p]),
list(r = B$r[!p], x = B$x[!p]),
kk_2_factorsB[p], kk_2_factorsB[!p],
singleton = singleton,
DoTestMaxInt = DoTestMaxInt, tolGauss = tolGauss,
N_GAUSS_DUPLICATES = N_GAUSS_DUPLICATES, dash = dash,
maxInd = maxInd, testMaxInt = testMaxInt)
}
if (sum(eliminatedBySingleton)) {
WhenProblematicSingletons(paste(sum(eliminatedBySingleton), "out of", n_unique, "unique singletons can reveal primary cells."))
}
}
}
}
NULL
}
N_GAUSS_DUPLICATES <- 1
if (!n2e) {
startA <- A
startB <- B
}
j_values_cell_grouping <- integer(0)
# The main Gaussian elimination loop
# Code made for speed, not readability
for (j in seq_len(n)) {
if (printInc)
if (j%%max(1, n%/%25) == 0) {
cat(dot)
flush.console()
}
if (nForced > 0 & j == 1) {
is0Br <- sapply(B$r, length) == 0
}
if (nForced > 0 & ((j == (nForced + 1)) |((ii > m) & (j <= nForced)))) {
is0Br_ <- sapply(B$r, length) == 0
if (any(is0Br != is0Br_)) {
unsafePrimary <- c(unsafePrimary, primary[is0Br != is0Br_]) # c(... since maybe future extension
unsafePrimaryAsFinal <- -SecondaryFinal(secondary = -unsafePrimary, primary = integer(0), idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = primaryOld)
unsafeOrinary <- unsafePrimaryAsFinal[unsafePrimaryAsFinal <= ncol_x_input]
unsafeExtra <- unsafePrimaryAsFinal[unsafePrimaryAsFinal > ncol_x_input & unsafePrimaryAsFinal <= ncol_x_with_xExtraPrimary]
unsafeSingleton <- unsafePrimaryAsFinal[unsafePrimaryAsFinal > ncol_x_with_xExtraPrimary]
if (length(unsafeExtra)+length(unsafeSingleton)) {
s <- paste0(length(unsafePrimaryAsFinal), " (", length(unsafeOrinary), " ordinary, ", length(unsafeExtra), " extra, ", length(unsafeSingleton), " singleton)")
} else {
s <- length(unsafeOrinary)
}
warning(paste(s, "unsafe primary cells due to forced cells")) # Forced cells -> All primary cells are not safe
}
}
if (!is.null(cell_grouping) & nForced > 0 & j == (nForced + 1)) {
is0Ar <- sapply(A$r, length) == 0
cell_grouping_not_eliminated <- unique(cell_grouping[!is0Ar])
cell_grouping_not_eliminated <- cell_grouping_not_eliminated[cell_grouping_not_eliminated > 0]
cell_grouping_eliminated <- unique(cell_grouping[is0Ar])
cell_grouping_eliminated <- cell_grouping_eliminated[cell_grouping_eliminated > 0]
cell_grouping_problematic <- cell_grouping_eliminated[cell_grouping_eliminated %in% cell_grouping_not_eliminated]
cell_grouping[cell_grouping %in% cell_grouping_eliminated] <- 0L
if (length(cell_grouping_problematic)) {
warning("some cell grouping ignored due to forced celles")
cell_grouping <- repeated_as_integer(cell_grouping)
}
}
if (ii > m){
if (printInc) {
cat("\n")
flush.console()
}
MessageProblematicSingletons()
return(c(candidates[secondary], -unsafePrimary))
}
if (!is.null(cell_grouping)) if (!(j %in% j_values_cell_grouping)) if (j > nForced) if (length(A$r[[j]])) {
if (cell_grouping[j]) {
check_a <- which(cell_grouping == cell_grouping[j])
check_b <- j + which(!(cell_grouping[-seq_len(j)] %in% c(0L, cell_grouping[j])))
if (check_a[1] < j) {
stop("Something wrong in cell_grouping algorithm")
}
} else {
check_a <- j
check_b <- j + which(cell_grouping[-seq_len(j)] != 0)
}
pgi <- rep(TRUE, length(check_a) -1)
pgi_gr <- cell_grouping[check_a]
pgi_gr <- pgi_gr[pgi_gr != 0]
dimensional_check <- is.null(table_id)
if (length(check_b)) {
pgi <- c(pgi, rep(FALSE, length(check_b)))
pgi_new <- FALSE
# pgi2 <- AnyProportionalGaussInt_OLD_ALL(A$r[[check_a]], A$x[[check_a]], A$r[check_b], A$x[check_b], tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsA[check_b])
pgi2 <- AnyEliminatedByMultiple(list(r = A$r[check_a], x = A$x[check_a]), list(r = A$r[check_b], x = A$x[check_b]),
kk_2_factorsA[check_a], kk_2_factorsA[check_b], singleton = singleton, DoTestMaxInt = DoTestMaxInt, tolGauss = tolGauss,
N_GAUSS_DUPLICATES = 1, dash = "x", maxInd = maxInd, testMaxInt = testMaxInt, return_all = TRUE)
check_extra <- FALSE
pgi_tid_old <- NULL
while (any(pgi2) | any(pgi_new) | check_extra) {
if (any(pgi2)) {
check_extra <- TRUE
pgi[!pgi] <- pgi2
pgi_gr <- unique(c(pgi_gr, cell_grouping[c(check_a[-1], check_b)[pgi]]))
pgi_new <- pgi_new | (cell_grouping[check_b] %in% pgi_gr) & !(pgi[SeqInc(length(check_a), length(pgi))])
pgi_tid <- table_id[c(j, c(check_a[-1], check_b)[pgi])]
dimensional_check <- decide_dimensional_check(dimensional_check, pgi_tid, pgi_tid_old)
pgi_tid_old <- pgi_tid
}
pgi2 <- FALSE
if (any(pgi_new)) {
check_extra <- TRUE
w1 <- which(pgi_new)[1]
pgi_new[w1] <- FALSE
pgi[SeqInc(length(check_a), length(pgi))][w1] <- TRUE ###################
pgi_tid <- table_id[c(j, c(check_a[-1], check_b)[pgi])]
dimensional_check <- decide_dimensional_check(dimensional_check, pgi_tid, pgi_tid_old)
pgi_tid_old <- pgi_tid
check_a1 <- check_b[w1]
check_b1 <- check_b[!(pgi[SeqInc(length(check_a), length(pgi))])] ############ check_b[!pgi]
if (length(A$r[[check_a1]])) {
if (length(check_b1)) {
pgi2 <- AnyProportionalGaussInt_OLD_ALL(A$r[[check_a1]], A$x[[check_a1]], A$r[check_b1], A$x[check_b1], tolGauss = tolGauss,
kk_2_factorsB = kk_2_factorsA[check_b1])
}
} else {
warning("length(A$r[[check_a1]] is 0")
}
}
if (!any(pgi2) & !any(pgi_new) & check_extra) {
if ((force_dimensional_check | dimensional_check)) {
check_a1 <- c(check_a, check_b[(pgi[SeqInc(length(check_a), length(pgi))])])
check_b1 <- check_b[!(pgi[SeqInc(length(check_a), length(pgi))])]
pgi2 <- AnyEliminatedByMultiple(list(r = A$r[check_a1], x = A$x[check_a1]), list(r = A$r[check_b1], x = A$x[check_b1]),
kk_2_factorsA[check_a1], kk_2_factorsA[check_b1], singleton = singleton, DoTestMaxInt = DoTestMaxInt, tolGauss = tolGauss,
N_GAUSS_DUPLICATES = 1, dash = "*", maxInd = maxInd, testMaxInt = testMaxInt, return_all = TRUE)
if (any(pgi2)) {
PrintInfo("dimensional_check 1 case found")
if(!dimensional_check){
stop("dimensional_check PROBLEM 1")
}
}
} else {
pgi2 <- FALSE
}
check_extra <- FALSE
}
}
}
if (any(pgi)) {
pgi2 <- rep(FALSE, length(cell_grouping) - j)
pgi2[c(check_a[-1], check_b)[pgi] - j] <- TRUE # use other var name than pgi2?
new_j_order <- j + c(which(pgi2), which(!pgi2))
cell_grouping[-seq_len(j)] <- cell_grouping[new_j_order]
if (!is.null(table_id)) {
table_id[-seq_len(j)] <- table_id[new_j_order]
}
if(any(cell_grouping[SeqInc(j + 1, j + sum(pgi))] %in% cell_grouping[SeqInc(j + sum(pgi) +1, length(cell_grouping))])){
message(j)
stop("Something wrong in cell_grouping algorithm")
}
cell_grouping[SeqInc(j, j + sum(pgi))] <- pgi_gr[1] # All set to same group
check_cell_grouping_within_gauss(cell_grouping)
candidates[-seq_len(j)] <- candidates[new_j_order]
A$r[-seq_len(j)] <- A$r[new_j_order]
A$x[-seq_len(j)] <- A$x[new_j_order]
kk_2_factorsA[-seq_len(j)] <- kk_2_factorsA[new_j_order]
if (N_GAUSS_DUPLICATES == 2) {
A_DUPLICATE$r[-seq_len(j)] <- A_DUPLICATE$r[new_j_order]
A_DUPLICATE$x[-seq_len(j)] <- A_DUPLICATE$x[new_j_order]
kk_2_factorsA_DUPLICATE[-seq_len(j)] <- kk_2_factorsA_DUPLICATE[new_j_order]
}
}
}
if (length(A$r[[j]])) {
if(numSingletonElimination)
if((allow_GAUSS_DUPLICATES & singleton_num[A$r[[j]][1]]) | force_GAUSS_DUPLICATES)
if(N_GAUSS_DUPLICATES==1){
A_DUPLICATE <- A
B_DUPLICATE <- B
eliminatedRows_DUPLICATE <- eliminatedRows
kk_2_factorsA_DUPLICATE <- kk_2_factorsA
kk_2_factorsB_DUPLICATE <- kk_2_factorsB
eliminatedRows_DUPLICATE <- eliminatedRows
DUPLICATE_order_singleton_num <- seq_len(m)
singleton_logical <- as.logical(singleton_num)
above_maxInd <- rep(FALSE, m)
above_maxInd[SeqInc(maxInd + 1, m)] <- TRUE
DUPLICATE_order_singleton_num[singleton_logical & above_maxInd] <- rev(DUPLICATE_order_singleton_num[singleton_logical & above_maxInd])
DUPLICATE_order_singleton_num[singleton_logical & !above_maxInd] <- rev(DUPLICATE_order_singleton_num[singleton_logical & !above_maxInd])
if (force_GAUSS_DUPLICATES) { # reverse other cells as well
DUPLICATE_order_singleton_num[!singleton_logical & above_maxInd] <- rev(DUPLICATE_order_singleton_num[!singleton_logical & above_maxInd])
DUPLICATE_order_singleton_num[!singleton_logical & !above_maxInd] <- rev(DUPLICATE_order_singleton_num[!singleton_logical & !above_maxInd])
}
singleton_num_DUPLICATE <- singleton_num[DUPLICATE_order_singleton_num]
A_DUPLICATE <- A
if (n2e) {
j_here <- j
} else {
j_here <- 1L
}
for(i in SeqInc(j_here, n)){
if(any( singleton_logical[A$r[[i]]]) | force_GAUSS_DUPLICATES){
A_DUPLICATE$r[[i]] <- DUPLICATE_order_singleton_num[A$r[[i]]]
r <- order(A_DUPLICATE$r[[i]])
A_DUPLICATE$r[[i]] <- A_DUPLICATE$r[[i]][r]
A_DUPLICATE$x[[i]] <- A_DUPLICATE$x[[i]][r]
}
}
B_DUPLICATE <- B
for(i in seq_len(nB)){
if(any( singleton_logical[B$r[[i]]]) | force_GAUSS_DUPLICATES){
B_DUPLICATE$r[[i]] <- DUPLICATE_order_singleton_num[B$r[[i]]]
r <- order(B_DUPLICATE$r[[i]])
B_DUPLICATE$r[[i]] <- B_DUPLICATE$r[[i]][r]
B_DUPLICATE$x[[i]] <- B_DUPLICATE$x[[i]][r]
}
}
N_GAUSS_DUPLICATES <- 2
if (dot == ".") {
dot <- ":"
} else {
dot <- dash[N_GAUSS_DUPLICATES]
}
}
reduced <- FALSE
if (j > nForced) {
if (!is.null(cell_grouping)) if (!(j %in% j_values_cell_grouping)) {
j_values_cell_grouping <- integer(0)
}
if (!is.null(cell_grouping) & !length(j_values_cell_grouping)) {
if (cell_grouping[j]) {
n_cell_grouping <- 1
cgj <- j + 1
while (cell_grouping[cgj] == cell_grouping[j]) {
n_cell_grouping <- n_cell_grouping + 1
cgj <- cgj + 1
if (cgj > length(cell_grouping)) {
break
}
}
j_values_cell_grouping <- j - 1L + seq_len(n_cell_grouping)
isSecondary_values <- vector("list", n_cell_grouping)
}
}
if (j %in% j_values_cell_grouping) {
if (j == j_values_cell_grouping[1]) {
j_values_loop <- j_values_cell_grouping
} else {
j_values_loop <- integer(0)
}
} else {
j_values_loop <- j
}
j_correct_value <- j
# The loop, for(j in j_values_loop), is designed so that the same code is run during j_values_cell_grouping as during normal execution.
# Regarding the error message above; stop("Chosen singletonMethod combined with cell_grouping is currently not implemented")
# This is about reduction being done inside the loop below. This needs to be checked more closely how to implement.
if (length(j_values_cell_grouping) & length(j_values_loop)) {
subUsed_old <- subUsed
}
for(j in j_values_loop) {
if (is.null(singleton)) {
isSecondary <- AnyProportionalGaussInt(A$r[[j]], A$x[[j]], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB)
} else {
subSubSec <- A$r[[j]][1] > maxInd2
if (grepl("Space", singletonMethod)) {
okArj <- A$r[[j]] <= maxInd
#isSecondary <- subSubSec | (AnyProportionalGaussInt(A$r[[j]][okArj], A$x[[j]][okArj], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB))
isSecondary <- subSubSec
if (!isSecondary) {
isSecondary <- AnyProportionalGaussInt(A$r[[j]][okArj], A$x[[j]][okArj], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB)
}
} else {
if (subSubSec & !anySum0conservative) {
if (length(unique(sign_here(A$x[[j]]))) > 1) { # Old version when sign_here = function(x) x, old text: # Not proportional to original sum,
if (!any(subUsed[A$r[[j]]])) { # but can't be sure after gaussian elimination of another "Not proportional to sum".
subSubSec <- FALSE # To be sure, non-overlapping restriction introduced (subUsed)
subUsed[A$r[[j]]] <- TRUE
} else {
# if(printInc) # "Can't-be-sure-suppression" if "AnyProportionalGaussInt(.." is FALSE
# # More advanced method may improve
}
}
}
secondaryTRUE <- TRUE
if (subSubSec & singletonNOTprimary) {
r_here <- A$r[[j]]
length_Arj <- length(r_here)
if (anySum0) {
r_here <- ParentChildExtension(r_here, A$r, B$r, parentChildSingleton, easy1, anySum0maxiter)
if (anySum02primary & length(r_here) > length_Arj) {
secondaryTRUE <- 1L # To be sure, secondary made primary when anySum0 matters
}
}
if (!Any0GaussInt(r_here, B$r)) {
for (I_GAUSS_DUPLICATES in 1:N_GAUSS_DUPLICATES){
if(I_GAUSS_DUPLICATES == 2){
A_TEMP <- A
B_TEMP <- B
eliminatedRows_TEMP <- eliminatedRows
singleton_num_TEMP <- singleton_num
A <- A_DUPLICATE
B <- B_DUPLICATE
eliminatedRows <- eliminatedRows_DUPLICATE
singleton_num <- singleton_num_DUPLICATE
}
subSubSec <- FALSE
for (i in c(keepSecondary, SeqInc(j + 1L, n))) {
j_in_i <- A$r[[i]] %in% r_here
if (all(j_in_i)) {
A$r[[i]] <- integer(0)
A$x[[i]] <- integer(0)
} else {
if (any(j_in_i)) {
A$r[[i]] <- A$r[[i]][!j_in_i]
A$x[[i]] <- A$x[[i]][!j_in_i]
}
}
}
for (i in seq_len(nB)) {
j_in_i <- B$r[[i]] %in% r_here
if (any(j_in_i)) {
B$r[[i]] <- B$r[[i]][!j_in_i]
B$x[[i]] <- B$x[[i]][!j_in_i]
}
}
if (n2e) {
A$r[[j]] <- integer(0)
A$x[[j]] <- integer(0)
}
isSecondary <- FALSE
eliminatedRows[r_here] <- TRUE
if(I_GAUSS_DUPLICATES == 2){
A_DUPLICATE <- A
B_DUPLICATE <- B
eliminatedRows_DUPLICATE <- eliminatedRows
singleton_num_DUPLICATE <- singleton_num
A <- A_TEMP
B <- B_TEMP
eliminatedRows <- eliminatedRows_TEMP
singleton_num <- singleton_num_TEMP
}
} # end for (I_GAUSS_DUPLICATES in 1:N_GAUSS_DUPLICATES){
reduced <- TRUE
} else {
isSecondary <- secondaryTRUE
}
} else {
#isSecondary <- subSubSec | (AnyProportionalGaussInt(A$r[[j]], A$x[[j]], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB))
isSecondary <- subSubSec
if (!isSecondary) {
isSecondary <- AnyProportionalGaussInt(A$r[[j]], A$x[[j]], B$r, B$x, tolGauss = tolGauss, kk_2_factorsB = kk_2_factorsB)
}
}
}
}
if (length(j_values_cell_grouping)) {
isSecondary_values[[j - j_correct_value + 1L]] = isSecondary
}
}
if (length(j_values_cell_grouping) & length(j_values_loop)) {
if (any(as.logical(isSecondary_values))) {
secondary_from_loop = TRUE
} else {
if (length(j_values_loop) == 1) {
warning("Not expected that length(j_values_loop) == 1")
}
if ((force_dimensional_check | dimensional_check) & length(j_values_loop) > 1) {
secondary_from_loop = AnyEliminatedByMultiple(list(r = A$r[j_values_loop], x = A$x[j_values_loop]),
B,
kk_2_factorsA[j_values_loop], kk_2_factorsB,
singleton = singleton,
DoTestMaxInt = DoTestMaxInt, tolGauss = tolGauss,
N_GAUSS_DUPLICATES = 1, dash = "+",
maxInd = maxInd, testMaxInt = testMaxInt)
if(secondary_from_loop) {
PrintInfo("dimensional_check 2 case found")
if(!dimensional_check){
stop("dimensional_check PROBLEM 2")
}
}
} else {
secondary_from_loop <- FALSE
}
}
if (secondary_from_loop) {
isSecondary_values <- lapply(isSecondary_values, function(element) if (!element) {
1L # That is, FALSE is set to 1L
} else {
element
})
subUsed <- subUsed_old # revert no longer subUsed since secondary instead
}
}
if (length(j_values_cell_grouping)) {
j <- j_correct_value
isSecondary <- isSecondary_values[[match(j, j_values_cell_grouping)]]
}
}
else {
isSecondary <- FALSE
}
if (!isSecondary) {
if (!reduced) {
ind <- A$r[[j]][1]
#eliminatedRows[ind] <- TRUE
for (I_GAUSS_DUPLICATES in 1:N_GAUSS_DUPLICATES){
if(I_GAUSS_DUPLICATES == 2){
A_TEMP <- A
B_TEMP <- B
eliminatedRows_TEMP <- eliminatedRows
singleton_num_TEMP <- singleton_num
kk_2_factorsA_TEMP <- kk_2_factorsA
kk_2_factorsB_TEMP <- kk_2_factorsB
A <- A_DUPLICATE
B <- B_DUPLICATE
eliminatedRows <- eliminatedRows_DUPLICATE
singleton_num <- singleton_num_DUPLICATE
kk_2_factorsA <- kk_2_factorsA_DUPLICATE
kk_2_factorsB <- kk_2_factorsB_DUPLICATE
ind <- A$r[[j]][1]
#eliminatedRows[ind] <- TRUE
}
eliminatedRows[ind] <- TRUE
nrA[] <- NA_integer_
nrB[] <- NA_integer_
for (i in c(keepSecondary, SeqInc(j + 1L, n)))
nrA[i] <- match(ind, A$r[[i]])
for (i in seq_len(nB))
nrB[i] <- match(ind, B$r[[i]])
Arj <- A$r[[j]][-1L]
Axj <- A$x[[j]][-1L]
Axj1 <- A$x[[j]][1L]
if (n2e) {
A$r[[j]] <- integer(0) # NA_integer_
A$x[[j]] <- integer(0) # NA_integer_
}
if (length(Arj) == 0L) {
for (i in which(!is.na(nrA))) {
if(length(A$r[[i]]) == 1L){
A$r[[i]] <- integer(0)
A$x[[i]] <- integer(0)
} else {
A$r[[i]] <- A$r[[i]][-nrA[i]]
A$x[[i]] <- A$x[[i]][-nrA[i]]
if (Scale2one(A$x[[i]])) {
A$x[[i]][] <- 1L
kk_2_factorsA[i] <- 1
}
}
}
} else {
for (i in which(!is.na(nrA))) {
if (length(A$x[[i]]) == 1L) {
A$r[[i]] <- Arj
A$x[[i]] <- Axj
kk_2_factorsA[i] <- kk_2_factorsA[j] # Factors are inherited when all values are inherited
} else {
ai <- Arj
bi <- A$r[[i]][-nrA[i]]
ma <- match(ai, bi)
isnama <- is.na(ma)
ma_isnama <- ma[!isnama]
di <- c(bi, ai[isnama])
if (abs(A$x[[i]][nrA[i]]) == abs(Axj1)) {
suppressWarnings({
if (A$x[[i]][nrA[i]] == Axj1) {
dx <- c(A$x[[i]][-nrA[i]], -Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - Axj[!isnama]
} else {
dx <- c(A$x[[i]][-nrA[i]], Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] + Axj[!isnama]
}
if (DoTestMaxInt) {
if (!anyNA(dx)) {
if (max(dx) > testMaxInt) {
dx[1] <- NA
warning("testMaxInt exceeded")
}
}
}
})
if (anyNA(dx))
{
dot <- dash[N_GAUSS_DUPLICATES] # dot <- "-"
if (A$x[[i]][nrA[i]] == Axj1) {
dx <- as.numeric(c(A$x[[i]][-nrA[i]], -Axj[isnama]))
dx[ma_isnama] <- dx[ma_isnama] - Axj[!isnama]
} else {
dx <- as.numeric(c(A$x[[i]][-nrA[i]], Axj[isnama]))
dx[ma_isnama] <- dx[ma_isnama] + Axj[!isnama]
}
dx <- dx/kk_2_factorsA[i] # rescale needed since change to numeric
kk_2_factorsA[i] <- 1
} else {
if(!is.integer(dx)){
if(is.integer(A$x[[i]])){ # Change to numeric caused by Axj, rescale needed here also
dx <- dx/kk_2_factorsA[i]
kk_2_factorsA[i] <- 1
}
}
}
} else {
kk <- ReduceGreatestDivisor(c(A$x[[i]][nrA[i]], Axj1))
if(is.integer(kk)){
kk_2_factorsA[i] <- kk[2] * kk_2_factorsA[i]
}
suppressWarnings({
dx <- c(kk[2] * A$x[[i]][-nrA[i]], -kk[1] * Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - kk[1] * Axj[!isnama]
if (DoTestMaxInt) {
if (!anyNA(dx)) {
if (max(dx) > testMaxInt) {
dx[1] <- NA
warning("testMaxInt exceeded")
}
}
}
})
if (anyNA(dx))
{
dot <- dash[N_GAUSS_DUPLICATES] # dot <- "-"
kk <- as.numeric(kk)
dx <- c(kk[2] * A$x[[i]][-nrA[i]], -kk[1] * Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - kk[1] * Axj[!isnama]
dx <- dx/kk_2_factorsA[i] # rescale needed since change to numeric
kk_2_factorsA[i] <- 1
} else {
if(!is.integer(dx)){
if(is.integer(A$x[[i]])){ # Change to numeric caused by Axj, rescale needed here also
dx <- dx/kk_2_factorsA[i]
kk_2_factorsA[i] <- 1
}
}
}
}
if(is.integer(dx)){
rows <- (dx != 0L)
} else {
rows <- (abs(dx) >= tolGauss)
}
di <- di[rows]
dx <- dx[rows]
r <- order(di)
A$r[[i]] <- di[r]
A$x[[i]] <- dx[r]
if (Scale2one(A$x[[i]])) {
A$x[[i]][] <- 1L
kk_2_factorsA[i] <- 1
}
}
}
}
if (!is.null(singleton)) {
okInd <- (Arj <= maxInd)
Arj <- Arj[okInd]
Axj <- Axj[okInd]
}
if (length(Arj) == 0L) {
for (i in which(!is.na(nrB))) {
B$r[[i]] <- B$r[[i]][-nrB[i]]
B$x[[i]] <- B$x[[i]][-nrB[i]]
if (Scale2one(B$x[[i]])) {
B$x[[i]][] <- 1L
kk_2_factorsB[i] <- 1
}
}
} else {
for (i in which(!is.na(nrB))) {
if (length(B$x[[i]]) == 1L) {
B$r[[i]] <- Arj
B$x[[i]] <- Axj
kk_2_factorsB[i] <- kk_2_factorsA[j] # Factors are inherited when all values are inherited
} else {
ai <- Arj
bi <- B$r[[i]][-nrB[i]]
ma <- match(ai, bi)
isnama <- is.na(ma)
ma_isnama <- ma[!isnama]
di <- c(bi, ai[isnama])
if (abs(B$x[[i]][nrB[i]]) == abs(Axj1)) {
suppressWarnings({
if (B$x[[i]][nrB[i]] == Axj1) {
dx <- c(B$x[[i]][-nrB[i]], -Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - Axj[!isnama]
} else {
dx <- c(B$x[[i]][-nrB[i]], Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] + Axj[!isnama]
}
if (DoTestMaxInt) {
if (!anyNA(dx)) {
if (max(dx) > testMaxInt) {
dx[1] <- NA
warning("testMaxInt exceeded")
}
}
}
})
if (anyNA(dx))
{
dot <- dash[N_GAUSS_DUPLICATES] # dot <- "-"
if (B$x[[i]][nrB[i]] == Axj1) {
dx <- as.numeric(c(B$x[[i]][-nrB[i]], -Axj[isnama]))
dx[ma_isnama] <- dx[ma_isnama] - Axj[!isnama]
} else {
dx <- as.numeric(c(B$x[[i]][-nrB[i]], Axj[isnama]))
dx[ma_isnama] <- dx[ma_isnama] + Axj[!isnama]
}
dx <- dx/kk_2_factorsB[i]
kk_2_factorsB[i] <- 1
}
else {
if(!is.integer(dx)){
if(is.integer(B$x[[i]])){
dx <- dx/kk_2_factorsB[i]
kk_2_factorsB[i] <- 1
}
}
}
} else {
kk <- ReduceGreatestDivisor(c(B$x[[i]][nrB[i]], Axj1))
if(is.integer(kk)){
kk_2_factorsB[i] <- kk[2] * kk_2_factorsB[i]
}
suppressWarnings({
dx <- c(kk[2] * B$x[[i]][-nrB[i]], -kk[1] * Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - kk[1] * Axj[!isnama]
if (DoTestMaxInt) {
if (!anyNA(dx)) {
if (max(dx) > testMaxInt) {
dx[1] <- NA
warning("testMaxInt exceeded")
}
}
}
})
if (anyNA(dx))
{
dot <- dash[N_GAUSS_DUPLICATES] # dot <- "-"
kk <- as.numeric(kk)
dx <- c(kk[2] * B$x[[i]][-nrB[i]], -kk[1] * Axj[isnama])
dx[ma_isnama] <- dx[ma_isnama] - kk[1] * Axj[!isnama]
dx <- dx/kk_2_factorsB[i]
kk_2_factorsB[i] <- 1
} else {
if(!is.integer(dx)){
if(is.integer(B$x[[i]])){
dx <- dx/kk_2_factorsB[i]
kk_2_factorsB[i] <- 1
}
}
}
}
if(is.integer(dx)){
rows <- (dx != 0L)
} else {
rows <- (abs(dx) >= tolGauss)
}
if(!length(rows)){
stop("Suppression method failed")
}
di <- di[rows]
dx <- dx[rows]
r <- order(di)
B$r[[i]] <- di[r]
B$x[[i]] <- dx[r]
if (Scale2one(B$x[[i]])) {
B$x[[i]][] <- 1L
kk_2_factorsB[i] <- 1
}
}
}
}
if(I_GAUSS_DUPLICATES == 2){
A_DUPLICATE <- A
B_DUPLICATE <- B
eliminatedRows_DUPLICATE <- eliminatedRows
singleton_num_DUPLICATE <- singleton_num
kk_2_factorsA_DUPLICATE <- kk_2_factorsA
kk_2_factorsB_DUPLICATE <- kk_2_factorsB
A <- A_TEMP
B <- B_TEMP
eliminatedRows <- eliminatedRows_TEMP
singleton_num <- singleton_num_TEMP
kk_2_factorsA <- kk_2_factorsA_TEMP
kk_2_factorsB <- kk_2_factorsB_TEMP
}
} # end for (I_GAUSS_DUPLICATES in 1:N_GAUSS_DUPLICATES){
}
ii <- ii + 1L
} else {
if (!is.logical(isSecondary)) { # Special AnyProportionalGaussInt output
B$r <- c(B$r, A$r[j])
B$x <- c(B$x, A$x[j])
kk_2_factorsB <- c(kk_2_factorsB, kk_2_factorsA[j])
if (N_GAUSS_DUPLICATES == 2) {
B_DUPLICATE$r <- c(B_DUPLICATE$r, A_DUPLICATE$r[j])
B_DUPLICATE$x <- c(B_DUPLICATE$x, A_DUPLICATE$x[j])
kk_2_factorsB_DUPLICATE <- c(kk_2_factorsB_DUPLICATE, kk_2_factorsA_DUPLICATE[j])
}
nB <- nB + 1L
}
if (j %in% parentChildSingleton$uniqueA) {
keepSecondary <- c(keepSecondary, j)
} else {
A$r[[j]] <- integer(0)
A$x[[j]] <- integer(0)
if (N_GAUSS_DUPLICATES == 2) {
A_DUPLICATE$r[[j]] <- integer(0)
A_DUPLICATE$x[[j]] <- integer(0)
}
}
secondary[j] <- TRUE
}
}
if (use_iFunction) {
sys_time2 <- Sys.time()
if (ii-1L == m) {
j_ <- n
} else {
j_ <- j
}
if (j_ == n) {
iWait <- 0
}
if (as.numeric(difftime(sys_time2, sys_time), units = "secs") >= iWait){
sys_time <- sys_time2
false_ <- !secondary
allEmptyDecided <- TRUE
if(allEmptyDecided){
false_[SeqInc(j_+1,n)] <- (lengths(A$r) == 0)[SeqInc(j_+1,n)]
na_ <- !(secondary | false_)
} else { # old code
false_[SeqInc(j_+1,n)] <- FALSE
na_ <- !secondary
na_[SeqInc(1,j_)] <- FALSE
}
iFunction(i = j_, I = n, j = ii-1L, J = m,
true = SecondaryFinal(secondary = candidates[secondary], primary = main_primary, idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = primaryOld),
false = SecondaryFinal(secondary = candidates[false_], primary = integer(0), idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = integer(0)),
na = SecondaryFinal(secondary = candidates[na_], primary = integer(0), idxDD = idxDD, idxDDunique = idxDDunique, candidatesOld = candidatesOld, primaryOld = integer(0)),
...)
}
}
}
if (printInc) {
cat("\n")
flush.console()
}
MessageProblematicSingletons()
if (!is.null(cell_grouping)) {
unique_cell_grouping <- c(unique(cell_grouping[secondary]), unique(cell_grouping[!secondary]))
unique_cell_grouping <- unique_cell_grouping[unique_cell_grouping != 0]
if (anyDuplicated(unique_cell_grouping)) {
warning("Inconsistent suppression seen early")
}
}
c(candidates[secondary], -unsafePrimary)
}
AnyProportionalGaussInt_OLD <- function(r, x, rB, xB, tolGauss, kk_2_factorsB) {
n <- length(r)
if(!n){
return(TRUE) # Empty "A-input" regarded as proportional
}
for (i in seq_along(rB)) {
ni <- length(xB[[i]])
if (ni) { # Empty "B-input" not regarded as proportional
if (ni == n) {
if (identical(r, rB[[i]])) {
if (n==1L)
return(TRUE)
if (identical(x, xB[[i]]))
return(TRUE)
if (identical(-x, xB[[i]]))
return(TRUE)
cx1xBi1 <- c(x[1], xB[[i]][1])
if(is.integer(cx1xBi1)){
kk <- ReduceGreatestDivisor(cx1xBi1)
suppressWarnings({
kk_2_x <- kk[2] * x
kk_1_xB_i <- kk[1] * xB[[i]]
})
if(anyNA(kk_2_x) | anyNA(kk_1_xB_i)){
kk <- as.numeric(kk)
kk_2_x <- kk[2] * x
kk_1_xB_i <- kk[1] * xB[[i]]
}
if (identical(kk_2_x, kk_1_xB_i))
return(TRUE)
if(is.numeric(kk)){
if( all(abs( xB[[i]] - kk_2_x/kk[1]) < tolGauss))
return(TRUE)
}
}
else {
#if (FALSE) {
#
# Possible code here to look at distribution of numeric computing errors
#
# aabb <- abs((xB[[i]] - (cx1xBi1[2]/cx1xBi1[1]) * x)/kk_2_factorsB[i])
# aabb <- aabb[aabb > 0 & aabb < 1e-04]
#}
if( all(abs( xB[[i]] - (cx1xBi1[2]/cx1xBi1[1])* x) < tolGauss*abs(kk_2_factorsB[i]) ) )
return(TRUE)
}
}
}
}
}
FALSE
}
# Helper function used above
# If new columns are added to an existing table_id,
# then there is reason to believe that the problem is
# not unidimensional (within table_id) and additional checks are needed.
decide_dimensional_check <- function(dimensional_check, pgi_tid, pgi_tid_old) {
if (dimensional_check) {
return(TRUE)
}
if (is.null(pgi_tid_old)) {
return(FALSE)
}
tt_tid_new <- table(pgi_tid)
tt_tid_old <- table(pgi_tid_old)
if (any(tt_tid_new[names(tt_tid_old)] - tt_tid_old)) {
return(TRUE)
}
FALSE
}
# Reduce by Greatest common divisor (when integer input)
ReduceGreatestDivisor <- function(ab) {
if(!is.integer(ab)){
return(c(ab[1]/ab[2], 1))
}
a <- ab[1]
b <- ab[2]
while (TRUE) {
r <- a%%b
a <- b
if (!r)
return(ab%/%b)
b <- r
}
stop("Something wrong")
}
Scale2one <- function(x) {
if (!length(x))
return(FALSE)
if (x[1] == 1L)
return(FALSE)
if (length(x) == 1L)
return(TRUE)
identical(min(x), max(x))
}
# Special version of DummyDuplicated(x, idx = TRUE, rnd = TRUE)
# Some 0’s changed to other values
DummyDuplicatedSpec <- function(x, candidates, primary, forced) {
xtu <- XprodRnd(x = x, duplic = FALSE, idx = FALSE, seed = 123)
if(length(primary)) xtu[primary][xtu[primary] == 0] <- -1L # negative values are unused
if(length(forced)) xtu[forced][xtu[forced] == 0] <- -2L
# to ensure whenEmptyUnsuppressed message as without removeDuplicated
cand0 <- candidates[xtu[candidates] == 0]
cand0 <- cand0[!(cand0 %in% primary)]
cand0 <- cand0[!(cand0 %in% forced)]
cand0 <- cand0[length(cand0)]
xtu[cand0] <- -3L
match(xtu, xtu)
}
# # Test using GaussSuppression that DummyDuplicatedSpec works as expected
# library(GaussSuppression)
# z3 <- SSBtoolsData("z3")
# set.seed(102)
# a <- GaussSuppressionFromData(z3[100:300, ], 1:6, 7, candidates = sample(1350), forced = sample(1350, size = 50), primary = sample(1350, size = 300),
# singletonMethod = "none", whenEmptyUnsuppressed = warning)
# aw <- length(warnings())
# set.seed(102)
# b <- GaussSuppressionFromData(z3[100:300, ], 1:6, 7, candidates = sample(1350), forced = sample(1350, size = 50), primary = sample(1350, size = 300),
# singletonMethod = "none", whenEmptyUnsuppressed = warning, removeDuplicated = FALSE)
# bw <- length(warnings())
#
# # TRUE TRUE
# identical(a, b)
# identical(c(aw, bw), 4:3)
# Some of the code is similar to GaussSuppression:::FindDifferenceCells
# Example: mm <- ModelMatrix(SSBtoolsData("sprt_emp_withEU")[1:6, 1:2])
# FindDiffMatrix(mm[, 5:6], mm[, c(1, 5)])
FindDiffMatrix <- function(x, y = x, max_colSums_diff = Inf) {
xty <- As_TsparseMatrix(crossprod(x, y))
colSums_y_xty_j_1 <- colSums(y)[xty@j + 1]
# finds children in x and parents in y
r <- colSums(x)[xty@i + 1] == xty@x &
colSums_y_xty_j_1 != xty@x &
(colSums_y_xty_j_1 - xty@x) <= max_colSums_diff
child <- xty@i[r] + 1L
parent <- xty@j[r] + 1L
diff_matrix <- y[, parent, drop = FALSE] -
x[, child, drop = FALSE]
colnames(diff_matrix) <- parent
diff_matrix
}
#High frequency unique values ordered last
Order_singleton_num <- function(x) {
y <- x[x > 0]
tt <- table(y)
z <- rep(0, length(x))
z[x > 0] <- tt[as.character(y)]
order(z, x)
}
Try the SSBtools package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.