R/PrimaryRemoveWg.R

In GaussSuppression: Tabular Data Suppression using Gaussian Elimination

#' Special functions for the avoidance of suppression
#' 
#' The SSBtools function \code{\link[SSBtools]{WildcardGlobbing}} is utilized
#' 
#' `CandidatesNumWg` is a generalization of \code{\link{CandidatesNumWg}}
#'
#' @param wg 	data.frame with wildcard/globbing. 
#'            A parameter to \code{\link[SSBtools]{WildcardGlobbing}}
#' @param ... unused parameters
#' @param crossTable crossTable generated by parent function 
#'
#' @return logical vector or row indices
#' @export
#' @importFrom SSBtools WildcardGlobbing
#'
#' @examples
#' dataset <- SSBtoolsData("magnitude1")
#' 
#' a1 <- SuppressDominantCells(data = dataset, numVar = "value", 
#'        dimVar = c("sector4", "geo"), n = 1:2, k = c(77, 99))
#' 
#' a1
#' 
#' wg <- data.frame(sector4 = "Ind*", geo = c("Ice????", "Portugal"))
#' wg
#' 
#' # Industry:Portugal not primary, but suppressed
#' a2 <- SuppressDominantCells(data = dataset, numVar = "value", 
#'        dimVar = c("sector4", "geo"), n = 1:2, k = c(77, 99), 
#'        wg = wg, primary = c(DominanceRule, PrimaryRemoveWg))
#' 
#' a2
#' 
#' # Industry:Portugal not primary and not suppressed
#' a3 <- SuppressDominantCells(data = dataset, numVar = "value", 
#'        dimVar = c("sector4", "geo"), n = 1:2, k = c(77, 99), 
#'        wg = wg, primary = c(DominanceRule, PrimaryRemoveWg), 
#'        candidates = CandidatesNumWg)
#' a3
#' 
#' # Industry:Portugal primary, but not suppressed
#' a4 <- SuppressDominantCells(data = dataset, numVar = "value", 
#'        dimVar = c("sector4", "geo"), n = 1:2, k = c(77, 99), 
#'        wg = wg, forced = ForcedWg, whenPrimaryForced = message)
#' a4
PrimaryRemoveWg <- function(wg = NULL, ..., crossTable) {
  primary <- rep(FALSE, nrow(crossTable))
  if(is.null(wg)){
    return(primary)
  }
  primary[WildcardGlobbing(crossTable, wg)] <- NA
  primary
}

#' @rdname PrimaryRemoveWg
#' @export
CandidatesNumWg <- function(wg = NULL, ..., crossTable) {
  candidates <- CandidatesNum(...)
  pr <- PrimaryRemoveWg(wg = wg, ..., crossTable = crossTable)
  is_pr <- candidates %in% which(is.na(pr))
  c(candidates[is_pr], candidates[!is_pr])
}


#' @rdname PrimaryRemoveWg
#' @export
ForcedWg <- function(crossTable, wg = NULL, ...) {
  pr <- PrimaryRemoveWg(wg = wg, ..., crossTable = crossTable)
  which(is.na(pr))
}