Refactor/perf batch 10

.Rbuildignore

@@ -25,3 +25,4 @@
 ^\.github$
 ^man-roxygen$
 ^codecov\.yml$
+^github-workflows_check\.Rout$

.github/workflows/check.yaml

@@ -79,8 +79,8 @@ jobs:
         id: rcmdcheck
         if: always()
         run: |
-          R -q -e "devtools::check(args = c('--no-examples', '--no-tests'))" | tee azure-pipelines_check.Rout
-          grep --quiet "^0 errors" azure-pipelines_check.Rout && grep --quiet " 0 warnings" azure-pipelines_check.Rout && grep --quiet " 0 notes" azure-pipelines_check.Rout
+          R -q -e "devtools::check(args = c('--no-examples', '--no-tests'))" | tee github-workflows_check.Rout
+          grep --quiet "^0 errors" github-workflows_check.Rout && grep --quiet " 0 warnings" github-workflows_check.Rout && grep --quiet " 0 notes" github-workflows_check.Rout
 
       - name: Post PR comment
         if: always()

.github/workflows/dsBaseClient_test_suite.yaml

@@ -96,7 +96,7 @@ env:
   # test reference rates/tolerances (see tests/testthat/perf_tests/perf_rate.R).
   # Reuses the existing azure-pipeline reference files rather than adding new
   # ones, matching what the old Azure pipelines set via perf.profile.
-  PERF_PROFILE: azure-pipeline
+  PERF_PROFILE: github-workflows
   # dsBase shards get their filter from matrix.filter per entry instead.
   TEST_FILTER_DSDANGER: '__dgr-|datachk_dgr-|smk_dgr-|arg_dgr-|disc_dgr-|smk_expt_dgr-|expt_dgr-|math_dgr-'
 

.gitignore

@@ -13,3 +13,4 @@ tests/testthat/connection_to_datasets/local_settings.csv
 tests/docker/armadillo/standard/logs/
 tests/docker/armadillo/standard/data/
 lintr_results.sarif
+tests/testthat/Rplots.pdf

R/ds.assign.R

@@ -16,6 +16,7 @@
 #' @return \code{ds.assign} returns the R object assigned to a name 
 #' that is written to the server-side.
 #' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' @examples 
 #' \dontrun{
@@ -56,15 +57,7 @@
 #'
 ds.assign <- function(toAssign=NULL, newobj=NULL, 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(toAssign)){
     stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE)
@@ -78,7 +71,4 @@ ds.assign <- function(toAssign=NULL, newobj=NULL, datasources=NULL){
   # now do the business
   DSI::datashield.assign(datasources, newobj, as.symbol(toAssign))
 
-  # check that the new object has been created and display a message accordingly
-  finalcheck <- isAssigned(datasources, newobj)
-
 }

R/ds.colnames.R

@@ -52,30 +52,8 @@
 #'
 ds.colnames <- function(x=NULL, 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)
-  }
-
-  if(is.null(x)){
-    stop("Please provide the name of a data.frame or matrix!", call.=FALSE)
-  }
-
-  # check if the input object(s) is(are) defined in all the studies
-  defined <- isDefined(datasources, x)
-
-  # call the internal function that checks the input object is of the same class in all studies.
-  typ <- checkClass(datasources, x)
-
-  # if the input object is not a matrix or a dataframe stop
-  if(!('data.frame' %in% typ) & !('matrix' %in% typ)){
-    stop("The input vector must be of type 'data.frame' or a 'matrix'!", call.=FALSE)
-  }
+  datasources <- .set_datasources(datasources)
+  .check_df_name_provided(x)
 
   cally <- call("colnamesDS", x)
   column_names <- DSI::datashield.aggregate(datasources, cally)

R/ds.contourPlot.R

