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.class.R b/R/ds.class.R index 036848ad..5f1d1188 100644 --- a/R/ds.class.R +++ b/R/ds.class.R @@ -54,23 +54,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.completeCases.R b/R/ds.completeCases.R index ed95bf6d..b990a6d9 100644 --- a/R/ds.completeCases.R +++ b/R/ds.completeCases.R @@ -71,120 +71,18 @@ #' @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.dim.R b/R/ds.dim.R index 4a6cd3a7..473f1e1f 100644 --- a/R/ds.dim.R +++ b/R/ds.dim.R @@ -84,51 +84,32 @@ #' #' } #' -ds.dim <- function(x=NULL, type='both', checks=FALSE, datasources=NULL) { +ds.dim <- function(x=NULL, type='both', 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) + + # check class consistency across studies + classes <- lapply(results, function(r) r$class) + if(length(unique(lapply(classes, sort))) > 1){ + stop("The input object is not of the same class in all studies!", call.=FALSE) + } + + # 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..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.isNA.R b/R/ds.isNA.R index 1d84577f..54a2563a 100644 --- a/R/ds.isNA.R +++ b/R/ds.isNA.R @@ -57,46 +57,23 @@ #' ds.isNA <- 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 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) - # 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]]){ 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..3e3f28fe 100644 --- a/R/ds.length.R +++ b/R/ds.length.R @@ -74,50 +74,35 @@ #' datashield.logout(connections) #' } #' -ds.length <- function(x=NULL, type='both', checks='FALSE', datasources=NULL){ +ds.length <- function(x=NULL, type='both', 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) + + # check class consistency across studies + classes <- lapply(results, function(r) r$class) + if(length(unique(lapply(classes, sort))) > 1){ + stop("The input object is not of the same class in all studies!", call.=FALSE) + } + + # 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..ffa655c3 100644 --- a/R/ds.levels.R +++ b/R/ds.levels.R @@ -58,35 +58,15 @@ #' 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) + output <- DSI::datashield.aggregate(datasources, cally) return(output) - + } 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.ls.R b/R/ds.ls.R index 2f65a3c8..4bc3aacf 100644 --- a/R/ds.ls.R +++ b/R/ds.ls.R @@ -117,15 +117,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 +184,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..2290e478 100644 --- a/R/ds.names.R +++ b/R/ds.names.R @@ -68,25 +68,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..a0d26695 100644 --- a/R/ds.numNA.R +++ b/R/ds.numNA.R @@ -54,29 +54,14 @@ #' ds.numNA <- 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 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) - - # call the server side function - cally <- paste0("numNaDS(", x, ")") - numNAs <- DSI::datashield.aggregate(datasources, as.symbol(cally)) + cally <- call("numNaDS", x) + numNAs <- DSI::datashield.aggregate(datasources, cally) return(numNAs) } 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/ds.unique.R b/R/ds.unique.R index 8f271705..0f1e7359 100644 --- a/R/ds.unique.R +++ b/R/ds.unique.R @@ -46,29 +46,18 @@ #' @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/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/REFACTOR_GUIDE.md b/REFACTOR_GUIDE.md new file mode 100644 index 00000000..3cbcedb7 --- /dev/null +++ b/REFACTOR_GUIDE.md @@ -0,0 +1,303 @@ +# Refactoring Plan: dsBase & dsBaseClient Function Pairs + +> **Action:** Replace `/Users/tcadman/github-repos/ds-core/dsBaseClient/REFACTOR_GUIDE.md` with this plan content so it's accessible across branches. + +## Context + +The `ds.colnames` / `colnamesDS` pair has been refactored as a reference implementation. The pattern shifts server-state validation (object existence, type checking) from client to server, reducing network round trips and centralizing validation where data lives. This needs to be applied across all remaining function pairs in both packages. + +The refactored `ds.colnames` branch (`v7.0-dev-colnames`) also introduces shared helpers: +- **Client:** `R/utils.R` with `.set_datasources()`, `.check_df_name_provided()` +- **Server:** `R/utils.R` with `.loadServersideObject()`, `.checkClass()` + +## Relationship Between Packages + +- **dsBaseClient** (`/Users/tcadman/github-repos/ds-core/dsBaseClient/R/`) — Client functions (`ds.functionName`) that validate inputs and dispatch calls to server +- **dsBase** (`/Users/tcadman/github-repos/ds-core/dsBase/R/`) — Server functions (`functionNameDS`) that execute on the data + +## What Changes Per Function Pair + +### Client-side (dsBaseClient) + +1. **Replace datasource boilerplate** with `datasources <- .set_datasources(datasources)` + - Removes: `datashield.connections_find()` + DSConnection class check (~8 lines) + +2. **Remove `isDefined()` calls** — server handles via `.loadServersideObject()` + +3. **Remove `checkClass()` calls and subsequent type guards** — server handles via `.checkClass()` + +4. **Remove `isAssigned()` calls** — no longer verify object creation client-side + +5. **Remove MODULE 5 boilerplate** — the ~40-80 line "CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED" block + +6. **Remove `checks` parameter** — functions like `ds.dim` and `ds.length` have a `checks` parameter that gates `isDefined()`/`checkClass()` calls. Once those calls are removed, the parameter serves no purpose. Remove it from the function signature and delete the associated conditional block. + +7. **Replace per-study loops with single aggregate calls** — some functions (e.g. `ds.isNA`) loop over datasources one at a time (`datashield.aggregate(datasources[i], ...)`). Since `datashield.aggregate` already supports multiple datasources and returns a named list, replace these loops with a single call and process results client-side. This collapses N sequential round trips into 1 parallel call. + +8. **Keep**: null-input checks (or replace with `.check_df_name_provided()`), default `newobj` naming, the actual server call dispatch, any pure client-side logic + +### Server-side (dsBase) + +1. **Replace `eval(parse(text=x), envir=parent.frame())`** with `.loadServersideObject(x)` + +2. **Replace dispatch-layer object resolution** with `.loadServersideObject(x)` + - Some functions (e.g. isNaDS, isValidDS, numNaDS, levelsDS) never use `eval(parse())` internally. Instead, the client dispatches them via `as.symbol(paste0("funcDS(", x, ")"))` or `call("funcDS", x)`, which causes DataSHIELD to evaluate the object name (e.g. `D$LAB_HDL`) at the dispatch layer — so the server function receives the resolved R object directly. + - To refactor: change the server function signature to accept a **string name** instead of the object, then call `.loadServersideObject(x)` inside the function body. On the client, switch to `call("funcDS", x)` (passing the string). This moves object resolution from the DataSHIELD dispatch layer into the server function, consistent with the `.loadServersideObject()` pattern. + +3. **Add `.checkClass()`** where the client previously enforced type constraints + +4. **Keep**: all computation logic, disclosure controls, privacy checks + +### Tests + +**Server-side unit tests** (new `test-smk-functionNameDS.R` in dsBase): +- Happy path: call with valid input, assert correct output +- Unhappy: nonexistent object → `expect_error(..., "does not exist")` +- Unhappy: wrong type → `expect_error(..., "must be of type")` (only where `.checkClass()` is used) + +**Client-side end-to-end tests** (update existing `test-smk-ds.functionName.R` in dsBaseClient): +- Happy path: existing tests should still pass +- Unhappy: nonexistent object → `expect_error(..., "DataSHIELD errors")` +- Unhappy: wrong type → `expect_error(..., "DataSHIELD errors")` (where type was previously checked client-side) +- Update any tests that expected client-side error messages to expect server-originated errors + +**Design decisions:** +- Functions accepting any class: use `.loadServersideObject()` only, no `.checkClass()` +- Client tests must include unhappy paths testing server error propagation +- Start with Batch 1 (simple coercions) + +## Excluded Functions + +**Deprecated (12):** ds.look, ds.meanByClass, ds.message, ds.recodeLevels, ds.setDefaultOpals, ds.subset, ds.subsetByClass, ds.table1D, ds.table2D, ds.vectorCalc, ds.listOpals, ds.listServersideFunctions + +**Already done:** ds.colnames / colnamesDS + +**Client-only (no server pair):** checkClass.R, isDefined.R, isAssigned.R, extract.R, glmChecks.R, getPooledMean.R, getPooledVar.R, helpers (meanByClassHelper*, subsetHelper, logical2int, colPercent, rowPercent) + +## Batches + +### Batch 1 — Simple Type Coercions (11 pairs) +Single input → single output, straightforward `eval(parse())` replacement. + +| Client | Server | Permitted classes | Notes | +|--------|--------|-------------------|-------| +| ds.abs | absDS | numeric, integer | | +| ds.asCharacter | asCharacterDS | * | | +| ds.asDataMatrix | asDataMatrixDS | data.frame, matrix | | +| ds.asInteger | asIntegerDS | * | | +| ds.asList | asListDS | * | **AGGREGATE** (not assign); server takes 2 params (x.name, newobj) | +| ds.asLogical | asLogicalDS | * | Server has existing type validation (numeric/integer/character/matrix) — preserve as `.checkClass()` | +| ds.asMatrix | asMatrixDS | * | | +| ds.asNumeric | asNumericDS | * | Server has complex factor/character conversion logic — preserve | +| ds.exp | **NEW: expDS** | numeric, integer | No server DS function exists — client currently calls native `exp()` via `as.symbol()`. Must create `expDS.R` | +| ds.log | **NEW: logDS** | numeric, integer | No server DS function exists — client currently calls native `log()` via `as.symbol()`. Must create `logDS.R`. Has `base` parameter | +| ds.sqrt | sqrtDS | numeric, integer | | + +`*` = accept any class — only use `.loadServersideObject()`, no `.checkClass()` needed + +**Batch 1 sub-patterns discovered:** +- **Math ops (abs, exp, log, sqrt):** Client uses `checkClass()` + `isAssigned()`, no MODULE 5 +- **Type conversions (asCharacter, asDataMatrix, asInteger, asLogical, asMatrix, asNumeric):** Client uses `isDefined()` + MODULE 5 block (except asList which has neither) +- **asList is unique:** Uses `datashield.aggregate` instead of `datashield.assign` + +### Batch 2 — Simple Aggregations (10 pairs) +Return results to client, no server-side assignment. + +| Client | Server | Permitted classes | +|--------|--------|-------------------| +| ds.class | classDS | * | +| ds.dim | dimDS | data.frame, matrix | +| ds.length | lengthDS | character, factor, integer, logical, numeric, list | +| ds.names | namesDS | * | +| ds.isNA | isNaDS | character, factor, integer, logical, numeric, data.frame, matrix | +| ds.numNA | numNaDS | * | +| ds.ls | lsDS | (no object input) | +| ds.completeCases | completeCasesDS | * (no .checkClass — server handles via own branching) | +| ds.levels | levelsDS | factor | +| ds.unique | uniqueDS | * | + +**Deferred from Batch 2:** ds.isValid / isValidDS — `isValidDS` is used as an internal disclosure-control helper by `replaceNaDS` (Batch 4), `quantileMeanDS` (Batch 3), and `rowColCalcDS` (Batch 10), all passing objects directly. Cannot change `isValidDS` signature until those callers are refactored. Refactor ds.isValid/isValidDS when the last internal caller is refactored (see Batch 10 notes). + +**Batch 2 sub-patterns:** +- **Standard eval(parse()) functions (classDS, dimDS, lengthDS, namesDS, lsDS, completeCasesDS, uniqueDS):** Server uses `eval(parse(text=x), envir=parent.frame())` — replace with `.loadServersideObject()` +- **Dispatch-layer resolution functions (isNaDS, numNaDS, levelsDS):** Server receives resolved R objects via client `as.symbol()`/`call()` dispatch — change server to accept string name + `.loadServersideObject()`, change client to `call("funcDS", x)` +- **Assign functions (completeCases, unique):** Use `datashield.assign` not `datashield.aggregate` — still remove MODULE 5 / isAssigned +- **Client-side processing to preserve:** ds.dim and ds.length have `type` parameter with alias normalization and cross-study pooling; ds.isNA has per-study loop with conditional messaging; ds.ls has wildcard `*` → `_:A:_` escaping +- **Pooling functions (dimDS, lengthDS):** Return `list(dim=..., class=...)` / `list(length=..., class=...)` so client can check cross-study class consistency before pooling results + +### Batch 3 — Statistics (10 pairs) +Aggregate functions returning computed values. Some have multi-step server calls. + +| Client | Server | Notes | +|--------|--------|-------| +| ds.mean | meanDS | has disclosure controls | +| ds.var | varDS | has disclosure controls | +| ds.cor | corDS | two inputs | +| ds.corTest | corTestDS | two inputs | +| ds.cov | covDS | two inputs | +| ds.kurtosis | kurtosisDS1/DS2 | multi-step | +| ds.skewness | skewnessDS1/DS2 | multi-step | +| ds.quantileMean | quantileMeanDS | aggregate | +| ds.meanSdGp | meanSdGpDS | aggregate | +| ds.summary | (check server) | aggregate | + +### Batch 4 — Data Manipulation / Assign (15 pairs) +Create/modify server objects. Many have MODULE 5 blocks. + +| Client | Server | Notes | +|--------|--------|-------| +| ds.Boole | BooleDS | assign, MODULE 5 | +| ds.c | cDS | multi-input assign | +| ds.cbind | cbindDS | multi-input, permissive check | +| ds.rbind | rbindDS | multi-input | +| ds.dataFrame | dataFrameDS | multi-input, complex | +| ds.dataFrameSort | dataFrameSortDS | assign, MODULE 5 | +| ds.dataFrameSubset | dataFrameSubsetDS1/DS2 | multi-step | +| ds.dataFrameFill | dataFrameFillDS | assign | +| ds.list | listDS | assign | +| ds.unList | unListDS | assign | +| ds.merge | mergeDS | assign, MODULE 5 | +| ds.rep | repDS | assign | +| ds.seq | seqDS | assign | +| ds.replaceNA | replaceNaDS | assign, per-source loop | +| ds.recodeValues | recodeValuesDS | assign | + +### Batch 5 — Matrix Operations (8 pairs) + +| Client | Server | +|--------|--------| +| ds.matrix | matrixDS | +| ds.matrixDet | matrixDetDS1/DS2 | +| ds.matrixDet.report | matrixDetDS2 | +| ds.matrixDiag | matrixDiagDS | +| ds.matrixDimnames | matrixDimnamesDS | +| ds.matrixInvert | matrixInvertDS | +| ds.matrixMult | matrixMultDS | +| ds.matrixTranspose | matrixTransposeDS | + +### Batch 6 — Factor & Recoding (5 pairs) + +| Client | Server | +|--------|--------| +| ds.asFactor | asFactorDS1/DS2 | +| ds.asFactorSimple | asFactorSimpleDS | +| ds.changeRefGroup | changeRefGroupDS | +| ds.reShape | reShapeDS | +| ds.dmtC2S | dmtC2SDS | + +### Batch 7 — Modelling (8 pairs) +Most complex. Multiple server calls, complex validation logic. + +| Client | Server | +|--------|--------| +| ds.glm | glmDS1/DS2 | +| ds.glmSLMA | glmSLMADS1/DS2/assign | +| ds.glmPredict | glmPredictDS.ag/as | +| ds.glmSummary | glmSummaryDS.ag/as | +| ds.glmerSLMA | glmerSLMADS2/assign | +| ds.lmerSLMA | lmerSLMADS2/assign | +| ds.gamlss | gamlssDS | +| ds.mice | miceDS | + +### Batch 8 — Random Generation & Sampling (6 pairs) + +| Client | Server | +|--------|--------| +| ds.rBinom | rBinomDS | +| ds.rNorm | rNormDS | +| ds.rPois | rPoisDS | +| ds.rUnif | rUnifDS | +| ds.sample | sampleDS | +| ds.setSeed | setSeedDS | + +### Batch 9 — Plotting & Visualization (7 pairs) + +| Client | Server | +|--------|--------| +| ds.histogram | histogramDS1/DS2 | +| ds.heatmapPlot | heatmapPlotDS | +| ds.contourPlot | (check server name) | +| ds.densityGrid | densityGridDS | +| ds.scatterPlot | scatterPlotDS | +| ds.boxPlot | (check server) | +| ds.boxPlotGG | boxPlotGGDS | + +### Batch 10 — Splines, Tables, Misc (14 pairs) + +| Client | Server | +|--------|--------| +| ds.elspline | elsplineDS | +| ds.lspline | lsplineDS | +| ds.ns | nsDS | +| ds.qlspline | qlsplineDS | +| ds.table | tableDS/tableDS.assign/tableDS2 | +| ds.tapply | tapplyDS | +| ds.tapply.assign | tapplyDS.assign | +| ds.rowColCalc | rowColCalcDS | +| ds.make | (check server) | +| ds.assign | (check server) | +| ds.metadata | metadataDS | +| ds.getWGSR | getWGSRDS | +| ds.lexis | lexisDS1/DS2/DS3 | +| ds.hetcor | hetcorDS | + +**Batch 10 dependency:** `rowColCalcDS` calls `isValidDS(result)` internally as a disclosure check. When refactoring `rowColCalcDS`, replace this with direct disclosure logic or `.loadServersideObject()` + `.checkClass()`. Once done, also refactor `ds.isValid` / `isValidDS` (deferred from Batch 2). Similarly, `replaceNaDS` (Batch 4) and `quantileMeanDS` (Batch 3) call `isValidDS()` internally — refactor those callers first before changing `isValidDS`'s signature. + +## Per-Batch Workflow + +**Important:** dsBase and dsBaseClient are separate git repos. Changes must be committed and tested in the correct order since the client depends on the server package being installed. + +### Step 1 — Server-side (dsBase repo) +1. Create feature branch from `v7.0-dev` in dsBase +2. Refactor server functions: + - Replace `eval(parse())` → `.loadServersideObject()` + - Add `.checkClass()` where the client had type guards +3. Write server-side unit tests (`test-smk-functionNameDS.R`) with happy + unhappy paths +4. Run `devtools::check(args = '--no-tests')` and `devtools::test()` in dsBase +5. Build package: `devtools::build()` + +### Step 2 — Install refactored dsBase on Armadillo +6. Ensure `inst/DATASHIELD` has `default.datashield.privacyControlLevel="permissive"` before building +7. Build package: `devtools::build()` in dsBase +8. Copy the built tar to dsBaseClient as `dsBase_7.0.0-permissive.tar.gz` (this is the filename the CI pipeline references in `armadillo_azure-pipelines.yml`) +9. Install on local Armadillo: `armadillo.login("http://localhost:8080")` then `armadillo.install_packages(paths = "", profile = "default")` + +### Step 3 — Client-side (dsBaseClient repo) +7. Create feature branch from `v7.0-dev` in dsBaseClient +8. Ensure `R/utils.R` exists (copy from `v7.0-dev-colnames` branch if needed) +9. Refactor client functions: + - Replace datasource boilerplate → `.set_datasources()` + - Remove `isDefined()`, `checkClass()`, `isAssigned()` calls + - Remove MODULE 5 blocks + - Replace null-input checks with `.check_df_name_provided()` where applicable +10. Update/add client end-to-end tests with happy + unhappy paths +11. Run `devtools::check(args = '--no-tests')` in dsBaseClient +12. Run `devtools::test(filter = "smk-|disc|arg")` for affected functions (requires refactored dsBase to be installed on Armadillo) + +### Step 4 — Verify +13. Run full test suite to check no regressions +14. Run perf tests at 30 seconds (default): `devtools::test(filter = "perf-")` +15. Compare perf results against the v7.0-dev branch baseline to detect any regressions from the refactoring + +## Key Files + +### Reference implementation +- Client refactored: `git show v7.0-dev-colnames:R/ds.colnames.R` +- Server refactored: `/Users/tcadman/github-repos/ds-core/dsBase/R/colnamesDS.R` +- Client utils: `git show v7.0-dev-colnames:R/utils.R` +- Server utils: `/Users/tcadman/github-repos/ds-core/dsBase/R/utils.R` +- Server tests: `/Users/tcadman/github-repos/ds-core/dsBase/tests/testthat/test-smk-colnamesDS.R` +- Client tests: `/Users/tcadman/github-repos/ds-core/dsBaseClient/tests/testthat/test-smk-ds.colnames.R` + +### Guides +- `/Users/tcadman/github-repos/ds-core/dsBaseClient/REFACTOR_GUIDE.md` +- `/Users/tcadman/github-repos/ds-core/dsBase/.github/pull_request_template` + +## Verification + +For each batch: +1. Run server-side unit tests: `cd dsBase && devtools::test(filter = "functionNameDS")` +2. Run client-side smoke tests: `cd dsBaseClient && devtools::test(filter = "smk-ds.functionName")` +3. Run `devtools::check(args = '--no-tests')` on both packages +4. Run full test suite: `devtools::test(filter = "smk-|disc|arg")` to check no regressions +5. Run perf tests: `PERF_DURATION_SEC=2 devtools::test(filter = "perf-")` to verify no performance regression diff --git a/dsBase_7.0.0-permissive.tar.gz b/dsBase_7.0.0-permissive.tar.gz index ab4b862e..f79f7691 100644 Binary files a/dsBase_7.0.0-permissive.tar.gz and b/dsBase_7.0.0-permissive.tar.gz differ 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.dim.Rd b/man/ds.dim.Rd index ea3aaa6d..c410ac46 100644 --- a/man/ds.dim.Rd +++ b/man/ds.dim.Rd @@ -4,7 +4,7 @@ \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", datasources = NULL) } \arguments{ \item{x}{a character string providing the name of the input object.} @@ -17,12 +17,12 @@ 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{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}}.} + +\item{checks}{logical. If TRUE undertakes all DataSHIELD checks (time-consuming). +Default FALSE.} } \value{ \code{ds.dim} retrieves to the client-side the dimension of the object 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.length.Rd b/man/ds.length.Rd index 27e105bc..01e96dc7 100644 --- a/man/ds.length.Rd +++ b/man/ds.length.Rd @@ -4,7 +4,7 @@ \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", datasources = NULL) } \arguments{ \item{x}{a character string specifying the name of a vector or list.} @@ -18,13 +18,13 @@ 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{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}}.} + +\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.} } \value{ \code{ds.length} returns to the client-side the pooled length of a vector or a list, 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.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..63f6918c 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") 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.length.R b/tests/testthat/test-smk-ds.length.R index b7c9bd76..5df9be59 100644 --- a/tests/testthat/test-smk-ds.length.R +++ b/tests/testthat/test-smk-ds.length.R @@ -53,7 +53,7 @@ test_that("basic length, combine", { }) test_that("basic length, both", { - res.length <- ds.length('D$LAB_TSC', type='both', check=TRUE) + res.length <- ds.length('D$LAB_TSC', type='both') expect_length(res.length, 4) expect_equal(res.length$`length of D$LAB_TSC in sim1`, 2163) @@ -63,7 +63,7 @@ test_that("basic length, both", { }) test_that("basic length, split", { - res.length <- ds.length('D$LAB_TSC', type='split', check=TRUE) + res.length <- ds.length('D$LAB_TSC', type='split') expect_length(res.length, 3) expect_equal(res.length$`length of D$LAB_TSC in sim1`, 2163) @@ -72,7 +72,7 @@ test_that("basic length, split", { }) test_that("basic length, combine", { - res.length <- ds.length('D$LAB_TSC', type='combine', check=TRUE) + res.length <- ds.length('D$LAB_TSC', type='combine') expect_length(res.length, 1) expect_equal(res.length$`total length of D$LAB_TSC in all studies combined`, 9379) diff --git a/tests/testthat/test-smk-ds.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")