tests/testthat/test-primarySuppression.r

In sdcTable: Methods for Statistical Disclosure Control in Tabular Data

context("test primarySuppression()")

test_that("primarySuppression works", {
  skip_on_cran()

  # load problem without suppressions
  problem <- sdc_testproblem(with_supps = FALSE)

  p1 <- primarySuppression(problem, type = "freq", maxN = 2)
  p1.sdc <- get.problemInstance(p1@problemInstance, "sdcStatus")
  expect_is(p1, "sdcProblem")
  expect_equal(sum(p1.sdc == "u"), 1)
  expect_equal(which(p1.sdc == "u"), 6)

  expect_error(primarySuppression(problem, type = "nk", n = 2, k = 80))
  p2 <- primarySuppression(problem, type = "nk", n = 2, k = 75, numVarName = "val")
  p2.sdc <- get.problemInstance(p2@problemInstance, "sdcStatus")
  expect_is(p2, "sdcProblem")
  expect_equal(sum(p2.sdc == "u"), 2)
  expect_equal(which(p2.sdc == "u"), c(6, 14))

  expect_error(primarySuppression(problem, type = "p", p = 80))
  expect_error(primarySuppression(problem, type = "p", p = 0, numVarName = "val"))
  expect_error(primarySuppression(problem, type = "p", p = 100, numVarName = "val"))
  p3 <- primarySuppression(problem, type = "p", p = 70, numVarName = "val")
  p3.sdc <- get.problemInstance(p3@problemInstance, "sdcStatus")
  expect_is(p3, "sdcProblem")
  expect_equal(sum(p3.sdc == "u"), 2)
  expect_equal(which(p3.sdc == "u"), c(6, 14))

  expect_error(primarySuppression(problem, type = "pq", pq = c(80, 90)))
  expect_error(primarySuppression(problem, type = "pq", pq = c(85, 80), numVarName = "val"))
  expect_error(primarySuppression(problem, type = "pq", pq = c(85, 180), numVarName = "val"))
  expect_error(primarySuppression(problem, type = "pq", pq = c(110, 120), numVarName = "val"))
  p4 <- primarySuppression(problem, type = "pq", pq = c(60, 80), numVarName = "val")
  p4.sdc <- get.problemInstance(p4@problemInstance, "sdcStatus")
  expect_is(p4, "sdcProblem")
  expect_equal(sum(p4.sdc == "u"), 2)
  expect_equal(which(p4.sdc == "u"), c(6, 14))

  problem@dataObj@rawData$val[5] <- -5
  expect_error(primarySuppression(problem, type = "nk", n = 2, k = 80, numVarName = "val"))
  expect_error(primarySuppression(problem, type = "p", p = 70, numVarName = "val"))
  expect_error(primarySuppression(problem, type = "pq", pq = c(60, 80), numVarName = "val"))


  # use weights
  rm(list = ls())
  utils::data("microdata1", package = "sdcTable")
  microdata1$samp_weights <- sample(rnorm(nrow(microdata1), mean = 10))
  dim_region <- sdcHierarchies::hier_create(
    root = "Total",
    nodes = LETTERS[1:5]
  )
  dim_gender <- sdcHierarchies::hier_create(
    root = "Total",
    nodes = c("male", "female")
  )
  dimList <- list(
    region = dim_region,
    gender = dim_gender
  )
  problem <- makeProblem(
    data = microdata1,
    dimList = dimList,
    freqVarInd = NULL,
    numVarInd = 3,
    sampWeightInd = 4)

  # no numVarInd or numVarName
  expect_error(
    primarySuppression(problem, type = "nk", n = 2, k = 80)
  )
  # variable does not exist
  expect_error(
    primarySuppression(problem, type = "nk", n = 2, k = 80, numVarName = "samp_weight")
  )

  # n < 2
  expect_error(
    primarySuppression(problem, type = "nk", n = 1, k = 80, numVarName = "samp_weights")
  )

  res <- primarySuppression(
    object = problem,
    type = "nk",
    n = 2,
    k = 80,
    numVarName = "val")

  res <- sdcProb2df(res, addDups = FALSE, addNumVars = TRUE)
  expect_equal(res[sdcStatus == "s", .N], 15)
  expect_equal(res[sdcStatus == "z", .N], 3)


  res <- primarySuppression(
    object = problem,
    type = "nk",
    n = 2,
    k = 80,
    allowZeros = TRUE,
    numVarName = "val"
  )
  res <- sdcProb2df(res, addDups = FALSE)

  expect_error(primarySuppression(
    object = problem,
    type = "p",
    p = -5,
    numVarName = "samp_weights"
  ))

  expect_error(primarySuppression(
    object = problem,
    type = "p",
    p = c(-5, 5),
    numVarName = "samp_weights"
  ))

  # print method
  print(res)
})