diff --git a/.Rbuildignore b/.Rbuildignore index 918ce19e..39edb639 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -25,3 +25,4 @@ ^\.github$ ^man-roxygen$ ^codecov\.yml$ +^github-workflows_check\.Rout$ diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml index db1f4a60..d736cb87 100644 --- a/.github/workflows/check.yaml +++ b/.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() diff --git a/.github/workflows/dsBaseClient_test_suite.yaml b/.github/workflows/dsBaseClient_test_suite.yaml index a33032ab..c094b4a4 100644 --- a/.github/workflows/dsBaseClient_test_suite.yaml +++ b/.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-' diff --git a/.gitignore b/.gitignore index 93decc0f..1f5f8c99 100644 --- a/.gitignore +++ b/.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 diff --git a/R/ds.assign.R b/R/ds.assign.R index 25b71c74..79c373d5 100644 --- a/R/ds.assign.R +++ b/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) - } diff --git a/R/ds.colnames.R b/R/ds.colnames.R index da842ec0..06e64728 100644 --- a/R/ds.colnames.R +++ b/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) diff --git a/R/ds.contourPlot.R b/R/ds.contourPlot.R index 0adb44fa..42084006 100644 --- a/R/ds.contourPlot.R +++ b/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() diff --git a/R/ds.densityGrid.R b/R/ds.densityGrid.R index c2aa8ffc..d617dd73 100644 --- a/R/ds.densityGrid.R +++ b/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() diff --git a/R/ds.elspline.R b/R/ds.elspline.R index 01ddca05..40a77db4 100644 --- a/R/ds.elspline.R +++ b/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) } diff --git a/R/ds.getWGSR.R b/R/ds.getWGSR.R index ff4c60f5..80306811 100644 --- a/R/ds.getWGSR.R +++ b/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 - ####################################################################################################### -} +} diff --git a/R/ds.heatmapPlot.R b/R/ds.heatmapPlot.R index 95232157..48312460 100644 --- a/R/ds.heatmapPlot.R +++ b/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() diff --git a/R/ds.hetcor.R b/R/ds.hetcor.R index 2b29be24..0a47676a 100644 --- a/R/ds.hetcor.R +++ b/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) diff --git a/R/ds.isValid.R b/R/ds.isValid.R index e43b61b1..266dbca2 100644 --- a/R/ds.isValid.R +++ b/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)) } diff --git a/R/ds.lexis.R b/R/ds.lexis.R index 665a29ed..abc019a7 100644 --- a/R/ds.lexis.R +++ b/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)){ diff --git a/R/ds.lspline.R b/R/ds.lspline.R index e044005c..2fe8471b 100644 --- a/R/ds.lspline.R +++ b/R/ds.lspline.R @@ -20,27 +20,17 @@ #' @return an object of class "lspline" and "matrix", which its name is specified by the #' \code{newobj} argument (or its default name "lspline.newobj"), is assigned on the serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.lspline <- function(x, knots = NULL, 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(knots)){ stop("Please provide a vector of knots!", call.=FALSE) } diff --git a/R/ds.make.R b/R/ds.make.R index 07d14a83..044c727a 100644 --- a/R/ds.make.R +++ b/R/ds.make.R @@ -67,10 +67,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}}. -#' @return \code{ds.make} returns the new object which is written to the -#' server-side. Also a validity message is returned to the client-side indicating whether the new object has been correctly -#' created at each source. +#' @return \code{ds.make} writes the new object to the server-side; nothing is +#' returned to the client-side. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -134,15 +134,7 @@ #' ds.make<-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) @@ -156,86 +148,6 @@ ds.make<-function(toAssign=NULL, newobj=NULL, datasources=NULL){ # now do the business DSI::datashield.assign(datasources, newobj, as.symbol(toAssign)) -############################################################################################################# -#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED # - # -#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION # -test.obj.name<-newobj # - # -#TRACER # -#return(test.obj.name) # -#} # - # - # -# 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 # -############################################################################################################# - } # ds.make diff --git a/R/ds.metadata.R b/R/ds.metadata.R index 58f615b1..78ceb43c 100644 --- a/R/ds.metadata.R +++ b/R/ds.metadata.R @@ -12,6 +12,7 @@ #' @return \code{ds.metadata} returns to the client-side the metadata of associated to an object #' held at the server. #' @author Stuart Wheater, DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -49,21 +50,7 @@ ds.metadata = function(x=NULL, datasources=NULL) { - ##################################################################################### - #MODULE 1: IDENTIFY DEFAULT CONNECTIONS # - # look for DS connections # - if (is.null(datasources)){ # - datasources <- datashield.connections_find() # - } # - ##################################################################################### - - ############################################################################################################### - #MODULE 2: ENSURE CORRECT DATASOURCES # - # 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) ##################################################################################### #MODULE 3: SET UP KEY VARIABLES ALLOWING FOR DIFFERENT INPUT FORMATS # @@ -79,14 +66,6 @@ ds.metadata = function(x=NULL, datasources=NULL) } # ##################################################################################### - ##################################################################################### - #MODULE 5: CHECK ALL SERVICES HAVE SPECIFIED VARIABLES DEFINED # - defined = all(unlist(isDefined(datasources, x))) # - if (! defined){ # - stop("Variable not defined in all servers", call.=FALSE) # - } # - ##################################################################################### - cally <- call("metadataDS", x) metadatas <- DSI::datashield.aggregate(datasources, cally) diff --git a/R/ds.ns.R b/R/ds.ns.R index e98643d4..e1e101ef 100644 --- a/R/ds.ns.R +++ b/R/ds.ns.R @@ -30,20 +30,13 @@ #' arguments to ns, and explicitly give the knots, Boundary.knots etc for use by predict.ns(). #' The object is assigned at each serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.ns <- function(x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = 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) # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ diff --git a/R/ds.qlspline.R b/R/ds.qlspline.R index 9839d984..ca808fb0 100644 --- a/R/ds.qlspline.R +++ b/R/ds.qlspline.R @@ -28,27 +28,17 @@ #' @return an object of class "lspline" and "matrix", which its name is specified by the #' \code{newobj} argument (or its default name "qlspline.newobj"), is assigned on the serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.qlspline <- function(x, q, na.rm = TRUE, 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(q)){ stop("Argument 'q' is missing, with no default!", call.=FALSE) } diff --git a/R/ds.rowColCalc.R b/R/ds.rowColCalc.R index 312e19c5..8d0ec804 100644 --- a/R/ds.rowColCalc.R +++ b/R/ds.rowColCalc.R @@ -68,58 +68,12 @@ #' ds.rowColCalc <- function(x=NULL, operation=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 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) - } - - # 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!") @@ -140,10 +94,6 @@ ds.rowColCalc <- function(x=NULL, operation=NULL, newobj=NULL, datasources=NULL) } # call the server side function that does the job - cally <- paste0("rowColCalcDS(", x, ",", indx, ")") - DSI::datashield.assign(datasources, newobj, as.symbol(cally)) - - # check that the new object has been created and display a message accordingly - finalcheck <- isAssigned(datasources, newobj) + DSI::datashield.assign(datasources, newobj, call("rowColCalcDS", dataset.name=x, operation=indx)) } diff --git a/R/ds.summary.R b/R/ds.summary.R index 82f04f93..3174023a 100644 --- a/R/ds.summary.R +++ b/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] diff --git a/R/ds.table.R b/R/ds.table.R index e1238e2a..ba6497d0 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, @@ -190,40 +191,21 @@ ds.table <- function(rvar=NULL, cvar=NULL, stvar=NULL, report.chisq.tests=FALSE, table.assign=FALSE, newobj=NULL, datasources=NULL, force.nfilter=NULL){ - # if no connection login details are provided look for 'connection' objects in the environment - 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 a value has been provided for rvar if(is.null(rvar)){ return("Error: rvar must have a value which is a character string naming the row variable for the table") } - # check if the input object is defined in all the studies - isDefined(datasources, rvar) - if(!is.null(cvar)&&!is.character(cvar)){ return("Error: if cvar is not null, it must have a value which is a character string naming the column variable for the table") } - if(!is.null(cvar)){ - isDefined(datasources, cvar) - } - if(!is.null(stvar)&&!is.character(stvar)){ return("Error: if stvar is not null, it must have a value which is a character string naming the variable coding separate tables for the table") } - if(!is.null(stvar)){ - isDefined(datasources, stvar) - } - if(useNA!="no" && useNA!="always"){ stop("useNA must be either 'no' or 'always'.") } diff --git a/R/ds.tapply.R b/R/ds.tapply.R index e9805e1d..3972bf83 100644 --- a/R/ds.tapply.R +++ b/R/ds.tapply.R @@ -120,19 +120,12 @@ #' #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export ds.tapply <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, datasources=NULL){ ###datasources - # 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) ###X.name # check if user has provided the name of the column that holds X.name @@ -140,9 +133,6 @@ ds.tapply <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, datasources= return("Error: Please provide the name of the variable to be summarized, as a character string") } - # check if the X object is defined in all the studies - isDefined(datasources, X.name) - ###INDEX.names # check if user has provided the name of the column(s) that holds INDEX.names if(is.null(INDEX.names)){ @@ -157,11 +147,6 @@ ds.tapply <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, datasources= stop("The 'INDEX.names' can include the names of up to two factors", call.=FALSE) } - # check if the INDEX objects are defined in all the studies - for(i in 1:length(INDEX.names)){ - isDefined(datasources, INDEX.names[i]) - } - # make INDEX.names transmitable if(!is.null(INDEX.names)){ INDEX.names.transmit <- paste(INDEX.names, collapse=",") diff --git a/R/ds.tapply.assign.R b/R/ds.tapply.assign.R index be7b7408..5e2ac52f 100644 --- a/R/ds.tapply.assign.R +++ b/R/ds.tapply.assign.R @@ -77,6 +77,7 @@ #' The array is written to the server-side. It has the same number of #' dimensions as INDEX. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @examples #' \dontrun{ #' ## Version 6, for version 5 see the Wiki @@ -129,15 +130,7 @@ ds.tapply.assign <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, newobj=NULL, datasources=NULL){ ###datasources - # 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) ###X.name # check if user has provided the name of the column that holds X.name @@ -145,9 +138,6 @@ ds.tapply.assign <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, newob return("Error: Please provide the name of the variable to be summarized, as a character string") } - # check if the X object is defined in all the studies - isDefined(datasources, X.name) - ###INDEX.names # check if user has provided the name of the column(s) that holds INDEX.names if(is.null(INDEX.names)){ @@ -162,11 +152,6 @@ ds.tapply.assign <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, newob stop("The 'INDEX.names' can include the names of up to two factors", call.=FALSE) } - # check if the INDEX objects are defined in all the studies - for(i in 1:length(INDEX.names)){ - isDefined(datasources, INDEX.names[i]) - } - # make INDEX.names transmitable if(!is.null(INDEX.names)){ INDEX.names.transmit <- paste(INDEX.names, collapse=",") @@ -190,83 +175,5 @@ ds.tapply.assign <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, newob DSI::datashield.assign(datasources, newobj, calltext) - ############################################################################################################# -#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 # -############################################################################################################# - - - } #ds.tapply.assign diff --git a/R/utils.R b/R/utils.R index 019f55a3..db6ac35d 100644 --- a/R/utils.R +++ b/R/utils.R @@ -110,7 +110,7 @@ #' @noRd .check_df_name_provided <- function(df) { if(is.null(df)){ - cli_abort("Please provide the name of a data.frame or matrix!", call.=FALSE) + cli_abort("Please provide the name of a data.frame or matrix!") } } diff --git a/dsBase_7.0.0-permissive.tar.gz b/dsBase_7.0.0-permissive.tar.gz index 285d780d..137855e3 100644 Binary files a/dsBase_7.0.0-permissive.tar.gz and b/dsBase_7.0.0-permissive.tar.gz differ diff --git a/man/ds.assign.Rd b/man/ds.assign.Rd index e09d426f..df41057b 100644 --- a/man/ds.assign.Rd +++ b/man/ds.assign.Rd @@ -70,4 +70,6 @@ assigned the variable called \code{newobj} on the server-side. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.elspline.Rd b/man/ds.elspline.Rd index d7f20819..2e9a27ec 100644 --- a/man/ds.elspline.Rd +++ b/man/ds.elspline.Rd @@ -50,4 +50,6 @@ range of x into n equal-width intervals. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.getWGSR.Rd b/man/ds.getWGSR.Rd index f48b9a28..c5a8c932 100644 --- a/man/ds.getWGSR.Rd +++ b/man/ds.getWGSR.Rd @@ -131,4 +131,6 @@ data. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.hetcor.Rd b/man/ds.hetcor.Rd index e236a0e9..35a48309 100644 --- a/man/ds.hetcor.Rd +++ b/man/ds.hetcor.Rd @@ -56,4 +56,6 @@ variables, and polychoric correlations between ordinal variables. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.isValid.Rd b/man/ds.isValid.Rd index 2f927ae2..eb4f4cd9 100644 --- a/man/ds.isValid.Rd +++ b/man/ds.isValid.Rd @@ -4,7 +4,7 @@ \alias{ds.isValid} \title{Checks if a server-side object is valid} \usage{ -ds.isValid(x = NULL, datasources = NULL) +ds.isValid(x = NULL, datasources = NULL, classConsistencyCheck = TRUE) } \arguments{ \item{x}{a character string specifying the name of a vector, dataframe or matrix.} @@ -12,6 +12,9 @@ ds.isValid(x = NULL, datasources = NULL) \item{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}}.} + +\item{classConsistencyCheck}{logical. If TRUE, checks that the input object has the same +class across all studies. Default TRUE.} } \value{ \code{ds.isValid} returns a boolean. If it is TRUE input object is valid, FALSE otherwise. @@ -71,4 +74,6 @@ Server function called: \code{isValidDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.lexis.Rd b/man/ds.lexis.Rd index a57cd28c..45c0afc3 100644 --- a/man/ds.lexis.Rd +++ b/man/ds.lexis.Rd @@ -231,4 +231,6 @@ Server functions called: \code{lexisDS1}, \code{lexisDS2} and \code{lexisDS3} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.lspline.Rd b/man/ds.lspline.Rd index c0189ce4..1a2bc6ff 100644 --- a/man/ds.lspline.Rd +++ b/man/ds.lspline.Rd @@ -47,4 +47,6 @@ in slope as compared to the previous segment. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.make.Rd b/man/ds.make.Rd index 197518bc..5b361b83 100644 --- a/man/ds.make.Rd +++ b/man/ds.make.Rd @@ -17,9 +17,8 @@ objects obtained after login. If the \code{datasources} argument is not specifie the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.} } \value{ -\code{ds.make} returns the new object which is written to the -server-side. Also a validity message is returned to the client-side indicating whether the new object has been correctly -created at each source. +\code{ds.make} writes the new object to the server-side; nothing is +returned to the client-side. } \description{ This function defines a new object in the server-side @@ -147,4 +146,6 @@ ds.make(toAssign = "exp(output.test.1)", } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.metadata.Rd b/man/ds.metadata.Rd index 128ca9ec..0e704042 100644 --- a/man/ds.metadata.Rd +++ b/man/ds.metadata.Rd @@ -61,4 +61,6 @@ which are non-disclosive. } \author{ Stuart Wheater, DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.ns.Rd b/man/ds.ns.Rd index 28ffaaa0..c69c050b 100644 --- a/man/ds.ns.Rd +++ b/man/ds.ns.Rd @@ -59,4 +59,6 @@ A primary use is in modelling formula to directly specify a natural spline term } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.qlspline.Rd b/man/ds.qlspline.Rd index 003f6b3a..b4b05a7a 100644 --- a/man/ds.qlspline.Rd +++ b/man/ds.qlspline.Rd @@ -57,4 +57,6 @@ probabilities directly (the vector is passed to argument probs of quantile). } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } 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/man/ds.tapply.Rd b/man/ds.tapply.Rd index 8d09e89c..5c764c2b 100644 --- a/man/ds.tapply.Rd +++ b/man/ds.tapply.Rd @@ -145,4 +145,6 @@ Server function called: \code{tapplyDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.tapply.assign.Rd b/man/ds.tapply.assign.Rd index f58810b2..908a1555 100644 --- a/man/ds.tapply.assign.Rd +++ b/man/ds.tapply.assign.Rd @@ -152,4 +152,6 @@ Server function called: \code{ds.tapply.assign} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv b/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv index 2133cdd1..3eb977f0 100644 --- a/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv +++ b/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv @@ -10,7 +10,7 @@ "ds.asLogical::perf::0","17.46","0.5","2" "ds.asMatrix::perf::0","17.44","0.5","2" "ds.asNumeric::perf:0","16.79","0.5","2" -"ds.assign::perf::0","10.23","0.5","2" +"ds.assign::perf::0","16.75","0.5","2" "ds.Boole::perf::0","2.324","0.5","2" "ds.boxPlot::perf::0","5.837","0.5","2" "ds.boxPlotGG::perf::0","6.696","0.5","2" @@ -18,7 +18,7 @@ "ds.cbind::perf::0","3.814","0.5","2" "ds.changeRefGroup::perf::0","17.98","0.5","2" "ds.class::perf::combine:0","24.90","0.5","2" -"ds.colnames::perf:0","8.16","0.5","2" +"ds.colnames::perf:0","24.59","0.5","2" "ds.completeCases::perf::combine:0","17.26","0.5","2" "ds.contourPlot::perf::0","4.593","0.5","2" "ds.cor::perf::combine:0","7.019","0.5","2" @@ -76,7 +76,7 @@ "ds.rep::perf::0","17.44","0.5","2" "ds.replaceNA::perf::0","3.292","0.5","2" "ds.reShape::perf::0","17.31","0.5","2" -"ds.rowColCalc::perf::0","4.300","0.5","2" +"ds.rowColCalc::perf::0","16.70","0.5","2" "ds.rNorm::perf::0","8.597","0.5","2" "ds.rPois::perf::0","8.556","0.5","2" "ds.rUnif::perf::0","8.695","0.5","2" diff --git a/tests/testthat/perf_files/armadillo_github-workflows_perf-profile.csv b/tests/testthat/perf_files/armadillo_github-workflows_perf-profile.csv new file mode 100644 index 00000000..454c22f4 --- /dev/null +++ b/tests/testthat/perf_files/armadillo_github-workflows_perf-profile.csv @@ -0,0 +1,96 @@ +"refer_name","rate","lower_tolerance","upper_tolerance" +"conndisconn::perf::simple0","0.1581","0.5","2" +"ds.abs::perf::0","17.27","0.5","2" +"ds.asCharacter::perf::0","16.84","0.5","2" +"ds.asDataMatrix::perf::0","17.44","0.5","2" +"ds.asFactor::perf::0","10.22","0.5","2" +"ds.asFactorSimple::perf::0","17.79","0.5","2" +"ds.asInteger::perf:0","17.61","0.5","2" +"ds.asList::perf:0","22.52","0.5","2" +"ds.asLogical::perf::0","17.46","0.5","2" +"ds.asMatrix::perf::0","17.44","0.5","2" +"ds.asNumeric::perf:0","16.79","0.5","2" +"ds.assign::perf::0","10.23","0.5","2" +"ds.Boole::perf::0","2.324","0.5","2" +"ds.boxPlot::perf::0","5.837","0.5","2" +"ds.boxPlotGG::perf::0","6.696","0.5","2" +"ds.c::perf::0","10.23","0.5","2" +"ds.cbind::perf::0","3.814","0.5","2" +"ds.changeRefGroup::perf::0","17.98","0.5","2" +"ds.class::perf::combine:0","24.90","0.5","2" +"ds.colnames::perf:0","24.83","0.5","2" +"ds.completeCases::perf::combine:0","17.26","0.5","2" +"ds.contourPlot::perf::0","4.593","0.5","2" +"ds.cor::perf::combine:0","7.019","0.5","2" +"ds.corTest::perf::combine:0","22.45","0.5","2" +"ds.cov::perf::combine:0","7.010","0.5","2" +"ds.dataFrame::perf::0","5.943","0.5","2" +"ds.dataFrameFill::perf::0","2.749","0.5","2" +"ds.dataFrameSort::perf::0","14.38","0.5","2" +"ds.dataFrameSubset::perf::0","2.450","0.5","2" +"ds.densityGrid::perf::0","4.653","0.5","2" +"ds.dim::perf::0","23.82","0.5","2" +"ds.dmtC2S::perf::0","16.61","0.5","2" +"ds.elspline::perf::0","16.32","0.5","2" +"ds.exists::perf::combine:0","24.21","0.5","2" +"ds.exp::perf::0","17.18","0.5","2" +"ds.gamlss::perf::0","10.81","0.5","2" +"ds.getWGSR::perf::0","0.3403","0.5","2" +"ds.glmPredict::perf::0","10.04","0.5","2" +"ds.glmSummary::perf::0","10.10","0.5","2" +"ds.heatmapPlot::perf::0","4.519","0.5","2" +"ds.hetcor::perf::0","0.2028","0.5","2" +"ds.histogram::perf::0","9.261","0.5","2" +"ds.isNA::perf::combine:0","23.86","0.5","2" +"ds.kurtosis::perf::combine:0","8.377","0.5","2" +"ds.length::perf::combine:0","24.04","0.5","2" +"ds.levels::perf::combine:0","23.96","0.5","2" +"ds.lexis::perf::0","3.760","0.5","2" +"ds.list::perf::0","10.03","0.5","2" +"ds.log::perf::0","17.30","0.5","2" +"ds.ls::perf::combine:0","24.35","0.5","2" +"ds.lspline::perf::0","14.17","0.5","2" +"ds.make::perf::0","16.81","0.5","2" +"ds.matrix::perf::0","16.140","0.5","2" +"ds.matrixDet::perf::0","16.015","0.5","2" +"ds.matrixDet.report::perf::0","24.038","0.5","2" +"ds.matrixDiag::perf::0","16.109","0.5","2" +"ds.matrixDimnames::perf::0","16.72","0.5","2" +"ds.matrixInvert::perf::0","16.49","0.5","2" +"ds.matrixMult::perf::0","16.65","0.5","2" +"ds.matrixTranspose::perf::0","17.90","0.5","2" +"ds.mean::perf::combine:0","24.12","0.5","2" +"ds.mean::perf::split:0","24.45","0.5","2" +"ds.meanSdGp::perf::combine:0","19.84","0.5","2" +"ds.merge::perf::0","0.7154","0.5","2" +"ds.metadata::perf::0","24.58","0.5","2" +"ds.mice::perf::0","1.996","0.5","2" +"ds.names::perf::combine:0","24.22","0.5","2" +"ds.ns::perf::0","16.41","0.5","2" +"ds.numNA::perf::combine:0","23.58","0.5","2" +"ds.qlspline::perf::0","15.40","0.5","2" +"ds.quantileMean::perf::combine:0","8.354","0.5","2" +"ds.rbind::perf::0","4.624","0.5","2" +"ds.rBinom::perf::0","8.444","0.5","2" +"ds.recodeValues::perf::0","16.842","0.5","2" +"ds.rep::perf::0","17.44","0.5","2" +"ds.replaceNA::perf::0","3.292","0.5","2" +"ds.reShape::perf::0","17.31","0.5","2" +"ds.rowColCalc::perf::0","23.48","0.5","2" +"ds.rNorm::perf::0","8.597","0.5","2" +"ds.rPois::perf::0","8.556","0.5","2" +"ds.rUnif::perf::0","8.695","0.5","2" +"ds.sample::perf::0","7.652","0.5","2" +"ds.scatterPlot::perf::0","3.318","0.5","2" +"ds.seq::perf::0","17.55","0.5","2" +"ds.setSeed::perf::0","22.25","0.5","2" +"ds.skewness::perf::combine:0","8.226","0.5","2" +"ds.sqrt::perf::0","16.83","0.5","2" +"ds.summary::perf::0","6.095","0.5","2" +"ds.table::perf::0","10.63","0.5","2" +"ds.tapply.assign::perf::0","12.61","0.5","2" +"ds.tapply::perf::0","16.96","0.5","2" +"ds.unique::perf::combine:0","17.04","0.5","2" +"ds.unList::perf::0","16.70","0.5","2" +"ds.var::perf::combine:0","25.02","0.5","2" +"void::perf::void::0","52590","0.5","2" diff --git a/tests/testthat/perf_files/opal_azure-pipeline_perf-profile.csv b/tests/testthat/perf_files/opal_azure-pipeline_perf-profile.csv index fdfb68f6..d2cdb5aa 100644 --- a/tests/testthat/perf_files/opal_azure-pipeline_perf-profile.csv +++ b/tests/testthat/perf_files/opal_azure-pipeline_perf-profile.csv @@ -31,12 +31,15 @@ "ds.densityGrid::perf::0","2.365","0.5","2" "ds.dim::perf::0","8.687","0.5","2" "ds.dmtC2S::perf::0","8.161","0.5","2" +"ds.elspline::perf::0","9.253","0.5","2" "ds.exists::perf::combine:0","10.02","0.5","2" "ds.exp::perf::0","8.644","0.5","2" "ds.gamlss::perf::0","6.853","0.5","2" +"ds.getWGSR::perf::0","0.2908","0.5","2" "ds.glmPredict::perf::0","5.006","0.5","2" "ds.glmSummary::perf::0","4.979","0.5","2" "ds.heatmapPlot::perf::0","2.409","0.5","2" +"ds.hetcor::perf::0","0.1757","0.5","2" "ds.histogram::perf::0","3.939","0.5","2" "ds.isNA::perf::combine:0","8.677","0.5","2" "ds.kurtosis::perf::combine:0","2.872","0.5","2" @@ -45,6 +48,8 @@ "ds.list::perf::0","4.415","0.5","2" "ds.log::perf::0","8.415","0.5","2" "ds.ls::perf::combine:0","8.689","0.5","2" +"ds.lspline::perf::0","9.241","0.5","2" +"ds.make::perf::0","10.92","0.5","2" "ds.matrix::perf::0","8.422","0.5","2" "ds.matrixDet::perf::0","9.613","0.5","2" "ds.matrixDet.report::perf::0","9.829","0.5","2" @@ -57,9 +62,12 @@ "ds.mean::perf::split:0","9.823","0.5","2" "ds.meanSdGp::perf::combine:0","8.285","0.5","2" "ds.merge::perf::0","0.576","0.5","2" +"ds.metadata::perf::0","9.529","0.5","2" "ds.mice::perf::0","1.515","0.5","2" "ds.names::perf::combine:0","8.620","0.5","2" +"ds.ns::perf::0","8.999","0.5","2" "ds.numNA::perf::combine:0","8.411","0.5","2" +"ds.qlspline::perf::0","9.053","0.5","2" "ds.quantileMean::perf::combine:0","2.896","0.5","2" "ds.rbind::perf::0","1.726","0.5","2" "ds.rBinom::perf::0","3.925","0.5","2" diff --git a/tests/testthat/perf_files/opal_github-workflows_perf-profile.csv b/tests/testthat/perf_files/opal_github-workflows_perf-profile.csv new file mode 100644 index 00000000..5fb05908 --- /dev/null +++ b/tests/testthat/perf_files/opal_github-workflows_perf-profile.csv @@ -0,0 +1,91 @@ +"refer_name","rate","lower_tolerance","upper_tolerance" +"conndisconn::perf::simple0","0.1654","0.5","2" +"ds.abs::perf::0","7.933","0.5","2" +"ds.asCharacter::perf::0","7.797","0.5","2" +"ds.asDataMatrix::perf::0","8.230","0.5","2" +"ds.asFactor::perf::0","4.249","0.5","2" +"ds.asFactorSimple::perf::0","8.590","0.5","2" +"ds.asInteger::perf:0","8.178","0.5","2" +"ds.asList::perf:0","8.243","0.5","2" +"ds.asLogical::perf::0","8.270","0.5","2" +"ds.asMatrix::perf::0","8.683","0.5","2" +"ds.asNumeric::perf:0","8.631","0.5","2" +"ds.assign::perf::0","11.53","0.5","2" +"ds.Boole::perf::0","1.676","0.5","2" +"ds.boxPlot::perf::0","2.295","0.5","2" +"ds.boxPlotGG::perf::0","2.628","0.5","2" +"ds.c::perf::0","4.207","0.5","2" +"ds.cbind::perf::0","1.486","0.5","2" +"ds.changeRefGroup::perf::0","9.927","0.5","2" +"ds.class::perf::combine:0","8.572","0.5","2" +"ds.colnames::perf:0","10.81","0.5","2" +"ds.completeCases::perf::combine:0","8.254","0.5","2" +"ds.contourPlot::perf::0","2.415","0.5","2" +"ds.cor::perf::combine:0","3.922","0.5","2" +"ds.corTest::perf::combine:0","8.246","0.5","2" +"ds.cov::perf::combine:0","4.792","0.5","2" +"ds.dataFrame::perf::0","2.488","0.5","2" +"ds.dataFrameFill::perf::0","1.098","0.5","2" +"ds.dataFrameSort::perf::0","8.263","0.5","2" +"ds.dataFrameSubset::perf::0","2.043","0.5","2" +"ds.densityGrid::perf::0","2.365","0.5","2" +"ds.dim::perf::0","8.687","0.5","2" +"ds.dmtC2S::perf::0","8.161","0.5","2" +"ds.elspline::perf::0","9.253","0.5","2" +"ds.exists::perf::combine:0","10.02","0.5","2" +"ds.exp::perf::0","8.644","0.5","2" +"ds.gamlss::perf::0","6.853","0.5","2" +"ds.getWGSR::perf::0","0.685","0.5","2" +"ds.glmPredict::perf::0","5.006","0.5","2" +"ds.glmSummary::perf::0","4.979","0.5","2" +"ds.heatmapPlot::perf::0","2.409","0.5","2" +"ds.hetcor::perf::0","0.3609","0.5","2" +"ds.histogram::perf::0","3.939","0.5","2" +"ds.isNA::perf::combine:0","8.677","0.5","2" +"ds.kurtosis::perf::combine:0","2.872","0.5","2" +"ds.length::perf::combine:0","8.551","0.5","2" +"ds.levels::perf::combine:0","8.594","0.5","2" +"ds.list::perf::0","4.415","0.5","2" +"ds.log::perf::0","8.415","0.5","2" +"ds.ls::perf::combine:0","8.689","0.5","2" +"ds.lspline::perf::0","9.241","0.5","2" +"ds.make::perf::0","10.92","0.5","2" +"ds.matrix::perf::0","8.422","0.5","2" +"ds.matrixDet::perf::0","9.613","0.5","2" +"ds.matrixDet.report::perf::0","9.829","0.5","2" +"ds.matrixDiag::perf::0","9.700","0.5","2" +"ds.matrixDimnames::perf::0","9.754","0.5","2" +"ds.matrixInvert::perf::0","9.728","0.5","2" +"ds.matrixMult::perf::0","9.876","0.5","2" +"ds.matrixTranspose::perf::0","9.746","0.5","2" +"ds.mean::perf::combine:0","8.690","0.5","2" +"ds.mean::perf::split:0","9.823","0.5","2" +"ds.meanSdGp::perf::combine:0","8.285","0.5","2" +"ds.merge::perf::0","0.576","0.5","2" +"ds.metadata::perf::0","9.529","0.5","2" +"ds.mice::perf::0","3.166","0.5","2" +"ds.names::perf::combine:0","8.620","0.5","2" +"ds.ns::perf::0","8.999","0.5","2" +"ds.numNA::perf::combine:0","8.411","0.5","2" +"ds.qlspline::perf::0","9.053","0.5","2" +"ds.quantileMean::perf::combine:0","2.896","0.5","2" +"ds.rbind::perf::0","1.726","0.5","2" +"ds.rBinom::perf::0","3.925","0.5","2" +"ds.recodeValues::perf::0","8.478","0.5","2" +"ds.rep::perf::0","8.645","0.5","2" +"ds.replaceNA::perf::0","1.280","0.5","2" +"ds.reShape::perf::0","8.211","0.5","2" +"ds.rNorm::perf::0","3.881","0.5","2" +"ds.rPois::perf::0","3.848","0.5","2" +"ds.rUnif::perf::0","3.864","0.5","2" +"ds.sample::perf::0","3.764","0.5","2" +"ds.seq::perf::0","8.522","0.5","2" +"ds.setSeed::perf::0","8.990","0.5","2" +"ds.skewness::perf::combine:0","2.889","0.5","2" +"ds.sqrt::perf::0","8.666","0.5","2" +"ds.summary::perf::0","2.149","0.5","2" +"ds.scatterPlot::perf::0","2.163","0.5","2" +"ds.unique::perf::combine:0","8.656","0.5","2" +"ds.unList::perf::0","8.128","0.5","2" +"ds.var::perf::combine:0","7.6420","0.5","2" +"void::perf::void::0","46340","0.5","2" diff --git a/tests/testthat/test-arg-ds.isValid.R b/tests/testthat/test-arg-ds.isValid.R index 37fbf21a..4d97f1fa 100644 --- a/tests/testthat/test-arg-ds.isValid.R +++ b/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) }) # diff --git a/tests/testthat/test-arg-ds.metadata.R b/tests/testthat/test-arg-ds.metadata.R index b31209f9..5bcabe43 100644 --- a/tests/testthat/test-arg-ds.metadata.R +++ b/tests/testthat/test-arg-ds.metadata.R @@ -26,17 +26,6 @@ test_that("setup", { # # context("ds.metadata::arg") -test_that("missing variable", { - expect_error(ds.metadata(x='E'), "The input object E is not defined in sim1, sim2, sim3!", fixed = TRUE) -}) - -# test_that("missing column", { -# expect_error(ds.metadata(x='E$E'), "The input object E$E is not defined in sim1, sim2, sim3!", fixed = TRUE) -# }) - -test_that("missing column", { - expect_error(ds.metadata(x='D$E'), "The input object D$E is not defined in sim1, sim2, sim3!", fixed = TRUE) -}) # # Tear down diff --git a/tests/testthat/test-arg-ds.table.R b/tests/testthat/test-arg-ds.table.R index 094cf97c..ae781fe2 100644 --- a/tests/testthat/test-arg-ds.table.R +++ b/tests/testthat/test-arg-ds.table.R @@ -26,15 +26,6 @@ test_that("table rvar has value", { expect_equal(res, "Error: rvar must have a value which is a character string naming the row variable for the table", fixed=TRUE) }) -# context("ds.table::arg::test rvar is not a variable") -test_that("table rvar is not a variable", { - expect_error(ds.table(rvar="D$NOT_VARIABLE"), "The input object D$NOT_VARIABLE is not defined in sim1, sim2, sim3!", fixed = TRUE) - - res.errors <- DSI::datashield.errors() - - expect_length(res.errors, 0) -}) - # context("ds.table::arg::test cvar has value") test_that("table cvar has value", { res <- ds.table(rvar="D$LAB_TSC", cvar=30) @@ -42,15 +33,6 @@ test_that("table cvar has value", { expect_equal(res, "Error: if cvar is not null, it must have a value which is a character string naming the column variable for the table", fixed=TRUE) }) -# context("ds.table::arg::test cvar is not a variable") -test_that("table cvar is not a variable", { - expect_error(ds.table(rvar="D$DIS_CVA", cvar="D$NOT_VARIABLE"), "The input object D$NOT_VARIABLE is not defined in sim1, sim2, sim3!", fixed = TRUE) - - res.errors <- DSI::datashield.errors() - - expect_length(res.errors, 0) -}) - # context("ds.table::arg::test stvar has value") test_that("table stvar has value", { res <- ds.table(rvar="D$LAB_TSC", cvar=NULL, stvar=25) @@ -58,15 +40,6 @@ test_that("table stvar has value", { expect_equal(res, "Error: if stvar is not null, it must have a value which is a character string naming the variable coding separate tables for the table", fixed=TRUE) }) -# context("ds.table::arg::test stvar is not a variable") -test_that("table stvar is not a variable", { - expect_error(ds.table(rvar="D$DIS_CVA", cvar="D$DIS_AMI", stvar="D$NOT_VARIABLE"), "The input object D$NOT_VARIABLE is not defined in sim1, sim2, sim3!", fixed = TRUE) - - res.errors <- DSI::datashield.errors() - - expect_length(res.errors, 0) -}) - # context("ds.table::arg::test stvar has CORRECT value") test_that("table useNA has value", { expect_error(ds.table(rvar="D$LAB_TSC", cvar=NULL, stvar=NULL, useNA = c("BEN")), "useNA must be either 'no' or 'always'.", fixed = TRUE) diff --git a/tests/testthat/test-perf-ds.elspline.R b/tests/testthat/test-perf-ds.elspline.R new file mode 100644 index 00000000..ba6a125c --- /dev/null +++ b/tests/testthat/test-perf-ds.elspline.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.elspline::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TRIG", "PM_BMI_CONTINUOUS")) + +# +# Tests +# + +# context("ds.elspline::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.elspline("D$PM_BMI_CONTINUOUS", n=3, newobj="elspline.newobj") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.elspline::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.elspline::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.elspline::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.elspline::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.elspline::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.elspline::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.elspline::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.elspline::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.elspline::perf::done") diff --git a/tests/testthat/test-perf-ds.getWGSR.R b/tests/testthat/test-perf-ds.getWGSR.R new file mode 100644 index 00000000..70dea199 --- /dev/null +++ b/tests/testthat/test-perf-ds.getWGSR.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.getWGSR::perf::setup") +connect.studies.dataset.anthro(list("age", "sex", "weight", "height", "muac")) + +# +# Tests +# + +# context("ds.getWGSR::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.getWGSR('D$sex', 'D$weight', 'D$height', 'wfh', newobj='wgsr.newobj') + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.getWGSR::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.getWGSR::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.getWGSR::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.getWGSR::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.getWGSR::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.getWGSR::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.getWGSR::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.getWGSR::perf::shutdown") +disconnect.studies.dataset.anthro() +# context("ds.getWGSR::perf::done") diff --git a/tests/testthat/test-perf-ds.hetcor.R b/tests/testthat/test-perf-ds.hetcor.R new file mode 100644 index 00000000..23da1a95 --- /dev/null +++ b/tests/testthat/test-perf-ds.hetcor.R @@ -0,0 +1,52 @@ + +# +# Set up +# + +# 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 +# + +# context("ds.hetcor::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.hetcor(data="df", ML=TRUE, std.err=TRUE, bins=4, pd=TRUE, use="complete.obs") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.hetcor::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.hetcor::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.hetcor::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.hetcor::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.hetcor::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.hetcor::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.hetcor::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.hetcor::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.hetcor::perf::done") diff --git a/tests/testthat/test-perf-ds.isValid.R b/tests/testthat/test-perf-ds.isValid.R new file mode 100644 index 00000000..83cde48b --- /dev/null +++ b/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") diff --git a/tests/testthat/test-perf-ds.lexis.R b/tests/testthat/test-perf-ds.lexis.R new file mode 100644 index 00000000..e6f3ebd2 --- /dev/null +++ b/tests/testthat/test-perf-ds.lexis.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.lexis::perf::setup") +connect.studies.dataset.survival(list("id", "starttime", "endtime", "cens", "age.60")) + +# +# Tests +# + +# context("ds.lexis::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.lexis(data='D', intervalWidth=c(1.0, 1.5, 2.5), idCol='D$id', entryCol='D$starttime', exitCol='D$endtime', statusCol='D$cens', variables=c('D$age.60'), expandDF='EM.new') + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.lexis::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.lexis::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.lexis::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.lexis::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.lexis::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.lexis::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.lexis::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.lexis::perf::shutdown") +disconnect.studies.dataset.survival() +# context("ds.lexis::perf::done") diff --git a/tests/testthat/test-perf-ds.lspline.R b/tests/testthat/test-perf-ds.lspline.R new file mode 100644 index 00000000..02dbe953 --- /dev/null +++ b/tests/testthat/test-perf-ds.lspline.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.lspline::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TRIG", "PM_BMI_CONTINUOUS")) + +# +# Tests +# + +# context("ds.lspline::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.lspline("D$PM_BMI_CONTINUOUS", knots=c(15,25,35), newobj="lspline.newobj") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.lspline::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.lspline::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.lspline::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.lspline::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.lspline::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.lspline::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.lspline::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.lspline::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.lspline::perf::done") diff --git a/tests/testthat/test-perf-ds.make.R b/tests/testthat/test-perf-ds.make.R new file mode 100644 index 00000000..1101ccd1 --- /dev/null +++ b/tests/testthat/test-perf-ds.make.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.make::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG", "LAB_HDL")) + +# +# Tests +# + +# context("ds.make::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.make("(D$LAB_TSC*D$LAB_TRIG*D$LAB_HDL)", "make.newobj") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.make::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.make::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.make::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.make::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.make::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.make::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.make::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.make::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.make::perf::done") diff --git a/tests/testthat/test-perf-ds.metadata.R b/tests/testthat/test-perf-ds.metadata.R new file mode 100644 index 00000000..56b1e130 --- /dev/null +++ b/tests/testthat/test-perf-ds.metadata.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.metadata::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')) + +# +# Tests +# + +# context("ds.metadata::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.metadata(x='D') + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.metadata::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.metadata::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.metadata::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.metadata::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.metadata::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.metadata::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.metadata::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.metadata::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.metadata::perf::done") diff --git a/tests/testthat/test-perf-ds.ns.R b/tests/testthat/test-perf-ds.ns.R new file mode 100644 index 00000000..074da997 --- /dev/null +++ b/tests/testthat/test-perf-ds.ns.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.ns::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TRIG", "PM_BMI_CONTINUOUS")) + +# +# Tests +# + +# context("ds.ns::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.ns(x="D$PM_BMI_CONTINUOUS", knots=c(15,25,35), newobj="ns.newobj") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.ns::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.ns::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.ns::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.ns::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.ns::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.ns::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.ns::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.ns::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.ns::perf::done") diff --git a/tests/testthat/test-perf-ds.qlspline.R b/tests/testthat/test-perf-ds.qlspline.R new file mode 100644 index 00000000..9e624339 --- /dev/null +++ b/tests/testthat/test-perf-ds.qlspline.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.qlspline::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TRIG", "PM_BMI_CONTINUOUS")) + +# +# Tests +# + +# context("ds.qlspline::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.qlspline(x="D$PM_BMI_CONTINUOUS", q=4, na.rm=TRUE, newobj="qlspline.newobj") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.qlspline::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.qlspline::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.qlspline::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.qlspline::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.qlspline::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.qlspline::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.qlspline::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.qlspline::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.qlspline::perf::done") diff --git a/tests/testthat/test-perf-ds.rowColCalc.R b/tests/testthat/test-perf-ds.rowColCalc.R new file mode 100644 index 00000000..54b1755e --- /dev/null +++ b/tests/testthat/test-perf-ds.rowColCalc.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.rowColCalc::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_HDL")) + +# +# Tests +# + +# context("ds.rowColCalc::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.rowColCalc(x="D", operation="rowSums", newobj="rowcol.newobj") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.rowColCalc::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.rowColCalc::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.rowColCalc::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.rowColCalc::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.rowColCalc::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.rowColCalc::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.rowColCalc::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.rowColCalc::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.rowColCalc::perf::done") diff --git a/tests/testthat/test-perf-ds.table.R b/tests/testthat/test-perf-ds.table.R new file mode 100644 index 00000000..0888fa08 --- /dev/null +++ b/tests/testthat/test-perf-ds.table.R @@ -0,0 +1,57 @@ + +# +# Set up +# + +# context("ds.table::perf::setup") + +connect.all.datasets() + +ds.asFactor(input.var.name="D$FACTOR_CHARACTER", newobj.name="factorCharacter") +ds.asFactor(input.var.name="D$FACTOR_INTEGER", newobj.name="factorInteger") +ds.asFactor(input.var.name="D$CATEGORY", newobj.name="factorCategory") +ds.dataFrame(x=c("factorInteger", "factorCharacter", "factorCategory"), newobj="tablesource") +ds.dataFrameSubset(df.name="tablesource", V1.name="factorInteger", V2.name='6', Boolean.operator="!=", newobj="tablesource_subset") + +# +# Tests +# + +# context("ds.table::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.table(rvar='tablesource_subset$factorCharacter') + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.table::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.table::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.table::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.table::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.table::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.table::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.table::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.table::perf::shutdown") +disconnect.all.datasets() +# context("ds.table::perf::done") diff --git a/tests/testthat/test-perf-ds.tapply.R b/tests/testthat/test-perf-ds.tapply.R new file mode 100644 index 00000000..a1bc1b65 --- /dev/null +++ b/tests/testthat/test-perf-ds.tapply.R @@ -0,0 +1,53 @@ + +# +# Set up +# + +# context("ds.tapply::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "GENDER")) + +ds.assign('D$LAB_TSC', 'LAB_TSC') +ds.assign('D$GENDER', 'GENDER') + +# +# Tests +# + +# context("ds.tapply::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.tapply('LAB_TSC', INDEX.names=c('GENDER'), FUN.name='mean') + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.tapply::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.tapply::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.tapply::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.tapply::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.tapply::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.tapply::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.tapply::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.tapply::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.tapply::perf::done") diff --git a/tests/testthat/test-perf-ds.tapply.assign.R b/tests/testthat/test-perf-ds.tapply.assign.R new file mode 100644 index 00000000..453ef1b4 --- /dev/null +++ b/tests/testthat/test-perf-ds.tapply.assign.R @@ -0,0 +1,53 @@ + +# +# Set up +# + +# context("ds.tapply.assign::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "GENDER")) + +ds.assign('D$LAB_TSC', 'LAB_TSC') +ds.assign('D$GENDER', 'GENDER') + +# +# Tests +# + +# context("ds.tapply.assign::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.tapply.assign('LAB_TSC', INDEX.names=c('GENDER'), FUN.name='mean', newobj="tapply.newobj") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.tapply.assign::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.tapply.assign::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.tapply.assign::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.tapply.assign::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.tapply.assign::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.tapply.assign::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.tapply.assign::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.tapply.assign::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.tapply.assign::perf::done") diff --git a/tests/testthat/test-smk-ds.colnames.R b/tests/testthat/test-smk-ds.colnames.R index b7d289ac..40d9e1c2 100644 --- a/tests/testthat/test-smk-ds.colnames.R +++ b/tests/testthat/test-smk-ds.colnames.R @@ -47,21 +47,28 @@ test_that("simple colnames", { test_that("fails if the object does not exist", { expect_error( ds.colnames("non_existing_df"), - regexp = "The input object non_existing_df is not defined in sim1, sim2, sim3!", - ignore.case = TRUE + "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 'non_existing_df' does not exist") + } }) -########################################### -### Remote checks not performed ### -########################################### -# test_that("fails if object is not a data frame or matrix", { -# expect_error( -# ds.colnames("D$LAB_TSC"), -# regexp = "must be of type data.frame or matrix", -# ignore.case = TRUE -# ) -# }) +test_that("fails if object is not a data frame or matrix", { + expect_error( + ds.colnames("D$LAB_TSC"), + "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, "must be of type data.frame or matrix") + } +}) # # Done diff --git a/tests/testthat/test-smk-ds.contourPlot.R b/tests/testthat/test-smk-ds.contourPlot.R index 944b192c..ff03ff8f 100644 --- a/tests/testthat/test-smk-ds.contourPlot.R +++ b/tests/testthat/test-smk-ds.contourPlot.R @@ -40,6 +40,15 @@ test_that("contour plot with wrong input class fails", { # Done # +test_that("contour plot with nonexistent object fails in the default combine path", { + expect_error(ds.contourPlot(x="nonexistent_obj", y="D$LAB_TRIG"), "There are some DataSHIELD errors", fixed=TRUE) + + res.errors <- DSI::datashield.errors() + for (study.errors in res.errors) { + expect_match(study.errors, "The server-side object 'nonexistent_obj' does not exist", fixed = TRUE) + } +}) + # context("ds.contourPlot::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.densityGrid.R b/tests/testthat/test-smk-ds.densityGrid.R index 2c01ae0f..61195b32 100644 --- a/tests/testthat/test-smk-ds.densityGrid.R +++ b/tests/testthat/test-smk-ds.densityGrid.R @@ -49,6 +49,15 @@ test_that("density grid with wrong input class fails", { # Done # +test_that("density grid with nonexistent object fails in the default combine path", { + expect_error(ds.densityGrid(x="nonexistent_obj", y="D$LAB_TRIG"), "There are some DataSHIELD errors", fixed=TRUE) + + res.errors <- DSI::datashield.errors() + for (study.errors in res.errors) { + expect_match(study.errors, "The server-side object 'nonexistent_obj' does not exist", fixed = TRUE) + } +}) + # context("ds.densityGrid::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.elspline.R b/tests/testthat/test-smk-ds.elspline.R index aa8d3d78..7f356fef 100644 --- a/tests/testthat/test-smk-ds.elspline.R +++ b/tests/testthat/test-smk-ds.elspline.R @@ -129,6 +129,19 @@ test_that("elspline", { }) +test_that("fails if the object does not exist", { + expect_error( + ds.elspline(x = "nonexistent_object", n = 3), + "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 # diff --git a/tests/testthat/test-smk-ds.getWGSR.R b/tests/testthat/test-smk-ds.getWGSR.R index c5034a71..7c6a2a53 100644 --- a/tests/testthat/test-smk-ds.getWGSR.R +++ b/tests/testthat/test-smk-ds.getWGSR.R @@ -27,13 +27,7 @@ test_that("setup", { # context("ds.getWGSR::smk") test_that("simple getWGSR", { - res <- ds.getWGSR('D$sex', 'D$weight', 'D$height', 'wfh', newobj='newobj.getwgsr') - - expect_length(res, 2) - expect_length(res$is.object.created, 1) - expect_equal(res$is.object.created, "A data object has been created in all specified data sources") - expect_length(res$validity.check, 1) - expect_equal(res$validity.check, " appears valid in all sources") + ds.getWGSR('D$sex', 'D$weight', 'D$height', 'wfh', newobj='newobj.getwgsr') res.class <- ds.class('newobj.getwgsr') @@ -62,10 +56,38 @@ test_that("simple getWGSR", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.getWGSR(sex = "D$sex", firstPart = "nonexistent_object", secondPart = "D$height", index = "hfa"), + "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") + } +}) + +test_that("fails if firstPart is not numeric", { + ds.asFactor(input.var.name = "D$sex", newobj.name = "sex_factor") + + expect_error( + ds.getWGSR(sex = "D$sex", firstPart = "sex_factor", secondPart = "D$height", index = "hfa"), + "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 must be of type numeric") + } +}) + # context("ds.getWGSR::smk::shutdown") test_that("shutdown", { - ds_expect_variables(c("D", "newobj.getwgsr")) + ds_expect_variables(c("D", "newobj.getwgsr", "sex_factor")) }) disconnect.studies.dataset.cnsim() diff --git a/tests/testthat/test-smk-ds.heatmapPlot.R b/tests/testthat/test-smk-ds.heatmapPlot.R index ed50c15f..3f1112b3 100644 --- a/tests/testthat/test-smk-ds.heatmapPlot.R +++ b/tests/testthat/test-smk-ds.heatmapPlot.R @@ -40,6 +40,15 @@ test_that("heatmap plot with wrong input class fails", { # Done # +test_that("heatmap plot with nonexistent object fails in the default combine path", { + expect_error(ds.heatmapPlot(x="nonexistent_obj", y="D$LAB_TRIG"), "There are some DataSHIELD errors", fixed=TRUE) + + res.errors <- DSI::datashield.errors() + for (study.errors in res.errors) { + expect_match(study.errors, "The server-side object 'nonexistent_obj' does not exist", fixed = TRUE) + } +}) + # context("ds.heatmapPlot::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.hetcor.R b/tests/testthat/test-smk-ds.hetcor.R index 906c1cdd..5c8c2abd 100644 --- a/tests/testthat/test-smk-ds.hetcor.R +++ b/tests/testthat/test-smk-ds.hetcor.R @@ -178,6 +178,19 @@ test_that("hetcor", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.hetcor(data = "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") + } +}) + # context("ds.hetcor::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.isValid.R b/tests/testthat/test-smk-ds.isValid.R index 59b72dcc..34d2f730 100644 --- a/tests/testthat/test-smk-ds.isValid.R +++ b/tests/testthat/test-smk-ds.isValid.R @@ -37,6 +37,13 @@ test_that("isValid", { expect_length(res1$sim3, 1) expect_true(res1$sim3) + res2 <- ds.isValid(x='D') + + expect_length(res2, 3) + expect_true(res2$sim1) + expect_true(res2$sim2) + expect_true(res2$sim3) + # myvectors <- c("D$LAB_TSC", "D$LAB_TRIG") # ds.dataFrame(x=myvectors, newobj="unsubset_df") # ds.dataFrameSubset(df.name="unsubset_df", V1.name="D$LAB_TSC", V2.name="D$LAB_TRIG", Boolean.operator=">", newobj="subset_df") @@ -52,6 +59,34 @@ test_that("isValid", { # expect_false(res2$sim3) }) +test_that("fails if the object does not exist", { + expect_error( + ds.isValid(x='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") + } +}) + +test_that("fails if the object is of a type that cannot be checked", { + ds.asList(x.name='D', newobj='D_list') + + expect_error( + ds.isValid(x='D_list'), + "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 must be of type") + } +}) + # # Tear down # @@ -59,7 +94,7 @@ test_that("isValid", { # context("ds.isValid::smk::shutdown") test_that("shutdown", { - ds_expect_variables(c("D")) + ds_expect_variables(c("D", "D_list")) }) disconnect.studies.dataset.cnsim() diff --git a/tests/testthat/test-smk-ds.lexis.R b/tests/testthat/test-smk-ds.lexis.R index c0c30233..e9c99b4f 100644 --- a/tests/testthat/test-smk-ds.lexis.R +++ b/tests/testthat/test-smk-ds.lexis.R @@ -51,14 +51,33 @@ test_that("simple lexis", { expect_equal(res.message$survival3, "ALL OK: there are no studysideMessage(s) on this datasource") }) +test_that("lexis without entryCol defaults entry times to 0", { + ds.lexis(data='D', intervalWidth = c(1.0, 1.5, 2.5), idCol = 'D$id', exitCol = 'D$endtime', statusCol = 'D$cens', expandDF = 'EM.noentry') + + ds_expect_variables(c("D", "EM.new", "messageobj", "EM.noentry")) +}) + # # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.lexis(data = "D", intervalWidth = c(1.0, 1.5, 2.5), idCol = "D$id", entryCol = "D$starttime", exitCol = "nonexistent_object", statusCol = "D$cens"), + "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") + } +}) + # context("ds.lexis::smk::shutdown") test_that("shutdown", { - ds_expect_variables(c("D", "EM.new", "messageobj")) + ds_expect_variables(c("D", "EM.new", "messageobj", "EM.noentry")) }) disconnect.studies.dataset.survival() diff --git a/tests/testthat/test-smk-ds.lspline.R b/tests/testthat/test-smk-ds.lspline.R index 08d45470..2e46ac45 100644 --- a/tests/testthat/test-smk-ds.lspline.R +++ b/tests/testthat/test-smk-ds.lspline.R @@ -82,6 +82,19 @@ test_that("lspline", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.lspline(x = "nonexistent_object", knots = c(1, 2)), + "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") + } +}) + # context("ds.lspline::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.make.R b/tests/testthat/test-smk-ds.make.R index cadb0470..a36a4ff8 100644 --- a/tests/testthat/test-smk-ds.make.R +++ b/tests/testthat/test-smk-ds.make.R @@ -27,29 +27,20 @@ test_that("setup", { # context("ds.make::smk") test_that("simple make", { - res <- ds.make("(D$LAB_TSC*D$LAB_TRIG*D$LAB_HDL)", "maded.rand") - - expect_length(res, 2) - expect_equal(res$is.object.created, "A data object has been created in all specified data sources") - expect_equal(res$validity.check, " appears valid in all sources") + ds.make("(D$LAB_TSC*D$LAB_TRIG*D$LAB_HDL)", "maded.rand") + ds_expect_variables(c("D", "maded.rand")) }) # context("ds.make::smk") test_that("simple make", { - res <- ds.make("(D$LAB_TSC*10)", "maded.rand") - - expect_length(res, 2) - expect_equal(res$is.object.created, "A data object has been created in all specified data sources") - expect_equal(res$validity.check, " appears valid in all sources") + ds.make("(D$LAB_TSC*10)", "maded.rand") + ds_expect_variables(c("D", "maded.rand")) }) # context("ds.make::smk") test_that("simple make", { - res <- ds.make("(D$LAB_TSC)*10", "maded.rand") - - expect_length(res, 2) - expect_equal(res$is.object.created, "A data object has been created in all specified data sources") - expect_equal(res$validity.check, " appears valid in all sources") + ds.make("(D$LAB_TSC)*10", "maded.rand") + ds_expect_variables(c("D", "maded.rand")) }) # diff --git a/tests/testthat/test-smk-ds.metadata.R b/tests/testthat/test-smk-ds.metadata.R index 5acbb2ad..6394bb9d 100644 --- a/tests/testthat/test-smk-ds.metadata.R +++ b/tests/testthat/test-smk-ds.metadata.R @@ -114,6 +114,32 @@ test_that("column metadata", { # Tear down # +test_that("fails if the object does not exist", { + expect_error( + ds.metadata(x = "nonexistent_object"), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + expect_match(res.errors$sim1, "The server-side object 'nonexistent_object' does not exist") + expect_match(res.errors$sim2, "The server-side object 'nonexistent_object' does not exist") + expect_match(res.errors$sim3, "The server-side object 'nonexistent_object' does not exist") +}) + +test_that("fails if the column does not exist", { + expect_error( + ds.metadata(x = "D$nonexistent_column"), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + expect_match(res.errors$sim1, "Column 'nonexistent_column' not found in 'D'") + expect_match(res.errors$sim2, "Column 'nonexistent_column' not found in 'D'") + expect_match(res.errors$sim3, "Column 'nonexistent_column' not found in 'D'") +}) + # context("ds.metadata::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.ns.R b/tests/testthat/test-smk-ds.ns.R index d925aa1e..d7aed55b 100644 --- a/tests/testthat/test-smk-ds.ns.R +++ b/tests/testthat/test-smk-ds.ns.R @@ -86,6 +86,19 @@ test_that("ns", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.ns(x = "nonexistent_object", df = 3), + "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") + } +}) + # context("ds.ns::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.qlspline.R b/tests/testthat/test-smk-ds.qlspline.R index e8b89701..7cbc7a7a 100644 --- a/tests/testthat/test-smk-ds.qlspline.R +++ b/tests/testthat/test-smk-ds.qlspline.R @@ -131,6 +131,19 @@ test_that("qlspline", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.qlspline(x = "nonexistent_object", q = 3), + "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") + } +}) + # context("ds.qlspline::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.rowColCalc.R b/tests/testthat/test-smk-ds.rowColCalc.R index 792bfb5e..bebcce20 100644 --- a/tests/testthat/test-smk-ds.rowColCalc.R +++ b/tests/testthat/test-smk-ds.rowColCalc.R @@ -49,10 +49,52 @@ test_that("rowColCalc_out_exists", { # # Tear down # +test_that("fails if the object does not exist", { + expect_error( + ds.rowColCalc(x = "nonexistent_object", operation = "rowSums"), + "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") + } +}) + +test_that("fails if the object is not a data.frame or matrix", { + expect_error( + ds.rowColCalc(x = "D$LAB_TSC", operation = "rowSums"), + "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 must be of type data.frame or matrix") + } +}) + +test_that("fails if a column is not numeric", { + ds.asCharacter(x.name = "D$LAB_TSC", newobj = "tsc_chr") + ds.dataFrame(x = c("D$LAB_HDL", "tsc_chr"), newobj = "mixed_df") + + expect_error( + ds.rowColCalc(x = "mixed_df", operation = "rowSums"), + "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, "are not of numeric type") + } +}) + # context("ds.rowColCalc::smk::shutdown") test_that("shutdown", { - ds_expect_variables(c("D", "rsum_hdl_tsc", "rowcolcalc.newobj")) + ds_expect_variables(c("D", "rsum_hdl_tsc", "rowcolcalc.newobj", "tsc_chr", "mixed_df")) }) disconnect.studies.dataset.cnsim() diff --git a/tests/testthat/test-smk-ds.table.R b/tests/testthat/test-smk-ds.table.R index a705d364..f944e1e5 100644 --- a/tests/testthat/test-smk-ds.table.R +++ b/tests/testthat/test-smk-ds.table.R @@ -150,6 +150,75 @@ test_that("simple table 3D, with assign", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.table(rvar = "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") + } +}) + +test_that("fails if rvar column does not exist", { + expect_error( + ds.table(rvar = "tablesource_subset$nonexistent_column"), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + expect_match(res.errors$study1, "Column 'nonexistent_column' not found in 'tablesource_subset'") + expect_match(res.errors$study2, "Column 'nonexistent_column' not found in 'tablesource_subset'") + expect_match(res.errors$study3, "Column 'nonexistent_column' not found in 'tablesource_subset'") +}) + +test_that("fails if cvar column does not exist", { + expect_error( + ds.table(rvar = "tablesource_subset$factorInteger", cvar = "tablesource_subset$nonexistent_column"), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + expect_match(res.errors$study1, "Column 'nonexistent_column' not found in 'tablesource_subset'") + expect_match(res.errors$study2, "Column 'nonexistent_column' not found in 'tablesource_subset'") + expect_match(res.errors$study3, "Column 'nonexistent_column' not found in 'tablesource_subset'") +}) + +test_that("fails if stvar column does not exist", { + expect_error( + ds.table(rvar = "tablesource_subset$factorInteger", cvar = "tablesource_subset$factorCharacter", stvar = "tablesource_subset$nonexistent_column"), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + expect_match(res.errors$study1, "Column 'nonexistent_column' not found in 'tablesource_subset'") + expect_match(res.errors$study2, "Column 'nonexistent_column' not found in 'tablesource_subset'") + expect_match(res.errors$study3, "Column 'nonexistent_column' not found in 'tablesource_subset'") +}) + +test_that("simple table 1D, with forced nfilter", { + expect_no_error(ds.table(rvar='tablesource_subset$factorCharacter', force.nfilter="5")) +}) + +test_that("fails if forced nfilter is below nfilter.tab", { + expect_error( + ds.table(rvar='tablesource_subset$factorCharacter', force.nfilter="1"), + "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, "force.nfilter is non-null it must be >= to nfilter.tab") + } +}) + # context("ds.table::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.tapply.R b/tests/testthat/test-smk-ds.tapply.R index 67aad82c..dfbc5f29 100644 --- a/tests/testthat/test-smk-ds.tapply.R +++ b/tests/testthat/test-smk-ds.tapply.R @@ -133,6 +133,19 @@ test_that("simplest 'ds.tapply', fun=quantile", { # Tear down # +test_that("fails if the object does not exist", { + expect_error( + ds.tapply("nonexistent_object", INDEX.names = c("GENDER"), FUN.name = "mean"), + "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") + } +}) + # context("ds.tapply::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.tapply.assign.R b/tests/testthat/test-smk-ds.tapply.assign.R index 8fd4918d..5c8cc5dc 100644 --- a/tests/testthat/test-smk-ds.tapply.assign.R +++ b/tests/testthat/test-smk-ds.tapply.assign.R @@ -31,11 +31,9 @@ ds.assign('D$GENDER', 'GENDER') # context("ds.tapply.assign::smk::fun=mean") test_that("simplest 'ds.tapply.assign', fun=mean", { - list <- ds.tapply.assign('LAB_TSC', INDEX.names=c('GENDER'), FUN.name='mean', newobj="fun_mean.newobj") + ds.tapply.assign('LAB_TSC', INDEX.names=c('GENDER'), FUN.name='mean', newobj="fun_mean.newobj") - expect_length(list, 2) - expect_equal(list$is.object.created, "A data object has been created in all specified data sources", fixed=TRUE) - expect_equal(list$validity.check, " appears valid in all sources", fixed=TRUE) + expect_no_error(ds.class("fun_mean.newobj")) res.length <- ds.length("fun_mean.newobj") expect_length(res.length, 4) @@ -47,11 +45,9 @@ test_that("simplest 'ds.tapply.assign', fun=mean", { # context("ds.tapply.assign::smk::fun=sd") test_that("simplest 'ds.tapply.assign', fun=sd", { - list <- ds.tapply.assign('LAB_TSC', INDEX.names=c('GENDER'), FUN.name='sd', newobj="fun_sd.newobj") + ds.tapply.assign('LAB_TSC', INDEX.names=c('GENDER'), FUN.name='sd', newobj="fun_sd.newobj") - expect_length(list, 2) - expect_equal(list$is.object.created, "A data object has been created in all specified data sources", fixed=TRUE) - expect_equal(list$validity.check, " appears valid in all sources", fixed=TRUE) + expect_no_error(ds.class("fun_sd.newobj")) res.length <- ds.length("fun_sd.newobj") expect_length(res.length, 4) @@ -63,11 +59,9 @@ test_that("simplest 'ds.tapply.assign', fun=sd", { # context("ds.tapply.assign::smk::fun=sum") test_that("simplest 'ds.tapply.assign', fun=sum", { - list <- ds.tapply.assign('LAB_TSC', INDEX.names=c('GENDER'), FUN.name='sum', newobj="fun_sum.newobj") + ds.tapply.assign('LAB_TSC', INDEX.names=c('GENDER'), FUN.name='sum', newobj="fun_sum.newobj") - expect_length(list, 2) - expect_equal(list$is.object.created, "A data object has been created in all specified data sources", fixed=TRUE) - expect_equal(list$validity.check, " appears valid in all sources", fixed=TRUE) + expect_no_error(ds.class("fun_sum.newobj")) res.length <- ds.length("fun_sum.newobj") expect_length(res.length, 4) @@ -79,11 +73,9 @@ test_that("simplest 'ds.tapply.assign', fun=sum", { # context("ds.tapply.assign::smk::fun=quantile") test_that("simplest 'ds.tapply.assign', fun=quantile", { - list <- ds.tapply.assign('LAB_TSC', INDEX.names=c('GENDER'), FUN.name='quantile', newobj="fun_quantile.newobj") + ds.tapply.assign('LAB_TSC', INDEX.names=c('GENDER'), FUN.name='quantile', newobj="fun_quantile.newobj") - expect_length(list, 2) - expect_equal(list$is.object.created, "A data object has been created in all specified data sources", fixed=TRUE) - expect_equal(list$validity.check, " appears valid in all sources", fixed=TRUE) + expect_no_error(ds.class("fun_quantile.newobj")) res.length <- ds.length("fun_quantile.newobj") expect_length(res.length, 4) @@ -97,6 +89,19 @@ test_that("simplest 'ds.tapply.assign', fun=quantile", { # Tear down # +test_that("fails if the object does not exist", { + expect_error( + ds.tapply.assign("nonexistent_object", INDEX.names = c("GENDER"), FUN.name = "mean"), + "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") + } +}) + # context("ds.tapply.assign::smk::shutdown") test_that("shutdown", {