@@ -181,9 +181,9 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2
     if(method=='smallCellsRule'){
 
     # get the range from each study and produce the 'global' range
-    x.ranges <- datashield.aggregate(datasources, as.symbol(paste0("rangeDS(", x, ")")))
+    x.ranges <- datashield.aggregate(datasources, call("rangeDS", x))
 
-    y.ranges <- datashield.aggregate(datasources, as.symbol(paste0("rangeDS(", y, ")")))
+    y.ranges <- datashield.aggregate(datasources, call("rangeDS", y))
 
     x.minrs <- c()
     x.maxrs <- c()

R/ds.densityGrid.R

@@ -104,9 +104,9 @@ ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasourc
 
   if(type=="combine"){
     # get the range from each study and produce the 'global' range
-    x.ranges <- datashield.aggregate(datasources, as.symbol(paste0("rangeDS(", x, ")")))
+    x.ranges <- datashield.aggregate(datasources, call("rangeDS", x))
 
-    y.ranges <- datashield.aggregate(datasources, as.symbol(paste0("rangeDS(", y, ")")))
+    y.ranges <- datashield.aggregate(datasources, call("rangeDS", y))
 
     x.minrs <- c()
     x.maxrs <- c()

R/ds.elspline.R

@@ -23,27 +23,17 @@
 #' @return an object of class "lspline" and "matrix", which its name is specified by the
 #' \code{newobj} argument (or its default name "elspline.newobj"), is assigned on the serverside.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 ds.elspline <- function(x, n, marginal = FALSE, names = NULL, newobj = NULL, 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("Please provide the name of the input variable x!", call.=FALSE)
   }
 
-  # check if the input object is defined in all the studies
-  defined <- isDefined(datasources, x)
-
   if(is.null(n)){
     stop("Argument 'n' is missing, with no default!", call.=FALSE)
   }

R/ds.getWGSR.R

@@ -58,6 +58,7 @@
 #' @return \code{ds.getWGSR} assigns a vector for each study that includes the z-scores for the
 #' specified index. The created vectors are stored in the servers.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' @examples
 #' \dontrun{
@@ -102,15 +103,7 @@
 #'
 ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, standing=NA, thirdPart=NA, newobj=NULL, 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(sex)){
     stop("Please provide the column name of the 'sex' variable!", call.=FALSE)
@@ -124,21 +117,6 @@ ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, st
     stop("Please provide the column name of the 'secondPart' variable!", call.=FALSE)
   }
 
-  # check if the input objects are defined in all the studies
-  isDefined(datasources, sex)
-  isDefined(datasources, firstPart)
-  isDefined(datasources, secondPart)
-
-  # if 'firstPart' or 'secondPart' are not numeric return an error message
-  typ.firstPart <- checkClass(datasources, firstPart)
-  typ.secondPart <- checkClass(datasources, secondPart)
-  if(!('numeric' %in% typ.firstPart)){
-    stop("The 'firstPart' variable must be a 'numeric' variable!", call.=FALSE)
-  }
-  if(!('numeric' %in% typ.secondPart)){
-    stop("The 'secondPart' variable must be a 'numeric' variable!", call.=FALSE)
-  }
-
   if(!any(index %in% c("bfa", "hca", "hfa", "lfa", "mfa", "ssa", "tsa", "wfa", "wfh", "wfl"))){
     stop("Please provide a correct abbreviation for the index!", call.=FALSE)
   }
@@ -148,14 +126,6 @@ ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, st
     stop("'thirdPart' variable should not be missing for index 'bfa'", call.=FALSE)
   }
 
-  # If 'thirdPart' (age) is not numeric for BMI-for-age return an error message
-  if(index == "bfa"){
-    typ.thirdPart <- checkClass(datasources, thirdPart)
-    if(!('numeric' %in% typ.firstPart)){
-      stop("The 'thirdPart' variable must be a 'numeric' variable!", call.=FALSE)
-    }  
-  }
-
   # If 'standing' is not a value either 1, 2, 3, or NA return an error message
   if(!any(standing %in% c(NA, 1, 2, 3))) {
     stop("The 'standing' variable must be a numeric value either 1, 2, or 3!", call.=FALSE)
@@ -168,63 +138,5 @@ ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, st
 
   cally <- call("getWGSRDS", sex, firstPart, secondPart, index, standing, thirdPart)
   DSI::datashield.assign(datasources, newobj, cally)
-
-  #############################################################################################################
-  # DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED  
-
-  # SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION 
-  test.obj.name <- newobj	
-
-  # CALL SEVERSIDE FUNCTION
-  calltext <- call("testObjExistsDS", test.obj.name)
-  object.info <- DSI::datashield.aggregate(datasources, calltext)
-
-  # CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS
-  # AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS
-  num.datasources <- length(object.info)
-
-  obj.name.exists.in.all.sources <- TRUE
-  obj.non.null.in.all.sources <- TRUE
-
-  for(j in 1:num.datasources){
-    if(!object.info[[j]]$test.obj.exists){
-      obj.name.exists.in.all.sources <- FALSE
-    }
-    if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){
-      obj.non.null.in.all.sources <- FALSE
-    }
-  }
-
-  if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){
-    return.message <- paste0("A data object <", test.obj.name, "> has been created in all specified data sources")
-  }else{
-    return.message.1 <- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources")
-    return.message.2 <- paste0("It is either ABSENT and/or has no valid content/class,see return.info above")	
-    return.message.3 <-	paste0("Please use ds.ls() to identify where missing")
-    return.message <- list(return.message.1,return.message.2,return.message.3)
-  }
-
-  calltext <- call("messageDS", test.obj.name)
-  studyside.message <- DSI::datashield.aggregate(datasources, calltext)
-  no.errors <- TRUE
-  for(nd in 1:num.datasources){
-    if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){
-      no.errors <- FALSE
-    }
-  }
-
-  if(no.errors){
-    validity.check <- paste0("<",test.obj.name, "> appears valid in all sources")
-    return(list(is.object.created=return.message,validity.check=validity.check))
-  }
-
-  if(!no.errors){
-    validity.check <- paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:")
-    return(list(is.object.created=return.message,validity.check=validity.check,
-                studyside.messages=studyside.message))
-  }
-
-  # END OF CHECK OBJECT CREATED CORECTLY MODULE	
-  #######################################################################################################
 
