Refactor/perf batch 3

R/corDS.R

@@ -16,6 +16,7 @@
 #' by the 'nfilter.glm'). The second disclosure control checks that none of them is dichotomous with a
 #' level having fewer counts than the pre-specified 'nfilter.tab' threshold.
 #' @author Paul Burton, and Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 corDS <- function(x=NULL, y=NULL){
@@ -27,14 +28,21 @@ corDS <- function(x=NULL, y=NULL){
   nfilter.glm <- as.numeric(thr$nfilter.glm)
   #############################################################
 
-  x.val <- eval(parse(text=x), envir = parent.frame())
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
+
   if (!is.null(y)){
-    y.val <- eval(parse(text=y), envir = parent.frame())
+    y.val <- .loadServersideObject(y)
+    .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
   }
   else{
     y.val <- NULL
   }
-
+
+  if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer"))) {
+    stop("If x is a numeric vector, y must also be a numeric vector.", call. = FALSE)
+  }
+
   # create a data frame for the variables
   if (is.null(y.val)){
     dataframe <- as.data.frame(x.val)
@@ -165,7 +173,7 @@ corDS <- function(x=NULL, y=NULL){
 
   }
 
-  return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, sums.of.squares=sums.of.squares))
+  return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, sums.of.squares=sums.of.squares, class=class(x.val)))
 
 }
 # AGGREGATE FUNCTION

R/corTestDS.R

@@ -13,22 +13,25 @@
 #' 4 complete pairs of observations.
 #' @return the results of the correlation test.
 #' @author Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 corTestDS <- function(x, y, method, exact, conf.level){
 
-  x.var <- eval(parse(text=x), envir = parent.frame())
-  y.var <- eval(parse(text=y), envir = parent.frame())
+  x.var <- .loadServersideObject(x)
+  .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer"))
+  y.var <- .loadServersideObject(y)
+  .checkClass(obj = y.var, obj_name = y, permitted_classes = c("numeric", "integer"))
 
   # get the number of pairwise complete cases
   n <- sum(stats::complete.cases(x.var, y.var))
 
   # runs a two-sided correlation test
   corTest <- stats::cor.test(x=x.var, y=y.var, method=method, exact=exact, conf.level=conf.level)
 
-  out <- list(n, corTest)
-  names(out) <- c("Number of pairwise complete cases", "Correlation test")
-  
+  out <- list(n, corTest, class = class(x.var))
+  names(out)[1:2] <- c("Number of pairwise complete cases", "Correlation test")
+
   # return the results
   return(out)
 

R/covDS.R

@@ -23,6 +23,7 @@
 #' counts than the pre-specified 'nfilter.tab' threshold. If any of the input variables do not pass the disclosure
 #' controls then all the output values are replaced with NAs.
 #' @author Amadou Gaye, Paul Burton, and Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 covDS <- function(x=NULL, y=NULL, use=NULL){
@@ -36,14 +37,21 @@ covDS <- function(x=NULL, y=NULL, use=NULL){
   #nfilter.string <- as.numeric(thr$nfilter.string)
   #############################################################
 
-  x.val <- eval(parse(text=x), envir = parent.frame())
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
+
   if (!is.null(y)){
-    y.val <- eval(parse(text=y), envir = parent.frame())
+    y.val <- .loadServersideObject(y)
+    .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
   }
   else{
     y.val <- NULL
   }
-
+
+  if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer"))) {
+    stop("If x is a numeric vector, y must also be a numeric vector.", call. = FALSE)
+  }
+
   # create a data frame for the variables
   if (is.null(y.val)){
     dataframe <- as.data.frame(x.val)
@@ -298,7 +306,7 @@ covDS <- function(x=NULL, y=NULL, use=NULL){
 
   }
 
-  return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, errorMessage=errorMessage))
+  return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, errorMessage=errorMessage, class=class(x.val)))
 
 }
 # AGGREGATE FUNCTION

R/expDS.R

@@ -15,7 +15,7 @@ expDS <- function(x) {
   x.var <- .loadServersideObject(x)
   .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer"))
 
-  out <- exp(x.var)
+out <- exp(x.var)
   return(out)
 }
 # ASSIGN FUNCTION

R/kurtosisDS1.R

@@ -9,6 +9,7 @@
 #' @return a list including the kurtosis of the input numeric variable, the number of valid observations and
 #' the study-side validity message.
 #' @author Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 kurtosisDS1 <- function (x, method){
