diff --git a/.Rbuildignore b/.Rbuildignore index 5fa08928..d0f05046 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -23,3 +23,4 @@ ^\.circleci$ ^\.circleci/config\.yml$ ^\.github$ +^man-roxygen$ diff --git a/DESCRIPTION b/DESCRIPTION index ad8e28a6..98c09643 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 8bdab82e..bd539a11 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 779eca1e..08b89bd5 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 41c20455..cc4523f3 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 c0bd4ce0..623e43db 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 7b4833bb..bdfa9fdd 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 9b3b1a39..0e9670df 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 d7366878..83007f5a 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 2ddc33cf..85617edc 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 1c5b0ced..f3980377 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 3e2b445f..803a6308 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 036848ad..ab6e8937 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 a4b98b1a..da842ec0 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 ed95bf6d..107f70de 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 3de389b7..d9fced5d 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 4a6cd3a7..519507ef 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 5bf325bd..65102600 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 1d84577f..5fa3cd01 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 83cb5cae..147fe984 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 b32a5d1c..5dc650b4 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 8c0b2e5d..cfa2155f 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 2f65a3c8..ce96c901 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 97ebbdfd..e348f002 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 0bd75185..4d7bb6d7 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 48aa705b..c658edc9 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 a22d25b3..32bf30e6 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 28a51adb..18d6ca68 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 d531cce4..312e19c5 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 e78011de..3aef2193 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 b3b14ec2..5470e614 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 2d86287b..0d0f6301 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 8f271705..dd8e5e53 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 6dcfe2ee..152b80bf 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 89c1c17d..0c37b9e4 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 55dca1c3..aa7667ba 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 4c834b78..3c753776 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 025a0680..62648552 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 00000000..83526df7 --- /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 b541a390..3844edeb 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 37c44cda..dba71daf 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 a62dec67..70bffd8d 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 ab4b862e..f726b66b 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 8f108fff..2d82fb7e 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 00000000..18b97996 --- /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 639ebd3e..6cd9404d 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 447d9cf9..e557c9fc 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 e6ea9eb9..d9e253e6 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 d2f0455b..0bf7ab47 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 1e2e3c73..6af6f960 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 c42d2e6a..ec539cc3 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 70948014..8116ac1d 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 9928942a..73f03693 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 b2fc0f07..861eeddc 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 e7391081..6915dd59 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 f5df7658..8a8f4ea4 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 44eef9e5..54775443 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 ea3aaa6d..338ee25f 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 875dbe00..dd10147a 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 ec6b2f6f..a9e55110 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 27e105bc..da61ec87 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 fbdab0c4..da714bf5 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 6ab8fee7..a48ee6aa 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 207af854..ae54bd5c 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 199b20d9..984e2596 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 896c76ee..e9724f14 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 03b469a1..1b10f0eb 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 14450927..4fbf3402 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 3b8a4ec0..f73a3ab5 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 dc4cfbd9..67818472 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 638d26a5..95b5432c 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 fe372adb..cd25fe69 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 2f52cff7..3e8da4f9 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 61d6355b..18d77005 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 ec482bed..a645541a 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 56dd89d1..b465e40a 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 27a763d7..3c513277 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 ee80e814..0c6b753e 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 b541a390..3844edeb 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 54e90c36..cb735d81 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 03d36d8f..00000000 --- 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 00000000..cd65d3d1 --- /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 9f1ae6e5..00000000 --- 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 00000000..831ff8e8 --- /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 00000000..181814d3 --- /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 334cd62c..00000000 --- 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 0384bf63..8d762207 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 00000000..fc1e26c3 --- /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 27b4e8bd..2fa7d228 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 06ce3a7a..7e997842 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 cf6bf974..ad2f5bde 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 f8c04910..3faa397a 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 00000000..fc5baf37 --- /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 5254897b..15afe0d5 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 95d0c60b..80dc4ca7 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 00000000..f9c08b7d --- /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 00000000..329c1e2f --- /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 00000000..f3c4d43d --- /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 00000000..a07e9605 --- /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 00000000..e2aa3667 --- /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 00000000..047dc453 --- /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 00000000..8ab5b3d9 --- /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 00000000..9b60c550 --- /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 00000000..4936a975 --- /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 00000000..96ab0be2 --- /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 00000000..e9ad009c --- /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 00000000..bd39e6af --- /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 00000000..682f5c71 --- /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 00000000..dffdbbb6 --- /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 00000000..cc4f54d2 --- /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 d95df5e9..e441895a 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 b8a52bd8..a2fe6384 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 b64b313b..fb3783fb 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 ae8b7e60..abc702e7 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 25ef3736..a9ca652a 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 1ef25fbf..b59ae832 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 9fbcfd42..9c359abf 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 6781beab..64ad15ec 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 b942425b..b05b3e84 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 e942c82a..beb3d0f8 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 6fe981c2..416ed448 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 86ba71eb..6f46df18 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 3be25b85..3e605882 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 bc5464dc..a09428eb 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 3c8caf0e..1ce6f250 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 fa850fb8..d4ef6098 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 a0419eff..8e916251 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 b7c9bd76..5df9be59 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 02275893..ab94f2ba 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 0e3221fb..df0d5fe4 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 c857408d..55878175 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 f4a65683..63615445 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 e73b7b57..71d93cdb 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 ccb50c0c..260da947 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 48a2fbd1..965d637a 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")) }) #