Refactor/fixes

R/ds.asList.R

@@ -67,7 +67,6 @@ ds.asList <- function(x.name=NULL, newobj=NULL, datasources=NULL){
     newobj <- "aslist.newobj"
   }
 
-  calltext <- call("asListDS", x.name, newobj)
-  out.message <- DSI::datashield.aggregate(datasources, calltext)
+  DSI::datashield.assign(datasources, newobj, call("asListDS", x.name))
 
 }

R/ds.changeRefGroup.R

@@ -130,7 +130,7 @@ ds.changeRefGroup <- function(x=NULL, ref=NULL, newobj=NULL, reorderByRef=FALSE,
   }
 
   # call the server side function that will recode the levels
-  calltext <- call("changeRefGroupDS", x, ref, reorderByRef)
+  calltext <- call("changeRefGroupDS", x, as.character(ref), reorderByRef)
   DSI::datashield.assign(datasources, newobj, calltext)
 
 }

R/ds.cor.R

@@ -100,6 +100,10 @@ ds.cor <- function(x=NULL, y=NULL, type="split", datasources=NULL, classConsiste
     .checkClassConsistency(output)
   }
 
+  if(!is.null(y) && any(output[[1]]$class %in% c("matrix", "data.frame"))){
+    warning("x is a matrix or a dataframe; y will be ignored and a correlation matrix computed for x!")
+  }
+
   if (type=="split"){
     covariance <- list()
     sqrt.diag <- list()

R/ds.cov.R

@@ -117,6 +117,10 @@ ds.cov <- function(x=NULL, y=NULL, naAction='pairwise.complete', type="split", d
     .checkClassConsistency(output)
   }
 
+  if(!is.null(y) && any(output[[1]]$class %in% c("matrix", "data.frame"))){
+    warning("x is a matrix or a dataframe; y will be ignored and a covariance matrix computed for x!")
+  }
+
   if (type=="split"){
     covariance <- list()
     results <- list()

R/ds.dim.R

@@ -64,14 +64,14 @@
 #'   # Calculate the dimension
 #'   ds.dim(x="D", 
 #'          type="combine", #global dimension
-#'#'          datasources = connections)#all opal servers are used
+#'          datasources = connections)#all opal servers are used
 #'   ds.dim(x="D",
 #'          type = "both",#separate dimension for each study
 #'                        #and the pooled dimension (default) 
-#'#'          datasources = connections)#all opal servers are used
+#'          datasources = connections)#all opal servers are used
 #'   ds.dim(x="D", 
 #'          type="split", #separate dimension for each study
-#'#'          datasources = connections[1])#only the first opal server is used ("study1")
+#'          datasources = connections[1])#only the first opal server is used ("study1")
 #'
 #'   # clear the Datashield R sessions and logout
 #'   datashield.logout(connections)

R/ds.glmSummary.R

@@ -95,7 +95,6 @@ ds.glmSummary <- function(x.name, newobj=NULL, datasources=NULL) {
 	calltext1 <- call("glmSummaryDS.as", x.name)
 	DSI::datashield.assign(datasources,newobj,calltext1)
 
-  # LOOK BELOW CLIENTSIDE MODULE FOR NEXT BLOCK OF CODE
   # PREPARE AND CALL THE SECOND ASSIGN FUNCTION TO PREPARE AN ABBREVIATED 
   # summary_glm OBJECT ON THE SERVERSIDE THAT CAN SAFELY BE RETURNED TO CLIENT
 

R/ds.mean.R

@@ -20,8 +20,7 @@
 #' are saved in the server-side. 
 #' Once the estimated means and \code{Nvalids}
 #' are written into the server-side R environments, they can be used directly to centralize
-#' the variable of interest around its global mean or its study-specific means. Finally,
-#' the \code{isDefined} internal function checks whether the key variables have been created.
+#' the variable of interest around its global mean or its study-specific means.
 #' 
 #' Server function called: \code{meanDS}
 #' @param x a character specifying the name of a numerical vector.

R/ds.recodeValues.R

@@ -67,7 +67,7 @@
 #'                   values2replace.vector = c(1,2), 
 #'                   new.values.vector = c(1,2),
 #'                   missing = 99, 
-#'                   newobj = 'bmi_recoded'
+#'                   newobj = 'bmi_recoded',
 #'                   datasources = connections)
 #'                  
 #'   # Clear the Datashield R sessions and logout                 

R/ds.table.R

@@ -183,6 +183,7 @@
 #' about the visible material passed to the clientside, and the optional
 #' table object written to the serverside can be seen under 'details' (above).
 #' @author Paul Burton and Alex Westerberg for DataSHIELD Development Team, 01/05/2020
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 ds.table <- function(rvar=NULL, cvar=NULL, stvar=NULL, report.chisq.tests=FALSE,
@@ -1539,6 +1540,12 @@ if(num.table.dims==1)
 
 }#END second dim=1 loop
 
+#################################################
+# Setup on.exit() to restore options 'warn' value
+#################################################
+
+old_warn_option <- base::getOption("warn")
+on.exit(base::options(warn = old_warn_option), add = TRUE)
 
 ################################
 #NOW UNDERTAKE CHISQUARED TESTS#

R/glmChecks.R

@@ -53,6 +53,13 @@ glmChecks <- function(formula, data, offset, weights, datasources){
     varIdentifier <- append(varIdentifier, "weights")
   }
 
+  #################################################
+  # Setup on.exit() to restore options 'warn' value
+  #################################################
+
+  old_warn_option <- base::getOption("warn")
+  on.exit(base::options(warn = old_warn_option), add = TRUE)
+
   # check that each variable is defined and not empty and each study. Stop the process if any check fails
   stdnames <- names(datasources)
   for(i in 1:length(elts)){

tests/testthat/test-smk-ds.asList.R

@@ -35,14 +35,52 @@ test_that("simple test", {
     expect_equal(res.class$sim3, "list")
 })
 
+test_that("no data is returned to the client", {
+    res <- ds.asList(x.name = "D$GENDER", newobj = "gender.list")
+
+    expect_null(res)
+})
+
+test_that("a data.frame is written to the server as a named list of its columns", {
+    ds.asList(x.name = "D", newobj = "df.list")
+
+    res.class <- ds.class("df.list")
+    for (study.class in res.class) {
+        expect_equal(study.class, "list")
+    }
+
+    res.length <- ds.length("df.list", type = "split")
+    for (study.length in res.length) {
+        expect_equal(study.length, 1)
+    }
+
+    res.names <- ds.names("df.list")
+    for (study.names in res.names) {
+        expect_equal(study.names, "GENDER")
+    }
+})
+
+test_that("fails if the object does not exist", {
+    expect_error(
+        ds.asList(x.name = "nonexistent_object"),
+        "There are some DataSHIELD errors, list them with datashield.errors()",
+        fixed = TRUE
+    )
+
+    res.errors <- DSI::datashield.errors()
+    for (study.errors in res.errors) {
+        expect_match(study.errors, "The server-side object 'nonexistent_object' does not exist")
+    }
+})
+
 #
 # Done
 #
 
 # context("ds.asList::smk::shutdown")
 
 test_that("stutdown", {
-    ds_expect_variables(c("D", "aslist.newobj"))
+    ds_expect_variables(c("D", "aslist.newobj", "gender.list", "df.list"))
 })
 
 disconnect.studies.dataset.cnsim()

tests/testthat/test-smk-ds.changeRefGroup.R

@@ -65,10 +65,22 @@ test_that("simple changeRefGroup", {
 # Done
 #
 
+test_that("a numeric ref is a level name, not a position", {
+    ds.recodeValues(var.name = "D$PM_BMI_CATEGORICAL", values2replace.vector = c(1, 2, 3), new.values.vector = c(0, 2, 5), newobj = "bmi_codes")
+    ds.asFactorSimple(input.var.name = "bmi_codes", newobj.name = "bmi_codes_f")
+
+    ds.changeRefGroup(x = "bmi_codes_f", ref = 5, newobj = "bmi_ref5")
+
+    res.levels <- ds.levels(x = "bmi_ref5")
+    for (study.levels in res.levels) {
+        expect_equal(study.levels$Levels[1], "5")
+    }
+})
+
 # context("ds.changeRefGroup::smk::shutdown")
 
 test_that("shutdown", {
-    ds_expect_variables(c("D", "bmi_new", "bmi_ob"))
+    ds_expect_variables(c("D", "bmi_new", "bmi_ob", "bmi_codes", "bmi_codes_f", "bmi_ref5"))
 })
 
 disconnect.studies.dataset.cnsim()

tests/testthat/test-smk-ds.cor.R

@@ -103,8 +103,25 @@ test_that("error, x numeric vector requires y", {
     expect_match(res.errors[[1]], "If x is a numeric vector, y must also be a numeric vector")
 })
 
+test_that("ds.cor ignores y with a warning when x is a data.frame", {
+    res.x <- ds.cor(x = "D", type = "split")
+
+    expect_warning(
+        res.xy <- ds.cor(x = "D", y = "D$survtime", type = "split"),
+        "y will be ignored", fixed = TRUE
+    )
+
+    expect_equal(res.xy, res.x)
+})
+
+test_that("cor accepts a factor variable", {
+    ds.asFactorSimple(input.var.name = "D$female", newobj.name = "female.factor")
+
+    expect_no_error(ds.cor(x = "female.factor", y = "D$survtime", type = "split"))
+})
+
 test_that("shutdown", {
-    ds_expect_variables(c("D"))
+    ds_expect_variables(c("D", "female.factor"))
 })
 
 disconnect.studies.dataset.survival()

tests/testthat/test-smk-ds.cov.R

@@ -68,6 +68,17 @@ test_that("simple test, combine", {
 # Done
 #
 
+test_that("ds.cov ignores y with a warning when x is a data.frame", {
+    res.x <- ds.cov(x = "D", type = "split")
+
+    expect_warning(
+        res.xy <- ds.cov(x = "D", y = "D$survtime", type = "split"),
+        "y will be ignored", fixed = TRUE
+    )
+
+    expect_equal(res.xy, res.x)
+})
+
 # context("ds.cov::smk::shutdown")
 
 test_that("error, x numeric vector requires y", {

tests/testthat/test-smk-ds.dim.R

@@ -70,10 +70,12 @@ test_that("simple dim, combine", {
     expect_equal(dim.res$`dimensions of D in combined studies`[[2]], 1)
 })
 
-test_that("dim, wrong input class returns a server error", {
-    expect_error(ds.dim("D$LAB_TSC"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE)
-    res.errors <- DSI::datashield.errors()
-    expect_match(res.errors[[1]], "must be of type data.frame or matrix")
+test_that("dim of a vector is NULL, as in R", {
+    res <- ds.dim("D$LAB_TSC", type = "split")
+
+    for (study.dim in res) {
+        expect_null(study.dim)
+    }
 })
 
 #

tests/testthat/test-smk-ds.listServersideFunctions.R

@@ -35,7 +35,7 @@ test_that("check results", {
       "tableDS.assign", "tan", "tapplyDS.assign", "unlist", "unListDS", "vectorDS"
     ))
     aggregate.functions <- factor(c(
-      "NROW", "asFactorDS1", "asListDS", "aucDS",
+      "NROW", "asFactorDS1", "aucDS",
       "checkNegValueDS", "classDS", "colnamesDS", "corDS", "corTestDS",
       "covDS", "dataFrameSubsetDS1",
       "densityGridDS", "dimDS", "gamlssDS",

tests/testthat/test-smk-ds.mean.R

@@ -258,17 +258,27 @@ test_that("mean values [both]", {
 # Done
 #
 
+test_that("mean of a logical variable is the proportion TRUE", {
+    ds.asLogical(x.name = "D$LAB_TSC", newobj = "tsc.logical")
+
+    res <- ds.mean(x = "tsc.logical", type = "split")
+
+    for (i in seq_len(nrow(res$Mean.by.Study))) {
+        expect_equal(res$Mean.by.Study[i, "EstimatedMean"], 1)
+    }
+})
+
 # context("ds.mean::smk::shutdown")
 
 test_that("error, input must be numeric or integer", {
     ds.asCharacter(x='D$LAB_TSC', newobj="not_a_numeric")
     expect_error(ds.mean(x='not_a_numeric'), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE)
     res.errors <- DSI::datashield.errors()
-    expect_match(res.errors[[1]], "must be of type numeric or integer")
+    expect_match(res.errors[[1]], "must be of type numeric, integer or logical")
 })
 
 test_that("shutdown", {
-    ds_expect_variables(c("D", "mean.all.studies", "mean.study.specific", "Nvalid.all.studies", "Nvalid.study.specific", "not_a_numeric"))
+    ds_expect_variables(c("D", "mean.all.studies", "mean.study.specific", "Nvalid.all.studies", "Nvalid.study.specific", "not_a_numeric", "tsc.logical"))
 })
 
 disconnect.studies.dataset.cnsim()

tests/testthat/test-smk-ds.var.R

@@ -89,17 +89,23 @@ test_that("simple var, both", {
 # Done
 #
 
+test_that("var of a logical variable is computed", {
+    ds.asLogical(x.name = "D$LAB_TSC", newobj = "tsc.logical")
+
+    expect_no_error(ds.var(x = "tsc.logical", type = "split"))
+})
+
 # context("ds.var::smk::shutdown")
 
 test_that("error, input must be numeric or integer", {
     ds.asCharacter(x='D$LAB_TSC', newobj="not_a_numeric")
     expect_error(ds.var(x='not_a_numeric'), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE)
     res.errors <- DSI::datashield.errors()
-    expect_match(res.errors[[1]], "must be of type numeric or integer")
+    expect_match(res.errors[[1]], "must be of type numeric, integer or logical")
 })
 
 test_that("shutdown", {
-    ds_expect_variables(c("D", "not_a_numeric"))
+    ds_expect_variables(c("D", "not_a_numeric", "tsc.logical"))
 })
 
 disconnect.studies.dataset.cnsim()