R/AdditionalSuppression.R

In GaussSuppression: Tabular Data Suppression using Gaussian Elimination

#' GaussSuppression from data and suppressed data
#' 
#' Extended version of \code{\link{GaussSuppressionFromData}} that takes into account suppression pattern in suppressed data sent as input
#' 
#' This function is an easy alternative to using `PrimaryFromSuppressedData` and the relating functions manually. 
#' See the examples of \code{\link{PrimaryFromSuppressedData}}. 
#' By default, the suppression pattern in `suppressedData` is preserved. The behavior can be tuned by the parameters.
#' 
#' Note that the variables used in `suppressedData` in addition to `"suppressed"` are those with matching names in `crossTable`. 
#' Others are ignored. See examples (d3, d4, d5).
#' NOW A FIX IS INCLUDED by attribute totCode. EXAMPLES NOT YET CHANGED.
#' 
#'
#' @param data Input data as a data frame
#' @param ... Further parameters to \code{\link{GaussSuppressionFromData}}
#' @param fun A function: \code{\link{GaussSuppressionFromData}} or one of its wrappers such as
#'              \code{\link{SuppressSmallCounts}} and \code{\link{SuppressDominantCells}}.
#' @param primary As input to \code{\link{GaussSuppressionFromData}} before possible extension caused by `suppressedData`.
#'                Supply `NULL` if all primary suppressions are retrieved form `suppressedData`.
#' @param suppressedData A data frame or a list of data frames as output from \code{\link{GaussSuppressionFromData}}. 
#' @param makePrimary When `TRUE`, suppression in `suppressedData` is preserved.
#' @param makeForced When TRUE, non-suppression in `suppressedData` is preserved. An exception is possible primary suppression which has priority over `forced`. Use forceNotPrimary to avoid this exception.
#' @param forceNotPrimary When TRUE, non-suppression in `suppressedData` is forced to be not primary suppressed. 
#'
#' @return Aggregated data with suppression information
#' @export
#'
#' @examples
#' 
#' z1 <- SSBtoolsData("z1")
#' z2 <- SSBtoolsData("z2")
#' z3 <- SSBtoolsData("z3")
#' 
#' # Ordinary suppressions
#' a <- GaussSuppressionFromData(z1, 1:2, 3, maxN = 5)
#' b <- GaussSuppressionFromData(z2, 1:4, 5, maxN = 1)
#' 
#' # As b and also suppression pattern in a preserved 
#' b1 <- AdditionalSuppression(z2, 1:4, 5, maxN = 1, suppressedData = a)
#' 
#' # Rows with differences
#' cbind(b, b1)[b1$suppressed != b$suppressed, ]
#' 
#' # All primary from a 
#' b2 <- AdditionalSuppression(z2, 1:4, 5, suppressedData = a, primary = NULL, singleton = NULL)
#' 
#' # Rows with suppression 
#' b2[b2$suppressed, ]
#' 
#' # All primary from b2
#' d1 <- AdditionalSuppression(data = z3, 1:6, 7, suppressedData = b2, primary = NULL, 
#'                             singleton = NULL)
#' 
#' # No suppression since no common codes 
#' d1[d1$suppressed, ]
#' 
#' # Use another coding of fylke
#' z3$fylke_ <- z3$fylke - 4
#' d2 <- AdditionalSuppression(data = z3, c(1, 3:6, 8), 7, suppressedData = b2, primary = NULL, 
#'                             singleton = NULL)
#' 
#' # Two primary found in b2 -> several secondary
#' d2[d2$suppressed,]
#' 
#' 
#' # Examples demonstrating limitations of AdditionalSuppression
#' # Variable mnd in suppressedData is not used 
#' 
#' # No suppression since unsuppressed rows used by makeForced and forceNotPrimary
#' d3 <- AdditionalSuppression(data = z3, c(1, 3:4, 8), 7, suppressedData = d2, primary = NULL, 
#'                             singleton = NULL)
#' d3[d3$suppressed, ]
#' 
#' # Now suppression, but not too much
#' d4 <- AdditionalSuppression(data = z3, c(1, 3:4, 8), 7, suppressedData = d2, 
#'                             forceNotPrimary = FALSE, primary = NULL, singleton = NULL)
#' d4[d4$suppressed, ]
#' 
#' # The correct way is to limit the input
#' d5 <- AdditionalSuppression(data = z3, c(1, 3:4, 8), 7, suppressedData = d2[d2$mnd == "Total", ], 
#'                             primary = NULL, singleton = NULL)
#' d5[d5$suppressed, ]
#' 
AdditionalSuppression = function(data, ..., 
                                 fun = GaussSuppressionFromData,  
                                 primary = GetDefault(fun, "primary"), 
                                 suppressedData = NULL, 
                                 makePrimary = TRUE, 
                                 makeForced = TRUE, 
                                 forceNotPrimary = TRUE){
  
  
  if (!is.data.frame(suppressedData)) {  # empty list as NULL
    if (is.list(suppressedData))
      if (!length(suppressedData)) {
        suppressedData <- NULL
      }
  }
  
  
  if(is.null(suppressedData)){
    return(fun(data = data, ..., primary = primary))
  }
  
  if(makePrimary){
    primary <- c(primary, PrimaryFromSuppressedData)
  }
  
  if(forceNotPrimary){
    primary <- c(primary, NotPrimaryFromSuppressedData)
  }
  
  
  if(!makeForced){
    return(fun(data = data, ..., primary = primary, suppressedData = suppressedData))
  }
  
  fun(data = data, ..., primary = primary, forced = ForcedFromSuppressedData, suppressedData = suppressedData)
  
}