diff --git a/DESCRIPTION b/DESCRIPTION index ad8e28a6..5203957a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -62,6 +62,7 @@ Depends: R (>= 4.0.0), DSI (>= 1.7.1) Imports: + cli, fields, metafor, meta, 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/ds.abs.R b/R/ds.abs.R index 41c20455..22c16648 100644 --- a/R/ds.abs.R +++ b/R/ds.abs.R @@ -72,41 +72,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..60b9d20a 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 @@ -57,111 +55,17 @@ #' 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..d705dc95 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 @@ -58,109 +54,17 @@ #' 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..da5117aa 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 @@ -71,106 +68,17 @@ #' @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..5c869d34 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 @@ -58,37 +56,17 @@ #' 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..ca3fec8c 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 @@ -58,109 +55,17 @@ #' 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..0adcb969 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 @@ -59,109 +57,17 @@ #' 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..2067bb53 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 @@ -72,108 +69,17 @@ #' 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.exp.R b/R/ds.exp.R index 5bf325bd..03454aed 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 @@ -57,42 +57,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.log.R b/R/ds.log.R index 8c0b2e5d..4e5b13f3 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)}. @@ -57,42 +57,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.sqrt.R b/R/ds.sqrt.R index e78011de..0f37fb6e 100644 --- a/R/ds.sqrt.R +++ b/R/ds.sqrt.R @@ -70,41 +70,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/utils.R b/R/utils.R new file mode 100644 index 00000000..85d8d7e2 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,51 @@ +#' 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 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/man/ds.asCharacter.Rd b/man/ds.asCharacter.Rd index 447d9cf9..29ceabe0 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. diff --git a/man/ds.asDataMatrix.Rd b/man/ds.asDataMatrix.Rd index e6ea9eb9..7cc1206c 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 diff --git a/man/ds.asInteger.Rd b/man/ds.asInteger.Rd index d2f0455b..d8c696db 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. diff --git a/man/ds.asList.Rd b/man/ds.asList.Rd index 1e2e3c73..1b96bb02 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. diff --git a/man/ds.asLogical.Rd b/man/ds.asLogical.Rd index c42d2e6a..8b277f51 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. diff --git a/man/ds.asMatrix.Rd b/man/ds.asMatrix.Rd index 70948014..e68d9703 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. diff --git a/man/ds.asNumeric.Rd b/man/ds.asNumeric.Rd index 9928942a..6e948d36 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. diff --git a/man/ds.exp.Rd b/man/ds.exp.Rd index 875dbe00..97ba1567 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{ diff --git a/man/ds.log.Rd b/man/ds.log.Rd index 6ab8fee7..661954cd 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{ 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.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-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.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.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.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-smk-ds.abs.R b/tests/testthat/test-smk-ds.abs.R index b64b313b..e35c3b0d 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_silent(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..09e13e0e 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_silent(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..ea606828 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_silent(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..ee841172 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_silent(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..7e198745 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_silent(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..34ad87c8 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_silent(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..aa05040e 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_silent(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..6c5c98e2 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_silent(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.exp.R b/tests/testthat/test-smk-ds.exp.R index fa850fb8..6a7f7b50 100644 --- a/tests/testthat/test-smk-ds.exp.R +++ b/tests/testthat/test-smk-ds.exp.R @@ -27,19 +27,7 @@ test_that("setup", { # context("ds.exp::smk") test_that("simple exp", { - res1 <- ds.exp("D$LAB_TSC", newobj="exp1_obj") - - expect_length(res1, 0) - - res1_exists <- ds.exists("exp1_obj") - - expect_length(res1_exists, 3) - expect_length(res1_exists$sim1, 1) - expect_equal(res1_exists$sim1, TRUE) - expect_length(res1_exists$sim2, 1) - expect_equal(res1_exists$sim2, TRUE) - expect_length(res1_exists$sim3, 1) - expect_equal(res1_exists$sim3, TRUE) + expect_silent(ds.exp("D$LAB_TSC", newobj="exp1_obj")) res1_class <- ds.class("exp1_obj") @@ -53,21 +41,9 @@ test_that("simple exp", { res_as <- ds.asInteger("D$LAB_TSC", newobj="new_data") - res2 <- ds.exp("new_data", newobj="exp2_obj") - - expect_length(res2, 0) - - res2_exists <- ds.exists("exp2_obj") - - expect_length(res2_exists, 3) - expect_length(res2_exists$sim1, 1) - expect_equal(res2_exists$sim1, TRUE) - expect_length(res2_exists$sim2, 1) - expect_equal(res2_exists$sim2, TRUE) - expect_length(res2_exists$sim3, 1) - expect_equal(res2_exists$sim3, TRUE) + expect_silent(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.log.R b/tests/testthat/test-smk-ds.log.R index c857408d..3d4699ac 100644 --- a/tests/testthat/test-smk-ds.log.R +++ b/tests/testthat/test-smk-ds.log.R @@ -27,19 +27,7 @@ test_that("setup", { # context("ds.log::smk") test_that("simple log", { - res1 <- ds.log("D$LAB_TSC", newobj="log1_obj") - - expect_length(res1, 0) - - res1_exists <- ds.exists("log1_obj") - - expect_length(res1_exists, 3) - expect_length(res1_exists$sim1, 1) - expect_equal(res1_exists$sim1, TRUE) - expect_length(res1_exists$sim2, 1) - expect_equal(res1_exists$sim2, TRUE) - expect_length(res1_exists$sim3, 1) - expect_equal(res1_exists$sim3, TRUE) + expect_silent(ds.log("D$LAB_TSC", newobj="log1_obj")) res1_class <- ds.class("log1_obj") @@ -53,19 +41,7 @@ test_that("simple log", { res_as <- ds.asInteger("D$LAB_TSC", newobj="new_data") - res2 <- ds.log("new_data", newobj="log2_obj") - - expect_length(res2, 0) - - res2_exists <- ds.exists("log2_obj") - - expect_length(res2_exists, 3) - expect_length(res2_exists$sim1, 1) - expect_equal(res2_exists$sim1, TRUE) - expect_length(res2_exists$sim2, 1) - expect_equal(res2_exists$sim2, TRUE) - expect_length(res2_exists$sim3, 1) - expect_equal(res2_exists$sim3, TRUE) + expect_silent(ds.log("new_data", newobj="log2_obj")) res2_class <- ds.class("log2_obj") diff --git a/tests/testthat/test-smk-ds.sqrt.R b/tests/testthat/test-smk-ds.sqrt.R index ccb50c0c..de6e3336 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_silent(ds.sqrt("D$LAB_TSC", newobj = "sqrt.newobj")) res.length <- ds.length("sqrt.newobj")