improve code and increase test coverage

Author: davraam

DESCRIPTION

@@ -21,6 +21,7 @@ Imports:
     childsds, 
     purrr, 
     tibble,
+    tidyselect,
     tidyverse
 Suggests:
     testthat

NAMESPACE

@@ -4,7 +4,6 @@ export(BooleDS)
 export(absDS)
 export(asCharacterDS)
 export(asDataFrameDS)
-export(asDataMatrixDS)
 export(asFactorDS1)
 export(asFactorDS2)
 export(asFactorSimpleDS)

R/BooleDS.R

@@ -16,10 +16,9 @@
 #' the final output variable
 #' should be of class numeric (1/0) or class logical (TRUE/FALSE).
 #' @param na.assign.text A character string taking values 'NA', '1' or '0'. If 'NA'
-#' then any NA values in the
-#' input vector remain as NAs in the output vector. If '1' or '0' NA values in the
-#' input vector are
-#' all converted to 1 or 0 respectively.#' @return the levels of the input variable.
+#' then any NA values in the input vector remain as NAs in the output vector. If '1' 
+#' or '0' NA values in the input vector are all converted to 1 or 0 respectively.
+#' @return the levels of the input variable.
 #' @author DataSHIELD Development Team
 #' @export
 #'
@@ -28,127 +27,77 @@ BooleDS <- function(V1.name=NULL, V2.name=NULL, Boolean.operator.n=NULL, na.assi
   # Check Permissive Privacy Control Level.
   dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana'))
 
-#########################################################################
-# DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS                       #
-thr <- dsBase::listDisclosureSettingsDS()                               #
-#nfilter.tab<-as.numeric(thr$nfilter.tab)                               #
-#nfilter.glm<-as.numeric(thr$nfilter.glm)                               #
-#nfilter.subset<-as.numeric(thr$nfilter.subset)                         #
-#nfilter.string<-as.numeric(thr$nfilter.string)                         #
-#nfilter.stringShort<-as.numeric(thr$nfilter.stringShort)               #
-#nfilter.kNN<-as.numeric(thr$nfilter.kNN)                               #
-#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel)       #
-#########################################################################
-
-
-#V1: numeric, factor or logical vector or scalar in .GlobalEnv
-#V2: numeric, factor or logical vector or scalar in .GlobalEnv or client specified scalar with which to compare V1
-
-#EVAL V1 and V2
-
-##########CHECK NOT LONG SPECIFIED VECTOR##############
-
-V1<-eval(parse(text=V1.name), envir = parent.frame())
-V2<-eval(parse(text=V2.name), envir = parent.frame())
-
-
-if(is.character(V1)){
-   studysideMessage<-"FAILED: V_i is character, please convert to numeric, factor or logical before running Boole"
-   stop(studysideMessage, call. = FALSE)
-   }
-
-if(is.character(V2)){
-   studysideMessage<-"FAILED: V_ii is character, please convert to numeric, factor or logical before running Boole"
-   stop(studysideMessage, call. = FALSE)
-   }
-
-V1.length<-length(V1)   
-V2.length<-length(V2)
-
-if(!((V1.length == V2.length) | (V2.length==1))){
-   studysideMessage<-"FAILED: V_ii must either be of length one or of length equal to V_i"
-   stop(studysideMessage, call. = FALSE)
-}
-
-if(!is.numeric(Boolean.operator.n) | Boolean.operator.n==0){
-   studysideMessage<-"FAILED: Boolean.operator specified incorrectly. Must be: '==', '!=', '<', '<=', '>' or '>='"
-   stop(studysideMessage, call. = FALSE)
-}
-
-Boolean.operator<-"  "
-if(Boolean.operator.n==1) Boolean.operator<-"=="
-if(Boolean.operator.n==2) Boolean.operator<-"!="
-if(Boolean.operator.n==3) Boolean.operator<-"<"
-if(Boolean.operator.n==4) Boolean.operator<-"<="
-if(Boolean.operator.n==5) Boolean.operator<-">"
-if(Boolean.operator.n==6) Boolean.operator<-">="
-
-
-#APPLY BOOLEAN OPERATOR SPECIFIED
-
-Boolean.indicator<-integer(length=V1.length)
-
-#EVALUATE DIFFERENTLY IF V2 IS SAME LENGTH AS V1 OR OF LENGTH 1
-if(V2.length==V1.length){
-for(j in 1:V1.length){
-command.text<-paste0(V1.name,"[",j,"] ",Boolean.operator," ",V2.name,"[",j,"]")
-Boolean.indicator[j]<-eval(parse(text=command.text), envir = parent.frame())*1
-}
-}
-
-if(V2.length==1){
-for(j in 1:V1.length){
-command.text<-paste0(V1.name,"[",j,"] ",Boolean.operator," ",V2.name)
-Boolean.indicator[j]<-eval(parse(text=command.text), envir = parent.frame())*1
-}
-}
-
-
-#BY DEFAULT NAs REMAIN AS NAs BUT IF YOU WANT TO YOU CAN FORCE THEM TO 1 OR 0 USING <na.assign.text> ARGUMENT
-
-if(na.assign.text=="1"){
-Boolean.indicator[is.na(Boolean.indicator)==1]<-1
-}
-
-if(na.assign.text=="0"){
-Boolean.indicator[is.na(Boolean.indicator)==1]<-0
-}
-
-
-outobj.b<-as.logical(Boolean.indicator)
-outobj<-Boolean.indicator
-
-
-
-#COMMENT OUT THIS CODE BLOCK BECAUSE TESTS OF MINIMUM CELL SIZE SHOULD ALL BE
-#ENACTED IN AGGREGATE FUNCTIONS. NO VECTOR IS DISCLOSIVE UNTIL IT RETURNS
-#SOMETHING TO THE CLIENTSIDE. I AM LEAVING THIS COMMENTED BUT UNDELETED
-#IN CASE WE LATER DECIDE TO CHANGE THIS STRATEGY
-#CHECK OUTPUT VECTOR VALIDITY
-#	outobj.invalid<-0
-#
-#	unique.values.outobj<-unique(outobj)
-#	unique.values.noNA.outobj<-unique.values.outobj[complete.cases(unique.values.outobj)]
-#
-#	#Boolean and can therefore only be binary so check this:
-#	if(length(unique.values.noNA.outobj)>2) outobj.invalid<-1
-#
-#	tabvar<-table(outobj,useNA="no")[table(outobj,useNA="no")>=1]
-#	min.category<-min(tabvar)
-#	if(min.category<nfilter.tab)outobj.invalid<-1
-#
-#TERMINATE CALCULATION IF outobj.invalid==1
-#if(outobj.invalid==1){
-#   studysideMessage<-"FAILED: outobj has at least one category below table filter limit"
-#   stop(studysideMessage, call. = FALSE)
-#}
-
-
-
-if(numeric.output==TRUE){
-   Boole.obj<-outobj
-   }else{Boole.obj<-outobj.b}
-return(Boole.obj)
+  V1 <- eval(parse(text=V1.name), envir = parent.frame())
+  V2 <- eval(parse(text=V2.name), envir = parent.frame())
+  
+  if(is.character(V1)){
+    studysideMessage <- "FAILED: V1 is character, please convert to numeric, factor or logical before running Boole"
+    stop(studysideMessage, call. = FALSE)
+  }
+  
+  if(is.character(V2)){
+    studysideMessage <- "FAILED: V2 is character, please convert to numeric, factor or logical before running Boole"
+    stop(studysideMessage, call. = FALSE)
+  }
+
+  V1.length <- length(V1)   
+  V2.length <- length(V2)
+
+  if(!((V1.length == V2.length) | (V2.length==1))){
+    studysideMessage <- "FAILED: V2 must either be of length one or of length equal to V1"
+    stop(studysideMessage, call. = FALSE)
+  }
+
+  if(!(Boolean.operator.n %in% c(1,2,3,4,5,6))){
+    studysideMessage <- "FAILED: Boolean.operator specified incorrectly. Must be: '==', '!=', '<', '<=', '>' or '>='"
+    stop(studysideMessage, call. = FALSE)
+  }
+
+  Boolean.operator <- " "
+  if(Boolean.operator.n==1) Boolean.operator <- "=="
+  if(Boolean.operator.n==2) Boolean.operator <- "!="
+  if(Boolean.operator.n==3) Boolean.operator <- "<"
+  if(Boolean.operator.n==4) Boolean.operator <- "<="
+  if(Boolean.operator.n==5) Boolean.operator <- ">"
+  if(Boolean.operator.n==6) Boolean.operator <- ">="
+
+  # APPLY BOOLEAN OPERATOR SPECIFIED
+  Boolean.indicator <- integer(length=V1.length)
+
+  # EVALUATE DIFFERENTLY IF V2 IS SAME LENGTH AS V1 OR OF LENGTH 1
+  if(V2.length==V1.length){
+    for(j in 1:V1.length){
+      command.text <- paste0(V1.name,"[",j,"] ",Boolean.operator," ",V2.name,"[",j,"]")
+      Boolean.indicator[j]<-eval(parse(text=command.text), envir = parent.frame())*1
+    }
+  }
+
+  if(V2.length==1){
+    for(j in 1:V1.length){
+      command.text<-paste0(V1.name,"[",j,"] ",Boolean.operator," ",V2.name)
+      Boolean.indicator[j]<-eval(parse(text=command.text), envir = parent.frame())*1
+    }
+  }
+
+  # BY DEFAULT NAs REMAIN AS NAs BUT IF YOU WANT TO YOU CAN FORCE THEM TO 1 OR 0 USING <na.assign.text> ARGUMENT
+  if(na.assign.text=="1"){
+    Boolean.indicator[is.na(Boolean.indicator)==1]<-1
+  }
+
+  if(na.assign.text=="0"){
+    Boolean.indicator[is.na(Boolean.indicator)==1]<-0
+  }
+
+  outobj.b <- as.logical(Boolean.indicator)
+  outobj <- Boolean.indicator
+
+  if(numeric.output==TRUE){
+    Boole.obj <- outobj
+  }else{
+    Boole.obj <- outobj.b
+  }
+
+  return(Boole.obj)
 }
