Refactor/perf batch 3

NAMESPACE

@@ -119,6 +119,8 @@ export(ds.var)
 export(ds.vectorCalc)
 import(DSI)
 import(data.table)
+importFrom(DSI,datashield.connections_find)
+importFrom(cli,cli_abort)
 importFrom(stats,as.formula)
 importFrom(stats,na.omit)
 importFrom(stats,ts)

R/ds.cor.R

@@ -37,6 +37,7 @@
 #' percentage is pre-specified 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 DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @examples
 #' \dontrun{
 #'
@@ -79,56 +80,25 @@
 #' }
 #' @export
 #' 
-ds.cor <- function(x=NULL, y=NULL, type="split", datasources=NULL){
+ds.cor <- function(x=NULL, y=NULL, type="split", classConsistencyCheck=TRUE, datasources=NULL){
 
-  # look for DS connections
-  if(is.null(datasources)){
-    datasources <- datashield.connections_find()
-  }
-
-  # ensure datasources is a list of DSConnection-class
-  if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
-    stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
-  }
+  datasources <- .set_datasources(datasources)
 
   if(is.null(x)){
     stop("x=NULL. Please provide the name of a matrix or dataframe or the names of two numeric vectors!", call.=FALSE)
-  }else{
-    isDefined(datasources, x)
-  }
-
-  # check the type of the input objects
-  typ <- checkClass(datasources, x)
-
-  if(('numeric' %in% typ) | ('integer' %in% typ) | ('factor' %in% typ)){
-    if(is.null(y)){
-      stop("If x is a numeric vector, y must be a numeric vector!", call.=FALSE)
-    }else{
-      isDefined(datasources, y)
-      typ2 <- checkClass(datasources, y)
-    }
-  }
-
-  if(('matrix' %in% typ) | ('data.frame' %in% typ) & !(is.null(y))){
-    y <- NULL
-    warning("x is a matrix or a dataframe; y will be ignored and a correlation matrix computed for x!")
   }
 
   # name of the studies to be used in the output
   stdnames <- names(datasources)
 
   # call the server side function
-  if(('matrix' %in% typ) | ('data.frame' %in% typ)){
-    calltext <- call("corDS", x, NULL)
-  }else{
-    if(!(is.null(y))){
-      calltext <- call("corDS", x, y)
-    }else{
-      calltext <- call("corDS", x, NULL)
-    }
-  }
+  calltext <- call("corDS", x, y)
   output <- DSI::datashield.aggregate(datasources, calltext)
-
+
+  if(classConsistencyCheck){
+    .checkClassConsistency(output)
+  }
+
   if (type=="split"){
     covariance <- list()
     sqrt.diag <- list()

R/ds.corTest.R

@@ -24,6 +24,7 @@
 #' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
 #' @return \code{ds.corTest} returns to the client-side the results of the correlation test. 
 #' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' @examples
 #' \dontrun{
@@ -63,17 +64,9 @@
 #'   
 #' }   
 #'
-ds.corTest <- function(x=NULL, y=NULL, method="pearson", exact=NULL, conf.level=0.95, type='split', datasources=NULL){
+ds.corTest <- function(x=NULL, y=NULL, method="pearson", exact=NULL, conf.level=0.95, type='split', classConsistencyCheck=FALSE, datasources=NULL){
 
-  # look for DS connections
-  if(is.null(datasources)){
-    datasources <- datashield.connections_find()
-  }
-
-  # ensure datasources is a list of DSConnection-class
-  if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
-    stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
-  }
+  datasources <- .set_datasources(datasources)
 
   if(is.null(x)){
     stop("x=NULL. Please provide the names of the 1st numeric vector!", call.=FALSE)
@@ -85,19 +78,18 @@ ds.corTest <- function(x=NULL, y=NULL, method="pearson", exact=NULL, conf.level=
   if(!(method %in% c("pearson", "kendall", "spearman"))){
     stop('Function argument "method" has to be either "pearson", "kendall" or "spearman"', call.=FALSE)
   }
-
-  # check if the input objects are defined in all the studies
-  isDefined(datasources, x)
-  isDefined(datasources, y)
-
-  # call the internal function that checks the input objects are of the same class in all studies.
-  typ <- checkClass(datasources, x)
-  typ <- checkClass(datasources, y)
 
   # call the server side function
   cally <- call("corTestDS", x, y, method, exact, conf.level)
   out <- DSI::datashield.aggregate(datasources, cally)
 
+  if(classConsistencyCheck){
+    .checkClassConsistency(out)
+  }
+
+  # strip class field from results before returning
+  out <- lapply(out, function(r) { r$class <- NULL; r })
+
   if(type=="split"){
     return(out)
   }else{

R/ds.cov.R

@@ -47,6 +47,7 @@
 #' the disclosure controls then all the output values are replaced with NAs. If all the variables are valid and pass
 #' the controls, then the output matrices are returned and also an error message is returned but it is replaced by NA.
 #' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @examples
 #' \dontrun{
 #'
@@ -96,56 +97,25 @@
 #' }
 #' @export
 #'
-ds.cov <- function(x=NULL, y=NULL, naAction='pairwise.complete', type="split", datasources=NULL){
+ds.cov <- function(x=NULL, y=NULL, naAction='pairwise.complete', type="split", classConsistencyCheck=TRUE, datasources=NULL){
 
-  # look for DS connections
-  if(is.null(datasources)){
-    datasources <- datashield.connections_find()
-  }
-
-  # ensure datasources is a list of DSConnection-class
-  if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
-    stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
-  }
+  datasources <- .set_datasources(datasources)
 
   if(is.null(x)){
     stop("x=NULL. Please provide the name of a matrix or dataframe or the names of two numeric vectors!", call.=FALSE)
-  }else{
-    isDefined(datasources, x)
-  }
-
-  # check the type of the input objects
-  typ <- checkClass(datasources, x)
-
-  if(('numeric' %in% typ) | ('integer' %in% typ) | ('factor' %in% typ)){
-    if(is.null(y)){
-      stop("If x is a numeric vector, y must be a numeric vector!", call.=FALSE)
-    }else{
-      isDefined(datasources, y)
-      typ2 <- checkClass(datasources, y)
-    }
-  }
-
-  if(('matrix' %in% typ) | ('data.frame' %in% typ) & !(is.null(y))){
-    y <- NULL
-    warning("x is a matrix or a dataframe; y will be ignored and a covariance matrix computed for x!")
   }
 
   # name of the studies to be used in the output
   stdnames <- names(datasources)
 
   # call the server side function
-  if(('matrix' %in% typ) | ('data.frame' %in% typ)){
-    calltext <- call("covDS", x, NULL, naAction)
-  }else{
-    if(!(is.null(y))){
-      calltext <- call("covDS", x, y, naAction)
-    }else{
-      calltext <- call("covDS", x, NULL, naAction)
-    }
-  }
+  calltext <- call("covDS", x, y, naAction)
   output <- DSI::datashield.aggregate(datasources, calltext)
-
+
+  if(classConsistencyCheck){
+    .checkClassConsistency(output)
+  }
+
   if (type=="split"){
     covariance <- list()
     results <- list()

R/ds.kurtosis.R

@@ -23,56 +23,40 @@
 #' @return a matrix showing the kurtosis of the input numeric variable, the number of valid observations and
 #' the validity message.
 #' @author Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
-ds.kurtosis <- function(x=NULL, method=1, type='both', datasources=NULL){
-
-  # if no opal login details are provided look for 'opal' objects in the environment
-  if(is.null(datasources)){
-    datasources <- datashield.connections_find()
-  }
+ds.kurtosis <- function(x=NULL, method=1, type='both', classConsistencyCheck=FALSE, datasources=NULL){
 
-  # ensure datasources is a list of DSConnection-class
-  if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
-    stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
-  }
+  datasources <- .set_datasources(datasources)
 
   if(is.null(x)){
     stop("Please provide the name of the input vector!", call.=FALSE)
   }
-  
+
   if(!all(method %in% c(1,2,3))){
     stop("method must be an integer between 1 and 3", call.=FALSE)
   }
-  
-  # enable valid aliases for "type" argument                  
+
+  # enable valid aliases for "type" argument
   if(type == 'combine' | type == 'combined' | type == 'combines' | type == 'c') type <- 'combine'
   if(type == 'split' | type == 'splits' | type == 's') type <- 'split'
   if(type == 'both' | type == 'b' ) type <- 'both'
   if(type != 'combine' & type != 'split' & type != 'both'){
     stop('Function argument "type" has to be either "both", "combine" or "split"', call.=FALSE)
   }
-
-  # check if the input object is defined in all the studies
-  isDefined(datasources, x)
-
-  # call the internal function that checks the input object is of the same class in all studies.
-  typ <- checkClass(datasources, x)
-
-  # the input object must be a numeric or an integer vector
-  if(typ != 'integer' & typ != 'numeric'){
-    message(paste0(x, " is of type ", typ, "!"))
-    stop("The input object must be an integer or numeric vector.", call.=FALSE)
-  }
-
+
   if (type=='split' | type=='both'){
     calltext.split <- call("kurtosisDS1", x, method)
-    output.split <- DSI::datashield.aggregate(datasources, calltext.split) 
-    mat.split <- matrix(as.numeric(matrix(unlist(output.split), nrow=length(datasources), byrow=TRUE)[,1:2]),nrow=length(datasources))
-    validity <- matrix(unlist(output.split), nrow=length(datasources), byrow=TRUE)[,3]
-    mat.split <- data.frame(cbind(mat.split, validity))
+    output.split <- DSI::datashield.aggregate(datasources, calltext.split)
+    if(classConsistencyCheck){
+      .checkClassConsistency(output.split)
+    }
+    mat.split <- data.frame(
+      Kurtosis = sapply(output.split, function(r) r$Kurtosis),
+      Nvalid = sapply(output.split, function(r) r$Nvalid)
+    )
     rownames(mat.split) <- names(output.split)
-    colnames(mat.split) <- c('Kurtosis', 'Nvalid', 'ValidityMessage')
   }
 
   if (type=='combine' | type=='both'){
@@ -83,8 +67,11 @@ ds.kurtosis <- function(x=NULL, method=1, type='both', datasources=NULL){
       stop("FAILED: The number of valid observations in one or more studies is less than nfilter.tab. \n Check that by using the argument type=='split'", call.=FALSE)
     }else{
       calltext.combined <- call("kurtosisDS2", x, global.mean)
-      output.combined <- DSI::datashield.aggregate(datasources, calltext.combined) 
-
+      output.combined <- DSI::datashield.aggregate(datasources, calltext.combined)
+      if(classConsistencyCheck){
+        .checkClassConsistency(output.combined)
+      }
+
       Global.sum.quartics <- 0
       Global.sum.squares <- 0
       Global.Nvalid <- 0
@@ -98,19 +85,15 @@ ds.kurtosis <- function(x=NULL, method=1, type='both', datasources=NULL){
 
       if(method==1){
         Global.kurtosis <- g2.global
-        combinedMessage <- "VALID ANALYSIS"
-      }  
+      }
       if(method==2){
         Global.kurtosis <- ((Global.Nvalid + 1) * g2.global + 6) * (Global.Nvalid - 1)/((Global.Nvalid - 2) * (Global.Nvalid - 3))
-        combinedMessage <- "VALID ANALYSIS"
-      }  
+      }
       if(method==3){
         Global.kurtosis <- (g2.global + 3) * (1 - 1/Global.Nvalid)^2 - 3
-        combinedMessage <- "VALID ANALYSIS"
       } 
-      mat.combined <- data.frame(cbind(Global.kurtosis, Global.Nvalid, combinedMessage))
+      mat.combined <- data.frame(Kurtosis = Global.kurtosis, Nvalid = Global.Nvalid)
       rownames(mat.combined) <- 'studiesCombined'
-      colnames(mat.combined) <- c('Kurtosis', 'Nvalid', 'ValidityMessage')
 
     }
   }