-}  
+}

R/ds.heatmapPlot.R

@@ -229,9 +229,9 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2
     if (method=="smallCellsRule"){
 
       # get the range from each study and produce the 'global' range
-      x.ranges <- datashield.aggregate(datasources, as.symbol(paste0("rangeDS(", x, ")")))
+      x.ranges <- datashield.aggregate(datasources, call("rangeDS", x))
 
-      y.ranges <- datashield.aggregate(datasources, as.symbol(paste0("rangeDS(", y, ")")))
+      y.ranges <- datashield.aggregate(datasources, call("rangeDS", y))
 
       x.minrs <- c()
       x.maxrs <- c()

R/ds.hetcor.R

@@ -27,27 +27,17 @@
 #' the method by which any missing data were handled: "complete.obs" or "pairwise.complete.obs"; TRUE 
 #' for ML estimates, FALSE for two-step estimates.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 ds.hetcor <- function(data=NULL, ML=TRUE, std.err=TRUE, bins=4, pd=TRUE, use="complete.obs", 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(data)){
     stop("Please provide the name of the input object!", call.=FALSE)
   }
 
-  # check if the input object is defined in all the studies
-  defined <- isDefined(datasources, data)
-
   calltext <- call('hetcorDS', data, ML, std.err, bins, pd, use)
   output <- DSI::datashield.aggregate(datasources, calltext)
 

R/ds.isValid.R

@@ -13,8 +13,10 @@
 #' @param datasources a list of \code{\link[DSI]{DSConnection-class}} 
 #' objects obtained after login. If the \code{datasources} argument is not specified
 #' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
+#' @template classConsistencyCheckTrue
 #' @return \code{ds.isValid} returns a boolean. If it is TRUE input object is valid, FALSE otherwise. 
 #' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' @examples
 #' \dontrun{
@@ -55,36 +57,21 @@
 #'
 #' }
 #'
-ds.isValid <- function(x=NULL, datasources=NULL){
+ds.isValid <- function(x=NULL, datasources=NULL, classConsistencyCheck=TRUE){
 
-  # 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("Please provide the name of the input vector!", 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)
+  # call the server side function that does the job and return its output
+  cally <- call("isValidDS", x)
+  results <- DSI::datashield.aggregate(datasources, cally)
 
-  # the input object must be a vector
-  if(!('character' %in% typ) & !('factor' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ) & !('numeric' %in% typ) & !('data.frame' %in% typ) & !('matrix' %in% typ)){
-    stop("The input object must be a character, factor, integer, logical or numeric vector or a dataframe or a matrix", call.=FALSE)
+  if(classConsistencyCheck){
+    .checkClassConsistency(results)
   }
 
-  # call the server side function that does the job and return its output
-  cally <- paste0('isValidDS(', x, ')')
-  output <- DSI::datashield.aggregate(datasources, as.symbol(cally))
-
-  return(output)
+  return(lapply(results, function(r) r$valid))
 }

R/ds.lexis.R

@@ -134,6 +134,7 @@
 #' the expanded version of the input table.
 #' 
 #' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @seealso \code{\link{ds.glm}} for generalized linear models. 
 #' @export
 #' @examples
@@ -202,15 +203,7 @@
 #'
 ds.lexis<-function(data=NULL, intervalWidth=NULL, idCol=NULL, entryCol=NULL, exitCol=NULL, statusCol=NULL, variables=NULL, expandDF=NULL, 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)
 
   # check if user have provided the name of the column that holds the subject ids
   if(is.null(idCol)){