diff --git a/R/ds.asList.R b/R/ds.asList.R index 83007f5a..d346be80 100644 --- a/R/ds.asList.R +++ b/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)) } diff --git a/R/ds.changeRefGroup.R b/R/ds.changeRefGroup.R index a06ac143..050c8f75 100644 --- a/R/ds.changeRefGroup.R +++ b/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) } diff --git a/R/ds.cor.R b/R/ds.cor.R index 9c0ef8e1..82e66962 100644 --- a/R/ds.cor.R +++ b/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() diff --git a/R/ds.cov.R b/R/ds.cov.R index 0aa75a3d..d3bcb437 100644 --- a/R/ds.cov.R +++ b/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() diff --git a/R/ds.dim.R b/R/ds.dim.R index 17c5fb75..ebb8db42 100644 --- a/R/ds.dim.R +++ b/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) diff --git a/R/ds.glmSummary.R b/R/ds.glmSummary.R index 5a80b7fc..e99dbaad 100644 --- a/R/ds.glmSummary.R +++ b/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 diff --git a/R/ds.mean.R b/R/ds.mean.R index ca91ca1d..00fac192 100644 --- a/R/ds.mean.R +++ b/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. diff --git a/R/ds.recodeValues.R b/R/ds.recodeValues.R index c0a52c3d..736f486f 100644 --- a/R/ds.recodeValues.R +++ b/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 diff --git a/R/ds.table.R b/R/ds.table.R index e1238e2a..14c67723 100644 --- a/R/ds.table.R +++ b/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# diff --git a/R/glmChecks.R b/R/glmChecks.R index 152b80bf..e05d0a4b 100644 --- a/R/glmChecks.R +++ b/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)){ diff --git a/man/ds.dim.Rd b/man/ds.dim.Rd index 1fbacddf..ae120e11 100644 --- a/man/ds.dim.Rd +++ b/man/ds.dim.Rd @@ -78,14 +78,14 @@ Server function called: \code{dimDS} # 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) diff --git a/man/ds.mean.Rd b/man/ds.mean.Rd index 9c7d7e78..537cd649 100644 --- a/man/ds.mean.Rd +++ b/man/ds.mean.Rd @@ -70,8 +70,7 @@ as well as the global equivalents across all studies combined 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} } diff --git a/man/ds.recodeValues.Rd b/man/ds.recodeValues.Rd index 8dd60bb3..a09c7db1 100644 --- a/man/ds.recodeValues.Rd +++ b/man/ds.recodeValues.Rd @@ -94,7 +94,7 @@ Server function called: \code{recodeValuesDS} 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 diff --git a/man/ds.table.Rd b/man/ds.table.Rd index 252232bd..4c501713 100644 --- a/man/ds.table.Rd +++ b/man/ds.table.Rd @@ -220,4 +220,6 @@ can be set to TRUE to block the warnings. However, it is defaulted to FALSE. } \author{ Paul Burton and Alex Westerberg for DataSHIELD Development Team, 01/05/2020 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/test-smk-ds.asList.R b/tests/testthat/test-smk-ds.asList.R index 9c359abf..efd24457 100644 --- a/tests/testthat/test-smk-ds.asList.R +++ b/tests/testthat/test-smk-ds.asList.R @@ -35,6 +35,44 @@ 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 # @@ -42,7 +80,7 @@ test_that("simple test", { # 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() diff --git a/tests/testthat/test-smk-ds.changeRefGroup.R b/tests/testthat/test-smk-ds.changeRefGroup.R index 416ed448..5c0964df 100644 --- a/tests/testthat/test-smk-ds.changeRefGroup.R +++ b/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() diff --git a/tests/testthat/test-smk-ds.cor.R b/tests/testthat/test-smk-ds.cor.R index a5c442fb..4f2ee6f8 100644 --- a/tests/testthat/test-smk-ds.cor.R +++ b/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() diff --git a/tests/testthat/test-smk-ds.cov.R b/tests/testthat/test-smk-ds.cov.R index b11eac64..e468051b 100644 --- a/tests/testthat/test-smk-ds.cov.R +++ b/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", { diff --git a/tests/testthat/test-smk-ds.dim.R b/tests/testthat/test-smk-ds.dim.R index 1ce6f250..8ba7266a 100644 --- a/tests/testthat/test-smk-ds.dim.R +++ b/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) + } }) # diff --git a/tests/testthat/test-smk-ds.listServersideFunctions.R b/tests/testthat/test-smk-ds.listServersideFunctions.R index df0d5fe4..9d48474c 100644 --- a/tests/testthat/test-smk-ds.listServersideFunctions.R +++ b/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", diff --git a/tests/testthat/test-smk-ds.mean.R b/tests/testthat/test-smk-ds.mean.R index e4590464..48dffa6f 100644 --- a/tests/testthat/test-smk-ds.mean.R +++ b/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() diff --git a/tests/testthat/test-smk-ds.var.R b/tests/testthat/test-smk-ds.var.R index 65128b19..63ea16ff 100644 --- a/tests/testthat/test-smk-ds.var.R +++ b/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()