diff --git a/DESCRIPTION b/DESCRIPTION index ad8e28a6..fd0d3d91 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -62,6 +62,7 @@ Depends: R (>= 4.0.0), DSI (>= 1.7.1) Imports: + cli, fields, metafor, meta, @@ -69,7 +70,8 @@ Imports: gridExtra, data.table, methods, - dplyr + dplyr, + cli Suggests: lme4, httr, 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..03d77c35 100644 --- a/R/ds.dataFrameFill.R +++ b/R/ds.dataFrameFill.R @@ -134,9 +134,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..bae9c1d7 100644 --- a/R/ds.numNA.R +++ b/R/ds.numNA.R @@ -13,6 +13,7 @@ #' @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 +53,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..08a0b06d 100644 --- a/R/ds.quantileMean.R +++ b/R/ds.quantileMean.R @@ -103,9 +103,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..013ebdaa 100644 --- a/R/ds.recodeLevels.R +++ b/R/ds.recodeLevels.R @@ -97,8 +97,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..e07072a2 100644 --- a/R/ds.replaceNA.R +++ b/R/ds.replaceNA.R @@ -123,7 +123,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..0235379c 100644 --- a/R/ds.rowColCalc.R +++ b/R/ds.rowColCalc.R @@ -100,10 +100,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..85b4eb8e 100644 --- a/R/ds.subsetByClass.R +++ b/R/ds.subsetByClass.R @@ -91,7 +91,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..fbd75c79 100644 --- a/R/ds.summary.R +++ b/R/ds.summary.R @@ -102,8 +102,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 +118,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 +132,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 +153,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 +167,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 +188,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..81044186 100644 --- a/R/glmChecks.R +++ b/R/glmChecks.R @@ -71,7 +71,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 +82,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..b40c6fff 100644 --- a/R/meanByClassHelper0b.R +++ b/R/meanByClassHelper0b.R @@ -32,14 +32,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..6e495deb 100644 --- a/R/meanByClassHelper2.R +++ b/R/meanByClassHelper2.R @@ -43,8 +43,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 +66,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..14817bb1 100644 --- a/R/meanByClassHelper3.R +++ b/R/meanByClassHelper3.R @@ -36,14 +36,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..51ef63e2 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,69 @@ +#' 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. +#' @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 +#' @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. +#' @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). +#' @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). +#' @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/dsBase_7.0.0-permissive.tar.gz b/dsBase_7.0.0-permissive.tar.gz index ab4b862e..103ffd24 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..1f25c50a 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.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..de4d4dbb 100644 --- a/man/ds.numNA.Rd +++ b/man/ds.numNA.Rd @@ -4,7 +4,7 @@ \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.} @@ -67,4 +67,6 @@ Server function called: \code{numNaDS} } \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.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/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..e4520dd0 100644 --- a/tests/testthat/test-smk-ds.exp.R +++ b/tests/testthat/test-smk-ds.exp.R @@ -27,19 +27,8 @@ 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")) + print(DSI::datashield.errors()) res1_class <- ds.class("exp1_obj") @@ -53,21 +42,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..d588fac9 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,12 +72,22 @@ 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) }) +test_that("length, wrong input class returns a server error", { + ds.asMatrix(x='D$LAB_TSC', newobj="not_a_numeric") + + expect_error(ds.length("not_a_numeric"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + res.errors <- DSI::datashield.errors() + expect_match(res.errors[[1]], "must be of type character, factor, integer, logical, numeric, list or data.frame") + + ds.rm("not_a_numeric") +}) + # # Done # 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..8a822395 100644 --- a/tests/testthat/test-smk-ds.log.R +++ b/tests/testthat/test-smk-ds.log.R @@ -27,19 +27,8 @@ 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")) + print(DSI::datashield.errors()) res1_class <- ds.class("log1_obj") @@ -53,19 +42,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")