@@ -19,8 +20,9 @@ kurtosisDS1 <- function (x, method){
   nfilter.tab <- as.numeric(thr$nfilter.tab)
   #############################################################
 
-  x <- eval(parse(text=x), envir = parent.frame())
-  x <- x[stats::complete.cases(x)]
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer"))
+  x <- x.val[stats::complete.cases(x.val)]
 
   if(length(x) < nfilter.tab){
     kurtosis.out <- NA
@@ -32,19 +34,16 @@ kurtosisDS1 <- function (x, method){
 
     if(method==1){
       kurtosis.out <- g2
-      studysideMessage <- "VALID ANALYSIS"
     }
     if(method==2){
       kurtosis.out <- ((length(x) + 1) * g2 + 6) * (length(x) - 1)/((length(x) - 2) * (length(x) - 3))
-      studysideMessage <- "VALID ANALYSIS"
     }
     if(method==3){
       kurtosis.out <- (g2 + 3) * (1 - 1/length(x))^2 - 3
-      studysideMessage <- "VALID ANALYSIS"
     }
   }
-  
-  out.obj <- list(Kurtosis=kurtosis.out, Nvalid=length(x), ValidityMessage=studysideMessage)
+
+  out.obj <- list(Kurtosis=kurtosis.out, Nvalid=length(x), class=class(x.val))
   return(out.obj)
 
 }

R/kurtosisDS2.R

@@ -13,6 +13,7 @@
 #' indicating indicating a valid analysis if the number of valid observations are above the protection filter 
 #' nfilter.tab or invalid analysis otherwise.
 #' @author Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 kurtosisDS2 <- function(x, global.mean){
@@ -23,20 +24,18 @@ kurtosisDS2 <- function(x, global.mean){
   nfilter.tab <- as.numeric(thr$nfilter.tab)
   #############################################################
 
-  x <- eval(parse(text=x), envir = parent.frame())
-  x <- x[stats::complete.cases(x)]
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer"))
+  x <- x.val[stats::complete.cases(x.val)]
 
   if(length(x) < nfilter.tab){
-    sum_quartics.out <- NA
-    sum_squares.out <- NA
-    studysideMessage <- "FAILED: Nvalid less than nfilter.tab"
-  }else{
-    sum_quartics.out <- sum((x - global.mean)^4)
-    sum_squares.out <- sum((x - global.mean)^2)
-    studysideMessage <- "VALID ANALYSIS"
+    stop("FAILED: Nvalid less than nfilter.tab", call. = FALSE)
   }
-
-  out.obj <- list(Sum.quartics=sum_quartics.out, Sum.squares=sum_squares.out, Nvalid=length(x), ValidityMessage=studysideMessage)
+
+  sum_quartics.out <- sum((x - global.mean)^4)
+  sum_squares.out <- sum((x - global.mean)^2)
+
+  out.obj <- list(Sum.quartics=sum_quartics.out, Sum.squares=sum_squares.out, Nvalid=length(x), class=class(x.val))
   return(out.obj)
 
 }

R/lengthDS.R

@@ -1,3 +1,4 @@
+
 #'
 #' @title Returns the length of a vector or list
 #' @description This function is similar to R function \code{length}.

R/meanDS.R

@@ -3,12 +3,13 @@
 #' @description Calculates the mean value.
 #' @details if the length of input vector is less than the set filter
 #' a missing value is returned.
-#' @param xvect a vector
+#' @param x a character string, the name of a numeric or integer vector
 #' @return a numeric, the statistical mean
 #' @author Gaye A, Burton PR
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
-meanDS <- function(xvect){
+meanDS <- function(x){
 
   #############################################################
   # MODULE 1: CAPTURE THE nfilter SETTINGS
@@ -19,18 +20,18 @@ meanDS <- function(xvect){
   #nfilter.string <- as.numeric(thr$nfilter.string)
   #############################################################
 
+  xvect <- .loadServersideObject(x)
+  .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer"))
+
   out.mean <- mean(xvect, na.rm=TRUE)
   out.numNa <- length(which(is.na(xvect)))
   out.totN <- length(xvect)
   out.validN <- out.totN-out.numNa
-  studysideMessage <- "VALID ANALYSIS"
-
   if((out.validN != 0) && (out.validN < nfilter.tab)){
-    out.mean <- NA
     stop("FAILED: Nvalid less than nfilter.tab", call. = FALSE)
   }
 
-  out.obj <- list(EstimatedMean=out.mean,Nmissing=out.numNa,Nvalid=out.validN,Ntotal=out.totN,ValidityMessage=studysideMessage)
+  out.obj <- list(EstimatedMean=out.mean,Nmissing=out.numNa,Nvalid=out.validN,Ntotal=out.totN,class=class(xvect))
   return(out.obj)
 
 }

R/meanSdGpDS.R

@@ -3,17 +3,18 @@
 #' @description Server-side function called by ds.meanSdGp 
 #' @details Computes the mean and standard deviation across groups defined by one
 #' factor
-#' @param X a client-side supplied character string identifying the variable for which
+#' @param x a client-side supplied character string identifying the variable for which
 #' means/SDs are to be calculated
-#' @param INDEX a client-side supplied character string identifying the factor across
+#' @param index a client-side supplied character string identifying the factor across
 #' which means/SDs are to be calculated
 #' @author Burton PR
-#' 
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#'
 #' @return List with results from the group statistics
 #' @export
 #'
-meanSdGpDS <- function (X, INDEX){
-  
+meanSdGpDS <- function (x, index){
+
   #############################################################
   # MODULE 1: CAPTURE THE nfilter SETTINGS
   thr <- dsBase::listDisclosureSettingsDS()
@@ -23,9 +24,16 @@ meanSdGpDS <- function (X, INDEX){
   #nfilter.string <- as.numeric(thr$nfilter.string)
   #############################################################
 
+  X <- .loadServersideObject(x)
+  .checkClass(obj = X, obj_name = x, permitted_classes = c("numeric", "integer"))
+  INDEX <- .loadServersideObject(index)
+  .checkClass(obj = INDEX, obj_name = index, permitted_classes = c("factor", "character", "integer"))
+  x.class <- class(X)
+  index.class <- class(INDEX)
+
   FUN.mean <- function(x) {mean(x,na.rm=TRUE)}
   FUN.var <- function(x)  {stats::var(x,na.rm=TRUE)}
-  
+
   #Strip missings from both X and INDEX
   analysis.matrix<-cbind(X,INDEX)
 
@@ -114,17 +122,17 @@ meanSdGpDS <- function (X, INDEX){
   {
     table.valid<-TRUE
     cell.count.warning<-paste0("All tables valid") 
-    result<-list(table.valid,ansmat.mean,ansmat.sd,ansmat.count,Nvalid,Nmissing,Ntotal,cell.count.warning)
-    names(result)<-list("Table_valid","Mean_gp","StDev_gp", "N_gp","Nvalid","Nmissing","Ntotal","Message")
+    result<-list(table.valid,ansmat.mean,ansmat.sd,ansmat.count,Nvalid,Nmissing,Ntotal,cell.count.warning,x.class,index.class)
+    names(result)<-list("Table_valid","Mean_gp","StDev_gp", "N_gp","Nvalid","Nmissing","Ntotal","Message","class.x","class.index")
     return(result)
   }
 
   if(any.invalid.cell)
   {
     table.valid<-FALSE
     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")
+    result<-list(table.valid,Nvalid,Nmissing,Ntotal,cell.count.warning,x.class,index.class)
+    names(result)<-list("Table_valid","Nvalid","Nmissing","Ntotal","Warning","class.x","class.index")
     return(result)
   }
 

R/quantileMeanDS.R

@@ -2,25 +2,29 @@
 #' @title Generates quantiles and mean information without maximum and minimum
 #' @description the probabilities 5%, 10%, 25%, 50%, 75%, 90%, 95% and the mean
 #' are used to compute the corresponding quantiles.
-#' @param xvect a numerical vector
-#' @return a numeric vector that represents the sample quantiles 
+#' @param x a character string, the name of a numeric or integer vector
+#' @return a numeric vector that represents the sample quantiles
 #' @export
 #' @author Burton, P.; Gaye, A.
-#' 
-quantileMeanDS <- function (xvect) {
-
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#'
+quantileMeanDS <- function (x) {
+
+  xvect <- .loadServersideObject(x)
+  .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer"))
+
   # check if the input vector is valid (i.e. meets DataSHIELD criteria)
   check <- isValidDS(xvect)
-  
+
   if(check){
-    # if the input vector is valid 
+    # if the input vector is valid
     qq <- stats::quantile(xvect,c(0.05,0.1,0.25,0.5,0.75,0.9,0.95), na.rm=TRUE)
     mm <- mean(xvect,na.rm=TRUE)
     quantile.obj <- c(qq, mm)
-    names(quantile.obj) <- c("5%","10%","25%","50%","75%","90%","95%","Mean")    
+    names(quantile.obj) <- c("5%","10%","25%","50%","75%","90%","95%","Mean")
   }else{
     quantile.obj <- NA
   }
-  
-  return(quantile.obj)
+
+  return(list(quantiles = quantile.obj, class = class(xvect)))
 }

R/skewnessDS1.R

@@ -9,6 +9,7 @@
 #' @return a list including the skewness of the input numeric variable, the number of valid observations and
 #' the study-side validity message.
 #' @author Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 skewnessDS1 <- function(x, method){
@@ -19,8 +20,9 @@ skewnessDS1 <- function(x, method){
   nfilter.tab <- as.numeric(thr$nfilter.tab)
   #############################################################
 
-  x <- eval(parse(text=x), envir = parent.frame())
-  x <- x[stats::complete.cases(x)]
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer"))
+  x <- x.val[stats::complete.cases(x.val)]
 
   if(length(x) < nfilter.tab){
     skewness.out <- NA
@@ -32,19 +34,16 @@ skewnessDS1 <- function(x, method){
 
     if(method==1){
       skewness.out <- g1
-      studysideMessage <- "VALID ANALYSIS"
     }
     if(method==2){
       skewness.out <- g1 * sqrt(length(x)*(length(x)-1))/(length(x)-2)
-      studysideMessage <- "VALID ANALYSIS"
     }
     if(method==3){
       skewness.out <- g1 * ((length(x)-1)/(length(x)))^(3/2)
-      studysideMessage <- "VALID ANALYSIS"
     }
   }
 
-  out.obj <- list(Skewness=skewness.out, Nvalid=length(x), ValidityMessage=studysideMessage)
+  out.obj <- list(Skewness=skewness.out, Nvalid=length(x), class=class(x.val))
   return(out.obj)
 
 }