diff --git a/.Rbuildignore b/.Rbuildignore index 5fa089287..d0f05046a 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -23,3 +23,4 @@ ^\.circleci$ ^\.circleci/config\.yml$ ^\.github$ +^man-roxygen$ diff --git a/DESCRIPTION b/DESCRIPTION index ad8e28a6d..98c096435 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -5,7 +5,7 @@ Description: Base 'DataSHIELD' functions for the client side. 'DataSHIELD' is a you to do non-disclosive federated analysis on sensitive data. 'DataSHIELD' analytic functions have been designed to only share non disclosive summary statistics, with built in automated output checking based on statistical disclosure control. With data sites setting the threshold values for - the automated output checks. For more details, see citation("dsBaseClient"). + the automated output checks. For more details, see citation('dsBaseClient'). Authors@R: c(person(given = "Paul", family = "Burton", role = c("aut"), @@ -56,12 +56,18 @@ Authors@R: c(person(given = "Paul", family = "Wheater", role = c("aut", "cre"), email = "stuart.wheater@arjuna.com", - comment = c(ORCID = "0009-0003-2419-1964"))) + comment = c(ORCID = "0009-0003-2419-1964")), + person(given = "Tim", + family = "Cadman", + role = c("aut"), + comment = c(ORCID = "0000-0002-7682-5645", + affiliation = "Genomics Coordination Centre, UMCG, Netherlands"))) License: GPL-3 Depends: R (>= 4.0.0), DSI (>= 1.7.1) Imports: + cli, fields, metafor, meta, @@ -81,6 +87,6 @@ Suggests: DSOpal, DSMolgenisArmadillo, DSLite -RoxygenNote: 7.3.3 +RoxygenNote: 8.0.0 Encoding: UTF-8 Language: en-GB diff --git a/NAMESPACE b/NAMESPACE index 8bdab82e9..bd539a118 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -119,6 +119,8 @@ export(ds.var) export(ds.vectorCalc) import(DSI) import(data.table) +importFrom(DSI,datashield.connections_find) +importFrom(cli,cli_abort) importFrom(stats,as.formula) importFrom(stats,na.omit) importFrom(stats,ts) diff --git a/R/checkClass.R b/R/checkClass.R index 779eca1e0..08b89bd51 100644 --- a/R/checkClass.R +++ b/R/checkClass.R @@ -13,7 +13,7 @@ checkClass <- function(datasources=NULL, obj=NULL){ # check the class of the input object cally <- call("classDS", obj) - classesBy <- DSI::datashield.aggregate(datasources, cally, async = FALSE) + classesBy <- DSI::datashield.aggregate(datasources, cally) classes <- unique(unlist(classesBy)) for (n in names(classesBy)) { if (!all(classes == classesBy[[n]])) { diff --git a/R/ds.abs.R b/R/ds.abs.R index 41c204551..cc4523f32 100644 --- a/R/ds.abs.R +++ b/R/ds.abs.R @@ -17,6 +17,7 @@ #' the input numeric or integer vector specified in the argument \code{x}. 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{ @@ -72,41 +73,17 @@ #' ds.abs <- function(x=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 object!", 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 internal function that checks the input object(s) is(are) of the same class in all studies. - if(!('numeric' %in% typ) && !('integer' %in% typ)){ - stop("Only objects of type 'numeric' or 'integer' are allowed.", call.=FALSE) - } - - # create a name by default if the user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "abs.newobj" } - # call the server side function that does the operation cally <- call("absDS", x) DSI::datashield.assign(datasources, newobj, cally) - # check that the new object has been created and display a message accordingly - finalcheck <- isAssigned(datasources, newobj) - } diff --git a/R/ds.asCharacter.R b/R/ds.asCharacter.R index c0bd4ce0a..623e43dbe 100644 --- a/R/ds.asCharacter.R +++ b/R/ds.asCharacter.R @@ -13,9 +13,7 @@ #' 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.asCharacter} returns the object converted into a class character -#' that is written to the server-side. Also, two validity messages are returned to the client-side -#' indicating the name of the \code{newobj} which has been created in each data source and if -#' it is in a valid form. +#' that is written to the server-side. #' @examples #' \dontrun{ #' ## Version 6, for version 5 see the Wiki @@ -53,115 +51,22 @@ #' #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.asCharacter <- function(x.name=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.name)){ 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.name) - - # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "ascharacter.newobj" } - # call the server side function that does the job - calltext <- call("asCharacterDS", x.name) - 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.asCharacter diff --git a/R/ds.asDataMatrix.R b/R/ds.asDataMatrix.R index 7b4833bbd..bdfa9fdd0 100644 --- a/R/ds.asDataMatrix.R +++ b/R/ds.asDataMatrix.R @@ -12,11 +12,7 @@ #' 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.asDataMatrix} returns the object converted into a matrix -#' that is written to the server-side. Also, two validity messages are returned -#' to the client-side -#' indicating the name of the \code{newobj} which -#' has been created in each data source and if -#' it is in a valid form. +#' that is written to the server-side. #' @examples #' \dontrun{ #' ## Version 6, for version 5 see the Wiki @@ -54,113 +50,22 @@ #' #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.asDataMatrix <- function(x.name=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.name)){ 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.name) - - # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "asdatamatrix.newobj" } - # call the server side function that does the job calltext <- call("asDataMatrixDS", x.name) 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.asDataMatrix diff --git a/R/ds.asInteger.R b/R/ds.asInteger.R index 9b3b1a397..0e9670df0 100644 --- a/R/ds.asInteger.R +++ b/R/ds.asInteger.R @@ -26,10 +26,7 @@ #' 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.asInteger} returns the R object converted into an integer -#' that is written to the server-side. Also, two validity messages are returned to the -#' client-side indicating the name of the \code{newobj} which -#' has been created in each data source and if -#' it is in a valid form. +#' that is written to the server-side. #' @examples #' \dontrun{ #' ## Version 6, for version 5 see the Wiki @@ -68,109 +65,21 @@ #' #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export ds.asInteger <- function(x.name=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.name)){ 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.name) - - # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "asinteger.newobj" } - # call the server side function that does the job calltext <- call("asIntegerDS", x.name) 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.asInteger diff --git a/R/ds.asList.R b/R/ds.asList.R index d73668785..83007f5a3 100644 --- a/R/ds.asList.R +++ b/R/ds.asList.R @@ -13,9 +13,7 @@ #' 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.asList} returns the R object converted into a list -#' which is written to the server-side. Also, two validity messages are returned to the -#' client-side indicating the name of the \code{newobj} which has been created in each data -#' source and if it is in a valid form. +#' which is written to the server-side. #' @examples #' \dontrun{ #' ## Version 6, for version 5 see the Wiki @@ -54,41 +52,22 @@ #' #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.asList <- function(x.name=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.name)){ 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.name) - - # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "aslist.newobj" } - # call the server side function that does the job - calltext <- call("asListDS", x.name, newobj) - out.message <- DSI::datashield.aggregate(datasources, calltext) -# print(out.message) - -#Don't include assign function completion module as it can print out an unhelpful -#warning message when newobj is a list } -# ds.asList diff --git a/R/ds.asLogical.R b/R/ds.asLogical.R index 2ddc33cfe..85617edcf 100644 --- a/R/ds.asLogical.R +++ b/R/ds.asLogical.R @@ -12,10 +12,7 @@ #' 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.asLogical} returns the R object converted into a logical -#' that is written to the server-side. Also, two validity messages are returned -#' to the client-side indicating the name of the \code{newobj} which -#' has been created in each data source and if -#' it is in a valid form. +#' that is written to the server-side. #' @examples #' \dontrun{ #' ## Version 6, for version 5 see the Wiki @@ -54,113 +51,22 @@ #' #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.asLogical <- function(x.name=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.name)){ 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.name) - - # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "aslogical.newobj" } - # call the server side function that does the job calltext <- call("asLogicalDS", x.name) 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.asLogical diff --git a/R/ds.asMatrix.R b/R/ds.asMatrix.R index 1c5b0ced7..f39803773 100644 --- a/R/ds.asMatrix.R +++ b/R/ds.asMatrix.R @@ -15,9 +15,7 @@ #' 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.asMatrix} returns the object converted into a matrix -#' that is written to the server-side. Also, two validity messages are returned -#' to the client-side indicating the name of the \code{newobj} which -#' has been created in each data source and if it is in a valid form. +#' that is written to the server-side. #' @examples #' \dontrun{ #' ## Version 6, for version 5 see the Wiki @@ -55,113 +53,22 @@ #' #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.asMatrix <- function(x.name=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.name)){ 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.name) - - # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "asmatrix.newobj" } - # call the server side function that does the job calltext <- call("asMatrixDS", x.name) 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.asMatrix diff --git a/R/ds.asNumeric.R b/R/ds.asNumeric.R index 3e2b445fa..803a6308d 100644 --- a/R/ds.asNumeric.R +++ b/R/ds.asNumeric.R @@ -26,10 +26,7 @@ #' 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.asNumeric} returns the R object converted into a numeric class -#' that is written to the server-side. Also, two validity messages are returned -#' to the client-side indicating the name of the \code{newobj} which -#' has been created in each data source and if -#' it is in a valid form. +#' that is written to the server-side. #' @examples #' \dontrun{ #' ## Version 6, for version 5 see the Wiki @@ -68,112 +65,22 @@ #' #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.asNumeric <- function(x.name=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.name)){ 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.name) - - # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "asnumeric.newobj" } - # call the server side function that does the job calltext <- call("asNumericDS", x.name) 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.asNumeric diff --git a/R/ds.class.R b/R/ds.class.R index 036848ad8..ab6e89378 100644 --- a/R/ds.class.R +++ b/R/ds.class.R @@ -11,6 +11,7 @@ #' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}. #' @return \code{ds.class} returns the type of the R object. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @seealso \code{\link{ds.exists}} to verify if an object is defined (exists) on the server-side. #' @examples #' \dontrun{ @@ -54,23 +55,12 @@ #' ds.class <- 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) - } + datasources <- .set_datasources(datasources) if(is.null(x)){ 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, x) - cally <- call('classDS', x) output <- DSI::datashield.aggregate(datasources, cally) diff --git a/R/ds.colnames.R b/R/ds.colnames.R index a4b98b1ad..da842ec0e 100644 --- a/R/ds.colnames.R +++ b/R/ds.colnames.R @@ -12,6 +12,7 @@ #' @return \code{ds.colnames} returns the column names of #' the specified server-side data frame or matrix. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @seealso \code{\link{ds.dim}} to obtain the dimensions of a matrix or a data frame. #' @examples #' \dontrun{ diff --git a/R/ds.completeCases.R b/R/ds.completeCases.R index ed95bf6d3..107f70de6 100644 --- a/R/ds.completeCases.R +++ b/R/ds.completeCases.R @@ -68,123 +68,22 @@ #' } #' #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.completeCases <- function(x1=NULL, newobj=NULL, datasources=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 x1 if(is.null(x1)){ return("Error: x1 must be a character string naming a serverside data.frame, matrix or vector") } - - # check if the input object is defined in all the studies - isDefined(datasources, x1) - - # rename target object for transfer (not strictly necessary as string will pass parser anyway) - # but maintains consistency with other functions - x1.transmit <- x1 - # if no value specified for output object, then specify a default if(is.null(newobj)){ newobj <- paste0(x1,"_complete.cases") } - # CALL THE MAIN SERVER SIDE FUNCTION - calltext <- call("completeCasesDS", x1.transmit) + calltext <- call("completeCasesDS", x1) 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 # - # -#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.completeCases - - diff --git a/R/ds.dataFrameFill.R b/R/ds.dataFrameFill.R index 3de389b7d..d9fced5dc 100644 --- a/R/ds.dataFrameFill.R +++ b/R/ds.dataFrameFill.R @@ -21,7 +21,8 @@ #' client-side indicating the name of the \code{newobj} that has been created in each data source #' and if it is in a valid form. #' @author Demetris Avraam for DataSHIELD Development Team -#' +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' #' @examples #' \dontrun{ #' @@ -134,9 +135,17 @@ ds.dataFrameFill <- function(df.name=NULL, newobj=NULL, datasources=NULL){ defined.vect1 <- lapply(defined.list, function(x){unlist(x)}) defined.vect2 <- lapply(defined.vect1, function(x){which(x == FALSE)}) - # get the class of each variable in the dataframes - class.list <- lapply(allNames, function(x){lapply(datasources, function(dts){DSI::datashield.aggregate(dts, call('classDS', paste0(df.name, '$', x)))})}) - class.vect1 <- lapply(class.list, function(x){unlist(x)}) + # get the class of each variable in the dataframes, skipping servers where the column doesn't exist + class.list <- lapply(seq_along(allNames), function(idx){ + sapply(seq_along(datasources), function(ds_idx){ + if(ds_idx %in% defined.vect2[[idx]]){ + "NULL" + } else { + DSI::datashield.aggregate(datasources[ds_idx], call('classDS', paste0(df.name, '$', allNames[idx])))[[1]] + } + }) + }) + class.vect1 <- class.list # the loop below is to avoid autocompletion of variable name for (i in 1:length(allNames.transmit)){ if(length(defined.vect2[[i]])>0){class.vect1[[i]][defined.vect2[[i]]]<-'NULL'} diff --git a/R/ds.dim.R b/R/ds.dim.R index 4a6cd3a76..519507ef9 100644 --- a/R/ds.dim.R +++ b/R/ds.dim.R @@ -7,21 +7,17 @@ #' from every single study and the pooled dimension of the object by summing up the individual #' dimensions returned from each study. #' -#' In \code{checks} parameter is suggested that checks should only be undertaken once the -#' function call has failed. -#' #' Server function called: \code{dimDS} -#' -#' @param x a character string providing the name of the input object. -#' @param type a character string that represents the type of analysis to carry out. +#' +#' @param x a character string providing the name of the input object. +#' @param type a character string that represents the type of analysis to carry out. #' If \code{type} is set to \code{'combine'}, \code{'combined'}, \code{'combines'} or \code{'c'}, -#' the global dimension is returned. -#' If \code{type} is set to \code{'split'}, \code{'splits'} or \code{'s'}, +#' the global dimension is returned. +#' If \code{type} is set to \code{'split'}, \code{'splits'} or \code{'s'}, #' the dimension is returned separately for each study. #' If \code{type} is set to \code{'both'} or \code{'b'}, both sets of outputs are produced. -#' Default \code{'both'}. -#' @param checks logical. If TRUE undertakes all DataSHIELD checks (time-consuming). -#' Default FALSE. +#' Default \code{'both'}. +#' @template classConsistencyCheck #' @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}}. @@ -29,6 +25,7 @@ #' in the form of a vector where the first #' element indicates the number of rows and the second element indicates the number of columns. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @seealso \code{\link{ds.dataFrame}} to generate a table of the type data frame. #' @seealso \code{\link{ds.changeRefGroup}} to change the reference level of a factor. #' @seealso \code{\link{ds.colnames}} to obtain the column names of a matrix or a data frame @@ -67,68 +64,44 @@ #' # Calculate the dimension #' ds.dim(x="D", #' type="combine", #global dimension -#' checks = FALSE, -#' datasources = connections)#all opal servers are used +#'#' datasources = connections)#all opal servers are used #' ds.dim(x="D", #' type = "both",#separate dimension for each study #' #and the pooled dimension (default) -#' checks = FALSE, -#' datasources = connections)#all opal servers are used +#'#' datasources = connections)#all opal servers are used #' ds.dim(x="D", #' type="split", #separate dimension for each study -#' checks = FALSE, -#' datasources = connections[1])#only the first opal server is used ("study1") +#'#' datasources = connections[1])#only the first opal server is used ("study1") #' #' # clear the Datashield R sessions and logout #' datashield.logout(connections) #' #' } #' -ds.dim <- function(x=NULL, type='both', checks=FALSE, datasources=NULL) { +ds.dim <- function(x=NULL, type='both', classConsistencyCheck=TRUE, 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) } - ######################################################################################################## - # MODULE: GENERIC OPTIONAL CHECKS TO ENSURE CONSISTENT STRUCTURE OF KEY VARIABLES IN DIFFERENT SOURCES # - # beginning of optional checks - the process stops and reports as soon as one check fails # - # # - if(checks){ # - message(" -- Verifying the variables in the model") # - # 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 suitable in all studies # - typ <- checkClass(datasources, x) # - # throw a message and stop if input is not table structure # - if(!('data.frame' %in% typ) & !('matrix' %in% typ)){ # - stop("The input object must be a table structure!", call.=FALSE) # - } # - } # - ######################################################################################################## - - ################################################################################################### #MODULE: EXTEND "type" argument to include "both" and enable valid aliases # if(type == 'combine' | type == 'combined' | type == 'combines' | type == 'c') type <- 'combine' # if(type == 'split' | type == 'splits' | type == 's') type <- 'split' # if(type == 'both' | type == 'b' ) type <- 'both' # - # - #MODIFY FUNCTION CODE TO DEAL WITH ALL THREE TYPES # ################################################################################################### cally <- call("dimDS", x) - dimensions <- DSI::datashield.aggregate(datasources, cally) + results <- DSI::datashield.aggregate(datasources, cally) + + if(classConsistencyCheck){ + .checkClassConsistency(results) + } + + # extract dimensions from results + dimensions <- lapply(results, function(r) r$dim) # names of the studies to be used in the output stdnames <- names(datasources) diff --git a/R/ds.exp.R b/R/ds.exp.R index 5bf325bd8..65102600a 100644 --- a/R/ds.exp.R +++ b/R/ds.exp.R @@ -4,7 +4,7 @@ #' This function is similar to R function \code{exp}. #' @details #' -#' Server function called: \code{exp}. +#' Server function called: \code{expDS}. #' #' @param x a character string providing the name of a numerical vector. #' @param newobj a character string that provides the name for the output variable @@ -15,6 +15,7 @@ #' @return \code{ds.exp} returns a vector for each study of the exponential values for the numeric vector #' specified in the argument \code{x}. The created vectors are stored in the server-side. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -57,42 +58,17 @@ #' ds.exp <- function(x=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 object!", 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 internal function that checks the input object(s) is(are) of the same class in all studies. - if(!('numeric' %in% typ) && !('integer' %in% typ)){ - stop(" Only objects of type 'numeric' and 'integer' are allowed.", call.=FALSE) - } - - # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "exp.newobj" } - # call the server side function that does the job - cally <- paste0('exp(', x, ')') - 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) + cally <- call("expDS", x) + DSI::datashield.assign(datasources, newobj, cally) } diff --git a/R/ds.isNA.R b/R/ds.isNA.R index 1d84577f7..5fa3cd01e 100644 --- a/R/ds.isNA.R +++ b/R/ds.isNA.R @@ -5,98 +5,81 @@ #' @details In certain analyses such as GLM none of the variables should be missing at complete #' (i.e. missing value for each observation). Since in DataSHIELD it is not possible to see the data #' it is important to know whether or not a vector is empty to proceed accordingly. -#' +#' #' Server function called: \code{isNaDS} #' @param x a character string specifying the name of the vector to check. -#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} +#' @template classConsistencyCheck +#' @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.isNA} returns a boolean. If it is TRUE the vector is empty +#' @return \code{ds.isNA} returns a boolean. If it is TRUE the vector is empty #' (all values are NA), FALSE otherwise. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ #' #' ## Version 6, for version 5 see the Wiki -#' +#' #' # connecting to the Opal servers -#' +#' #' require('DSI') #' require('DSOpal') #' require('dsBaseClient') #' #' builder <- DSI::newDSLoginBuilder() -#' builder$append(server = "study1", -#' url = "http://192.168.56.100:8080/", -#' user = "administrator", password = "datashield_test&", +#' builder$append(server = "study1", +#' url = "http://192.168.56.100:8080/", +#' user = "administrator", password = "datashield_test&", #' table = "CNSIM.CNSIM1", driver = "OpalDriver") -#' builder$append(server = "study2", -#' url = "http://192.168.56.100:8080/", -#' user = "administrator", password = "datashield_test&", +#' builder$append(server = "study2", +#' url = "http://192.168.56.100:8080/", +#' user = "administrator", password = "datashield_test&", #' table = "CNSIM.CNSIM2", driver = "OpalDriver") #' builder$append(server = "study3", -#' url = "http://192.168.56.100:8080/", -#' user = "administrator", password = "datashield_test&", +#' url = "http://192.168.56.100:8080/", +#' user = "administrator", password = "datashield_test&", #' table = "CNSIM.CNSIM3", driver = "OpalDriver") #' logindata <- builder$build() -#' -#' connections <- DSI::datashield.login(logins = logindata, assign = TRUE, symbol = "D") -#' +#' +#' connections <- DSI::datashield.login(logins = logindata, assign = TRUE, symbol = "D") +#' #' # check if all the observation of the variable 'LAB_HDL' are missing (NA) #' ds.isNA(x = 'D$LAB_HDL', #' datasources = connections) #all servers are used #' ds.isNA(x = 'D$LAB_HDL', -#' datasources = connections[1]) #only the first server is used (study1) -#' +#' datasources = connections[1]) #only the first server is used (study1) +#' #' #' # clear the Datashield R sessions and logout #' datashield.logout(connections) #' #' } -#' -ds.isNA <- function(x=NULL, datasources=NULL){ - - # look for DS connections - if(is.null(datasources)){ - datasources <- datashield.connections_find() - } +#' +ds.isNA <- function(x=NULL, classConsistencyCheck=TRUE, datasources=NULL){ - # 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) - - # 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.", call.=FALSE) - } - - # name of the studies to be used in the plots' titles stdnames <- names(datasources) - - # name of the variable xnames <- extract(x) varname <- xnames$elements - # keep of the results of the checks for each study - track <- list() + cally <- call("isNaDS", x) + results <- DSI::datashield.aggregate(datasources, cally) + + if(classConsistencyCheck){ + .checkClassConsistency(results) + } - # call server side function 'isNaDS' to check, in each study, if the vector is empty - for(i in 1: length(datasources)){ - cally <- call("isNaDS", x) - out <- DSI::datashield.aggregate(datasources[i], cally) - if(out[[1]]){ + # report per-study if all NA + track <- list() + for(i in 1:length(results)){ + if(results[[i]]$is.na){ track[[i]] <- TRUE message("The variable ", varname, " in ", stdnames[i], " is missing at complete (all values are 'NA').") }else{ diff --git a/R/ds.length.R b/R/ds.length.R index 83cb5cae6..147fe984b 100644 --- a/R/ds.length.R +++ b/R/ds.length.R @@ -14,15 +14,14 @@ #' if \code{type} is set to \code{'both'} or \code{'b'}, #' both sets of outputs are produced. #' Default \code{'both'}. -#' @param checks logical. If TRUE the model components are checked. -#' Default FALSE to save time. It is suggested that checks -#' should only be undertaken once the function call has failed. +#' @template classConsistencyCheck #' @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.length} returns to the client-side the pooled length of a vector or a list, #' or the length of a vector or a list for each study separately. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -74,50 +73,33 @@ #' datashield.logout(connections) #' } #' -ds.length <- function(x=NULL, type='both', checks='FALSE', datasources=NULL){ +ds.length <- function(x=NULL, type='both', classConsistencyCheck=TRUE, datasources=NULL){ + + datasources <- .set_datasources(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) - } - if(is.null(x)){ stop("Please provide the name of the input object!", call.=FALSE) - } - - # beginning of optional checks - the process stops and reports as soon as one check fails - if(checks){ - - # check if the input object is defined in all the studies - isDefined(datasources, x) - - # call the internal function that checks the input object is suitable in all studies - typ <- checkClass(datasources, x) - - # the input object must be a vector or a list - if(!('character' %in% typ) & !('factor' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ) & !('numeric' %in% typ) & !('list' %in% typ)){ - stop("The input object must be a character, factor, integer, logical or numeric vector or a list.", call.=FALSE) - } - - } + } ################################################################################################### - # MODULE: EXTEND "type" argument to include "both" and enable valid alisases # + # MODULE: EXTEND "type" argument to include "both" and enable valid aliases # if(type == 'combine' | type == 'combined' | type == 'combines' | type == 'c') type <- 'combine' # if(type == 'split' | type == 'splits' | type == 's') type <- 'split' # if(type == 'both' | type == 'b' ) type <- 'both' # if(type != 'combine' & type != 'split' & type != 'both'){ # stop('Function argument "type" has to be either "both", "combine" or "split"', call.=FALSE) # } - + # call the server-side function cally <- call("lengthDS", x) - lengths <- DSI::datashield.aggregate(datasources, cally) + results <- DSI::datashield.aggregate(datasources, cally) + + if(classConsistencyCheck){ + .checkClassConsistency(results) + } + + # extract lengths from results + lengths <- lapply(results, function(r) r$length) # names of the studies to be used in the output stdnames <- names(datasources) diff --git a/R/ds.levels.R b/R/ds.levels.R index b32a5d1c6..5dc650b40 100644 --- a/R/ds.levels.R +++ b/R/ds.levels.R @@ -12,6 +12,7 @@ #' @return \code{ds.levels} returns to the client-side the levels of a factor #' class variable stored in the server-side. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -58,35 +59,16 @@ #' ds.levels <- 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) - } + 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) - - # the input object must be a factor - if(!('factor' %in% typ)){ - stop("The input object must be a factor.", call.=FALSE) - } - - # call the server-side function - cally <- paste0("levelsDS(", x, ")") - output <- DSI::datashield.aggregate(datasources, as.symbol(cally)) + cally <- call("levelsDS", x) + results <- DSI::datashield.aggregate(datasources, cally) + output <- lapply(results, function(r) list(Levels = r$Levels)) return(output) - + } diff --git a/R/ds.log.R b/R/ds.log.R index 8c0b2e5d2..cfa2155f2 100644 --- a/R/ds.log.R +++ b/R/ds.log.R @@ -2,7 +2,7 @@ #' @title Computes logarithms in the server-side #' @description Computes the logarithms for a specified numeric vector. #' This function is similar to the R \code{log} function. by default natural logarithms. -#' @details Server function called: \code{log} +#' @details Server function called: \code{logDS} #' @param x a character string providing the name of a numerical vector. #' @param base a positive number, the base for which logarithms are computed. #' Default \code{exp(1)}. @@ -14,6 +14,7 @@ #' @return \code{ds.log} returns a vector for each study of the transformed values for the numeric vector #' specified in the argument \code{x}. The created vectors are stored in the server-side. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -57,42 +58,17 @@ #' ds.log <- function(x=NULL, base=exp(1), 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 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) - - # the input object must be a vector - if(!('integer' %in% typ) & !('numeric' %in% typ)){ - message(paste0(x, " is of type ", typ, "!")) - stop("The input object must be an integer or numeric vector.", call.=FALSE) - } - - # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "log.newobj" } - # call the server side function that does the job - cally <- paste0("log(", x, ",", base, ")") - 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) + cally <- call("logDS", x, base) + DSI::datashield.assign(datasources, newobj, cally) } diff --git a/R/ds.ls.R b/R/ds.ls.R index 2f65a3c8f..ce96c9015 100644 --- a/R/ds.ls.R +++ b/R/ds.ls.R @@ -61,6 +61,7 @@ #' specified R server-side environment;\cr #' (3) the nature of the search filter string as it was applied. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @examples #' \dontrun{ #' @@ -117,15 +118,8 @@ #' #' @export ds.ls <- function(search.filter=NULL, env.to.search=1L, search.GlobalEnv=TRUE, datasources=NULL){ - - 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) # make default to .GlobalEnv unambiguous if(search.GlobalEnv||is.null(env.to.search)){ @@ -191,7 +185,7 @@ if(!is.null(transmit.object)) # call the server side function calltext <- call("lsDS", search.filter=transmit.object.final, env.to.search) - output <- datashield.aggregate(datasources, calltext) + output <- DSI::datashield.aggregate(datasources, calltext) return(output) diff --git a/R/ds.names.R b/R/ds.names.R index 97ebbdfd7..e348f0021 100644 --- a/R/ds.names.R +++ b/R/ds.names.R @@ -20,6 +20,7 @@ #' of a list object stored on the server-side. #' @author Amadou Gaye, updated by Paul Burton for DataSHIELD development #' team 25/06/2020 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -68,25 +69,14 @@ #' ds.names <- function(xname=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(xname)){ stop("Please provide the name of the input list!", call.=FALSE) } - - # check if the input object is defined in all the studies - isDefined(datasources, xname) calltext <- call("namesDS", xname) - output <- datashield.aggregate(datasources, calltext) + output <- DSI::datashield.aggregate(datasources, calltext) return(output) } #ds.names diff --git a/R/ds.numNA.R b/R/ds.numNA.R index 0bd75185a..4d7bb6d7d 100644 --- a/R/ds.numNA.R +++ b/R/ds.numNA.R @@ -6,13 +6,15 @@ #' @details The number of missing entries are counted and the total for each study is returned. #' #' Server function called: \code{numNaDS} -#' @param x a character string specifying the name of the vector. +#' @param x a character string specifying the name of the vector. +#' @template classConsistencyCheck #' @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.numNA} returns to the client-side the number of missing values #' on a server-side vector. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -52,31 +54,21 @@ #' #' } #' -ds.numNA <- function(x=NULL, datasources=NULL){ +ds.numNA <- function(x=NULL, classConsistencyCheck=TRUE, 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 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) + cally <- call("numNaDS", x) + results <- DSI::datashield.aggregate(datasources, cally) - # call the server side function - cally <- paste0("numNaDS(", x, ")") - numNAs <- DSI::datashield.aggregate(datasources, as.symbol(cally)) + if(classConsistencyCheck){ + .checkClassConsistency(results) + } + numNAs <- lapply(results, function(r) r$numNA) return(numNAs) } diff --git a/R/ds.quantileMean.R b/R/ds.quantileMean.R index 48aa705b4..c658edc9d 100644 --- a/R/ds.quantileMean.R +++ b/R/ds.quantileMean.R @@ -21,6 +21,7 @@ #' @return \code{ds.quantileMean} returns to the client-side the quantiles and statistical mean #' of a server-side numeric vector. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @seealso \code{\link{ds.mean}} to compute the statistical mean. #' @seealso \code{\link{ds.summary}} to generate the summary of a variable. #' @export @@ -103,9 +104,11 @@ ds.quantileMean <- function(x=NULL, type='combine', datasources=NULL){ # combine the vector of quantiles - using weighted sum cally2 <- call('lengthDS', x) - lengths <- DSI::datashield.aggregate(datasources, cally2) - cally3 <- paste0("numNaDS(", x, ")") - numNAs <- DSI::datashield.aggregate(datasources, as.symbol(cally3)) + lengths.raw <- DSI::datashield.aggregate(datasources, cally2) + lengths <- lapply(lengths.raw, function(r) r$length) + cally3 <- call("numNaDS", x) + numNAs.raw <- DSI::datashield.aggregate(datasources, cally3) + numNAs <- lapply(numNAs.raw, function(r) r$numNA) global.quantiles <- rep(0, length(quants[[1]])-1) global.mean <- 0 for(i in 1: length(datasources)){ diff --git a/R/ds.recodeLevels.R b/R/ds.recodeLevels.R index a22d25b31..32bf30e62 100644 --- a/R/ds.recodeLevels.R +++ b/R/ds.recodeLevels.R @@ -19,6 +19,7 @@ #' @return \code{ds.recodeLevels} returns to the server-side a variable of type factor #' with the replaces levels. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -97,8 +98,8 @@ ds.recodeLevels <- function(x=NULL, newCategories=NULL, newobj=NULL, datasources } # get the current number of levels - cally <- paste0("levelsDS(", x, ")") - xx <- DSI::datashield.aggregate(datasources, as.symbol(cally)) + cally <- call("levelsDS", x) + xx <- DSI::datashield.aggregate(datasources, cally) all.study.levels <- c() for (study.levels in xx) { if (any(is.na(study.levels$Levels))) diff --git a/R/ds.replaceNA.R b/R/ds.replaceNA.R index 28a51adb1..18d6ca681 100644 --- a/R/ds.replaceNA.R +++ b/R/ds.replaceNA.R @@ -26,6 +26,7 @@ #' with the missing values replaced by the specified values. #' The class of the vector is the same as the initial vector. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -123,7 +124,7 @@ ds.replaceNA <- function(x=NULL, forNA=NULL, newobj=NULL, datasources=NULL){ # number of missing values stop the process and tell the analyst cally <- call("numNaDS", x) numNAs <- DSI::datashield.aggregate(datasources[i], cally) - if(length(forNA[[i]]) != 1 & length(forNA[[i]]) != numNAs[[1]]){ + if(length(forNA[[i]]) != 1 & length(forNA[[i]]) != numNAs[[1]]$numNA){ message("The number of replacement values must be of length 1 or of the same length as the number of missing values.") stop(paste0("This is not the case in ", names(datasources)[i]), call.=FALSE) } diff --git a/R/ds.rowColCalc.R b/R/ds.rowColCalc.R index d531cce47..312e19c58 100644 --- a/R/ds.rowColCalc.R +++ b/R/ds.rowColCalc.R @@ -19,6 +19,7 @@ #' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}. #' @return \code{ds.rowColCalc} returns to the server-side rows and columns sums and means. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @examples #' \dontrun{ #' @@ -100,10 +101,10 @@ ds.rowColCalc <- function(x=NULL, operation=NULL, newobj=NULL, datasources=NULL) dim2 <- c() for(i in 1:numsources){ dims <- DSI::datashield.aggregate(datasources[i], call("dimDS", x)) - if(length(dims[[1]]) != 2){ + 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]][2]) + dim2 <- append(dim2, dims[[1]]$dim[2]) } # check that, for each study, all the columns of the input table are of 'numeric' type diff --git a/R/ds.sqrt.R b/R/ds.sqrt.R index e78011def..3aef21937 100644 --- a/R/ds.sqrt.R +++ b/R/ds.sqrt.R @@ -17,6 +17,7 @@ #' the input numeric or integer vector specified in the argument \code{x}. 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{ @@ -70,41 +71,17 @@ #' ds.sqrt <- function(x=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 object!", 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 internal function that checks the input object(s) is(are) of the same class in all studies. - if(!('numeric' %in% typ) && !('integer' %in% typ)){ - stop("Only objects of type 'numeric' or 'integer' are allowed.", call.=FALSE) - } - - # create a name by default if the user did not provide a name for the new variable if(is.null(newobj)){ newobj <- "sqrt.newobj" } - # call the server side function that does the operation cally <- call("sqrtDS", x) DSI::datashield.assign(datasources, newobj, cally) - # check that the new object has been created and display a message accordingly - finalcheck <- isAssigned(datasources, newobj) - } diff --git a/R/ds.subsetByClass.R b/R/ds.subsetByClass.R index b3b14ec27..5470e6148 100644 --- a/R/ds.subsetByClass.R +++ b/R/ds.subsetByClass.R @@ -15,6 +15,7 @@ #' the default set of connections will be used: see \link[DSI]{datashield.connections_default}. #' @return a no data are return to the user but messages are printed out. #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @seealso \link{ds.meanByClass} to compute mean and standard deviation across categories of a factor vectors. #' @seealso \link{ds.subset} to subset by complete cases (i.e. removing missing values), threshold, columns and rows. #' @export @@ -91,7 +92,7 @@ ds.subsetByClass <- function(x=NULL, subsets="subClasses", variables=NULL, datas cols <- DSI::datashield.aggregate(datasources[i], call("colnamesDS", x)) dims <- DSI::datashield.aggregate(datasources[i], call("dimDS", x)) tracker <-c() - for(j in 1:dims[[1]][2]){ + for(j in 1:dims[[1]]$dim[2]){ cally <- call("classDS", paste0(dtname, "$", cols[[1]][j])) res <- DSI::datashield.aggregate(datasources[i], cally) if(res[[1]] != 'factor'){ diff --git a/R/ds.summary.R b/R/ds.summary.R index 2d86287b1..0d0f6301a 100644 --- a/R/ds.summary.R +++ b/R/ds.summary.R @@ -19,6 +19,7 @@ #' such as the minimum and maximum values of numeric vectors are not returned. #' The summary is given for each study separately. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -102,8 +103,8 @@ ds.summary <- function(x=NULL, datasources=NULL){ validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]] if(validity){ dims <- DSI::datashield.aggregate(datasources[i], call('dimDS', x)) - r <- dims[[1]][1] - c <- dims[[1]][2] + r <- dims[[1]]$dim[1] + c <- dims[[1]]$dim[2] cols <- (DSI::datashield.aggregate(datasources[i], call('colnamesDS', x)))[[1]] stdsummary <- list('class'=typ, 'number of rows'=r, 'number of columns'=c, 'variables held'=cols) finalOutput[[i]] <- stdsummary @@ -118,7 +119,7 @@ ds.summary <- function(x=NULL, datasources=NULL){ for(i in 1:numsources){ validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]] if(validity){ - l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]] + l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length stdsummary <- list('class'=typ, 'length'=l) finalOutput[[i]] <- stdsummary }else{ @@ -132,8 +133,8 @@ ds.summary <- function(x=NULL, datasources=NULL){ for(i in 1:numsources){ validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]] if(validity){ - l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]] - levels.resp <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('levelsDS(', x, ')' )))[[1]] + l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length + levels.resp <- DSI::datashield.aggregate(datasources[i], call('levelsDS', x))[[1]] categories <- levels.resp$Levels freq <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('table1DDS(', x, ')' )))[[1]][1] stdsummary <- list('class'=typ, 'length'=l, 'categories'=categories) @@ -153,7 +154,7 @@ ds.summary <- function(x=NULL, datasources=NULL){ for(i in 1:numsources){ validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]] if(validity){ - l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]] + l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length q <- (DSI::datashield.aggregate(datasources[i], as.symbol(paste0('quantileMeanDS(', x, ')' ))))[[1]] stdsummary <- list('class'=typ, 'length'=l, 'quantiles & mean'=q) finalOutput[[i]] <- stdsummary @@ -167,7 +168,7 @@ ds.summary <- function(x=NULL, datasources=NULL){ if("list" %in% typ){ for(i in 1:numsources){ - l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]] + l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length elts <- DSI::datashield.aggregate(datasources[i], call('namesDS', x)) if(length(elts) == 0){ elts <- NULL @@ -188,7 +189,7 @@ ds.summary <- function(x=NULL, datasources=NULL){ for(i in 1:numsources){ validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]] if(validity){ - l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]] + l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length freq <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('table1DDS(', x, ')' )))[[1]][1] stdsummary <- list('class'=typ, 'length'=l) for(j in 1:length(2)){ diff --git a/R/ds.unique.R b/R/ds.unique.R index 8f2717054..dd8e5e532 100644 --- a/R/ds.unique.R +++ b/R/ds.unique.R @@ -43,32 +43,22 @@ #' datashield.logout(connections) #' } #' @author Stuart Wheater, DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.unique <- function(x.name = 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.name)) { stop("x.name=NULL. Please provide the names of the objects to de-duplicated!", call. = FALSE) } - # create a name by default if user did not provide a name for the new variable if (is.null(newobj)) { newobj <- "unique.newobj" } - # call the server side function that does the job cally <- call('uniqueDS', x.name) DSI::datashield.assign(datasources, newobj, cally) - # check that the new object has been created and display a message accordingly - finalcheck <- isAssigned(datasources, newobj) } diff --git a/R/glmChecks.R b/R/glmChecks.R index 6dcfe2ee7..152b80bf9 100644 --- a/R/glmChecks.R +++ b/R/glmChecks.R @@ -17,6 +17,7 @@ #' @keywords internal #' @return an integer 0 if check was passed and 1 if failed #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' glmChecks <- function(formula, data, offset, weights, datasources){ @@ -71,7 +72,7 @@ glmChecks <- function(formula, data, offset, weights, datasources){ if(!(myterms[2] %in% clnames)){ stop(paste0("'", myterms[2], "' is not defined in ", stdnames[j], "!"), call.=FALSE) }else{ - call0 <- paste0("isNaDS(", elts[i], ")") + call0 <- call("isNaDS", elts[i]) if(varIdentifier[i] == "offset" | varIdentifier[i] == "weights"){ typ <- checkClass(datasources, elts[i]) } if(varIdentifier[i] == "weights"){ call1 <- paste0("checkNegValueDS(", elts[i], ")") } } @@ -82,24 +83,24 @@ glmChecks <- function(formula, data, offset, weights, datasources){ clnames <- unlist(DSI::datashield.aggregate(datasources[j], cally)) if(!(elts[i] %in% clnames)){ dd <- isDefined(datasources, elts[i]) - call0 <- paste0("isNaDS(", elts[i], ")") + call0 <- call("isNaDS", elts[i]) if(varIdentifier[i] == "offset" | varIdentifier[i] == "weights"){ typ <- checkClass(datasources, elts[i]) } if(varIdentifier[i] == "weights"){ call1 <- paste0("checkNegValueDS(", elts[i], ")") } }else{ - call0 <- paste0("isNaDS(", paste0(data, "$", elts[i]), ")") + call0 <- call("isNaDS", paste0(data, "$", elts[i])) if(varIdentifier[i] == "offset" | varIdentifier[i] == "weights"){ typ <- checkClass(datasources, paste0(data, "$", elts[i])) } if(varIdentifier[i] == "weights"){ call1 <- paste0("checkNegValueDS(", paste0(data, "$", elts[i]), ")") } } }else{ defined <- isDefined(datasources, elts[i]) - call0 <- paste0("isNaDS(", elts[i], ")") + call0 <- call("isNaDS", elts[i]) if(varIdentifier[i] == "offset" | varIdentifier[i] == "weights"){ typ <- checkClass(datasources, elts[i]) } if(varIdentifier[i] == "weights"){ call1 <- paste0("checkNegValueDS(", elts[i], ")") } } } # check if variable is not missing at complete - out1 <- DSI::datashield.aggregate(datasources[j], as.symbol(call0)) - if(out1[[1]]){ + out1 <- DSI::datashield.aggregate(datasources[j], call0) + if(out1[[1]]$is.na){ stop("The variable ", elts[i], " in ", stdnames[j], " is missing at complete (all values are 'NA').", call.=FALSE) } # if offset and or weights are set check they are numeric and for weights that it does not hold negative value diff --git a/R/meanByClassHelper0b.R b/R/meanByClassHelper0b.R index 89c1c17d6..0c37b9e43 100644 --- a/R/meanByClassHelper0b.R +++ b/R/meanByClassHelper0b.R @@ -15,6 +15,7 @@ #' and standard deviation in each subgroup (subset). #' @keywords internal #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' meanByClassHelper0b <- function(x, outvar, covar, type, datasources){ if(is.null(outvar)){ @@ -32,14 +33,14 @@ meanByClassHelper0b <- function(x, outvar, covar, type, datasources){ # categories in each of the categorical variables classes <- vector("list", length(covar)) for(i in 1:length(covar)){ - cally <- paste0("levelsDS(",paste0(x, '$', covar[i]), ")") + cally <- call("levelsDS", paste0(x, '$', covar[i])) all.study.levels <- list() - full.levels.resp <- DSI::datashield.aggregate(datasources, as.symbol(cally)) + full.levels.resp <- DSI::datashield.aggregate(datasources, cally) for (index in 1:length(full.levels.resp)) { - if (any(is.na(full.levels.resp[[i]]$Levels))) - stop(paste0("Failed to get levels from study: ", full.levels.resp[[i]]$ValidityMessage), call.=FALSE) - all.study.levels[[index]] <- full.levels.resp[[i]]$Levels + if (any(is.na(full.levels.resp[[index]]$Levels))) + stop(paste0("Failed to get levels from study"), call.=FALSE) + all.study.levels[[index]] <- full.levels.resp[[index]]$Levels } classes[[i]] <- all.study.levels } diff --git a/R/meanByClassHelper2.R b/R/meanByClassHelper2.R index 55dca1c33..aa7667ba0 100644 --- a/R/meanByClassHelper2.R +++ b/R/meanByClassHelper2.R @@ -12,6 +12,7 @@ #' @return a matrix, a table which contains the length, mean and standard deviation of each of the #' specified 'variables' in each subset table. #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' meanByClassHelper2 <- function(dtsources, tablenames, variables, invalidrecorder){ numtables <- length(tablenames[[1]]) @@ -43,8 +44,8 @@ meanByClassHelper2 <- function(dtsources, tablenames, variables, invalidrecorder def <- unlist(DSI::datashield.aggregate(dtsources[qq], cally)) if(def){ cally <- call("dimDS", tnames[[qq]][i]) - temp <- unlist(DSI::datashield.aggregate(dtsources[qq], cally)) - lengths <- append(lengths, temp[1]) + temp <- DSI::datashield.aggregate(dtsources[qq], cally) + lengths <- append(lengths, temp[[1]]$dim[1]) }else{ lengths <- append(lengths, 0) } @@ -66,8 +67,8 @@ meanByClassHelper2 <- function(dtsources, tablenames, variables, invalidrecorder } }else{ cally <- call("lengthDS", paste0(tablename,'$',variables[z])) - lengths <- DSI::datashield.aggregate(dtsources, cally) - ll <- sum(unlist(lengths)) + lengths.raw <- DSI::datashield.aggregate(dtsources, cally) + ll <- sum(sapply(lengths.raw, function(r) r$length)) mm <- round(getPooledMean(dtsources, paste0(tablename,'$',variables[z])),2) sdv <- round(getPooledVar(dtsources, paste0(tablename,'$',variables[z])),2) if(is.na(mm)){ sdv <- NA} diff --git a/R/meanByClassHelper3.R b/R/meanByClassHelper3.R index 4c834b78a..3c753776c 100644 --- a/R/meanByClassHelper3.R +++ b/R/meanByClassHelper3.R @@ -11,6 +11,7 @@ #' @keywords internal #' @return a list which one results table for each study. #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' meanByClassHelper3 <- function(dtsources, tablenames, variables, invalidrecorder){ numtables <- length(tablenames[[1]]) @@ -36,14 +37,14 @@ meanByClassHelper3 <- function(dtsources, tablenames, variables, invalidrecorder if(length(rc) > 0){ cally <- call("lengthDS", paste0(tablenames[[s]][i],'$',variables[z])) - ll <- unlist(DSI::datashield.aggregate(dtsources[s], cally)) + ll <- DSI::datashield.aggregate(dtsources[s], cally)[[1]]$length mm <- NA sdv <- NA mean.sd <- paste0(mm, '(', sdv, ')') entries <- c(ll, mean.sd) }else{ cally <- call("lengthDS", paste0(tablenames[[s]][i],'$',variables[z])) - ll <- unlist(DSI::datashield.aggregate(dtsources[s], cally)) + ll <- DSI::datashield.aggregate(dtsources[s], cally)[[1]]$length mm <- round(getPooledMean(dtsources[s], paste0(tablenames[[s]][i],'$',variables[z])),2) sdv <- round(getPooledVar(dtsources[s], paste0(tablenames[[s]][i],'$',variables[z])),2) if(is.na(mm)){ sdv <- NA } diff --git a/R/subsetHelper.R b/R/subsetHelper.R index 025a06803..62648552c 100644 --- a/R/subsetHelper.R +++ b/R/subsetHelper.R @@ -61,13 +61,13 @@ subsetHelper <- function(dts, data, rs=NULL, cs=NULL){ fail <- c(0,0) if(!(is.null(rs))){ - if(length(rs) > dims[[1]][1] ){ + if(length(rs) > dims[[1]]$dim[1] ){ fail[1] <- 1 } } if(!(is.null(cs))){ - if(length(cs) > dims[[1]][2]){ + if(length(cs) > dims[[1]]$dim[2]){ fail[2] <- 1 } } diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 000000000..83526df73 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,74 @@ +#' Retrieve datasources if not specified +#' +#' @param datasources An optional list of data sources. If not provided, the function will attempt +#' to find available data sources. +#' @importFrom DSI datashield.connections_find +#' @return A list of data sources. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.get_datasources <- function(datasources) { + if (is.null(datasources)) { + datasources <- datashield.connections_find() + } + return(datasources) +} + +#' Verify that the provided data sources are of class 'DSConnection'. +#' +#' @param datasources A list of data sources. +#' @importFrom cli cli_abort +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.verify_datasources <- function(datasources) { + is_connection_class <- sapply(datasources, function(x) inherits(unlist(x), "DSConnection")) + if (!all(is_connection_class)) { + cli_abort("The 'datasources' were expected to be a list of DSConnection-class objects") + } +} + +#' Set and verify data sources. +#' +#' @param datasources An optional list of data sources. If not provided, the function will attempt +#' to find available data sources. +#' @return A list of verified data sources. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.set_datasources <- function(datasources) { + datasources <- .get_datasources(datasources) + .verify_datasources(datasources) + return(datasources) +} + +#' Check cross-study class consistency from a list of server aggregate results +#' +#' Batch-refactored server functions return a list per study that includes a +#' `class` field. This helper verifies that the class field is identical across +#' all studies and aborts if not. +#' +#' @param results A named list of server-side aggregate results, one per study, +#' each containing a `class` element. +#' @importFrom cli cli_abort +#' @return Invisibly returns `NULL`. Called for its side effect (error checking). +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.checkClassConsistency <- function(results) { + classes <- lapply(results, function(r) r$class) + if (length(unique(lapply(classes, sort))) > 1) { + cli_abort("The input object is not of the same class in all studies!") + } +} + +#' Check That a Data Frame Name Is Provided +#' +#' Internal helper that checks whether a data frame or matrix object +#' has been provided. If `NULL`, it aborts with a user-friendly error. +#' +#' @param df A data.frame or matrix. +#' @return Invisibly returns `NULL`. Called for its side effect (error checking). +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @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) + } +} diff --git a/azure-pipelines.yml b/azure-pipelines.yml index b541a3903..3844edebf 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -221,7 +221,9 @@ jobs: sleep 60 - R -q -e "library(opalr); opal <- opal.login('administrator','datashield_test&', url='http://localhost:8080/'); dsadmin.set_option(opal, 'default.datashield.privacyControlLevel', 'permissive'); opal.logout(opal)" + R -q -e "library(opalr); opal <- opal.login('administrator', 'datashield_test&', url='http://localhost:8080/'); dsadmin.profile_init(opal, name = 'default', packages = c('dsBase', 'dsTidyverse', 'resourcer')); opal.logout(opal)" + + R -q -e "library(opalr); opal <- opal.login('administrator', 'datashield_test&', url='http://localhost:8080/'); dsadmin.set_option(opal, 'default.datashield.privacyControlLevel', 'permissive'); opal.logout(opal)" workingDirectory: $(Pipeline.Workspace)/dsBaseClient/tests/testthat/data_files displayName: 'Install dsBase to Opal, as set disclosure test options' diff --git a/docker-compose_armadillo.yml b/docker-compose_armadillo.yml index 37c44cdae..dba71daf8 100644 --- a/docker-compose_armadillo.yml +++ b/docker-compose_armadillo.yml @@ -3,11 +3,12 @@ services: hostname: armadillo ports: - 8080:8080 - image: datashield/armadillo_citest:5.11.0 + image: datashield/armadillo_citest:latest environment: LOGGING_CONFIG: 'classpath:logback-file.xml' AUDIT_LOG_PATH: '/app/logs/audit.log' SPRING_SECURITY_USER_PASSWORD: 'admin' + DEBUG: "FALSE" volumes: - ./tests/docker/armadillo/standard/logs:/logs - ./tests/docker/armadillo/standard/data:/data @@ -16,7 +17,6 @@ services: default: hostname: default - image: datashield/rock-quebrada-lamda:latest -# image: datashield/rserver-panda-lamda:devel + image: datashield/rock_citest-permissive:latest environment: DEBUG: "FALSE" diff --git a/docker-compose_opal.yml b/docker-compose_opal.yml index a62dec679..70bffd8d1 100644 --- a/docker-compose_opal.yml +++ b/docker-compose_opal.yml @@ -3,6 +3,7 @@ services: image: datashield/opal_citest:latest ports: - 8443:8443 + - 8080:8080 links: - mongo - rock @@ -15,11 +16,11 @@ services: - ROCK_HOSTS=rock:8085 - ROCK_ADMINISTRATOR_PASSWORD=foobar mongo: - image: mongo:4.4.15 + image: mongo:8.0 environment: - MONGO_INITDB_ROOT_USERNAME=root - MONGO_INITDB_ROOT_PASSWORD=foobar rock: - image: datashield/rock-quebrada-lamda-permissive:latest + image: datashield/rock_citest-permissive:latest environment: DEBUG: "FALSE" diff --git a/dsBase_7.0.0-permissive.tar.gz b/dsBase_7.0.0-permissive.tar.gz index ab4b862e2..f726b66b1 100644 Binary files a/dsBase_7.0.0-permissive.tar.gz and b/dsBase_7.0.0-permissive.tar.gz differ diff --git a/dsBase_7.0.0.tar.gz b/dsBase_7.0.0.tar.gz index 8f108fff6..2d82fb7e7 100644 Binary files a/dsBase_7.0.0.tar.gz and b/dsBase_7.0.0.tar.gz differ diff --git a/man-roxygen/classConsistencyCheck.R b/man-roxygen/classConsistencyCheck.R new file mode 100644 index 000000000..18b979964 --- /dev/null +++ b/man-roxygen/classConsistencyCheck.R @@ -0,0 +1,2 @@ +#' @param classConsistencyCheck logical. If TRUE, checks that the input object has the same +#' class across all studies. Default TRUE. diff --git a/man/ds.abs.Rd b/man/ds.abs.Rd index 639ebd3e9..6cd9404d8 100644 --- a/man/ds.abs.Rd +++ b/man/ds.abs.Rd @@ -87,4 +87,6 @@ specified by the user through the argument \code{newobj}, otherwise is named by } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.asCharacter.Rd b/man/ds.asCharacter.Rd index 447d9cf9e..e557c9fc1 100644 --- a/man/ds.asCharacter.Rd +++ b/man/ds.asCharacter.Rd @@ -19,9 +19,7 @@ the default set of connections will be used: see \code{\link[DSI]{datashield.con } \value{ \code{ds.asCharacter} returns the object converted into a class character -that is written to the server-side. Also, two validity messages are returned to the client-side -indicating the name of the \code{newobj} which has been created in each data source and if -it is in a valid form. +that is written to the server-side. } \description{ Converts the input object into a character class. @@ -69,4 +67,6 @@ Server function called: \code{asCharacterDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.asDataMatrix.Rd b/man/ds.asDataMatrix.Rd index e6ea9eb9c..d9e253e6a 100644 --- a/man/ds.asDataMatrix.Rd +++ b/man/ds.asDataMatrix.Rd @@ -19,11 +19,7 @@ the default set of connections will be used: see \code{\link[DSI]{datashield.con } \value{ \code{ds.asDataMatrix} returns the object converted into a matrix -that is written to the server-side. Also, two validity messages are returned -to the client-side -indicating the name of the \code{newobj} which -has been created in each data source and if -it is in a valid form. +that is written to the server-side. } \description{ Coerces an R object into a matrix maintaining original @@ -73,4 +69,6 @@ Server function called: \code{asDataMatrixDS}. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.asInteger.Rd b/man/ds.asInteger.Rd index d2f0455be..0bf7ab473 100644 --- a/man/ds.asInteger.Rd +++ b/man/ds.asInteger.Rd @@ -19,10 +19,7 @@ the default set of connections will be used: see \code{\link[DSI]{datashield.con } \value{ \code{ds.asInteger} returns the R object converted into an integer -that is written to the server-side. Also, two validity messages are returned to the -client-side indicating the name of the \code{newobj} which -has been created in each data source and if -it is in a valid form. +that is written to the server-side. } \description{ Coerces an R object into an integer class. @@ -86,4 +83,6 @@ Server function called: \code{asIntegerDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.asList.Rd b/man/ds.asList.Rd index 1e2e3c733..6af6f9607 100644 --- a/man/ds.asList.Rd +++ b/man/ds.asList.Rd @@ -19,9 +19,7 @@ the default set of connections will be used: see \code{\link[DSI]{datashield.con } \value{ \code{ds.asList} returns the R object converted into a list -which is written to the server-side. Also, two validity messages are returned to the -client-side indicating the name of the \code{newobj} which has been created in each data -source and if it is in a valid form. +which is written to the server-side. } \description{ Coerces an R object into a list. @@ -70,4 +68,6 @@ Server function called: \code{asListDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.asLogical.Rd b/man/ds.asLogical.Rd index c42d2e6aa..ec539cc33 100644 --- a/man/ds.asLogical.Rd +++ b/man/ds.asLogical.Rd @@ -19,10 +19,7 @@ the default set of connections will be used: see \code{\link[DSI]{datashield.con } \value{ \code{ds.asLogical} returns the R object converted into a logical -that is written to the server-side. Also, two validity messages are returned -to the client-side indicating the name of the \code{newobj} which -has been created in each data source and if -it is in a valid form. +that is written to the server-side. } \description{ Coerces an R object into a logical class. @@ -71,4 +68,6 @@ Server function called: \code{asLogicalDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.asMatrix.Rd b/man/ds.asMatrix.Rd index 709480148..8116ac1d1 100644 --- a/man/ds.asMatrix.Rd +++ b/man/ds.asMatrix.Rd @@ -19,9 +19,7 @@ the default set of connections will be used: see \code{\link[DSI]{datashield.con } \value{ \code{ds.asMatrix} returns the object converted into a matrix -that is written to the server-side. Also, two validity messages are returned -to the client-side indicating the name of the \code{newobj} which -has been created in each data source and if it is in a valid form. +that is written to the server-side. } \description{ Coerces an R object into a matrix. @@ -74,4 +72,6 @@ Server function called: \code{asMatrixDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.asNumeric.Rd b/man/ds.asNumeric.Rd index 9928942a5..73f03693f 100644 --- a/man/ds.asNumeric.Rd +++ b/man/ds.asNumeric.Rd @@ -19,10 +19,7 @@ the default set of connections will be used: see \code{\link[DSI]{datashield.con } \value{ \code{ds.asNumeric} returns the R object converted into a numeric class -that is written to the server-side. Also, two validity messages are returned -to the client-side indicating the name of the \code{newobj} which -has been created in each data source and if -it is in a valid form. +that is written to the server-side. } \description{ Coerces an R object into a numeric class. @@ -85,4 +82,6 @@ Server function called: \code{asNumericDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.class.Rd b/man/ds.class.Rd index b2fc0f07c..861eeddc9 100644 --- a/man/ds.class.Rd +++ b/man/ds.class.Rd @@ -69,4 +69,6 @@ Server function called: \code{classDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.colnames.Rd b/man/ds.colnames.Rd index e73910812..6915dd592 100644 --- a/man/ds.colnames.Rd +++ b/man/ds.colnames.Rd @@ -66,4 +66,6 @@ Server function called: \code{colnamesDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.completeCases.Rd b/man/ds.completeCases.Rd index f5df76586..8a8f4ea4f 100644 --- a/man/ds.completeCases.Rd +++ b/man/ds.completeCases.Rd @@ -85,4 +85,6 @@ Server function called: \code{completeCasesDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.dataFrameFill.Rd b/man/ds.dataFrameFill.Rd index 44eef9e55..54775443f 100644 --- a/man/ds.dataFrameFill.Rd +++ b/man/ds.dataFrameFill.Rd @@ -89,4 +89,6 @@ Server function called: \code{dataFrameFillDS} } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.dim.Rd b/man/ds.dim.Rd index ea3aaa6d1..338ee25fe 100644 --- a/man/ds.dim.Rd +++ b/man/ds.dim.Rd @@ -4,21 +4,26 @@ \alias{ds.dim} \title{Retrieves the dimension of a server-side R object} \usage{ -ds.dim(x = NULL, type = "both", checks = FALSE, datasources = NULL) +ds.dim( + x = NULL, + type = "both", + classConsistencyCheck = TRUE, + datasources = NULL +) } \arguments{ \item{x}{a character string providing the name of the input object.} -\item{type}{a character string that represents the type of analysis to carry out. +\item{type}{a character string that represents the type of analysis to carry out. If \code{type} is set to \code{'combine'}, \code{'combined'}, \code{'combines'} or \code{'c'}, - the global dimension is returned. -If \code{type} is set to \code{'split'}, \code{'splits'} or \code{'s'}, + the global dimension is returned. +If \code{type} is set to \code{'split'}, \code{'splits'} or \code{'s'}, the dimension is returned separately for each study. If \code{type} is set to \code{'both'} or \code{'b'}, both sets of outputs are produced. Default \code{'both'}.} -\item{checks}{logical. If TRUE undertakes all DataSHIELD checks (time-consuming). -Default FALSE.} +\item{classConsistencyCheck}{logical. If TRUE, checks that the input object has the same +class across all studies. Default TRUE.} \item{datasources}{a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login. If the \code{datasources} argument is not specified @@ -39,9 +44,6 @@ input object (e.g. array, matrix or data frame) from every single study and the pooled dimension of the object by summing up the individual dimensions returned from each study. -In \code{checks} parameter is suggested that checks should only be undertaken once the -function call has failed. - Server function called: \code{dimDS} } \examples{ @@ -76,17 +78,14 @@ Server function called: \code{dimDS} # Calculate the dimension ds.dim(x="D", type="combine", #global dimension - checks = FALSE, - datasources = connections)#all opal servers are used +#' datasources = connections)#all opal servers are used ds.dim(x="D", type = "both",#separate dimension for each study #and the pooled dimension (default) - checks = FALSE, - datasources = connections)#all opal servers are used +#' datasources = connections)#all opal servers are used ds.dim(x="D", type="split", #separate dimension for each study - checks = FALSE, - datasources = connections[1])#only the first opal server is used ("study1") +#' datasources = connections[1])#only the first opal server is used ("study1") # clear the Datashield R sessions and logout datashield.logout(connections) @@ -107,4 +106,6 @@ Server function called: \code{dimDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.exp.Rd b/man/ds.exp.Rd index 875dbe00e..dd10147ab 100644 --- a/man/ds.exp.Rd +++ b/man/ds.exp.Rd @@ -25,7 +25,7 @@ Computes the exponential values for a specified numeric vector. This function is similar to R function \code{exp}. } \details{ -Server function called: \code{exp}. +Server function called: \code{expDS}. } \examples{ \dontrun{ @@ -69,4 +69,6 @@ Server function called: \code{exp}. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.isNA.Rd b/man/ds.isNA.Rd index ec6b2f6fe..a9e551109 100644 --- a/man/ds.isNA.Rd +++ b/man/ds.isNA.Rd @@ -4,17 +4,20 @@ \alias{ds.isNA} \title{Checks if a server-side vector is empty} \usage{ -ds.isNA(x = NULL, datasources = NULL) +ds.isNA(x = NULL, classConsistencyCheck = TRUE, datasources = NULL) } \arguments{ \item{x}{a character string specifying the name of the vector to check.} -\item{datasources}{a list of \code{\link[DSI]{DSConnection-class}} +\item{classConsistencyCheck}{logical. If TRUE, checks that the input object has the same +class across all studies. Default TRUE.} + +\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}}.} } \value{ -\code{ds.isNA} returns a boolean. If it is TRUE the vector is empty +\code{ds.isNA} returns a boolean. If it is TRUE the vector is empty (all values are NA), FALSE otherwise. } \description{ @@ -32,7 +35,7 @@ Server function called: \code{isNaDS} \dontrun{ ## Version 6, for version 5 see the Wiki - + # connecting to the Opal servers require('DSI') @@ -40,28 +43,28 @@ Server function called: \code{isNaDS} require('dsBaseClient') builder <- DSI::newDSLoginBuilder() - builder$append(server = "study1", - url = "http://192.168.56.100:8080/", - user = "administrator", password = "datashield_test&", + builder$append(server = "study1", + url = "http://192.168.56.100:8080/", + user = "administrator", password = "datashield_test&", table = "CNSIM.CNSIM1", driver = "OpalDriver") - builder$append(server = "study2", - url = "http://192.168.56.100:8080/", - user = "administrator", password = "datashield_test&", + builder$append(server = "study2", + url = "http://192.168.56.100:8080/", + user = "administrator", password = "datashield_test&", table = "CNSIM.CNSIM2", driver = "OpalDriver") builder$append(server = "study3", - url = "http://192.168.56.100:8080/", - user = "administrator", password = "datashield_test&", + url = "http://192.168.56.100:8080/", + user = "administrator", password = "datashield_test&", table = "CNSIM.CNSIM3", driver = "OpalDriver") logindata <- builder$build() - - connections <- DSI::datashield.login(logins = logindata, assign = TRUE, symbol = "D") - + + connections <- DSI::datashield.login(logins = logindata, assign = TRUE, symbol = "D") + # check if all the observation of the variable 'LAB_HDL' are missing (NA) ds.isNA(x = 'D$LAB_HDL', datasources = connections) #all servers are used ds.isNA(x = 'D$LAB_HDL', - datasources = connections[1]) #only the first server is used (study1) - + datasources = connections[1]) #only the first server is used (study1) + # clear the Datashield R sessions and logout datashield.logout(connections) @@ -71,4 +74,6 @@ Server function called: \code{isNaDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.length.Rd b/man/ds.length.Rd index 27e105bc4..da61ec877 100644 --- a/man/ds.length.Rd +++ b/man/ds.length.Rd @@ -4,7 +4,12 @@ \alias{ds.length} \title{Gets the length of an object in the server-side} \usage{ -ds.length(x = NULL, type = "both", checks = "FALSE", datasources = NULL) +ds.length( + x = NULL, + type = "both", + classConsistencyCheck = TRUE, + datasources = NULL +) } \arguments{ \item{x}{a character string specifying the name of a vector or list.} @@ -18,9 +23,8 @@ if \code{type} is set to \code{'both'} or \code{'b'}, both sets of outputs are produced. Default \code{'both'}.} -\item{checks}{logical. If TRUE the model components are checked. -Default FALSE to save time. It is suggested that checks -should only be undertaken once the function call has failed.} +\item{classConsistencyCheck}{logical. If TRUE, checks that the input object has the same +class across all studies. Default TRUE.} \item{datasources}{a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login. If the \code{datasources} argument is not specified @@ -91,4 +95,6 @@ Server function called: \code{lengthDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.levels.Rd b/man/ds.levels.Rd index fbdab0c46..da714bf57 100644 --- a/man/ds.levels.Rd +++ b/man/ds.levels.Rd @@ -71,4 +71,6 @@ Server function called: \code{levelsDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.log.Rd b/man/ds.log.Rd index 6ab8fee72..a48ee6aae 100644 --- a/man/ds.log.Rd +++ b/man/ds.log.Rd @@ -28,7 +28,7 @@ Computes the logarithms for a specified numeric vector. This function is similar to the R \code{log} function. by default natural logarithms. } \details{ -Server function called: \code{log} +Server function called: \code{logDS} } \examples{ \dontrun{ @@ -73,4 +73,6 @@ Server function called: \code{log} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.ls.Rd b/man/ds.ls.Rd index 207af8548..ae54bd5cd 100644 --- a/man/ds.ls.Rd +++ b/man/ds.ls.Rd @@ -139,4 +139,6 @@ Server function called: \code{lsDS}. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.names.Rd b/man/ds.names.Rd index 199b20d97..984e25967 100644 --- a/man/ds.names.Rd +++ b/man/ds.names.Rd @@ -82,4 +82,6 @@ is formally of class "glm" and "ls" but responds TRUE to is.list(), \author{ Amadou Gaye, updated by Paul Burton for DataSHIELD development team 25/06/2020 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.numNA.Rd b/man/ds.numNA.Rd index 896c76ee1..e9724f141 100644 --- a/man/ds.numNA.Rd +++ b/man/ds.numNA.Rd @@ -4,11 +4,14 @@ \alias{ds.numNA} \title{Gets the number of missing values in a server-side vector} \usage{ -ds.numNA(x = NULL, datasources = NULL) +ds.numNA(x = NULL, classConsistencyCheck = TRUE, datasources = NULL) } \arguments{ \item{x}{a character string specifying the name of the vector.} +\item{classConsistencyCheck}{logical. If TRUE, checks that the input object has the same +class across all studies. Default TRUE.} + \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}}.} @@ -67,4 +70,6 @@ Server function called: \code{numNaDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.quantileMean.Rd b/man/ds.quantileMean.Rd index 03b469a18..1b10f0ebb 100644 --- a/man/ds.quantileMean.Rd +++ b/man/ds.quantileMean.Rd @@ -85,4 +85,6 @@ Server functions called: \code{quantileMeanDS}, \code{length} and \code{numNaDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.recodeLevels.Rd b/man/ds.recodeLevels.Rd index 144509277..4fbf3402c 100644 --- a/man/ds.recodeLevels.Rd +++ b/man/ds.recodeLevels.Rd @@ -82,4 +82,6 @@ Server function called: \code{levels()} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.replaceNA.Rd b/man/ds.replaceNA.Rd index 3b8a4ec01..f73a3ab50 100644 --- a/man/ds.replaceNA.Rd +++ b/man/ds.replaceNA.Rd @@ -107,4 +107,6 @@ Server function called: \code{replaceNaDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.rowColCalc.Rd b/man/ds.rowColCalc.Rd index dc4cfbd93..678184728 100644 --- a/man/ds.rowColCalc.Rd +++ b/man/ds.rowColCalc.Rd @@ -80,4 +80,6 @@ Server functions called: \code{classDS}, \code{dimDS} and \code{colnamesDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.sqrt.Rd b/man/ds.sqrt.Rd index 638d26a5f..95b5432cd 100644 --- a/man/ds.sqrt.Rd +++ b/man/ds.sqrt.Rd @@ -82,4 +82,6 @@ specified by the user through the argument \code{newobj}, otherwise is named by } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.subsetByClass.Rd b/man/ds.subsetByClass.Rd index fe372adb8..cd25fe69e 100644 --- a/man/ds.subsetByClass.Rd +++ b/man/ds.subsetByClass.Rd @@ -77,4 +77,6 @@ a subset is empty (i.e. no entries) the name of the subset is labelled with the } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.summary.Rd b/man/ds.summary.Rd index 2f52cff7e..3e8da4f98 100644 --- a/man/ds.summary.Rd +++ b/man/ds.summary.Rd @@ -80,4 +80,6 @@ server functions called: \code{isValidDS}, \code{dimDS} and \code{colnamesDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.unique.Rd b/man/ds.unique.Rd index 61d6355bd..18d77005a 100644 --- a/man/ds.unique.Rd +++ b/man/ds.unique.Rd @@ -61,4 +61,6 @@ Server function called: \code{uniqueDS} } \author{ Stuart Wheater, DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmChecks.Rd b/man/glmChecks.Rd index ec482bed6..a645541ab 100644 --- a/man/glmChecks.Rd +++ b/man/glmChecks.Rd @@ -35,5 +35,7 @@ at complete) and eventually (if 'offset' or 'weights') are of 'numeric' with non } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } \keyword{internal} diff --git a/man/meanByClassHelper0b.Rd b/man/meanByClassHelper0b.Rd index 56dd89d10..b465e40a3 100644 --- a/man/meanByClassHelper0b.Rd +++ b/man/meanByClassHelper0b.Rd @@ -33,5 +33,7 @@ if the user specify a table structure. } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } \keyword{internal} diff --git a/man/meanByClassHelper2.Rd b/man/meanByClassHelper2.Rd index 27a763d74..3c513277d 100644 --- a/man/meanByClassHelper2.Rd +++ b/man/meanByClassHelper2.Rd @@ -29,5 +29,7 @@ if the user sets the parameter 'type' to combine (the default behaviour of 'ds.m } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } \keyword{internal} diff --git a/man/meanByClassHelper3.Rd b/man/meanByClassHelper3.Rd index ee80e814f..0c6b753e8 100644 --- a/man/meanByClassHelper3.Rd +++ b/man/meanByClassHelper3.Rd @@ -28,5 +28,7 @@ if the user sets the parameter 'type' to 'split'. } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } \keyword{internal} diff --git a/opal_azure-pipelines.yml b/opal_azure-pipelines.yml index b541a3903..3844edebf 100644 --- a/opal_azure-pipelines.yml +++ b/opal_azure-pipelines.yml @@ -221,7 +221,9 @@ jobs: sleep 60 - R -q -e "library(opalr); opal <- opal.login('administrator','datashield_test&', url='http://localhost:8080/'); dsadmin.set_option(opal, 'default.datashield.privacyControlLevel', 'permissive'); opal.logout(opal)" + R -q -e "library(opalr); opal <- opal.login('administrator', 'datashield_test&', url='http://localhost:8080/'); dsadmin.profile_init(opal, name = 'default', packages = c('dsBase', 'dsTidyverse', 'resourcer')); opal.logout(opal)" + + R -q -e "library(opalr); opal <- opal.login('administrator', 'datashield_test&', url='http://localhost:8080/'); dsadmin.set_option(opal, 'default.datashield.privacyControlLevel', 'permissive'); opal.logout(opal)" workingDirectory: $(Pipeline.Workspace)/dsBaseClient/tests/testthat/data_files displayName: 'Install dsBase to Opal, as set disclosure test options' diff --git a/tests/docker/armadillo/standard/config/application.yml b/tests/docker/armadillo/standard/config/application.yml index 54e90c36a..cb735d811 100644 --- a/tests/docker/armadillo/standard/config/application.yml +++ b/tests/docker/armadillo/standard/config/application.yml @@ -14,11 +14,12 @@ armadillo: # oidc-admin-user: user@yourdomain.org profiles: - name: default - image: datashield/rock-quebrada-lamda-permissive:latest + image: datashield/rock_citest-permissive:latest port: 8085 host: default package-whitelist: # Packages for 'permissive' - dsBase + - dsTidyverse - resourcer function-blacklist: [ ] options: @@ -66,8 +67,13 @@ stdout.log.path: '/logs/armadillo.log' logging: level: - root: INFO + root: "warn" ## change to DEBUG to have more details, typically when developing - org.molgenis: INFO + org.molgenis: "warn" ## Don't log upload data - org.apache.coyote.http11.Http11InputBuffer: INFO + org.apache.coyote.http11.Http11InputBuffer: "warn" + ## SpringFramework + org.springframework.boot: "warn" + org.springframework.web: "warn" + org.springframework.core: "warn" + org.springframework.codex: "warn" diff --git a/tests/testthat/perf_files/armadillo_azure-pipeline.csv b/tests/testthat/perf_files/armadillo_azure-pipeline.csv deleted file mode 100644 index 03d36d8fe..000000000 --- a/tests/testthat/perf_files/armadillo_azure-pipeline.csv +++ /dev/null @@ -1,14 +0,0 @@ -"refer_name","rate","lower_tolerance","upper_tolerance" -"conndisconn::perf::simple0","0.1651","0.5","2" -"ds.abs::perf::0","6.273","0.5","2" -"ds.asInteger::perf:0","5.731","0.5","2" -"ds.asList::perf:0","12.74","0.5","2" -"ds.asNumeric::perf:0","5.637","0.5","2" -"ds.assign::perf::0","10.46","0.5","2" -"ds.class::perf::combine:0","12.69","0.5","2" -"ds.colnames::perf:0","9.518","0.5","2" -"ds.exists::perf::combine:0","25.33","0.5","2" -"ds.length::perf::combine:0","25.45","0.5","2" -"ds.mean::perf::combine:0","25.37","0.5","2" -"ds.mean::perf::split:0","25.74","0.5","2" -"void::perf::void::0","56310.0","0.5","2" diff --git a/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv b/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv new file mode 100644 index 000000000..cd65d3d18 --- /dev/null +++ b/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv @@ -0,0 +1,29 @@ +"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.asInteger::perf:0","17.61","0.5","2" +"ds.asList::perf:0","16.46","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.class::perf::combine:0","24.90","0.5","2" +"ds.colnames::perf:0","8.16","0.5","2" +"ds.completeCases::perf::combine:0","17.26","0.5","2" +"ds.dim::perf::combine:0","23.82","0.5","2" +"ds.exists::perf::combine:0","24.21","0.5","2" +"ds.exp::perf::combine:0","17.18","0.5","2" +"ds.isNA::perf::combine:0","23.86","0.5","2" +"ds.length::perf::combine:0","24.04","0.5","2" +"ds.levels::perf::combine:0","23.96","0.5","2" +"ds.log::perf::0","17.30","0.5","2" +"ds.ls::perf::combine:0","24.35","0.5","2" +"ds.mean::perf::combine:0","24.12","0.5","2" +"ds.mean::perf::split:0","24.45","0.5","2" +"ds.names::perf::combine:0","24.22","0.5","2" +"ds.numNA::perf::combine:0","23.58","0.5","2" +"ds.sqrt::perf::0","16.83","0.5","2" +"ds.unique::perf::combine:0","17.04","0.5","2" +"void::perf::void::0","52590","0.5","2" diff --git a/tests/testthat/perf_files/armadillo_hp-laptop_quay.csv b/tests/testthat/perf_files/armadillo_hp-laptop-quay_pipeline-perf.csv similarity index 100% rename from tests/testthat/perf_files/armadillo_hp-laptop_quay.csv rename to tests/testthat/perf_files/armadillo_hp-laptop-quay_pipeline-perf.csv diff --git a/tests/testthat/perf_files/template_perf_profile.csv b/tests/testthat/perf_files/default_template_perf-profile.csv similarity index 100% rename from tests/testthat/perf_files/template_perf_profile.csv rename to tests/testthat/perf_files/default_template_perf-profile.csv diff --git a/tests/testthat/perf_files/dslite_hp-laptop_quay.csv b/tests/testthat/perf_files/dslite_hp-laptop-quay_perf-profile.csv similarity index 100% rename from tests/testthat/perf_files/dslite_hp-laptop_quay.csv rename to tests/testthat/perf_files/dslite_hp-laptop-quay_perf-profile.csv diff --git a/tests/testthat/perf_files/opal_azure-pipeline.csv b/tests/testthat/perf_files/opal_azure-pipeline.csv deleted file mode 100644 index 9f1ae6e5e..000000000 --- a/tests/testthat/perf_files/opal_azure-pipeline.csv +++ /dev/null @@ -1,14 +0,0 @@ -"refer_name","rate","lower_tolerance","upper_tolerance" -"conndisconn::perf::simple0","0.2725","0.5","2" -"ds.abs::perf::0","2.677","0.5","2" -"ds.asInteger::perf:0","2.294","0.5","2" -"ds.asList::perf:0","4.587","0.5","2" -"ds.asNumeric::perf:0","2.185","0.5","2" -"ds.assign::perf::0","5.490","0.5","2" -"ds.class::perf::combine:0","4.760","0.5","2" -"ds.colnames::perf:0","4.218","0.5","2" -"ds.exists::perf::combine:0","11.09","0.5","2" -"ds.length::perf::combine:0","9.479","0.5","2" -"ds.mean::perf::combine:0","9.650","0.5","2" -"ds.mean::perf::split:0","11.26","0.5","2" -"void::perf::void::0","46250.0","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 new file mode 100644 index 000000000..831ff8e89 --- /dev/null +++ b/tests/testthat/perf_files/opal_azure-pipeline_perf-profile.csv @@ -0,0 +1,29 @@ +"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.152","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","4.978","0.5","2" +"ds.class::perf::combine:0","8.572","0.5","2" +"ds.colnames::perf:0","2.856","0.5","2" +"ds.completeCases::perf::combine:0","8.254","0.5","2" +"ds.dim::perf::combine:0","8.687","0.5","2" +"ds.exists::perf::combine:0","10.02","0.5","2" +"ds.exp::perf::combine:0","8.644","0.5","2" +"ds.isNA::perf::combine:0","8.677","0.5","2" +"ds.length::perf::combine:0","8.551","0.5","2" +"ds.levels::perf::combine:0","8.594","0.5","2" +"ds.log::perf::0","8.415","0.5","2" +"ds.ls::perf::combine:0","8.689","0.5","2" +"ds.mean::perf::combine:0","8.690","0.5","2" +"ds.mean::perf::split:0","9.823","0.5","2" +"ds.names::perf::combine:0","8.620","0.5","2" +"ds.numNA::perf::combine:0","8.411","0.5","2" +"ds.sqrt::perf::0","8.666","0.5","2" +"ds.unique::perf::combine:0","8.656","0.5","2" +"void::perf::void::0","46340","0.5","2" diff --git a/tests/testthat/perf_files/opal_hp-laptop-quay_perf-profile.csv b/tests/testthat/perf_files/opal_hp-laptop-quay_perf-profile.csv new file mode 100644 index 000000000..181814d3c --- /dev/null +++ b/tests/testthat/perf_files/opal_hp-laptop-quay_perf-profile.csv @@ -0,0 +1,29 @@ +"refer_name","rate","lower_tolerance","upper_tolerance" +"conndisconn::perf::simple0","0.1340","0.5","2" +"ds.abs::perf::0","2.822","0.5","2" +"ds.asCharacter::perf::0","2.393","0.5","2" +"ds.asDataMatrix::perf::0","2.554","0.5","2" +"ds.asInteger::perf:0","3.056","0.5","2" +"ds.asList::perf:0","2.649","0.5","2" +"ds.asLogical::perf::0","2.629","0.5","2" +"ds.asMatrix::perf::0","2.717","0.5","2" +"ds.asNumeric::perf:0","2.629","0.5","2" +"ds.assign::perf::0","1.709","0.5","2" +"ds.class::perf::combine:0","3.216","0.5","2" +"ds.colnames::perf:0","0.941","0.5","2" +"ds.completeCases::perf::combine:0","2.660","0.5","2" +"ds.dim::perf::combine:0","25.31","0.5","2" +"ds.exists::perf::combine:0","3.493","0.5","2" +"ds.exp::perf::combine:0","17.90","0.5","2" +"ds.isNA::perf::combine:0","25.43","0.5","2" +"ds.length::perf::combine:0","25.44","0.5","2" +"ds.levels::perf::combine:0","3.275","0.5","2" +"ds.log::perf::0","17.89","0.5","2" +"ds.ls::perf::combine:0","2.857","0.5","2" +"ds.mean::perf::combine:0","2.756","0.5","2" +"ds.mean::perf::split:0","3.547","0.5","2" +"ds.names::perf::combine:0","2.246","0.5","2" +"ds.numNA::perf::combine:0","25.46","0.5","2" +"ds.sqrt::perf::0","2.686","0.5","2" +"ds.unique::perf::combine:0","2.681","0.5","2" +"void::perf::void::0","20150","0.5","2" diff --git a/tests/testthat/perf_files/opal_hp-laptop_quay.csv b/tests/testthat/perf_files/opal_hp-laptop_quay.csv deleted file mode 100644 index 334cd62c1..000000000 --- a/tests/testthat/perf_files/opal_hp-laptop_quay.csv +++ /dev/null @@ -1,14 +0,0 @@ -"refer_name","rate","lower_tolerance","upper_tolerance" -"conndisconn::perf::simple0","0.147643461923159","0.5","2" -"ds.abs::perf::0","0.631818039001181","0.5","2" -"ds.asInteger::perf:0","0.675696161933654","0.5","2" -"ds.asList::perf:0","1.59078428438764","0.5","2" -"ds.asNumeric::perf:0","0.692813012683229","0.5","2" -"ds.assign::perf::0","1.89351857736982","0.5","2" -"ds.class::perf::combine:0","1.62870246867488","0.5","2" -"ds.colnames::perf:0","1.32209430785405","0.5","2" -"ds.exists::perf::combine:0","3.45004426293124","0.5","2" -"ds.length::perf::combine:0","2.78832377100152","0.5","2" -"ds.mean::perf::combine:0","2.7801284055162","0.5","2" -"ds.mean::perf::split:0","3.67443474363821","0.5","2" -"void::perf::void::0","18974.1385397392","0.5","2" diff --git a/tests/testthat/perf_files/default_perf_profile.csv b/tests/testthat/perf_files/unknown_default-perf-profile.csv similarity index 100% rename from tests/testthat/perf_files/default_perf_profile.csv rename to tests/testthat/perf_files/unknown_default-perf-profile.csv diff --git a/tests/testthat/perf_tests/perf_rate.R b/tests/testthat/perf_tests/perf_rate.R index 0384bf637..8d762207c 100644 --- a/tests/testthat/perf_tests/perf_rate.R +++ b/tests/testthat/perf_tests/perf_rate.R @@ -1,5 +1,5 @@ #------------------------------------------------------------------------------- -# Copyright (c) 2024-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2024-2026 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. # # This program and the accompanying materials # are made available under the terms of the GNU Public License v3.0. @@ -8,12 +8,36 @@ # along with this program. If not, see . #------------------------------------------------------------------------------- -.perf.reference.filename <- 'perf_files/default_perf_profile.csv' +.perf.reference.filename.base.prefix <- 'perf_files/' +.perf.reference.filename.base.postfix <- '_perf-profile.csv' +.perf.reference.save.filename <- NULL .perf.reference <- NULL .load.pref <- function() { - .perf.reference <<- read.csv(.perf.reference.filename, header = TRUE, sep = ",") + if (ds.test_env$driver == "OpalDriver") + perf.reference.filename.driver.infix <- "opal" + else if (ds.test_env$driver == "ArmadilloDriver") + perf.reference.filename.driver.infix <- "armadillo" + else if (ds.test_env$driver == "DSLiteDriver") + perf.reference.filename.driver.infix <- "dslite" + else + { + perf.reference.filename.infix <- "unknown" + warning("Unknown performance profile driver, using 'unknown'") + } + + perf.profile <- base::Sys.getenv("PERF_PROFILE") + if (nchar(perf.profile) > 0) + perf.reference.filename.platform.infix <- base::tolower(perf.profile) + else + { + perf.reference.filename.platform.infix <- "default" + warning("Unknown performance profile platform, using 'default'") + } + + perf.reference.filename <- paste(.perf.reference.filename.base.prefix, perf.reference.filename.driver.infix, '_', perf.reference.filename.platform.infix, .perf.reference.filename.base.postfix, sep = "") + .perf.reference <<- read.csv(perf.reference.filename, header = TRUE, sep = ",") } perf.reference.save <- function(perf.ref.name, rate, tolerance.lower, tolerance.upper) { @@ -22,11 +46,22 @@ perf.reference.save <- function(perf.ref.name, rate, tolerance.lower, tolerance. .perf.reference[nrow(.perf.reference)+1,] <- c(perf.ref.name, rate, tolerance.lower, tolerance.upper) - write.csv(.perf.reference, .perf.reference.filename, row.names = FALSE) + if (is.null(.perf.reference.save.filename)) + { + .perf.reference.save.filename <<- base::tempfile(pattern = "perf_file_", fileext = ".csv") + message(paste0("Additional perf record added to '", .perf.reference.save.filename, "'")) + } + + write.csv(.perf.reference, .perf.reference.save.filename, row.names = FALSE) .perf.reference <<- .perf.reference } +# Obtain performance test duration from PERF_DURATION_SEC environment variable, otherwise default.duration argument, otherwise "30". +perf.testduration <- function(default.duration = 30) { + base::as.integer(base::Sys.getenv("PERF_DURATION_SEC", unset = base::as.character(default.duration))) +} + perf.reference.rate <- function(perf.ref.name) { if (is.null(.perf.reference)) .load.pref() diff --git a/tests/testthat/test-arg-ds.abs.R b/tests/testthat/test-arg-ds.abs.R new file mode 100644 index 000000000..fc1e26c33 --- /dev/null +++ b/tests/testthat/test-arg-ds.abs.R @@ -0,0 +1,31 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2018-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +connect.studies.dataset.cnsim(list("LAB_TSC")) + +# +# Tests +# + +# context("ds.abs::arg::test errors") +test_that("abs_errors", { + expect_error(ds.abs(), "Please provide the name of the input object!", fixed=TRUE) +}) + +# +# Done +# + +disconnect.studies.dataset.cnsim() diff --git a/tests/testthat/test-arg-ds.dim.R b/tests/testthat/test-arg-ds.dim.R index 27b4e8bd8..2fa7d228c 100644 --- a/tests/testthat/test-arg-ds.dim.R +++ b/tests/testthat/test-arg-ds.dim.R @@ -22,7 +22,6 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.dim::arg::test errors") test_that("dim_erros", { expect_error(ds.dim(), "Please provide the name of a data.frame or matrix!", fixed=TRUE) - expect_error(ds.dim(x="F", checks = TRUE), "The input object must be a table structure!", fixed=TRUE) expect_error(ds.dim(x="D", type = "other"), 'Function argument "type" has to be either "both", "combine" or "split"', fixed=TRUE) }) diff --git a/tests/testthat/test-arg-ds.length.R b/tests/testthat/test-arg-ds.length.R index 06ce3a7a5..7e997842f 100644 --- a/tests/testthat/test-arg-ds.length.R +++ b/tests/testthat/test-arg-ds.length.R @@ -21,13 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.length::arg::test errors") test_that("length_erros", { - ds.asMatrix(x='D$LAB_TSC', newobj="not_a_numeric") - expect_error(ds.length(), "Please provide the name of the input object!", fixed=TRUE) expect_error(ds.length(x='D$LAB_TSC', type='datashield'), 'Function argument "type" has to be either "both", "combine" or "split"', fixed=TRUE) - expect_error(ds.length(check=TRUE), "Please provide the name of the input object!", fixed=TRUE) - expect_error(ds.length(x='D$LAB_TSC', type='datashield', check=TRUE), 'Function argument "type" has to be either "both", "combine" or "split"', fixed=TRUE) - expect_error(ds.length(x='not_a_numeric', checks=TRUE), "The input object must be a character, factor, integer, logical or numeric vector or a list.", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.levels.R b/tests/testthat/test-arg-ds.levels.R index cf6bf974b..ad2f5bde1 100644 --- a/tests/testthat/test-arg-ds.levels.R +++ b/tests/testthat/test-arg-ds.levels.R @@ -22,7 +22,6 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.levels::arg") test_that("simple levels", { expect_error(ds.levels(), "Please provide the name of the input vector!", fixed=TRUE) - expect_error(ds.levels("LAB_TSC"), "The input object LAB_TSC is not defined in sim1, sim2, sim3!", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.names.R b/tests/testthat/test-arg-ds.names.R index f8c049106..3faa397a7 100644 --- a/tests/testthat/test-arg-ds.names.R +++ b/tests/testthat/test-arg-ds.names.R @@ -26,15 +26,6 @@ test_that("simple ds.names errors", { res.errors <- DSI::datashield.errors() expect_length(res.errors, 0) - - expect_error(ds.names(x="D$LAB_TSC"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed = TRUE) - - res.errors <- DSI::datashield.errors() - - expect_length(res.errors, 3) - expect_match(res.errors$sim1, "* Error : The input object is not of class numeric") - expect_match(res.errors$sim2, "* Error : The input object is not of class numeric") - expect_match(res.errors$sim3, "* Error : The input object is not of class numeric") }) # diff --git a/tests/testthat/test-arg-ds.sqrt.R b/tests/testthat/test-arg-ds.sqrt.R new file mode 100644 index 000000000..fc5baf37f --- /dev/null +++ b/tests/testthat/test-arg-ds.sqrt.R @@ -0,0 +1,31 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2018-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +connect.studies.dataset.cnsim(list("LAB_TSC")) + +# +# Tests +# + +# context("ds.sqrt::arg::test errors") +test_that("sqrt_errors", { + expect_error(ds.sqrt(), "Please provide the name of the input object!", fixed=TRUE) +}) + +# +# Done +# + +disconnect.studies.dataset.cnsim() diff --git a/tests/testthat/test-datachk-DISCORDANT.R b/tests/testthat/test-datachk-DISCORDANT.R index 5254897b2..15afe0d5e 100644 --- a/tests/testthat/test-datachk-DISCORDANT.R +++ b/tests/testthat/test-datachk-DISCORDANT.R @@ -64,16 +64,17 @@ test_that("Check DISCORDANT dataset", { expect_length(res.class.a.2, 1) expect_length(res.class.a.2$discordant2, 1) expect_equal(res.class.a.2$discordant2, "integer") - expect_error(res.class.a.3 <- ds.class(x='D$A', datasources=ds.test_env$connections[3]), "The input object D$A is not defined in discordant3!", fixed=TRUE) + expect_error(ds.class(x='D$A', datasources=ds.test_env$connections[3]), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_length(res.errors, 1) + expect_match(res.errors[[1]], "Column 'A' not found in 'D'") - res.length.a <- ds.length(x='D$A') - expect_length(res.length.a, 4) + res.length.a <- ds.length(x='D$A', datasources=ds.test_env$connections[1:2]) + expect_length(res.length.a, 3) expect_length(res.length.a$`length of D$A in discordant1`, 1) expect_equal(res.length.a$`length of D$A in discordant1`, 12) expect_length(res.length.a$`length of D$A in discordant2`, 1) expect_equal(res.length.a$`length of D$A in discordant2`, 12) - expect_length(res.length.a$`length of D$A in discordant3`, 1) - expect_equal(res.length.a$`length of D$A in discordant3`, 0) expect_length(res.length.a$`total length of D$A in all studies combined`, 1) expect_equal(res.length.a$`total length of D$A in all studies combined`, 24) @@ -81,24 +82,28 @@ test_that("Check DISCORDANT dataset", { expect_length(res.class.b.1, 1) expect_length(res.class.b.1$discordant1, 1) expect_equal(res.class.b.1$discordant1, "integer") - expect_error(res.class.b.3 <- ds.class(x='D$B', datasources=ds.test_env$connections[2]), "The input object D$B is not defined in discordant2!", fixed=TRUE) + expect_error(ds.class(x='D$B', datasources=ds.test_env$connections[2]), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_length(res.errors, 1) + expect_match(res.errors[[1]], "Column 'B' not found in 'D'") res.class.b.3 <- ds.class(x='D$B', datasources=ds.test_env$connections[3]) expect_length(res.class.b.3, 1) expect_length(res.class.b.3$discordant3, 1) expect_equal(res.class.b.3$discordant3, "integer") - res.length.b <- ds.length(x='D$B') - expect_length(res.length.b, 4) + res.length.b <- ds.length(x='D$B', datasources=ds.test_env$connections[c(1,3)]) + expect_length(res.length.b, 3) expect_length(res.length.b$`length of D$B in discordant1`, 1) expect_equal(res.length.b$`length of D$B in discordant1`, 12) - expect_length(res.length.b$`length of D$B in discordant2`, 1) - expect_equal(res.length.b$`length of D$B in discordant2`, 0) expect_length(res.length.b$`length of D$B in discordant3`, 1) expect_equal(res.length.b$`length of D$B in discordant3`, 12) expect_length(res.length.b$`total length of D$B in all studies combined`, 1) expect_equal(res.length.b$`total length of D$B in all studies combined`, 24) - expect_error(res.class.c.1 <- ds.class(x='D$C', datasources=ds.test_env$connections[1]), "The input object D$C is not defined in discordant1!", fixed=TRUE) + expect_error(ds.class(x='D$C', datasources=ds.test_env$connections[1]), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_length(res.errors, 1) + expect_match(res.errors[[1]], "Column 'C' not found in 'D'") res.class.c.2 <- ds.class(x='D$C', datasources=ds.test_env$connections[2]) expect_length(res.class.c.2, 1) expect_length(res.class.c.2$discordant2, 1) @@ -108,10 +113,8 @@ test_that("Check DISCORDANT dataset", { expect_length(res.class.c.3$discordant3, 1) expect_equal(res.class.c.3$discordant3, "integer") - res.length.c <- ds.length(x='D$C') - expect_length(res.length.c, 4) - expect_length(res.length.c$`length of D$C in discordant1`, 1) - expect_equal(res.length.c$`length of D$C in discordant1`, 0) + res.length.c <- ds.length(x='D$C', datasources=ds.test_env$connections[2:3]) + expect_length(res.length.c, 3) expect_length(res.length.c$`length of D$C in discordant2`, 1) expect_equal(res.length.c$`length of D$C in discordant2`, 12) expect_length(res.length.c$`length of D$C in discordant3`, 1) diff --git a/tests/testthat/test-disc-ds.levels.R b/tests/testthat/test-disc-ds.levels.R index 95d0c60b5..80dc4ca70 100644 --- a/tests/testthat/test-disc-ds.levels.R +++ b/tests/testthat/test-disc-ds.levels.R @@ -25,27 +25,9 @@ test_that("setup", { # Tests # # context("ds.levels::disc") +# Density disclosure check is tested in dsBase server-side unit tests. +# Cannot easily trigger with CNSIM data (too few levels relative to rows). test_that("simple levels", { -# res <- ds.levels("D$GENDER") - -# expect_length(res, 3) -# expect_length(res$sim1, 2) -# expect_length(res$sim1$ValidityMessage, 1) -# expect_equal(res$sim1$ValidityMessage, "VALID ANALYSIS") -# expect_length(res$sim1$Levels, 2) -# expect_equal(res$sim1$Levels, NA) - -# expect_length(res$sim2, 2) -# expect_length(res$sim2$ValidityMessage, 1) -# expect_equal(res$sim2$ValidityMessage, "VALID ANALYSIS") -# expect_length(res$sim2$Levels, 2) -# expect_equal(res$sim2$Levels, NA) - -# expect_length(res$sim3, 2) -# expect_length(res$sim3$ValidityMessage, 1) -# expect_equal(res$sim3$ValidityMessage, "VALID ANALYSIS") -# expect_length(res$sim3$Levels, 2) -# expect_equal(res$sim3$Levels, NA) }) # diff --git a/tests/testthat/test-perf-ds.asCharacter.R b/tests/testthat/test-perf-ds.asCharacter.R new file mode 100644 index 000000000..f9c08b7df --- /dev/null +++ b/tests/testthat/test-perf-ds.asCharacter.R @@ -0,0 +1,58 @@ +#------------------------------------------------------------------------------- +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.asCharacter::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.asCharacter::perf:0") +test_that("combine - 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.asCharacter("D$LAB_TSC", newobj = "perf.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.asCharacter::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.asCharacter::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.asCharacter::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.asCharacter::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.asCharacter::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.asCharacter::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.asCharacter::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.asCharacter::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.asCharacter::perf::done") diff --git a/tests/testthat/test-perf-ds.asDataMatrix.R b/tests/testthat/test-perf-ds.asDataMatrix.R new file mode 100644 index 000000000..329c1e2f6 --- /dev/null +++ b/tests/testthat/test-perf-ds.asDataMatrix.R @@ -0,0 +1,58 @@ +#------------------------------------------------------------------------------- +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.asDataMatrix::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.asDataMatrix::perf:0") +test_that("combine - 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.asDataMatrix(x.name = "D", newobj = "perf.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.asDataMatrix::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.asDataMatrix::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.asDataMatrix::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.asDataMatrix::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.asDataMatrix::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.asDataMatrix::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.asDataMatrix::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.asDataMatrix::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.asDataMatrix::perf::done") diff --git a/tests/testthat/test-perf-ds.asLogical.R b/tests/testthat/test-perf-ds.asLogical.R new file mode 100644 index 000000000..f3c4d43d9 --- /dev/null +++ b/tests/testthat/test-perf-ds.asLogical.R @@ -0,0 +1,58 @@ +#------------------------------------------------------------------------------- +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.asLogical::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.asLogical::perf:0") +test_that("combine - 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.asLogical("D$LAB_TSC", newobj = "perf.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.asLogical::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.asLogical::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.asLogical::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.asLogical::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.asLogical::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.asLogical::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.asLogical::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.asLogical::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.asLogical::perf::done") \ No newline at end of file diff --git a/tests/testthat/test-perf-ds.asMatrix.R b/tests/testthat/test-perf-ds.asMatrix.R new file mode 100644 index 000000000..a07e9605a --- /dev/null +++ b/tests/testthat/test-perf-ds.asMatrix.R @@ -0,0 +1,58 @@ +#------------------------------------------------------------------------------- +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.asMatrix::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.asMatrix::perf:0") +test_that("combine - 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.asMatrix(x.name = "D$LAB_TSC", newobj = "perf.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.asMatrix::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.asMatrix::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.asMatrix::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.asMatrix::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.asMatrix::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.asMatrix::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.asMatrix::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.asMatrix::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.asMatrix::perf::done") \ No newline at end of file diff --git a/tests/testthat/test-perf-ds.completeCases.R b/tests/testthat/test-perf-ds.completeCases.R new file mode 100644 index 000000000..e2aa3667d --- /dev/null +++ b/tests/testthat/test-perf-ds.completeCases.R @@ -0,0 +1,59 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2024-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.completeCases::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.completeCases::perf::combine:0") +test_that("combine - 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.completeCases("D", newobj="D_complete") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.completeCases::perf::combine:0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.completeCases::perf::combine:0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.completeCases::perf::combine:0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.completeCases::perf::combine:0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.completeCases::perf::combine:0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.completeCases::perf::combine:0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.completeCases::perf::combine: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.completeCases::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.completeCases::perf::done") diff --git a/tests/testthat/test-perf-ds.dim.R b/tests/testthat/test-perf-ds.dim.R new file mode 100644 index 000000000..047dc453e --- /dev/null +++ b/tests/testthat/test-perf-ds.dim.R @@ -0,0 +1,59 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2024-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.dim::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.dim::perf::combine:0") +test_that("combine - 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.dim("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.dim::perf::combine:0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.dim::perf::combine:0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.dim::perf::combine:0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.dim::perf::combine:0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.dim::perf::combine:0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.dim::perf::combine:0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.dim::perf::combine: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.dim::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.dim::perf::done") diff --git a/tests/testthat/test-perf-ds.exp.R b/tests/testthat/test-perf-ds.exp.R new file mode 100644 index 000000000..8ab5b3d95 --- /dev/null +++ b/tests/testthat/test-perf-ds.exp.R @@ -0,0 +1,58 @@ +#------------------------------------------------------------------------------- +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.exp::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.exp::perf:0") +test_that("combine - 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.exp("D$LAB_TSC", newobj = "perf.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.exp::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.exp::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.exp::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.exp::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.exp::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.exp::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.exp::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.exp::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.exp::perf::done") diff --git a/tests/testthat/test-perf-ds.isNA.R b/tests/testthat/test-perf-ds.isNA.R new file mode 100644 index 000000000..9b60c5500 --- /dev/null +++ b/tests/testthat/test-perf-ds.isNA.R @@ -0,0 +1,59 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2024-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.isNA::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.isNA::perf::combine:0") +test_that("combine - 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.isNA("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.isNA::perf::combine:0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.isNA::perf::combine:0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.isNA::perf::combine:0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.isNA::perf::combine:0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.isNA::perf::combine:0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.isNA::perf::combine:0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.isNA::perf::combine: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.isNA::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.isNA::perf::done") diff --git a/tests/testthat/test-perf-ds.levels.R b/tests/testthat/test-perf-ds.levels.R new file mode 100644 index 000000000..4936a975c --- /dev/null +++ b/tests/testthat/test-perf-ds.levels.R @@ -0,0 +1,59 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2024-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.levels::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "PM_BMI_CATEGORICAL")) + +# +# Tests +# + +# context("ds.levels::perf::combine:0") +test_that("combine - 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.levels("D$PM_BMI_CATEGORICAL") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.levels::perf::combine:0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.levels::perf::combine:0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.levels::perf::combine:0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.levels::perf::combine:0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.levels::perf::combine:0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.levels::perf::combine:0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.levels::perf::combine: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.levels::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.levels::perf::done") diff --git a/tests/testthat/test-perf-ds.log.R b/tests/testthat/test-perf-ds.log.R new file mode 100644 index 000000000..96ab0be27 --- /dev/null +++ b/tests/testthat/test-perf-ds.log.R @@ -0,0 +1,58 @@ +#------------------------------------------------------------------------------- +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.log::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.log::perf:0") +test_that("combine - 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.log("D$LAB_TSC", newobj = "perf.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.log::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.log::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.log::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.log::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.log::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.log::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.log::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.log::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.log::perf::done") diff --git a/tests/testthat/test-perf-ds.ls.R b/tests/testthat/test-perf-ds.ls.R new file mode 100644 index 000000000..e9ad009c6 --- /dev/null +++ b/tests/testthat/test-perf-ds.ls.R @@ -0,0 +1,59 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2024-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.ls::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.ls::perf::combine:0") +test_that("combine - 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.ls() + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.ls::perf::combine:0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.ls::perf::combine:0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.ls::perf::combine:0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.ls::perf::combine:0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.ls::perf::combine:0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.ls::perf::combine:0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.ls::perf::combine: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.ls::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.ls::perf::done") diff --git a/tests/testthat/test-perf-ds.names.R b/tests/testthat/test-perf-ds.names.R new file mode 100644 index 000000000..bd39e6afc --- /dev/null +++ b/tests/testthat/test-perf-ds.names.R @@ -0,0 +1,59 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2024-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.names::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.names::perf::combine:0") +test_that("combine - 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.names("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.names::perf::combine:0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.names::perf::combine:0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.names::perf::combine:0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.names::perf::combine:0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.names::perf::combine:0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.names::perf::combine:0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.names::perf::combine: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.names::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.names::perf::done") diff --git a/tests/testthat/test-perf-ds.numNA.R b/tests/testthat/test-perf-ds.numNA.R new file mode 100644 index 000000000..682f5c71d --- /dev/null +++ b/tests/testthat/test-perf-ds.numNA.R @@ -0,0 +1,59 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2024-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.numNA::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.numNA::perf::combine:0") +test_that("combine - 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.numNA("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.numNA::perf::combine:0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.numNA::perf::combine:0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.numNA::perf::combine:0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.numNA::perf::combine:0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.numNA::perf::combine:0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.numNA::perf::combine:0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.numNA::perf::combine: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.numNA::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.numNA::perf::done") diff --git a/tests/testthat/test-perf-ds.sqrt.R b/tests/testthat/test-perf-ds.sqrt.R new file mode 100644 index 000000000..dffdbbb64 --- /dev/null +++ b/tests/testthat/test-perf-ds.sqrt.R @@ -0,0 +1,58 @@ +#------------------------------------------------------------------------------- +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.sqrt::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.sqrt::perf:0") +test_that("combine - 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.sqrt("D$LAB_TSC", newobj = "perf.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.sqrt::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.sqrt::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.sqrt::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.sqrt::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.sqrt::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.sqrt::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.sqrt::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.sqrt::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.sqrt::perf::done") diff --git a/tests/testthat/test-perf-ds.unique.R b/tests/testthat/test-perf-ds.unique.R new file mode 100644 index 000000000..cc4f54d20 --- /dev/null +++ b/tests/testthat/test-perf-ds.unique.R @@ -0,0 +1,59 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2024-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("ds.unique::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) + +# +# Tests +# + +# context("ds.unique::perf::combine:0") +test_that("combine - 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.unique("D$LAB_TSC", newobj="unique_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.unique::perf::combine:0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.unique::perf::combine:0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.unique::perf::combine:0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.unique::perf::combine:0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.unique::perf::combine:0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.unique::perf::combine:0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.unique::perf::combine: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.unique::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.unique::perf::done") diff --git a/tests/testthat/test-smk-checkClass-discordant.R b/tests/testthat/test-smk-checkClass-discordant.R index d95df5e99..e441895a6 100644 --- a/tests/testthat/test-smk-checkClass-discordant.R +++ b/tests/testthat/test-smk-checkClass-discordant.R @@ -27,15 +27,24 @@ test_that("setup", { # context("checkClass::smk::discordant") test_that("simple test, discordant dataset A", { - expect_error(checkClass(ds.test_env$connections, "D$A"), " End of process!", fixed=TRUE) + expect_error(checkClass(ds.test_env$connections, "D$A"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_length(res.errors, 1) + expect_match(res.errors[[1]], "Column 'A' not found in 'D'") }) test_that("simple test, discordant dataset B", { - expect_error(checkClass(ds.test_env$connections, "D$B"), " End of process!", fixed=TRUE) + expect_error(checkClass(ds.test_env$connections, "D$B"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_length(res.errors, 1) + expect_match(res.errors[[1]], "Column 'B' not found in 'D'") }) test_that("simple test, discordant dataset C", { - expect_error(checkClass(ds.test_env$connections, "D$C"), " End of process!", fixed=TRUE) + expect_error(checkClass(ds.test_env$connections, "D$C"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_length(res.errors, 1) + expect_match(res.errors[[1]], "Column 'C' not found in 'D'") }) # diff --git a/tests/testthat/test-smk-checkClass.R b/tests/testthat/test-smk-checkClass.R index b8a52bd86..a2fe63844 100644 --- a/tests/testthat/test-smk-checkClass.R +++ b/tests/testthat/test-smk-checkClass.R @@ -86,11 +86,10 @@ test_that("data.frame test", { }) test_that("missing test", { - res <- checkClass(ds.test_env$connections, "D$TEST") - - expect_length(res, 1) - expect_equal(class(res), "character") - expect_equal(res, "NULL") + expect_error(checkClass(ds.test_env$connections, "D$TEST"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_length(res.errors, 3) + expect_match(res.errors[[1]], "Column 'TEST' not found in 'D'") }) # diff --git a/tests/testthat/test-smk-ds.abs.R b/tests/testthat/test-smk-ds.abs.R index b64b313bf..fb3783fbd 100644 --- a/tests/testthat/test-smk-ds.abs.R +++ b/tests/testthat/test-smk-ds.abs.R @@ -27,9 +27,7 @@ test_that("setup", { # context("ds.abs::smk") test_that("simple c", { - res <- ds.abs("D$LAB_TSC", newobj = "abs.newobj") - - expect_true(is.null(res)) + expect_no_error(ds.abs("D$LAB_TSC", newobj = "abs.newobj")) res.length <- ds.length("abs.newobj") diff --git a/tests/testthat/test-smk-ds.asCharacter.R b/tests/testthat/test-smk-ds.asCharacter.R index ae8b7e60c..abc702e70 100644 --- a/tests/testthat/test-smk-ds.asCharacter.R +++ b/tests/testthat/test-smk-ds.asCharacter.R @@ -27,11 +27,12 @@ test_that("setup", { # context("ds.asCharacter::smk::simple test") test_that("simple test", { - res <- ds.asCharacter("D$LAB_TSC") + expect_no_error(ds.asCharacter("D$LAB_TSC")) - expect_equal(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") + res.class <- ds.class("ascharacter.newobj") + expect_equal(res.class$sim1, "character") + expect_equal(res.class$sim2, "character") + expect_equal(res.class$sim3, "character") }) # diff --git a/tests/testthat/test-smk-ds.asDataMatrix.R b/tests/testthat/test-smk-ds.asDataMatrix.R index 25ef3736a..a9ca652a1 100644 --- a/tests/testthat/test-smk-ds.asDataMatrix.R +++ b/tests/testthat/test-smk-ds.asDataMatrix.R @@ -27,11 +27,7 @@ test_that("setup", { # context("ds.asDataMatrix::smk::simple test") test_that("simple test", { - res <- ds.asDataMatrix(x.name="D$GENDER") - - 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") + expect_no_error(ds.asDataMatrix(x.name="D$GENDER")) res.class <- ds.class("asdatamatrix.newobj") expect_length(res.class, 3) diff --git a/tests/testthat/test-smk-ds.asInteger.R b/tests/testthat/test-smk-ds.asInteger.R index 1ef25fbf0..b59ae832e 100644 --- a/tests/testthat/test-smk-ds.asInteger.R +++ b/tests/testthat/test-smk-ds.asInteger.R @@ -27,11 +27,12 @@ test_that("setup", { # context("ds.asInteger::smk::simple test") test_that("simple test", { - res <- ds.asInteger("D$GENDER") + expect_no_error(ds.asInteger("D$GENDER")) - expect_equal(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") + res.class <- ds.class("asinteger.newobj") + expect_equal(res.class$sim1, "integer") + expect_equal(res.class$sim2, "integer") + expect_equal(res.class$sim3, "integer") }) # diff --git a/tests/testthat/test-smk-ds.asList.R b/tests/testthat/test-smk-ds.asList.R index 9fbcfd425..9c359abf1 100644 --- a/tests/testthat/test-smk-ds.asList.R +++ b/tests/testthat/test-smk-ds.asList.R @@ -27,18 +27,12 @@ test_that("setup", { # context("ds.asList::smk::simple test") test_that("simple test", { - res <- ds.asList(x.name="D$GENDER") - - expect_length(res, 3) - expect_length(res$sim1, 2) - expect_equal(res$sim1$return.message, "New object created") - expect_equal(res$sim1$class.of.newobj, "Class of is 'list'") - expect_length(res$sim2, 2) - expect_equal(res$sim2$return.message, "New object created") - expect_equal(res$sim2$class.of.newobj, "Class of is 'list'") - expect_length(res$sim3, 2) - expect_equal(res$sim3$return.message, "New object created") - expect_equal(res$sim3$class.of.newobj, "Class of is 'list'") + expect_no_error(ds.asList(x.name="D$GENDER")) + + res.class <- ds.class("aslist.newobj") + expect_equal(res.class$sim1, "list") + expect_equal(res.class$sim2, "list") + expect_equal(res.class$sim3, "list") }) # diff --git a/tests/testthat/test-smk-ds.asLogical.R b/tests/testthat/test-smk-ds.asLogical.R index 6781beab6..64ad15ece 100644 --- a/tests/testthat/test-smk-ds.asLogical.R +++ b/tests/testthat/test-smk-ds.asLogical.R @@ -27,11 +27,12 @@ test_that("setup", { # context("ds.asLogical::smk::simple test") test_that("simple test", { - res <- ds.asLogical("D$LAB_TSC") + expect_no_error(ds.asLogical("D$LAB_TSC")) - expect_equal(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") + res.class <- ds.class("aslogical.newobj") + expect_equal(res.class$sim1, "logical") + expect_equal(res.class$sim2, "logical") + expect_equal(res.class$sim3, "logical") }) # diff --git a/tests/testthat/test-smk-ds.asMatrix.R b/tests/testthat/test-smk-ds.asMatrix.R index b942425b7..b05b3e846 100644 --- a/tests/testthat/test-smk-ds.asMatrix.R +++ b/tests/testthat/test-smk-ds.asMatrix.R @@ -27,11 +27,12 @@ test_that("setup", { # context("ds.asMatrix::smk::simple test") test_that("simple test", { - res <- ds.asMatrix(x.name="D$GENDER") + expect_no_error(ds.asMatrix(x.name="D$GENDER")) - 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") + res.class <- ds.class("asmatrix.newobj") + expect_true("matrix" %in% res.class$sim1) + expect_true("matrix" %in% res.class$sim2) + expect_true("matrix" %in% res.class$sim3) }) # diff --git a/tests/testthat/test-smk-ds.asNumeric.R b/tests/testthat/test-smk-ds.asNumeric.R index e942c82af..beb3d0f80 100644 --- a/tests/testthat/test-smk-ds.asNumeric.R +++ b/tests/testthat/test-smk-ds.asNumeric.R @@ -27,11 +27,12 @@ test_that("setup", { # context("ds.asNumeric::smk::simple test") test_that("simple test", { - res <- ds.asNumeric("D$GENDER") + expect_no_error(ds.asNumeric("D$GENDER")) - expect_equal(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") + res.class <- ds.class("asnumeric.newobj") + expect_equal(res.class$sim1, "numeric") + expect_equal(res.class$sim2, "numeric") + expect_equal(res.class$sim3, "numeric") }) # diff --git a/tests/testthat/test-smk-ds.changeRefGroup.R b/tests/testthat/test-smk-ds.changeRefGroup.R index 6fe981c2c..416ed4489 100644 --- a/tests/testthat/test-smk-ds.changeRefGroup.R +++ b/tests/testthat/test-smk-ds.changeRefGroup.R @@ -44,23 +44,17 @@ test_that("simple changeRefGroup", { expect_length(res.class$sim1, 1) expect_equal(res.class$sim3, 'factor') expect_length(res.levels, 3) - expect_length(res.levels$sim1, 2) - expect_length(res.levels$sim1$ValidityMessage, 1) - expect_equal(res.levels$sim1$ValidityMessage, "VALID ANALYSIS") + expect_length(res.levels$sim1, 1) expect_length(res.levels$sim1$Levels, 3) expect_equal(res.levels$sim1$Levels[1], 'obesity') expect_equal(res.levels$sim1$Levels[2], 'normal') expect_equal(res.levels$sim1$Levels[3], 'overweight') - expect_length(res.levels$sim2, 2) - expect_length(res.levels$sim2$ValidityMessage, 1) - expect_equal(res.levels$sim2$ValidityMessage, "VALID ANALYSIS") + expect_length(res.levels$sim2, 1) expect_length(res.levels$sim2$Levels, 3) expect_equal(res.levels$sim2$Levels[1], 'obesity') expect_equal(res.levels$sim2$Levels[2], 'normal') expect_equal(res.levels$sim2$Levels[3], 'overweight') - expect_length(res.levels$sim3, 2) - expect_length(res.levels$sim3$ValidityMessage, 1) - expect_equal(res.levels$sim3$ValidityMessage, "VALID ANALYSIS") + expect_length(res.levels$sim3, 1) expect_length(res.levels$sim3$Levels, 3) expect_equal(res.levels$sim3$Levels[1], 'obesity') expect_equal(res.levels$sim3$Levels[2], 'normal') diff --git a/tests/testthat/test-smk-ds.completeCases-vectors.R b/tests/testthat/test-smk-ds.completeCases-vectors.R index 86ba71eb9..6f46df187 100644 --- a/tests/testthat/test-smk-ds.completeCases-vectors.R +++ b/tests/testthat/test-smk-ds.completeCases-vectors.R @@ -29,11 +29,7 @@ test_that("setup", { test_that("completeCases vector", { ds.c("D$survtime", newobj="vec_n") - res.completeCases <- ds.completeCases("vec_n", "vec_n_new") - - expect_length(res.completeCases, 2) - expect_equal(res.completeCases$is.object.created, "A data object has been created in all specified data sources") - expect_equal(res.completeCases$validity.check, " appears valid in all sources") + ds.completeCases("vec_n", "vec_n_new") res.vec.class <- ds.class("vec_n") @@ -84,11 +80,7 @@ test_that("completeCases vector", { test_that("completeCases vector", { ds.asInteger("D$age.60", newobj="vec_i") - res.completeCases <- ds.completeCases("vec_i", "vec_i_new") - - expect_length(res.completeCases, 2) - expect_equal(res.completeCases$is.object.created, "A data object has been created in all specified data sources") - expect_equal(res.completeCases$validity.check, " appears valid in all sources") + ds.completeCases("vec_i", "vec_i_new") res.vec.class <- ds.class("vec_i") @@ -139,11 +131,7 @@ test_that("completeCases vector", { test_that("completeCases vector", { ds.asCharacter("D$age.60", newobj="vec_c") - res.completeCases <- ds.completeCases("vec_c", "vec_c_new") - - expect_length(res.completeCases, 2) - expect_equal(res.completeCases$is.object.created, "A data object has been created in all specified data sources") - expect_equal(res.completeCases$validity.check, " appears valid in all sources") + ds.completeCases("vec_c", "vec_c_new") res.vec.class <- ds.class("vec_c") @@ -194,11 +182,7 @@ test_that("completeCases vector", { test_that("completeCases vector", { ds.asLogical("D$age.60", newobj="vec_l") - res.completeCases <- ds.completeCases("vec_l", "vec_l_new") - - expect_length(res.completeCases, 2) - expect_equal(res.completeCases$is.object.created, "A data object has been created in all specified data sources") - expect_equal(res.completeCases$validity.check, " appears valid in all sources") + ds.completeCases("vec_l", "vec_l_new") res.vec.class <- ds.class("vec_l") @@ -249,11 +233,7 @@ test_that("completeCases vector", { test_that("completeCases vector", { ds.c("D$female", newobj="vec_f") - res.completeCases <- ds.completeCases("vec_f", "vec_f_new") - - expect_length(res.completeCases, 2) - expect_equal(res.completeCases$is.object.created, "A data object has been created in all specified data sources") - expect_equal(res.completeCases$validity.check, " appears valid in all sources") + ds.completeCases("vec_f", "vec_f_new") res.vec.class <- ds.class("vec_f") diff --git a/tests/testthat/test-smk-ds.completeCases.R b/tests/testthat/test-smk-ds.completeCases.R index 3be25b85d..3e6058829 100644 --- a/tests/testthat/test-smk-ds.completeCases.R +++ b/tests/testthat/test-smk-ds.completeCases.R @@ -29,11 +29,7 @@ test_that("setup", { test_that("completeCases data.frame", { 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") - res.completeCases <- ds.completeCases("df", "df_new") - - expect_length(res.completeCases, 2) - expect_equal(res.completeCases$is.object.created, "A data object has been created in all specified data sources") - expect_equal(res.completeCases$validity.check, " appears valid in all sources") + ds.completeCases("df", "df_new") res.df.class <- ds.class("df") @@ -86,11 +82,7 @@ test_that("completeCases data.frame", { test_that("completeCases matrix", { ds.asDataMatrix("D", newobj="mat") - res.completeCases <- ds.completeCases("mat", "mat_new") - - expect_length(res.completeCases, 2) - expect_equal(res.completeCases$is.object.created, "A data object has been created in all specified data sources") - expect_equal(res.completeCases$validity.check, " appears valid in all sources") + ds.completeCases("mat", "mat_new") res.mat.class <- ds.class("mat") @@ -145,6 +137,16 @@ test_that("completeCases matrix", { expect_equal(res.mat_new.dim$`dimensions of mat_new in combined studies`[2], 11) }) +test_that("completeCases, wrong input class returns a server error", { + ds.asList("D$LAB_TSC", newobj="not_a_df") + + expect_error(ds.completeCases("not_a_df", "cc_new"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_match(res.errors[[1]], "is x1 of wrong class") + + ds.rm("not_a_df") +}) + # # Done # diff --git a/tests/testthat/test-smk-ds.dataFrameFill-factor.R b/tests/testthat/test-smk-ds.dataFrameFill-factor.R index bc5464dcf..a09428eb3 100644 --- a/tests/testthat/test-smk-ds.dataFrameFill-factor.R +++ b/tests/testthat/test-smk-ds.dataFrameFill-factor.R @@ -126,13 +126,13 @@ test_that("dataFrameFill_exists", { dis_cva_levelsFilled <- ds.levels('filled_df$DIS_CVA') expect_length(dis_cva_levelsFilled, 3) - expect_length(dis_cva_levelsFilled$sim1, 2) + expect_length(dis_cva_levelsFilled$sim1, 1) expect_length(dis_cva_levelsFilled$sim1$Levels, 2) expect_true(all(dis_cva_levelsFilled$sim1$Levels %in% c("0", "1"))) - expect_length(dis_cva_levelsFilled$sim2, 2) + expect_length(dis_cva_levelsFilled$sim2, 1) expect_length(dis_cva_levelsFilled$sim2$Levels, 2) expect_true(all(dis_cva_levelsFilled$sim2$Levels %in% c("0", "1"))) - expect_length(dis_cva_levelsFilled$sim3, 2) + expect_length(dis_cva_levelsFilled$sim3, 1) expect_length(dis_cva_levelsFilled$sim3$Levels, 2) expect_true(all(dis_cva_levelsFilled$sim3$Levels %in% c("0", "1"))) @@ -159,13 +159,13 @@ test_that("dataFrameFill_exists", { dis_diab_levelsFilled <- ds.levels('filled_df$DIS_DIAB') expect_length(dis_diab_levelsFilled, 3) - expect_length(dis_diab_levelsFilled$sim1, 2) + expect_length(dis_diab_levelsFilled$sim1, 1) expect_length(dis_diab_levelsFilled$sim1$Levels, 2) expect_true(all(dis_diab_levelsFilled$sim1$Levels %in% c("0", "1"))) - expect_length(dis_diab_levelsFilled$sim2, 2) + expect_length(dis_diab_levelsFilled$sim2, 1) expect_length(dis_diab_levelsFilled$sim2$Levels, 2) expect_true(all(dis_diab_levelsFilled$sim2$Levels %in% c("0", "1"))) - expect_length(dis_diab_levelsFilled$sim3, 2) + expect_length(dis_diab_levelsFilled$sim3, 1) expect_length(dis_diab_levelsFilled$sim3$Levels, 2) expect_true(all(dis_diab_levelsFilled$sim3$Levels %in% c("0", "1"))) }) diff --git a/tests/testthat/test-smk-ds.dim.R b/tests/testthat/test-smk-ds.dim.R index 3c8caf0e1..1ce6f250b 100644 --- a/tests/testthat/test-smk-ds.dim.R +++ b/tests/testthat/test-smk-ds.dim.R @@ -70,6 +70,12 @@ test_that("simple dim, combine", { expect_equal(dim.res$`dimensions of D in combined studies`[[2]], 1) }) +test_that("dim, wrong input class returns a server error", { + expect_error(ds.dim("D$LAB_TSC"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_match(res.errors[[1]], "must be of type data.frame or matrix") +}) + # # Done # diff --git a/tests/testthat/test-smk-ds.exp.R b/tests/testthat/test-smk-ds.exp.R index fa850fb81..d4ef60989 100644 --- a/tests/testthat/test-smk-ds.exp.R +++ b/tests/testthat/test-smk-ds.exp.R @@ -27,19 +27,7 @@ test_that("setup", { # context("ds.exp::smk") test_that("simple exp", { - res1 <- ds.exp("D$LAB_TSC", newobj="exp1_obj") - - expect_length(res1, 0) - - res1_exists <- ds.exists("exp1_obj") - - expect_length(res1_exists, 3) - expect_length(res1_exists$sim1, 1) - expect_equal(res1_exists$sim1, TRUE) - expect_length(res1_exists$sim2, 1) - expect_equal(res1_exists$sim2, TRUE) - expect_length(res1_exists$sim3, 1) - expect_equal(res1_exists$sim3, TRUE) + expect_no_error(ds.exp("D$LAB_TSC", newobj="exp1_obj")) res1_class <- ds.class("exp1_obj") @@ -53,21 +41,9 @@ test_that("simple exp", { res_as <- ds.asInteger("D$LAB_TSC", newobj="new_data") - res2 <- ds.exp("new_data", newobj="exp2_obj") - - expect_length(res2, 0) - - res2_exists <- ds.exists("exp2_obj") - - expect_length(res2_exists, 3) - expect_length(res2_exists$sim1, 1) - expect_equal(res2_exists$sim1, TRUE) - expect_length(res2_exists$sim2, 1) - expect_equal(res2_exists$sim2, TRUE) - expect_length(res2_exists$sim3, 1) - expect_equal(res2_exists$sim3, TRUE) + expect_no_error(ds.exp("new_data", newobj="exp2_obj")) - res2_class <- ds.class("exp1_obj") + res2_class <- ds.class("exp2_obj") expect_length(res2_class, 3) expect_length(res2_class$sim1, 1) diff --git a/tests/testthat/test-smk-ds.isNA.R b/tests/testthat/test-smk-ds.isNA.R index a0419eff8..8e916251e 100644 --- a/tests/testthat/test-smk-ds.isNA.R +++ b/tests/testthat/test-smk-ds.isNA.R @@ -33,6 +33,16 @@ test_that("isNA", { expect_false(res$sim1) }) +test_that("isNA, wrong input class returns a server error", { + ds.asList("D$LAB_HDL", newobj="not_a_vector") + + expect_error(ds.isNA(x="not_a_vector"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_match(res.errors[[1]], "must be of type character, factor, integer, logical, numeric, data.frame or matrix") + + ds.rm("not_a_vector") +}) + # # Tear down # diff --git a/tests/testthat/test-smk-ds.length.R b/tests/testthat/test-smk-ds.length.R index b7c9bd764..5df9be590 100644 --- a/tests/testthat/test-smk-ds.length.R +++ b/tests/testthat/test-smk-ds.length.R @@ -53,7 +53,7 @@ test_that("basic length, combine", { }) test_that("basic length, both", { - res.length <- ds.length('D$LAB_TSC', type='both', check=TRUE) + res.length <- ds.length('D$LAB_TSC', type='both') expect_length(res.length, 4) expect_equal(res.length$`length of D$LAB_TSC in sim1`, 2163) @@ -63,7 +63,7 @@ test_that("basic length, both", { }) test_that("basic length, split", { - res.length <- ds.length('D$LAB_TSC', type='split', check=TRUE) + res.length <- ds.length('D$LAB_TSC', type='split') expect_length(res.length, 3) expect_equal(res.length$`length of D$LAB_TSC in sim1`, 2163) @@ -72,7 +72,7 @@ test_that("basic length, split", { }) test_that("basic length, combine", { - res.length <- ds.length('D$LAB_TSC', type='combine', check=TRUE) + res.length <- ds.length('D$LAB_TSC', type='combine') expect_length(res.length, 1) expect_equal(res.length$`total length of D$LAB_TSC in all studies combined`, 9379) diff --git a/tests/testthat/test-smk-ds.levels.R b/tests/testthat/test-smk-ds.levels.R index 022758937..ab94f2ba1 100644 --- a/tests/testthat/test-smk-ds.levels.R +++ b/tests/testthat/test-smk-ds.levels.R @@ -15,7 +15,7 @@ # context("ds.levels::smk::setup") -connect.studies.dataset.cnsim(list("GENDER", "PM_BMI_CATEGORICAL")) +connect.studies.dataset.cnsim(list("LAB_TSC", "GENDER", "PM_BMI_CATEGORICAL")) test_that("setup", { ds_expect_variables(c("D")) @@ -32,21 +32,15 @@ test_that("simple levels", { res <- ds.levels("gender") expect_length(res, 3) - expect_length(res$sim1, 2) - expect_length(res$sim1$ValidityMessage, 1) - expect_equal(res$sim1$ValidityMessage, "VALID ANALYSIS") + expect_length(res$sim1, 1) expect_length(res$sim1$Levels, 2) expect_equal(res$sim1$Levels[1], "0") expect_equal(res$sim1$Levels[2], "1") - expect_length(res$sim2, 2) - expect_length(res$sim2$ValidityMessage, 1) - expect_equal(res$sim2$ValidityMessage, "VALID ANALYSIS") + expect_length(res$sim2, 1) expect_length(res$sim2$Levels, 2) expect_equal(res$sim2$Levels[1], "0") expect_equal(res$sim2$Levels[2], "1") - expect_length(res$sim3, 2) - expect_length(res$sim3$ValidityMessage, 1) - expect_equal(res$sim3$ValidityMessage, "VALID ANALYSIS") + expect_length(res$sim3, 1) expect_length(res$sim3$Levels, 2) expect_equal(res$sim3$Levels[1], "0") expect_equal(res$sim3$Levels[2], "1") @@ -59,29 +53,29 @@ test_that("simple levels", { res <- ds.levels("pm_bmi_categorical") expect_length(res, 3) - expect_length(res$sim1, 2) - expect_length(res$sim1$ValidityMessage, 1) - expect_equal(res$sim1$ValidityMessage, "VALID ANALYSIS") + expect_length(res$sim1, 1) expect_length(res$sim1$Levels, 3) expect_equal(res$sim1$Levels[1], "1") expect_equal(res$sim1$Levels[2], "2") expect_equal(res$sim1$Levels[3], "3") - expect_length(res$sim2, 2) - expect_length(res$sim2$ValidityMessage, 1) - expect_equal(res$sim2$ValidityMessage, "VALID ANALYSIS") + expect_length(res$sim2, 1) expect_length(res$sim2$Levels, 3) expect_equal(res$sim2$Levels[1], "1") expect_equal(res$sim2$Levels[2], "2") expect_equal(res$sim2$Levels[3], "3") - expect_length(res$sim3, 2) - expect_length(res$sim3$ValidityMessage, 1) - expect_equal(res$sim3$ValidityMessage, "VALID ANALYSIS") + expect_length(res$sim3, 1) expect_length(res$sim3$Levels, 3) expect_equal(res$sim3$Levels[1], "1") expect_equal(res$sim3$Levels[2], "2") expect_equal(res$sim3$Levels[3], "3") }) +test_that("levels, wrong input class returns a server error", { + expect_error(ds.levels("D$LAB_TSC"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_match(res.errors[[1]], "must be of type factor") +}) + # # Done # diff --git a/tests/testthat/test-smk-ds.listServersideFunctions.R b/tests/testthat/test-smk-ds.listServersideFunctions.R index 0e3221fb2..df0d5fe49 100644 --- a/tests/testthat/test-smk-ds.listServersideFunctions.R +++ b/tests/testthat/test-smk-ds.listServersideFunctions.R @@ -26,8 +26,8 @@ test_that("check results", { "asFactorDS2", "asFactorSimpleDS", "asIntegerDS", "asListDS", "asLogicalDS", "asMatrixDS", "asNumericDS", "asin", "atan", "attach", "blackBoxRanksDS", "blackBoxRanksDS", "boxPlotGG_data_TreatmentDS", "boxPlotGG_data_Treatment_numericDS", "cDS", "cbindDS", "changeRefGroupDS", "completeCasesDS", "complete.cases", "dataFrameDS", "dataFrameFillDS", "dataFrameSortDS", - "dataFrameSubsetDS2", "dataFrameDS", "dmtC2SDS", "exp", "glmPredictDS.as", "glmSLMADS.assign", "glmSummaryDS.as", "glmerSLMADS.assign", - "lexisDS2", "lexisDS3", "list", "listDS", "log", "lsplineDS", + "dataFrameSubsetDS2", "dataFrameDS", "dmtC2SDS", "expDS", "glmPredictDS.as", "glmSLMADS.assign", "glmSummaryDS.as", "glmerSLMADS.assign", + "lexisDS2", "lexisDS3", "list", "listDS", "logDS", "lsplineDS", "matrixDS", "matrixDetDS2", "matrixDiagDS", "matrixDimnamesDS", "matrixInvertDS", "matrixMultDS", "matrixTransposeDS", "mergeDS", "nsDS", "qlsplineDS", "rBinomDS", "rNormDS", "rPoisDS", "rUnifDS", "ranksSecureDS2", "ranksSecureDS4", "ranksSecureDS5", "rbindDS", "reShapeDS", "recodeLevelsDS", "recodeValuesDS", "repDS", diff --git a/tests/testthat/test-smk-ds.log.R b/tests/testthat/test-smk-ds.log.R index c857408db..558781754 100644 --- a/tests/testthat/test-smk-ds.log.R +++ b/tests/testthat/test-smk-ds.log.R @@ -27,19 +27,7 @@ test_that("setup", { # context("ds.log::smk") test_that("simple log", { - res1 <- ds.log("D$LAB_TSC", newobj="log1_obj") - - expect_length(res1, 0) - - res1_exists <- ds.exists("log1_obj") - - expect_length(res1_exists, 3) - expect_length(res1_exists$sim1, 1) - expect_equal(res1_exists$sim1, TRUE) - expect_length(res1_exists$sim2, 1) - expect_equal(res1_exists$sim2, TRUE) - expect_length(res1_exists$sim3, 1) - expect_equal(res1_exists$sim3, TRUE) + expect_no_error(ds.log("D$LAB_TSC", newobj="log1_obj")) res1_class <- ds.class("log1_obj") @@ -53,19 +41,7 @@ test_that("simple log", { res_as <- ds.asInteger("D$LAB_TSC", newobj="new_data") - res2 <- ds.log("new_data", newobj="log2_obj") - - expect_length(res2, 0) - - res2_exists <- ds.exists("log2_obj") - - expect_length(res2_exists, 3) - expect_length(res2_exists$sim1, 1) - expect_equal(res2_exists$sim1, TRUE) - expect_length(res2_exists$sim2, 1) - expect_equal(res2_exists$sim2, TRUE) - expect_length(res2_exists$sim3, 1) - expect_equal(res2_exists$sim3, TRUE) + expect_no_error(ds.log("new_data", newobj="log2_obj")) res2_class <- ds.class("log2_obj") diff --git a/tests/testthat/test-smk-ds.look.R b/tests/testthat/test-smk-ds.look.R index f4a656837..636154458 100644 --- a/tests/testthat/test-smk-ds.look.R +++ b/tests/testthat/test-smk-ds.look.R @@ -31,9 +31,9 @@ test_that("simple look", { expect_length(res, 1) expect_length(res$output, 3) - expect_equal(res$output$sim1, 2163) - expect_equal(res$output$sim2, 3088) - expect_equal(res$output$sim3, 4128) + expect_equal(res$output$sim1$length, 2163) + expect_equal(res$output$sim2$length, 3088) + expect_equal(res$output$sim3$length, 4128) }) # diff --git a/tests/testthat/test-smk-ds.names.R b/tests/testthat/test-smk-ds.names.R index e73b7b57c..71d93cdb4 100644 --- a/tests/testthat/test-smk-ds.names.R +++ b/tests/testthat/test-smk-ds.names.R @@ -44,6 +44,17 @@ test_that("level_names", { expect_equal(res$sim3[2], 'LAB_HDL') }) +test_that("names, wrong input class returns a server error", { + expect_error(ds.names(x="D$LAB_TSC"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed = TRUE) + + res.errors <- DSI::datashield.errors() + + expect_length(res.errors, 3) + expect_match(res.errors$sim1, "The input object is not of class . 'D$LAB_TSC' is type numeric", fixed = TRUE) + expect_match(res.errors$sim2, "The input object is not of class . 'D$LAB_TSC' is type numeric", fixed = TRUE) + expect_match(res.errors$sim3, "The input object is not of class . 'D$LAB_TSC' is type numeric", fixed = TRUE) +}) + # # Tear down # diff --git a/tests/testthat/test-smk-ds.sqrt.R b/tests/testthat/test-smk-ds.sqrt.R index ccb50c0ca..260da9470 100644 --- a/tests/testthat/test-smk-ds.sqrt.R +++ b/tests/testthat/test-smk-ds.sqrt.R @@ -27,9 +27,7 @@ test_that("setup", { # context("ds.sqrt::smk") test_that("simple c", { - res <- ds.sqrt("D$LAB_TSC", newobj = "sqrt.newobj") - - expect_true(is.null(res)) + expect_no_error(ds.sqrt("D$LAB_TSC", newobj = "sqrt.newobj")) res.length <- ds.length("sqrt.newobj") diff --git a/tests/testthat/test-smk_dgr-ds.asCharacter.R b/tests/testthat/test-smk_dgr-ds.asCharacter.R index 48a2fbd12..965d637a2 100644 --- a/tests/testthat/test-smk_dgr-ds.asCharacter.R +++ b/tests/testthat/test-smk_dgr-ds.asCharacter.R @@ -29,11 +29,7 @@ test_that("setup", { # context("ds.asCharacter::smk_dgr::simple test") test_that("simple test", { - res <- ds.asCharacter("D$LAB_TSC") - - expect_equal(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") + expect_no_error(ds.asCharacter("D$LAB_TSC")) }) #