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.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..9cc87851 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,6 @@ 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.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.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..1def3dcf 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{ @@ -135,14 +135,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 +149,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..cf133c27 100644 --- a/R/ds.rowColCalc.R +++ b/R/ds.rowColCalc.R @@ -68,31 +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) @@ -140,10 +121,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.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/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.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/Rplots.pdf b/tests/testthat/Rplots.pdf new file mode 100644 index 00000000..3439ff7d Binary files /dev/null and b/tests/testthat/Rplots.pdf differ 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/test-arg-ds.metadata.R b/tests/testthat/test-arg-ds.metadata.R index b31209f9..a80b40cc 100644 --- a/tests/testthat/test-arg-ds.metadata.R +++ b/tests/testthat/test-arg-ds.metadata.R @@ -26,17 +26,9 @@ 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) -}) +# "missing variable" / "missing column" moved to test-smk-ds.metadata.R: +# these are now server-side existence checks (via .loadServersideObject), not +# client-side argument validation, so they belong in the smk suite. # # Tear down 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..69a3a79f --- /dev/null +++ b/tests/testthat/test-perf-ds.hetcor.R @@ -0,0 +1,50 @@ + +# +# 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")) + +# +# 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="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.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.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..2b23a48f --- /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(toAssign="D$LAB_TSC + D$LAB_TRIG", newobj="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..ee17ac41 --- /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$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.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..3d8811e7 --- /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("D$PM_BMI_CONTINUOUS", df=3, 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..99aa6dce --- /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("D$PM_BMI_CONTINUOUS", q=3, 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..21e5736d --- /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="colMeans", 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..5511710b --- /dev/null +++ b/tests/testthat/test-perf-ds.table.R @@ -0,0 +1,51 @@ + +# +# Set up +# + +# context("ds.table::perf::setup") + +connect.studies.dataset.cnsim(list("GENDER")) + +# +# 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="D$GENDER") + + .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.studies.dataset.cnsim() +# 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..8ad28a46 --- /dev/null +++ b/tests/testthat/test-perf-ds.tapply.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.tapply::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "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(X.name="D$LAB_TSC", INDEX.names="D$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..f3bedfe1 --- /dev/null +++ b/tests/testthat/test-perf-ds.tapply.assign.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.tapply.assign::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "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(X.name="D$LAB_TSC", INDEX.names="D$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.elspline.R b/tests/testthat/test-smk-ds.elspline.R index aa8d3d78..9b859808 100644 --- a/tests/testthat/test-smk-ds.elspline.R +++ b/tests/testthat/test-smk-ds.elspline.R @@ -129,6 +129,13 @@ test_that("elspline", { }) +test_that("fails if the object does not exist", { + expect_error( + ds.elspline(x = "nonexistent_object", n = 3), + regexp = "DataSHIELD errors" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-ds.getWGSR.R b/tests/testthat/test-smk-ds.getWGSR.R index c5034a71..7aaf391e 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,6 +56,13 @@ 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"), + regexp = "DataSHIELD errors" + ) +}) + # context("ds.getWGSR::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..026cf051 100644 --- a/tests/testthat/test-smk-ds.hetcor.R +++ b/tests/testthat/test-smk-ds.hetcor.R @@ -178,6 +178,13 @@ test_that("hetcor", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.hetcor(data = "nonexistent_object"), + regexp = "DataSHIELD errors" + ) +}) + # context("ds.hetcor::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.lexis.R b/tests/testthat/test-smk-ds.lexis.R index c0c30233..13708d58 100644 --- a/tests/testthat/test-smk-ds.lexis.R +++ b/tests/testthat/test-smk-ds.lexis.R @@ -55,6 +55,13 @@ test_that("simple lexis", { # 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"), + regexp = "DataSHIELD errors" + ) +}) + # context("ds.lexis::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.lspline.R b/tests/testthat/test-smk-ds.lspline.R index 08d45470..7f79cadf 100644 --- a/tests/testthat/test-smk-ds.lspline.R +++ b/tests/testthat/test-smk-ds.lspline.R @@ -82,6 +82,13 @@ test_that("lspline", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.lspline(x = "nonexistent_object", knots = c(1, 2)), + regexp = "DataSHIELD errors" + ) +}) + # 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..b805a9f8 100644 --- a/tests/testthat/test-smk-ds.ns.R +++ b/tests/testthat/test-smk-ds.ns.R @@ -86,6 +86,13 @@ test_that("ns", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.ns(x = "nonexistent_object", df = 3), + regexp = "DataSHIELD errors" + ) +}) + # 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..2a169d9e 100644 --- a/tests/testthat/test-smk-ds.qlspline.R +++ b/tests/testthat/test-smk-ds.qlspline.R @@ -131,6 +131,13 @@ test_that("qlspline", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.qlspline(x = "nonexistent_object", q = 3), + regexp = "DataSHIELD errors" + ) +}) + # 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..6b8a50fb 100644 --- a/tests/testthat/test-smk-ds.rowColCalc.R +++ b/tests/testthat/test-smk-ds.rowColCalc.R @@ -49,6 +49,13 @@ 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"), + regexp = "DataSHIELD errors" + ) +}) + # context("ds.rowColCalc::smk::shutdown") test_that("shutdown", { diff --git a/tests/testthat/test-smk-ds.table.R b/tests/testthat/test-smk-ds.table.R index a705d364..4290c338 100644 --- a/tests/testthat/test-smk-ds.table.R +++ b/tests/testthat/test-smk-ds.table.R @@ -150,6 +150,52 @@ test_that("simple table 3D, with assign", { # Done # +test_that("fails if the object does not exist", { + expect_error( + ds.table(rvar = "nonexistent_object"), + regexp = "DataSHIELD errors" + ) +}) + +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'") +}) + # 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..bec4e50c 100644 --- a/tests/testthat/test-smk-ds.tapply.R +++ b/tests/testthat/test-smk-ds.tapply.R @@ -133,6 +133,13 @@ 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"), + regexp = "DataSHIELD errors" + ) +}) + # 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..b3214d79 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,13 @@ 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"), + regexp = "DataSHIELD errors" + ) +}) + # context("ds.tapply.assign::smk::shutdown") test_that("shutdown", {