Refactor/perf batch 10

.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.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.getWGSR.R

@@ -139,5 +139,4 @@ 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)
 
-
-}  
+}

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.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.make.R

@@ -134,7 +134,6 @@
 #'
 ds.make<-function(toAssign=NULL, newobj=NULL, datasources=NULL){
 
-  # look for DS connections
   datasources <- .set_datasources(datasources)
 
   if(is.null(toAssign)){

R/ds.rowColCalc.R

@@ -74,33 +74,6 @@ ds.rowColCalc <- function(x=NULL, operation=NULL, newobj=NULL, datasources=NULL)
     stop("Please provide the name of a data.frame or matrix!", call.=FALSE)
   }
 
-  # number of studies and their names
-  numsources <- length(datasources)
-  stdnames <- names(datasources)
-
-  # we want to deal only with two dimensional tables
-  dim2 <- c()
-  for(i in 1:numsources){
-    dims <- DSI::datashield.aggregate(datasources[i], call("dimDS", x))
-    if(length(dims[[1]]$dim) != 2){
-      stop("The input table in ", stdnames[i]," has more than two dimensions. Only strutures of two dimensions are allowed", call.=FALSE)
-    }
-    dim2 <- append(dim2, dims[[1]]$dim[2])
-  }
-
-  # check that, for each study,  all the columns of the input table are of 'numeric' type
-  dtname <- x
-  for(i in 1:numsources){
-    cols <- DSI::datashield.aggregate(datasources[i], call("colnamesDS", x))
-    for(j in 1:dim2[i]){
-      cally <- call("classDS", paste0(dtname, "$", cols[[1]][j]))
-      res <- DSI::datashield.aggregate(datasources[i], cally)
-      if(res[[1]] != 'numeric' & res[[1]] != 'integer'){
-        stop("One or more columns of ", dtname, " are not of numeric type, in ",  stdnames[i], ".", call.=FALSE)
-      }
-    }
-  }
-
   ops <- c("rowSums","colSums","rowMeans","colMeans")
   if(is.null(operation)){
     message(" ALERT!")

R/ds.summary.R

@@ -89,7 +89,7 @@ ds.summary <- function(x=NULL, datasources=NULL){
   # now get the summary depending on the type of the input variable
   if(("data.frame" %in% typ) | ("matrix" %in% typ)){
     for(i in 1:numsources){
-      validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]]
+      validity <- DSI::datashield.aggregate(datasources[i], call('isValidDS', x))[[1]]$valid
       if(validity){
         dims <- DSI::datashield.aggregate(datasources[i], call('dimDS', x))
         r <- dims[[1]]$dim[1]
@@ -106,7 +106,7 @@ ds.summary <- function(x=NULL, datasources=NULL){
 
   if("character" %in% typ){
     for(i in 1:numsources){
-      validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]]
+      validity <- DSI::datashield.aggregate(datasources[i], call('isValidDS', x))[[1]]$valid
       if(validity){
         l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length
         stdsummary <- list('class'=typ, 'length'=l)
@@ -120,7 +120,7 @@ ds.summary <- function(x=NULL, datasources=NULL){
 
   if("factor" %in% typ){
     for(i in 1:numsources){
-      validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]]
+      validity <- DSI::datashield.aggregate(datasources[i], call('isValidDS', x))[[1]]$valid
       if(validity){
         l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length
         levels.resp <- DSI::datashield.aggregate(datasources[i], call('levelsDS', x))[[1]]
@@ -141,7 +141,7 @@ ds.summary <- function(x=NULL, datasources=NULL){
 
   if(("integer" %in% typ) | ("numeric" %in% typ)){
     for(i in 1:numsources){
-      validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]]
+      validity <- DSI::datashield.aggregate(datasources[i], call('isValidDS', x))[[1]]$valid
       if(validity){
         l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length
         q <- (DSI::datashield.aggregate(datasources[i], call('quantileMeanDS', x)))[[1]]$quantiles
@@ -176,7 +176,7 @@ ds.summary <- function(x=NULL, datasources=NULL){
 
   if("logical" %in% typ){
     for(i in 1:numsources){
-      validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]]
+      validity <- DSI::datashield.aggregate(datasources[i], call('isValidDS', x))[[1]]$valid
       if(validity){
         l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length
         freq <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('table1DDS(', x, ')' )))[[1]][1]

tests/testthat/test-arg-ds.isValid.R

@@ -22,7 +22,6 @@ connect.studies.dataset.cnsim(list("LAB_HDL"))
 # context("ds.isValid::arg::errors")
 test_that("isValid errors", {
     expect_error(ds.isValid(), "Please provide the name of the input vector!", fixed=TRUE)
-    expect_error(ds.isValid("D$NOT_THERE"), "The input object D$NOT_THERE is not defined in sim1, sim2, sim3!", fixed=TRUE)
 })
 
 #

tests/testthat/test-arg-ds.metadata.R

@@ -26,9 +26,6 @@ test_that("setup", {
 #
 
 # context("ds.metadata::arg")
-# "missing variable" / "missing column" moved to test-smk-ds.metadata.R:
-# these are now server-side existence checks (via .loadServersideObject), not
-# client-side argument validation, so they belong in the smk suite.
 
 #
 # Tear down

tests/testthat/test-perf-ds.hetcor.R

@@ -6,6 +6,8 @@
 # context("ds.hetcor::perf::setup")
 connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG", "LAB_HDL", "LAB_GLUC_ADJUSTED", "PM_BMI_CONTINUOUS", "DIS_CVA", "MEDI_LPD", "DIS_DIAB", "DIS_AMI", "GENDER", "PM_BMI_CATEGORICAL"))
 
+ds.dataFrame(c("D$LAB_TSC", "D$LAB_TRIG", "D$LAB_HDL", "D$LAB_GLUC_ADJUSTED", "D$PM_BMI_CONTINUOUS", "D$DIS_CVA", "D$MEDI_LPD", "D$DIS_DIAB", "D$DIS_AMI", "D$GENDER", "D$PM_BMI_CATEGORICAL"), newobj="df")
+
 #
 # Tests
 #
@@ -18,7 +20,7 @@ test_that("performance", {
     .current.time <- .start.time
 
     while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) {
-        ds.hetcor(data="D")
+        ds.hetcor(data="df", ML=TRUE, std.err=TRUE, bins=4, pd=TRUE, use="complete.obs")
 
         .count <- .count + 1
         .current.time <- Sys.time()

tests/testthat/test-perf-ds.isValid.R

@@ -0,0 +1,50 @@
+
+#
+# Set up
+#
+
+# context("ds.isValid::perf::setup")
+connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG"))
+
+#
+# Tests
+#
+
+# context("ds.isValid::perf::0")
+test_that("performance", {
+    .durationSec  <- 30 # seconds
+    .count        <- 0
+    .start.time   <- Sys.time()
+    .current.time <- .start.time
+
+    while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) {
+        ds.isValid(x='D$LAB_TSC')
+
+        .count <- .count + 1
+        .current.time <- Sys.time()
+    }
+
+    .current.rate   <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]])
+    .reference.rate <- perf.reference.rate("ds.isValid::perf::0")
+    if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) {
+        print(paste("ds.isValid::perf::0 ", .current.rate, 0.5, 2.0))
+        perf.reference.save("ds.isValid::perf::0", .current.rate, 0.5, 2.0)
+    } else {
+        print(paste("ds.isValid::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''))
+    }
+
+    .reference.rate            <- perf.reference.rate("ds.isValid::perf::0")
+    .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.isValid::perf::0")
+    .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.isValid::perf::0")
+
+    expect_gt(.current.rate, .reference.rate * .reference.tolerance.lower, label = "Observed rate", expected.label = "lower threshold on rate")
+    expect_lt(.current.rate, .reference.rate * .reference.tolerance.upper, label = "Observed rate", expected.label = "upper threshold on rate")
+})
+
+#
+# Done
+#
+
+# context("ds.isValid::perf::shutdown")
+disconnect.studies.dataset.cnsim()
+# context("ds.isValid::perf::done")

tests/testthat/test-perf-ds.make.R

@@ -18,7 +18,7 @@ test_that("performance", {
     .current.time <- .start.time
 
     while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) {
-        ds.make(toAssign="D$LAB_TSC + D$LAB_TRIG", newobj="make.newobj")
+        ds.make("(D$LAB_TSC*D$LAB_TRIG*D$LAB_HDL)", "make.newobj")
 
         .count <- .count + 1
         .current.time <- Sys.time()

tests/testthat/test-perf-ds.metadata.R

@@ -18,7 +18,7 @@ test_that("performance", {
     .current.time <- .start.time
 
     while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) {
-        ds.metadata(x="D$LAB_TSC")
+        ds.metadata(x='D')
 
         .count <- .count + 1
         .current.time <- Sys.time()

tests/testthat/test-perf-ds.ns.R

@@ -18,7 +18,7 @@ test_that("performance", {
     .current.time <- .start.time
 
     while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) {
-        ds.ns("D$PM_BMI_CONTINUOUS", df=3, newobj="ns.newobj")
+        ds.ns(x="D$PM_BMI_CONTINUOUS", knots=c(15,25,35), newobj="ns.newobj")
 
         .count <- .count + 1
         .current.time <- Sys.time()

tests/testthat/test-perf-ds.qlspline.R

@@ -18,7 +18,7 @@ test_that("performance", {
     .current.time <- .start.time
 
     while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) {
-        ds.qlspline("D$PM_BMI_CONTINUOUS", q=3, newobj="qlspline.newobj")
+        ds.qlspline(x="D$PM_BMI_CONTINUOUS", q=4, na.rm=TRUE, newobj="qlspline.newobj")
 
         .count <- .count + 1
         .current.time <- Sys.time()

tests/testthat/test-perf-ds.rowColCalc.R

@@ -18,7 +18,7 @@ test_that("performance", {
     .current.time <- .start.time
 
     while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) {
-        ds.rowColCalc(x="D", operation="colMeans", newobj="rowcol.newobj")
+        ds.rowColCalc(x="D", operation="rowSums", newobj="rowcol.newobj")
 
         .count <- .count + 1
         .current.time <- Sys.time()