inst/doc/sdcTable.R

In sdcTable: Methods for Statistical Disclosure Control in Tabular Data

## ---- include=FALSE-----------------------------------------------------------
library(sdcTable)

## ---- eval=TRUE---------------------------------------------------------------
library(sdcTable)
packageVersion("sdcTable")

## ---- include=FALSE-----------------------------------------------------------
# daten laden
microData <- readRDS("microdat.rds")
aggregatedData <- readRDS("aggdat.rds")
completeData <- readRDS("completedat.rds")

h1 <- sdcHierarchies::hier_create("Tot", nodes = LETTERS[1:4])
h1 <- sdcHierarchies::hier_add(h1, "B", nodes = paste0("B", letters[1:3]))
h2 <- sdcHierarchies::hier_create("Tot", nodes = c("m", "w"))
h3 <- sdcHierarchies::hier_create("Tot", nodes = letters[1:6])
dimList <- list(
  V1 = sdcHierarchies::hier_convert(h1, as = "df"),
  V2 = sdcHierarchies::hier_convert(h2, as = "df"),
  V3 = sdcHierarchies::hier_convert(h3, as = "df")
)

## ---- echo=FALSE--------------------------------------------------------------
print(head(microData), row.names = FALSE)

## ---- echo=FALSE--------------------------------------------------------------
lev.V1 <- as.character(sort(unique(microData$V1)))
lev.V2 <- as.character(sort(unique(microData$V2)))
lev.V3 <- as.character(sort(unique(microData$V3)))

## ---- echo=FALSE, comment=""--------------------------------------------------
cat(paste(shQuote(lev.V1), collapse = ", "))

## ---- echo=FALSE, comment=""--------------------------------------------------
cat(paste(shQuote(lev.V2), collapse = ", "))

## ---- echo=FALSE, comment=""--------------------------------------------------
cat(paste(shQuote(lev.V3), collapse = ", "))

## -----------------------------------------------------------------------------
print(tail(completeData))

## ---- echo=FALSE--------------------------------------------------------------
levComp.V1 <- dimList$V1$name
levComp.V2 <- dimList$V2$name
levComp.V3 <- dimList$V3$name

## ---- echo=FALSE, comment=""--------------------------------------------------
cat(paste(shQuote(levComp.V1), collapse = ", "))

## ---- echo=FALSE, comment=""--------------------------------------------------
cat(paste(shQuote(levComp.V2), collapse = ", "))

## ---- echo=FALSE, comment=""--------------------------------------------------
cat(paste(shQuote(levComp.V3), collapse = ", "))

## ---- echo=FALSE--------------------------------------------------------------
x <- completeData[nrow(completeData), ]

## ---- echo=FALSE, comment=""--------------------------------------------------
subTots.V1 <- setdiff(levComp.V1, lev.V1)
cat(paste(shQuote(subTots.V1), collapse = ", "))

## ---- echo=FALSE, comment=""--------------------------------------------------
subTots.V2 <- setdiff(levComp.V2, lev.V2)
cat(paste(shQuote(subTots.V2), collapse = ", "))

## ---- echo=FALSE, comment=""--------------------------------------------------
subTots.V3 <- setdiff(levComp.V3, lev.V3)
cat(paste(shQuote(subTots.V3), collapse = ", "))


## -----------------------------------------------------------------------------
dimV1 <- matrix(nrow = 0, ncol = 2)
dimV1 <- rbind(dimV1, c("@", "Tot"))
print(dimV1)

## -----------------------------------------------------------------------------
mat <- matrix(nrow = 4, ncol = 2)
mat[, 1] <- rep("@@", 4)
mat[, 2] <- LETTERS[1:4]
dimV1 <- rbind(dimV1, mat)
print(dimV1)

## -----------------------------------------------------------------------------
mat <- matrix(nrow = 3, ncol = 2)
mat[, 1] <- rep("@@@", 3)
mat[, 2] <- c("Ba", "Bb", "Bc")

dimV1 <- rbind(dimV1, mat)
print(dimV1)

## -----------------------------------------------------------------------------
dimV1 <- dimV1[c(1:3,6:8, 4:5),]
print(dimV1, row.names = FALSE)

## -----------------------------------------------------------------------------
dimV1 <- sdcHierarchies::hier_create(root = "Tot", nodes = LETTERS[1:4])
dimV1 <- sdcHierarchies::hier_add(dimV1, root = "B", nodes = c("Ba","Bb","Bc"))
sdcHierarchies::hier_display(dimV1)

## -----------------------------------------------------------------------------
dimV2 <- sdcHierarchies::hier_create(root = "Tot", nodes = c("m", "w"))
sdcHierarchies::hier_display(dimV2)

## -----------------------------------------------------------------------------
dimV3 <- sdcHierarchies::hier_create(root = "Tot", nodes = letters[1:6])
sdcHierarchies::hier_display(dimV3)

## -----------------------------------------------------------------------------
dimList <- list(V1 = dimV1, V2 = dimV2, V3 = dimV3)
prob.microDat <- makeProblem(
	data = microData,
	dimList = dimList,
	dimVarInd = 1:3,
	freqVarInd = NULL,
	numVarInd = 4:5,
	weightInd = NULL,
	sampWeightInd = NULL)

## -----------------------------------------------------------------------------
### problem from complete data ###
dimList <- list(V1 = dimV1, V2 = dimV2, V3 = dimV3)
prob.completeDat <- makeProblem(
	data = completeData,
	dimList = dimList,
	dimVarInd = 1:3,
	freqVarInd = 4,
	numVarInd = 5:6,
	weightInd = NULL,
	sampWeightInd = NULL)

## -----------------------------------------------------------------------------
all(c(class(prob.microDat), class(prob.completeDat)) == "sdcProblem")

## -----------------------------------------------------------------------------
counts1 <- getInfo(prob.completeDat, type = "freq")
counts2 <- getInfo(prob.microDat, type = "freq")
all(counts1 == counts2)

## -----------------------------------------------------------------------------
prob.completeDat <- primarySuppression(prob.completeDat, type = "freq", maxN = 10)

## -----------------------------------------------------------------------------
print(table(getInfo(prob.completeDat, type = "sdcStatus")))
summary(prob.completeDat)

## ---- echo=FALSE--------------------------------------------------------------
nrPrimSupps <- length(which(getInfo(prob.completeDat, type = "sdcStatus") == "u"))

## ---- cache=TRUE--------------------------------------------------------------
resGAUSS <- protectTable(prob.completeDat, method = "GAUSS")
resHITAS <- protectTable(prob.completeDat, method = "HITAS")
resOPT <- protectTable(prob.completeDat, method = "OPT")
resHYPER <- protectTable(prob.completeDat, method = "HYPERCUBE")
resSIMPLE <- protectTable(prob.completeDat, method = "SIMPLEHEURISTIC")

## -----------------------------------------------------------------------------
finalData <- getInfo(resOPT, type = "finalData")
print(head(finalData))

## -----------------------------------------------------------------------------
summary(resOPT)