R/PrimaryFromSuppressedData.R

In GaussSuppression: Tabular Data Suppression using Gaussian Elimination

#' `primary` and `forced` from suppressed data
#' 
#' Function for \code{\link{GaussSuppressionFromData}}
#' 
#' `ForcedFromSuppressedData`  uses `forcedData = TRUE` and hence a  vector to be use as forced is generated. 
#' `NotPrimaryFromSuppressedData` is similar, but `TRUE` elements are replaced by `NA`'s. 
#' Hence the result can be used as an extra primary vector to ensure that code combinations 
#' not suppressed according to `suppressedData` are forced not to be primary suppressed.
#' 
#' The variables used in `suppressedData` in addition to `"suppressed"` are those with matching names in `crossTable`. Others are ignored. 
#' For variables in `crossTable` not in `suppressedData`, only totals are considered.   
#' Others rows are ignored when mathing with `suppressedData`.
#' 
#' When suppressedData is a list, the final result is the union of individual results of each data frame. 
#'
#' @param x A (sparse) dummy matrix
#' @param crossTable crossTable generated by parent function
#' @param suppressedData A data frame or a list of data frames as output from \code{\link{GaussSuppressionFromData}}. 
#'                      If the variable `suppressed` is not included, all rows are considered suppressed.
#' @param forcedData When `TRUE`, the suppressed coding is swapped. 
#' @param totCode A named list of totals codes   
#' @param ... Unused parameters 
#' 
#' @return Logical vector to be used as \code{\link[SSBtools]{GaussSuppression}} input 
#' 
#' @export
#' 
#' @examples 
#' 
#' z2 <- SSBtoolsData("z2")
#' 
#' # Data to be used as suppressedData
#' a <- GaussSuppressionFromData(z2, c(1, 3, 4), 5, protectZeros = FALSE)
#' 
#' # For alternative ways to suppress the same table
#' b1 <- GaussSuppressionFromData(z2, 1:4, 5)
#' b2 <- GaussSuppressionFromData(z2, 1:4, 5, primary = c(PrimaryDefault, PrimaryFromSuppressedData),
#'                                suppressedData = a)
#' b3 <- GaussSuppressionFromData(z2, 1:4, 5, primary = c(PrimaryDefault, PrimaryFromSuppressedData),
#'                                suppressedData = a, forced = ForcedFromSuppressedData)
#' b4 <- GaussSuppressionFromData(z2, 1:4, 5, 
#'              primary = c(PrimaryDefault, PrimaryFromSuppressedData, NotPrimaryFromSuppressedData),
#'                                suppressedData = a, forced = ForcedFromSuppressedData)
#' 
#' # Reducing data to rows mathing a
#' b1r <- b1[SSBtools::Match(a[1:2], b1[1:2]), ]
#' b2r <- b2[SSBtools::Match(a[1:2], b2[1:2]), ]
#' b3r <- b3[SSBtools::Match(a[1:2], b3[1:2]), ]
#' b4r <- b4[SSBtools::Match(a[1:2], b4[1:2]), ]
#' 
#' 
#' # Look at rows where new suppression is different from that in a  
#' 
#' # Both TRUE and FALSE changed
#' cbind(a, b1r)[b1r$suppressed != a$suppressed, c(1:5, 9:10)]
#' 
#' # Only  FALSE changed to TRUE (suppression is preserved)
#' cbind(a, b2r)[b2r$suppressed != a$suppressed, c(1:5, 9:10)]
#' 
#' # Only change is due to new primary suppression rule (protectZeros = TRUE) 
#' cbind(a, b3r)[b3r$suppressed != a$suppressed, c(1:5, 9:10)]
#' 
#' # No changes 
#' cbind(a, b4r)[b4r$suppressed != a$suppressed, c(1:5, 9:10)]
#' 
#' 
PrimaryFromSuppressedData <- function(x, crossTable, suppressedData, forcedData = FALSE, totCode = FindTotCode2(x, crossTable), ...) {
  
  if (is.null(dim(suppressedData))) {  # list of several suppressedData
    primary <- rep(FALSE, nrow(crossTable))
    for (i in seq_along(suppressedData)) {
      primary <- primary | PrimaryFromSuppressedData(x = x, crossTable = crossTable, suppressedData = suppressedData[[i]], forcedData = forcedData, totCode = totCode)
    }
    return(primary)
  }
  
  crossTable_in_suppressedData <- names(crossTable) %in% names(suppressedData)
  
  if (!sum(crossTable_in_suppressedData)) {
    return(rep(FALSE, nrow(crossTable)))
  }
  
  namesIn <- names(crossTable)[crossTable_in_suppressedData]
  namesNotIn <- names(crossTable)[!crossTable_in_suppressedData]
  
  totCodeExtern <- attr(suppressedData, "totCode")
  namesExtern <- names(totCodeExtern)
  namesExtern <- namesExtern[!(namesExtern %in% names(crossTable))]
  if (length(namesExtern)) {
    rows <- rep(TRUE, nrow(suppressedData))
    for (i in seq_along(namesExtern)) {
      rows <- rows & (suppressedData[[namesExtern[i]]] %in% totCodeExtern[[namesExtern[i]]])
    }
    suppressedData <- suppressedData[rows, ,drop=FALSE] 
  }
  
  rows <- rep(TRUE, nrow(crossTable))
  
  for (i in seq_along(namesNotIn)) {
    rows <- rows & (crossTable[[namesNotIn[i]]] %in% totCode[[namesNotIn[i]]])
  }
  
  if ("suppressed" %in% names(suppressedData)) {
    if (anyNA(suppressedData$suppressed)) {
      suppressedData <- suppressedData[!is.na(suppressedData$suppressed), , drop = FALSE]
    }
    suppressedDataFALSE <- suppressedData[!suppressedData$suppressed, namesIn, drop = FALSE]
    suppressedData <- suppressedData[suppressedData$suppressed, namesIn, drop = FALSE]
    ma <- Match(suppressedData, suppressedDataFALSE)
    if (any(!is.na(ma))) {
      stop("Suppression pattern in suppressedData is not unique") 
    }
    if (forcedData) {
      suppressedData <- suppressedDataFALSE 
    }
  }
  
  ma <- Match(crossTable[rows, namesIn, drop = FALSE], suppressedData)
  
  rows[rows][is.na(ma)] <- FALSE
  rows
}

#' @rdname PrimaryFromSuppressedData
#' @export
ForcedFromSuppressedData <- function(..., forcedData = TRUE) {
  PrimaryFromSuppressedData(..., forcedData = forcedData)
}


#' @rdname PrimaryFromSuppressedData
#' @export
NotPrimaryFromSuppressedData <- function(..., forcedData = TRUE) {
  a <- PrimaryFromSuppressedData(..., forcedData = forcedData)
  a[a] <- NA
  a
}

  
FindTotCode2 <- function(x, crossTable) {   # other function SSBtools:::FindTotCode exist
  totCol <- FindTotCol(x)
  lapply(as.list(crossTable[totCol, , drop = FALSE]), unique)
}


FindTotCol <- function(x) {  # based on SSBtools:::FindTotRow
  nr <- nrow(x)
  w1 <- which(colSums(x) == nr)
  if (length(w1)) {
    z <- x[, w1, drop = FALSE]^2
    w2 <- which(colSums(z) == nr)
    if (length(w2)) {
      return(w1[w2])
    }
  }
  w1
}