Merge pull request #16 from tenderle/master

Version 0.2.0 Prototype Version for Census Testing

Author: tenderle

.gitignore

@@ -4,4 +4,5 @@
 .Ruserdata
 *.Rproj
 *.html
-Readme.Rmd
+Readme.Rmd
+inst/doc

DESCRIPTION

@@ -1,15 +1,17 @@
 Package: ptable
 Type: Package
-Date: 2018-11-20
+Date: 2018-12-02
 Title: Generation of perturbation tables
-Version: 0.1.13
+Version: 0.2.0
 Authors@R: c(person("Tobias", "Enderle", email = "[email protected]", role = c("aut", "cre")),
           person("Sarah", "Giessing", email = "[email protected]", role = c("ctb")))
 Description: This package computes perturbation tables with probabilities or pre-drawn perturbation values.
 Imports: data.table,nloptr,RColorBrewer,flexdashboard,lattice,methods,rlang,rmarkdown,ggplot2
-Suggests: cellKey, sdcTable
+Suggests: cellKey, sdcTable,
+    knitr
 License: EUPL
 Encoding: UTF-8
 Maintainer: Tobias Enderle <[email protected]>
 LazyData: true
-RoxygenNote: 6.0.1
+RoxygenNote: 6.0.1
+VignetteBuilder: knitr

NAMESPACE

@@ -4,6 +4,7 @@ export(fifi_plot)
 export(pt_create_pParams)
 export(pt_create_pTable)
 export(pt_export)
+export(pt_vignette)
 export(ptable)
 exportClasses(ptable)
 exportClasses(ptable_params)
@@ -42,4 +43,5 @@ importFrom(stats,formula)
 importFrom(stats,runif)
 importFrom(stats,weights)
 importFrom(stats,xtabs)
+importFrom(utils,RShowDoc)
 importFrom(utils,write.table)

R/pt_create_pParams.R

@@ -2,11 +2,10 @@
 #'
 #' creates the required input for \code{\linkS4class{ptable}}.
 #'
-#' @param D perturbation parameter for maximum perturbation (scalar or vector)
+#' @param D perturbation parameter for maximum noise/perturbation (scalar or vector)
 #' @param V perturbation parameter for variance (scalar)
-#' @param js treshold value for blocking of small frequencies (i.e. there won't occur positive target frequencies below the treshold value)
-#' Target frequencies are defined by ...
-#' @param pstay optional parameter to set
+#' @param js treshold value for blocking of small frequencies (i.e. the perturbation will not produce positive cell values that are equal to or smaller than the treshold value).
+#' @param pstay optional parameter to set the probability (0 < p < 1) of an original frequency to remain unperturbed: NA (default) no preset probability (i.e. produces the maximum entropy solution)
 #' @param optim optimization parameter: \code{1} standard approach (default)
 #' @param mono (logical) vector specifying optimization parameter for monotony condition
 #' @param epsilon (double)
