diff --git a/NAMESPACE b/NAMESPACE index 88498755..bd539a11 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -121,9 +121,7 @@ import(DSI) import(data.table) importFrom(DSI,datashield.connections_find) importFrom(cli,cli_abort) -importFrom(stats, - as.formula, - na.omit, - ts, - weighted.mean -) +importFrom(stats,as.formula) +importFrom(stats,na.omit) +importFrom(stats,ts) +importFrom(stats,weighted.mean) diff --git a/R/ds.asFactor.R b/R/ds.asFactor.R index 8e5fbd09..e6b6e7ce 100644 --- a/R/ds.asFactor.R +++ b/R/ds.asFactor.R @@ -133,10 +133,8 @@ #' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login. #' If the \code{datasources} argument is not specified #' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}. -#' @return \code{ds.asFactor} returns the unique levels of the converted -#' variable in ascending order and a validity -#' message with the name of the created object on the client-side and -#' the output matrix or vector in the server-side. +#' @return \code{ds.asFactor} returns the unique levels of the converted +#' variable in ascending order. The output matrix or vector is written to the server-side. #' #' @examples #' \dontrun{ @@ -185,19 +183,12 @@ #' datashield.logout(connections) #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export ds.asFactor <- function(input.var.name=NULL, newobj.name=NULL, forced.factor.levels=NULL, fixed.dummy.vars=FALSE, baseline.level=1, 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) # check if user has provided the name of the column that holds the input variable if(is.null(input.var.name)){ @@ -248,58 +239,7 @@ ds.asFactor <- function(input.var.name=NULL, newobj.name=NULL, forced.factor.lev calltext2 <- call("asFactorDS2", input.var.name, all.unique.levels.transmit, fixed.dummy.vars, baseline.level) DSI::datashield.assign(datasources, newobj.name, calltext2) -########################################################################################################## -#MODULE 5: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED # - # -#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION # -test.obj.name<-newobj.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("Data object <", test.obj.name, "> correctly created in all specified data sources") # - # - return(list(all.unique.levels=all.unique.levels,return.message=return.message)) # - # - }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<-list(return.message.1,return.message.2) # - # - return.info<-object.info # - # -return(list(all.unique.levels=all.unique.levels,return.info=return.info,return.message=return.message)) # - # - } # -#END OF MODULE 5 # -########################################################################################################## - + return(list(all.unique.levels=all.unique.levels)) } #ds.asFactor diff --git a/R/ds.asFactorSimple.R b/R/ds.asFactorSimple.R index 313f7b40..fc092d35 100644 --- a/R/ds.asFactorSimple.R +++ b/R/ds.asFactorSimple.R @@ -17,23 +17,14 @@ #' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login. #' If the \code{datasources} argument is not specified #' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}. -#' @return an output vector of class factor to the serverside. In addition, returns a validity -#' message with the name of the created object on the client-side and if creation fails an -#' error message which can be viewed using datashield.errors(). +#' @return an output vector of class factor written to the serverside. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.asFactorSimple <- function(input.var.name=NULL, newobj.name=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) # check if user has provided the name of the column that holds the input variable if(is.null(input.var.name)){ @@ -55,58 +46,5 @@ ds.asFactorSimple <- function(input.var.name=NULL, newobj.name=NULL, datasources calltext0 <- call("asFactorSimpleDS", input.var.name) DSI::datashield.assign(datasources, newobj.name, calltext0) -########################################################################################################## -#MODULE 5: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED # - # -#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION # -test.obj.name<-newobj.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("Data object <", test.obj.name, "> correctly created in all specified data sources") # - # - return(list(return.message=return.message)) # - # - }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<-list(return.message.1,return.message.2) # - # - return.info<-object.info # - # -return(list(return.info=return.info,return.message=return.message)) # - # - } # -#END OF MODULE 5 # -########################################################################################################## - - } #ds.asFactorSimple diff --git a/R/ds.changeRefGroup.R b/R/ds.changeRefGroup.R index 4bd5080a..a06ac143 100644 --- a/R/ds.changeRefGroup.R +++ b/R/ds.changeRefGroup.R @@ -28,6 +28,7 @@ #' @return \code{ds.changeRefGroup} returns a new vector with the specified level as a reference #' which is written to the server-side. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @seealso \code{\link{ds.cbind}} Combines objects column-wise. #' @seealso \code{\link{ds.levels}} to obtain the levels (categories) of a vector of type factor. #' @seealso \code{\link{ds.colnames}} to obtain the column names of a matrix or a data frame @@ -109,15 +110,7 @@ #' @export ds.changeRefGroup <- function(x=NULL, ref=NULL, newobj=NULL, reorderByRef=FALSE, 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 of type factor!", call.=FALSE) @@ -132,26 +125,12 @@ ds.changeRefGroup <- function(x=NULL, ref=NULL, newobj=NULL, reorderByRef=FALSE, newobj <- "changerefgroup.newobj" } - # 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) - - # if input vector is not a factor stop - if(!('factor' %in% typ)){ - stop("The input vector must be a factor!", call.=FALSE) - } - if(reorderByRef){ warning("'reorderByRef' is set to TRUE. Please read the documentation for possible consequences!", call.=FALSE) } # call the server side function that will recode the levels - cally <- paste0('changeRefGroupDS(', x, ",'", ref, "',", reorderByRef,")") - 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) + calltext <- call("changeRefGroupDS", x, ref, reorderByRef) + DSI::datashield.assign(datasources, newobj, calltext) } diff --git a/R/ds.dmtC2S.R b/R/ds.dmtC2S.R index 085d198f..3c032b71 100644 --- a/R/ds.dmtC2S.R +++ b/R/ds.dmtC2S.R @@ -41,20 +41,13 @@ #' @return the object specified by the argument (or default name "dmt.copied.C2S") #' which is written as a data.frame/matrix/tibble to the serverside. #' @author Paul Burton for DataSHIELD Development Team - 3rd June, 2021 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.dmtC2S <- function(dfdata=NA, newobj=NULL, datasources=NULL){ - # if no opal login details are provided look for 'opal' 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 dfdata if(is.null(dfdata)){ return("Error: dfdata must be a character string, a numeric vector or a scalar") diff --git a/R/ds.reShape.R b/R/ds.reShape.R index f2214f55..38fa36b5 100644 --- a/R/ds.reShape.R +++ b/R/ds.reShape.R @@ -32,12 +32,10 @@ #' @param datasources a list of \code{\link[DSI]{DSConnection-class}} #' objects obtained after login. If the \code{datasources} argument is not specified #' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}. -#' @return \code{ds.reShape} returns to the server-side a reshaped data frame -#' converted from 'long' to 'wide' format or from 'wide' to long' format. -#' Also, two validity messages are returned to the client-side -#' indicating whether the new object has been created in each data source and if so whether -#' it is in a valid form. +#' @return \code{ds.reShape} returns to the server-side a reshaped data frame +#' converted from 'long' to 'wide' format or from 'wide' to long' format. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @examples #' \dontrun{ #' @@ -84,15 +82,7 @@ ds.reShape <- function(data.name=NULL, varying=NULL, v.names=NULL, timevar.name="time", idvar.name="id", drop=NULL, direction=NULL, sep=".", newobj="newObject", 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(data.name)){ stop("Please provide the name of the list that holds the input vectors!", call.=FALSE) @@ -125,81 +115,5 @@ ds.reShape <- function(data.name=NULL, varying=NULL, v.names=NULL, timevar.name= calltext <- call("reShapeDS", data.name, varying.transmit, v.names.transmit, timevar.name, idvar.name, drop.transmit, direction, sep) 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.reShape diff --git a/dsBase_7.0.0-permissive.tar.gz b/dsBase_7.0.0-permissive.tar.gz index 52a3a52f..6ee83c57 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.asFactor.Rd b/man/ds.asFactor.Rd index 24125632..2ca4d1c4 100644 --- a/man/ds.asFactor.Rd +++ b/man/ds.asFactor.Rd @@ -38,10 +38,8 @@ If the \code{datasources} argument is not specified the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.} } \value{ -\code{ds.asFactor} returns the unique levels of the converted -variable in ascending order and a validity -message with the name of the created object on the client-side and -the output matrix or vector in the server-side. +\code{ds.asFactor} returns the unique levels of the converted +variable in ascending order. The output matrix or vector is written to the server-side. } \description{ This function assigns a server-side numeric vector into a factor class. @@ -213,4 +211,6 @@ Server functions called: \code{asFactorDS1} and \code{asFactorDS2} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.asFactorSimple.Rd b/man/ds.asFactorSimple.Rd index d54776a1..8dea54df 100644 --- a/man/ds.asFactorSimple.Rd +++ b/man/ds.asFactorSimple.Rd @@ -22,9 +22,7 @@ If the \code{datasources} argument is not specified the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.} } \value{ -an output vector of class factor to the serverside. In addition, returns a validity -message with the name of the created object on the client-side and if creation fails an -error message which can be viewed using datashield.errors(). +an output vector of class factor written to the serverside. } \description{ ds.asFactorSimple calls the assign function asFactorSimpleDS and @@ -42,4 +40,6 @@ of these things you will have to use the ds.asFactor function. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.changeRefGroup.Rd b/man/ds.changeRefGroup.Rd index 1730a62f..c20f2389 100644 --- a/man/ds.changeRefGroup.Rd +++ b/man/ds.changeRefGroup.Rd @@ -136,4 +136,6 @@ Server function called: \code{changeRefGroupDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.dmtC2S.Rd b/man/ds.dmtC2S.Rd index 51ef6a96..bfd673b4 100644 --- a/man/ds.dmtC2S.Rd +++ b/man/ds.dmtC2S.Rd @@ -59,4 +59,6 @@ columns or by rows and this is defaulted to byrow=FALSE i.e. "by column". } \author{ Paul Burton for DataSHIELD Development Team - 3rd June, 2021 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.reShape.Rd b/man/ds.reShape.Rd index 8acdd161..7b032112 100644 --- a/man/ds.reShape.Rd +++ b/man/ds.reShape.Rd @@ -54,11 +54,8 @@ objects obtained after login. If the \code{datasources} argument is not specifie the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.} } \value{ -\code{ds.reShape} returns to the server-side a reshaped data frame -converted from 'long' to 'wide' format or from 'wide' to long' format. -Also, two validity messages are returned to the client-side -indicating whether the new object has been created in each data source and if so whether -it is in a valid form. +\code{ds.reShape} returns to the server-side a reshaped data frame +converted from 'long' to 'wide' format or from 'wide' to long' format. } \description{ Reshapes a data frame containing longitudinal or @@ -117,4 +114,6 @@ Server function called: \code{reShapeDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/perf_files/armadillo_default_perf-profile.csv b/tests/testthat/perf_files/armadillo_default_perf-profile.csv new file mode 100644 index 00000000..f168f1e6 --- /dev/null +++ b/tests/testthat/perf_files/armadillo_default_perf-profile.csv @@ -0,0 +1,6 @@ +"refer_name","rate","lower_tolerance","upper_tolerance" +"ds.asFactor::perf::0","22.5315","0.5","2" +"ds.asFactorSimple::perf::0","23.9648","0.5","2" +"ds.changeRefGroup::perf::0","24.4483","0.5","2" +"ds.dmtC2S::perf::0","35.8918","0.5","2" +"ds.reShape::perf::0","25.3213","0.5","2" diff --git a/tests/testthat/perf_files/opal_default_perf-profile.csv b/tests/testthat/perf_files/opal_default_perf-profile.csv new file mode 100644 index 00000000..223e17ad --- /dev/null +++ b/tests/testthat/perf_files/opal_default_perf-profile.csv @@ -0,0 +1,6 @@ +"refer_name","rate","lower_tolerance","upper_tolerance" +"ds.asFactor::perf::0","6.4172","0.5","2" +"ds.asFactorSimple::perf::0","13.2276","0.5","2" +"ds.changeRefGroup::perf::0","14.3177","0.5","2" +"ds.dmtC2S::perf::0","13.6619","0.5","2" +"ds.reShape::perf::0","13.7571","0.5","2" diff --git a/tests/testthat/test-arg-ds.changeRefGroup.R b/tests/testthat/test-arg-ds.changeRefGroup.R index 91a0fe24..e1a9977b 100644 --- a/tests/testthat/test-arg-ds.changeRefGroup.R +++ b/tests/testthat/test-arg-ds.changeRefGroup.R @@ -23,7 +23,15 @@ connect.studies.dataset.cnsim(list("DIS_AMI", "LAB_TSC")) test_that("changeRefGroup_erros", { expect_error(ds.changeRefGroup(), "Please provide the name of a vector of type factor!") expect_error(ds.changeRefGroup(x="D$DIS_AMI"), " You must indicate a reference level - set the parameter 'ref'.") - expect_error(ds.changeRefGroup(x="D$LAB_TSC", ref="LAB_TSC"), "The input vector must be a factor!") + + expect_error(ds.changeRefGroup(x="D$LAB_TSC", ref="LAB_TSC"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) + + res.errors <- DSI::datashield.errors() + + expect_length(res.errors, 3) + expect_match(res.errors$sim1, "The server-side object must be of type factor. 'D\\$LAB_TSC' is type numeric.") + expect_match(res.errors$sim2, "The server-side object must be of type factor. 'D\\$LAB_TSC' is type numeric.") + expect_match(res.errors$sim3, "The server-side object must be of type factor. 'D\\$LAB_TSC' is type numeric.") }) # diff --git a/tests/testthat/test-perf-ds.asFactor.R b/tests/testthat/test-perf-ds.asFactor.R new file mode 100644 index 00000000..efcb222c --- /dev/null +++ b/tests/testthat/test-perf-ds.asFactor.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.asFactor::perf::setup") +connect.studies.dataset.survival(list("survtime", "time.id", "female", "age.60")) + +# +# Tests +# + +# context("ds.asFactor::perf::0") +test_that("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.asFactor("D$time.id", newobj.name="factor.newobj", forced.factor.levels=1:6) + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.asFactor::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.asFactor::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.asFactor::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.asFactor::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.asFactor::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.asFactor::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.asFactor::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.asFactor::perf::shutdown") +disconnect.studies.dataset.survival() +# context("ds.asFactor::perf::done") diff --git a/tests/testthat/test-perf-ds.asFactorSimple.R b/tests/testthat/test-perf-ds.asFactorSimple.R new file mode 100644 index 00000000..4d15933c --- /dev/null +++ b/tests/testthat/test-perf-ds.asFactorSimple.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.asFactorSimple::perf::setup") +connect.studies.dataset.survival(list("survtime", "time.id", "female", "age.60")) + +# +# Tests +# + +# context("ds.asFactorSimple::perf::0") +test_that("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.asFactorSimple("D$time.id", newobj.name="factorSimple.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.asFactorSimple::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.asFactorSimple::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.asFactorSimple::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.asFactorSimple::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.asFactorSimple::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.asFactorSimple::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.asFactorSimple::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.asFactorSimple::perf::shutdown") +disconnect.studies.dataset.survival() +# context("ds.asFactorSimple::perf::done") diff --git a/tests/testthat/test-perf-ds.changeRefGroup.R b/tests/testthat/test-perf-ds.changeRefGroup.R new file mode 100644 index 00000000..1b9c5ce1 --- /dev/null +++ b/tests/testthat/test-perf-ds.changeRefGroup.R @@ -0,0 +1,51 @@ + +# +# Set up +# + +# context("ds.changeRefGroup::perf::setup") +connect.studies.dataset.cnsim(list('PM_BMI_CATEGORICAL')) + +# +# Tests +# + +# context("ds.changeRefGroup::perf::0") +test_that("performance", { + ds.asFactorSimple("D$PM_BMI_CATEGORICAL", newobj.name="bmi_new") + .durationSec <- 30 # seconds + .count <- 0 + .start.time <- Sys.time() + .current.time <- .start.time + + while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { + ds.changeRefGroup(x="bmi_new", ref="1", reorderByRef=FALSE, newobj="bmi_ob") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.changeRefGroup::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.changeRefGroup::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.changeRefGroup::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.changeRefGroup::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.changeRefGroup::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.changeRefGroup::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.changeRefGroup::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.changeRefGroup::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.changeRefGroup::perf::done") diff --git a/tests/testthat/test-perf-ds.dmtC2S.R b/tests/testthat/test-perf-ds.dmtC2S.R new file mode 100644 index 00000000..689726be --- /dev/null +++ b/tests/testthat/test-perf-ds.dmtC2S.R @@ -0,0 +1,52 @@ + +# +# Set up +# + +# context("ds.dmtC2S::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC")) + +# +# Tests +# + +# context("ds.dmtC2S::perf::0") +test_that("performance", { + .durationSec <- 30 # seconds + .count <- 0 + .start.time <- Sys.time() + .current.time <- .start.time + + cdf <- data.frame(c(1, 2, 3, 4), c(2, 3, 4, 1)) + + while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { + ds.dmtC2S(dfdata=cdf, newobj="dmtc2s.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.dmtC2S::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.dmtC2S::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.dmtC2S::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.dmtC2S::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.dmtC2S::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.dmtC2S::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.dmtC2S::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.dmtC2S::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.dmtC2S::perf::done") diff --git a/tests/testthat/test-perf-ds.reShape.R b/tests/testthat/test-perf-ds.reShape.R new file mode 100644 index 00000000..a6aa856a --- /dev/null +++ b/tests/testthat/test-perf-ds.reShape.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.reShape::perf::setup") +connect.studies.dataset.survival(list("id", "study.id", "time.id", "cens", "age.60", "female")) + +# +# Tests +# + +# context("ds.reShape::perf::0") +test_that("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.reShape(data.name="D", varying=NULL, v.names=NULL, timevar.name=NULL, idvar.name=NULL, direction="wide", newobj="reshape.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.reShape::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.reShape::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.reShape::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.reShape::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.reShape::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.reShape::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.reShape::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.reShape::perf::shutdown") +disconnect.studies.dataset.survival() +# context("ds.reShape::perf::done") diff --git a/tests/testthat/test-smk-ds.reShape.R b/tests/testthat/test-smk-ds.reShape.R index 2836d20b..dc6a8047 100644 --- a/tests/testthat/test-smk-ds.reShape.R +++ b/tests/testthat/test-smk-ds.reShape.R @@ -27,11 +27,9 @@ test_that("setup", { # context("ds.reShape::smk") test_that("simplest ds.reShape, wide", { - res <- ds.reShape(data.name="D", v.names="age.60", timevar.name="time.id", idvar.name="id", direction="wide", newobj="reshape1_obj") + ds.reShape(data.name="D", v.names="age.60", timevar.name="time.id", idvar.name="id", direction="wide", newobj="reshape1_obj") - 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") + ds_expect_variables(c("D", "reshape1_obj")) }) # test_that("simplest ds.reShape, long", {