-#ASSIGN FUNCTION
+# ASSIGN FUNCTION
 # BooleDS

R/asCharacterDS.R

@@ -12,7 +12,7 @@
 #' @author Amadou Gaye, Paul Burton, Demetris Avraam for DataSHIELD Development Team
 #' @export
 #' 
-asCharacterDS <- function (x.name){
+asCharacterDS <- function(x.name){
 
   x <- eval(parse(text=x.name), envir = parent.frame())
 

R/asFactorDS2.R

@@ -4,12 +4,12 @@
 #' a factor type that presented as a vector or as a matrix with dummy variables.
 #' @details The functions converts the input variable into a factor which is presented as a vector
 #' if the \code{fixed.dummy.vars} is set to FALSE or as a matrix with dummy variables if the
-#' \code{fixed.dummy.vars} is set to TRUE (see the help file of ds.asFactor.b for more details).
+#' \code{fixed.dummy.vars} is set to TRUE (see the help file of ds.asFactor for more details).
 #' @param input.var.name the name of the variable that is to be converted to a factor.
 #' @param all.unique.levels.transmit the levels that the variable will be transmitted to.
 #' @param fixed.dummy.vars a boolean that determines whether the new object will be represented as
 #' a vector or as a matrix of dummy variables indicating the factor level of each data point.
-#' If this argyment is set to FALSE (default) then the input variable is converted to a factor and
+#' If this argument is set to FALSE (default) then the input variable is converted to a factor and
 #' assigned as a vector. If is set to TRUE then the input variable is converted to a factor but
 #' assigned as a matrix of dummy variables.
 #' @param baseline.level a number indicating the baseline level to be used in the creation of the

man/BooleDS.Rd

@@ -24,3 +24,27 @@ set.standard.disclosure.settings <- function() {
     options(default.nfilter.levels.density = "0.33")
     options(default.nfilter.levels.max = "40")
 }
+
+set.specific.disclosure.settings <- function(datashield.privacyControlLevel='permissive',
+                                             nfilter.tab='3',
+                                             nfilter.subset='3',
+                                             nfilter.glm='0.33',
+                                             nfilter.string='80',
+                                             nfilter.stringShort='20',
+                                             nfilter.kNN='3',
+                                             nfilter.levels.density='0.33',
+                                             nfilter.levels.max='40',
+                                             nfilter.noise='0.25',
+                                             nfilter.privacy.old='5') {
+  options(datashield.privacyLevel = nfilter.privacy.old)
+  options(default.datashield.privacyControlLevel = datashield.privacyControlLevel)
+  options(default.nfilter.glm = nfilter.glm)
+  options(default.nfilter.kNN = nfilter.kNN)
+  options(default.nfilter.string = nfilter.string)
+  options(default.nfilter.subset = nfilter.subset)
+  options(default.nfilter.stringShort = nfilter.stringShort)
+  options(default.nfilter.tab = nfilter.tab)
+  options(default.nfilter.noise = nfilter.noise)
+  options(default.nfilter.levels.density = nfilter.levels.density)
+  options(default.nfilter.levels.max = nfilter.levels.max)
+}