@@ -36,8 +35,10 @@ pt_create_pParams <-function(D, V, js=0, pstay=NULL, optim=1, mono=TRUE, epsilon
   stopifnot(is_bare_logical(mono))
   stopifnot(is_bare_integerish(pTableSize))
 
-  if (is.null(pstay)) pstay <- 0
-  stopifnot(is_bare_numeric(pstay))
+  if (is.null(pstay)) pstay <- NA
+  #stopifnot(is_bare_numeric(pstay))
+  if(sum(c(0,1) %in% pstay) > 0)
+    stop(paste("Parameter 'pstay' must be larger than zero and smaller than one (i.e. 0 < pstay < 1)."))
 
 
   if (js==0) ncat <- D

R/pt_create_pTable.R

@@ -1,16 +1,18 @@
 #' pt_create_pTable
 #'
 #' produces perturbation table that is needed to add noise to statistical frequency tables. The perturbation probabilities are constructed given the following constraints:
-#' 1. Zero mean
-#' 2. Constant variance
-#' 3. Probabilities are between zero and one
-#' 4.
-#' 5. probabilities sum up to 1
+#' - Unbiasedness of the noise
+#' - Fixed noise variance
+#' - Transition probabilities are between zero and one and the sum up to 1
+#' - Perturbations will not produce negaive cell values or positive cell values equal to or less than a specific threshold value 
+#' - The absolute value of any perturbation is less than a specific integer value (i.e. the maxiumum noise)
+#' 
+#' For more information, see the vignette using \code{pt_vignette()}.
 #' @md
 #'
 #' @param params an object of class \code{\linkS4class{ptable_params}}
 #' generated with \code{\link{pt_create_pParams}}
-#' @param type (character) type of pTable (either 'abs' or 'destatis')
+#' @param type (character) type of pTable, either 'destatis' (default) or 'abs' or 'abs2'
 #' @param monitoring (logical) output monitoring on/off
 #' @param debugging (logical) debug monitoring on/off
 #'
@@ -29,7 +31,7 @@
 #' @rdname pt_create_pTable
 #' @export
 #'
-pt_create_pTable <-function(params, type, monitoring=FALSE, debugging=FALSE){
+pt_create_pTable <-function(params, type="destatis", monitoring=FALSE, debugging=FALSE){
   . <- v <- p <- NULL
   pert_params <- params
 
@@ -41,6 +43,8 @@ pt_create_pTable <-function(params, type, monitoring=FALSE, debugging=FALSE){
   V <- slot(pert_params, "V")
   js <- slot(pert_params, "js")
   pstay <- slot(pert_params, "pstay")
+  pstay[is.na(pstay)] <- 0
+  
   mono <- slot(pert_params, "mono")
   epsilon <- slot(pert_params, "epsilon")
 

R/pt_export.R

@@ -1,9 +1,10 @@
 #' pt_export
 #'
-#' Function to export ptable (csv).
+#' Function to export perturbation table to Tau-Argus or SAS (as csv-file).
 #'
 #' @param input an object of class \code{\linkS4class{ptable}}
 #' @param file (character) filename
+#' @param SDCtool (character) either "TauArgus" or "SAS"
 #'
 #' @author Tobias Enderle
 #' @keywords export
@@ -12,13 +13,13 @@
 #' params <- pt_create_pParams(D=5, V=3, js=2, label="test")
 #' ptable_destatis <- pt_create_pTable(params=params, type="destatis")
 #' \dontrun{
-#' pt_export(ptable_destatis,file="Test")
+#' pt_export(ptable_destatis,file="Test", SDCtool="TauArgus")
 #' }
 #' 
 #' @rdname pt_export
 #' @export
 #'
-pt_export <- function(input, file){
+pt_export <- function(input, file, SDCtool="TauArgus"){
 
   stopifnot(isS4(input))
   stopifnot(class(input)=="ptable")
@@ -27,7 +28,14 @@ pt_export <- function(input, file){
   type <- slot(params, "type")
   stopifnot(type=="destatis")
 
-  pTable <- slot(input, "pTable")[,c('i','j','p','v','p_int_ub'),]
+  stopifnot(SDCtool %in% c("TauArgus","SAS"))
+  
+  if (SDCtool=="TauArgus")
+    pTable <- slot(input, "pTable")[,c('i','j','p','v','p_int_ub'),]
+  
+  if (SDCtool=="SAS")
+    pTable <- slot(input, "pTable")[,c('i','j','p','v','p_int_lb','p_int_ub'),]
+  
 
   write.table(pTable, file=paste(file,".csv",sep=""), sep=";", dec=".", row.names = FALSE, col.names = TRUE)
 }

R/pt_vignette.R

@@ -0,0 +1,14 @@
+#' pt_vignette
+#'
+#' starts the package vignette that gets you started with the package
+#'
+#' @return a browser windows/tab with showing the vignette
+#' @export
+#' @importFrom utils RShowDoc
+#' @examples
+#' \dontrun{
+#' pt_vignette()
+#' }
+pt_vignette <- function() {
+  RShowDoc("introduction", package="ptable")
+}

README.md

@@ -19,15 +19,24 @@ We have a first rough version with which interested users may play around. Feedb
 
 -   Merge the two main functions `pt_create_pParams(...)` and `pt_create_pTable(...)` into one function
 -   Allow for special cases: extended parameter setting, i.e. improved row-wise parameter settings
--   Add theoretical short description
--   Add vignettes (documentation)
 -   Add error codes
 -   Improved `fifi_...`-functions
 -   Add test environment
 -   Improve accuracy of ptable by means of digits-functionality
 -   Add generic functions in pt\_methods.R, e.g. plot(...)
 -   Update optimization for predrawn allocation if `type="abs"`
 
+#### Version 0.2.0
+
+-   Prototype Version for Testing (Census)
+
+#### Version 0.1.14
+
+-   feature: new argument `SDCtool` of function `pt_export()`: either "TauArgus" or "SAS"
+-   feature: vignette and new function `pt_vignette()` to show it
+-   updated default for argument `pstay` in function `pt_create_pParams()`
+-   updated default for argument `type` in function `pt_create_pTable()`
+
 #### Version 0.1.12/13
 
 -   Prepared for prototype testing
@@ -72,13 +81,12 @@ We have a first rough version with which interested users may play around. Feedb
 
 -   first uploaded version
 
-
 ### Installation
 
 The package can directly be installed from `github`
 
 ``` r
-devtools::install_github("sdcTools/ptable", build_vignette=FALSE)
+devtools::install_github("sdcTools/ptable", build_vignette=TRUE)
 ```
 
 ### Usage

inst/pt_dashboard.Rmd

@@ -27,8 +27,13 @@ numericInput(inputId="V", label="Variance (=V)",
              value=3, min = 0.1, max = 5, step = 0.1, width="100px")
 sliderInput("js", label = "Treshold (=js)",
             min = 0, max = 5, value = 2, step = 1)
-sliderInput("pstay", label = "Probability of frequencies not to be perturbed (=pstay)",
-            min = 0, max = 1, value = 0, step = 0.05)
+
+numericInput(inputId="pstay", label="Preset probability of frequencies not to be perturbed (=pstay)",              value=NA, min = 0.05, max = 0.99, step = 0.05, width="200px")
+#checkboxInput("pstayset", "Preset probability of frequencies not to be perturbed (=pstay)", value=FALSE, width = NULL)
+#test <-  reactive(input$pstayset)
+#if (reactive(test()) == TRUE) pstay <- NA
+#sliderInput("pstay", label = "Set probability (=pstay)",
+#            min = 0.05, max = 0.95, value = 0.5, step = 0.05)
 
 checkboxInput("mono", "Set Monotony", value = TRUE, width = NULL)
 radioButtons("optim", "Set of objective functions (=optim)",