From 029a58f7c4c249eb38d549e92e7dea104b82621c Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Fri, 22 Nov 2019 23:41:51 +0000 Subject: [PATCH] Updated 'nfilter' use --- R/cDS.R | 12 ++++++++++-- R/isValidDS.R | 18 +++++++++++++----- R/meanSdGpDS.R | 16 +++++++++++----- R/subsetByClassDS.R | 18 +++++++++++++----- R/subsetDS.R | 16 ++++++++++++---- R/table1DDS.R | 16 ++++++++++++---- 6 files changed, 71 insertions(+), 25 deletions(-) diff --git a/R/cDS.R b/R/cDS.R index 2c059e3a..3fb05916 100644 --- a/R/cDS.R +++ b/R/cDS.R @@ -10,12 +10,20 @@ #' cDS <- function (objs) { # this filter sets the minimum number of observations that are allowed - nfilter <- setFilterDS() + + ############################################################# + # MODULE 1: CAPTURE THE nfilter SETTINGS + thr <- 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) + ############################################################# x <- unlist(objs) # check if the output is valid and output accordingly - if(length(x) < nfilter){ + if(length(x) < nfilter.tab){ if(length(x == 0)){ x <- c() }else{ diff --git a/R/isValidDS.R b/R/isValidDS.R index b79164df..fc60dfa1 100644 --- a/R/isValidDS.R +++ b/R/isValidDS.R @@ -10,10 +10,18 @@ isValidDS <- function(obj) { # this filter sets the minimum number of observations that are allowed - nfilter <- setFilterDS() + + ############################################################# + # MODULE 1: CAPTURE THE nfilter SETTINGS + thr <- 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) + ############################################################# if(class(obj) == "character" | class(obj) == "integer" | class(obj) == "logical" | class(obj) == "numeric") { - if(length(obj) > 0 & length(obj) < nfilter) { + if(length(obj) > 0 & length(obj) < nfilter.tab) { return(FALSE) } else { return(TRUE) @@ -21,7 +29,7 @@ isValidDS <- function(obj) { }else{ if(class(obj) == "factor"){ tt <- tabulate(obj) - xx <- which(tt > 0 & tt < nfilter) + xx <- which(tt > 0 & tt < nfilter.tab) if(length(xx) > 0) { return(FALSE) } else { @@ -29,7 +37,7 @@ isValidDS <- function(obj) { } }else{ if(class(obj) == "data.frame" | class(obj) == "matrix"){ - if(dim(obj)[1] > 0 & dim(obj)[1] < nfilter){ + if(dim(obj)[1] > 0 & dim(obj)[1] < nfilter.tab){ return(FALSE) }else{ return(TRUE) @@ -40,4 +48,4 @@ isValidDS <- function(obj) { } } -} \ No newline at end of file +} diff --git a/R/meanSdGpDS.R b/R/meanSdGpDS.R index 1d4010db..f7aa5e15 100644 --- a/R/meanSdGpDS.R +++ b/R/meanSdGpDS.R @@ -12,6 +12,15 @@ #' meanSdGpDS <- function (X, INDEX){ + ############################################################# + # MODULE 1: CAPTURE THE nfilter SETTINGS + thr <- 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) + ############################################################# + FUN.mean <- function(x) {mean(x,na.rm=TRUE)} FUN.var <- function(x) {stats::var(x,na.rm=TRUE)} @@ -98,10 +107,7 @@ meanSdGpDS <- function (X, INDEX){ # Set filter for cell sizes that are too small # the minimum number of observations that are allowed (the below function gets the value from opal) - # NEED CORRECT SOURCE FUNCTION SPECIFICATION - NOT: opal::setFilterDS() - # nfilter <- opal::setFilterDS() - nfilter <- 5 - any.invalid.cell<-(sum(ansmat.count0)>=1) + any.invalid.cell<-(sum(ansmat.count0)>=1) if(!any.invalid.cell) { table.valid<-TRUE @@ -114,7 +120,7 @@ meanSdGpDS <- function (X, INDEX){ if(any.invalid.cell) { table.valid<-FALSE - cell.count.warning<-paste0("At least one group has between 1 and ", nfilter-1, " observations. Please change groups") + cell.count.warning<-paste0("At least one group has between 1 and ", nfilter.tab-1, " observations. Please change groups") result<-list(table.valid,Nvalid,Nmissing,Ntotal,cell.count.warning) names(result)<-list("Table_valid","Nvalid","Nmissing","Ntotal","Warning") return(result) diff --git a/R/subsetByClassDS.R b/R/subsetByClassDS.R index ea71685e..f74c6b4d 100644 --- a/R/subsetByClassDS.R +++ b/R/subsetByClassDS.R @@ -18,8 +18,16 @@ subsetByClassDS <- function(data=NULL, variables=NULL){ # this filter sets the minimum number of observations that are allowed - nfilter <- setFilterDS() - + + ############################################################# + # MODULE 1: CAPTURE THE nfilter SETTINGS + thr <- 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) + ############################################################# + # evaluate the string passed on to the function as an object input <- eval(parse(text=data)) @@ -27,7 +35,7 @@ subsetByClassDS <- function(data=NULL, variables=NULL){ if(is.factor(input)){ # call the internal function that generates subsets if the input is a factor variable Dname <- extract(data)[[2]] - output <- subsetByClassHelper1(input, Dname, nfilter) + output <- subsetByClassHelper1(input, Dname, nfilter.subset) }else{ # get the names of the variables on the dataset varnames <- colnames(input) @@ -52,12 +60,12 @@ subsetByClassDS <- function(data=NULL, variables=NULL){ # of each factor variable and keep the generated subset dataframes in a list if(length(loop) > 1){ # call the function that gets the subsets if the user specified non or more than 1 variable - out.temp <- subsetByClassHelper2(input,loop,nfilter) + out.temp <- subsetByClassHelper2(input,loop,nfilter.subset) subsets <- out.temp[[1]] nonfactorvars <- out.temp[[2]] }else{ # call the function that gets the subsets if the user specified only one variable to subset by - out.temp <- subsetByClassHelper3(input,indx,nfilter) + out.temp <- subsetByClassHelper3(input,indx,nfilter.subset) subsets <- out.temp[[1]] nonfactorvars <- out.temp[[2]] } diff --git a/R/subsetDS.R b/R/subsetDS.R index 4091fe59..6db1a311 100644 --- a/R/subsetDS.R +++ b/R/subsetDS.R @@ -30,8 +30,16 @@ subsetDS <- function(dt=NULL, complt=NULL, rs=NULL, cs=NULL, lg=NULL, th=NULL, varname=NULL){ # this filter sets the minimum number of observations that are allowed - nfilter <- setFilterDS() - + + ############################################################# + # MODULE 1: CAPTURE THE nfilter SETTINGS + thr <- 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) + ############################################################# + # the logical operators are given as integers change them into characters if(!(is.null(lg))){ if(lg == 1){lg <- ">"} @@ -71,7 +79,7 @@ subsetDS <- function(dt=NULL, complt=NULL, rs=NULL, cs=NULL, lg=NULL, th=NULL, v subvect <- D[rs] } - if(length(subvect) < nfilter){ + if(length(subvect) < nfilter.tab){ if(length(subvect) == 0){ output <- D[-c(1:length(D))] }else{ @@ -106,7 +114,7 @@ subsetDS <- function(dt=NULL, complt=NULL, rs=NULL, cs=NULL, lg=NULL, th=NULL, v } } - if((dim(subtable)[1]) < nfilter){ + if((dim(subtable)[1]) < nfilter.tab){ if((dim(subtable)[1]) == 0){ output <- D[-c(1:dim(D)[1]),] }else{ diff --git a/R/table1DDS.R b/R/table1DDS.R index 1ef1281d..70211de5 100644 --- a/R/table1DDS.R +++ b/R/table1DDS.R @@ -15,6 +15,17 @@ #' table1DDS <- function(xvect){ + # the minimum number of observations that are allowed (the below function gets the value from opal) + + ############################################################# + # MODULE 1: CAPTURE THE nfilter SETTINGS + thr <- 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) + ############################################################# + # tabulate the input vector and output the result in a data frame format aa <- t(as.data.frame((table(xvect)))) bb <- as.data.frame(t(as.numeric(aa[2,]))) @@ -23,12 +34,9 @@ table1DDS <- function(xvect){ cc <- cbind(bb, sum(bb[1,], na.rm=TRUE)) colnames(cc) <- c(aa[1,], "Total") - # the minimum number of observations that are allowed (the below function gets the value from opal) - nfilter <- setFilterDS() - # check for invalid cells if any found change them to 'NA' and set the validity message accordingly validity <- "valid Table" - indx <- which(cc[1,1:(dim(cc)[2] - 1)] > 0 & cc[1,1:(dim(cc)[2] - 1)] < nfilter) + indx <- which(cc[1,1:(dim(cc)[2] - 1)] > 0 & cc[1,1:(dim(cc)[2] - 1)] < nfilter.tab) if(length(indx) > 0){ cc[1,1:(dim(cc)[2] - 1)] <- NA validity <- "invalid table - invalid counts present"