diff --git a/R/ds.rBinom.R b/R/ds.rBinom.R index ec8b4f88..1759db7d 100644 --- a/R/ds.rBinom.R +++ b/R/ds.rBinom.R @@ -31,9 +31,9 @@ #' Server functions called: \code{rBinomDS} and \code{setSeedDS}. #' @param samp.size an integer value or an integer vector that defines the length of #' the random numeric vector to be created in each source. -#' @param size a positive integer that specifies the number of Bernoulli trials. +#' @param size a positive integer that specifies the number of Bernoulli trials. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k. #' @param prob a numeric scalar value or vector in range 0 > prob > 1 which specifies the -#' probability of a positive response (i.e. 1 rather than 0). +#' probability of a positive response (i.e. 1 rather than 0). A single value is used in every study; a vector must have one value per study, with its k-th value used in study k. #' @param newobj a character string that provides the name for the output variable #' that is stored on the data servers. Default \code{rbinom.newobj}. #' @param seed.as.integer an integer or a NULL value which provides the @@ -44,13 +44,12 @@ #' @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.rBinom} returns random number vectors -#' with a Binomial distribution for each study, -#' taking into account the values specified in each parameter of the function. -#' The output vector is written to the server-side. -#' If requested, it also returned to the client-side the full 626 lengths -#' random seed vector generated in each source -#' (see info for the argument \code{return.full.seed.as.set}). +#' @return \code{ds.rBinom} writes a random number vector with a Binomial distribution +#' to the server-side in each study and returns a list to the client-side containing +#' \code{integer.seed.as.set.by.source} (the trigger seed set in each source), +#' \code{random.vector.length.by.source} (the length of the vector created in each source) +#' and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set} +#' (the full 626 length random seed vector generated in each source). #' #' @examples #' \dontrun{ @@ -83,7 +82,7 @@ #' #' #Generating the vectors in the Opal servers #' ds.rBinom(samp.size=c(13,20,25), #the length of the vector created in each source is different -#' size=as.character(c(10,23,5)), #Bernoulli trials change in each source +#' size=c(10,23,5), #Bernoulli trials change in each source #' prob=c(0.6,0.1,0.5), #Probability changes in each source #' newobj="Binom.dist", #' seed.as.integer=45, @@ -103,19 +102,11 @@ #' datashield.logout(connections) #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export ds.rBinom<-function(samp.size=1,size=0,prob=1, newobj=NULL, seed.as.integer=NULL, return.full.seed.as.set=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) # create a name by default if user did not provide a name for the new variable if(is.null(newobj)){ @@ -162,9 +153,13 @@ mess2<-("ERROR: appropriate values must be set for samp.size, size, prob, and ne return(mess2) } +numsources<-length(datasources) +size<-.expand_to_studies(size, "size", numsources) +prob<-.expand_to_studies(prob, "prob", numsources) + size.valid<-1 if(is.numeric(size)){ - if(size<=0){ + if(any(size<=0)){ size.valid<-0 } } @@ -176,7 +171,7 @@ return(mess3) prob.valid<-1 if(is.numeric(prob)){ - if(prob<=0||prob>=1.0){ + if(any(prob<=0|prob>=1.0)){ prob.valid<-0 } } @@ -217,8 +212,7 @@ if(seed.as.text=="NULL"){ message("NO SEED SET IN STUDY",study.id,"\n\n") } else { - calltext <- paste0("setSeedDS(", seed.as.text, ")") - ssDS.obj[[study.id]] <- DSI::datashield.aggregate(datasources[study.id], as.symbol(calltext)) + ssDS.obj[[study.id]] <- datashield.aggregate(datasources[study.id], call("setSeedDS", seedtext=seed.as.text)) } } message("\n\n") @@ -235,104 +229,15 @@ samp.size<-rep(samp.size,numsources) } for(k in 1:numsources){ + datashield.assign(datasources[k], newobj, call("rBinomDS", samp.size[k], size=size[k], prob=prob[k])) +} -toAssign<-paste0("rBinomDS(",samp.size[k],",",size, ",", prob, ")") - - - if(is.null(toAssign)){ - stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE) - } - - # now do the business - - DSI::datashield.assign(datasources[k], newobj, as.symbol(toAssign)) - } - -############################################################################################################# -#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 && !return.full.seed.as.set){ # - validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") # - return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, # - is.object.created=return.message,validity.check=validity.check)) # - } # - # - if(no.errors && return.full.seed.as.set){ # - validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") # - return(list(full.seed.as.set=ssDS.obj, # - integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, # - 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 # -############################################################################################################# - +if(return.full.seed.as.set){ +return(list(full.seed.as.set=ssDS.obj, + integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size)) +} +return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size)) } diff --git a/R/ds.rNorm.R b/R/ds.rNorm.R index 76d885f1..05bb15d2 100644 --- a/R/ds.rNorm.R +++ b/R/ds.rNorm.R @@ -40,8 +40,8 @@ #' #' @param samp.size an integer value or an integer vector that defines the length #' of the random numeric vector to be created in each source. -#' @param mean the mean value or vector of the Normal distribution to be created. -#' @param sd the standard deviation of the Normal distribution to be created. +#' @param mean the mean value or vector of the Normal distribution to be created. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k. +#' @param sd the standard deviation of the Normal distribution to be created. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k. #' @param newobj a character string that provides the name for the output variable #' that is stored on the data servers. Default \code{newObject}. #' @param seed.as.integer an integer @@ -51,15 +51,16 @@ #' If FALSE it will only return the trigger seed value you have provided. #' Default is FALSE. #' @param force.output.to.k.decimal.places an integer vector that -#' forces the output random numbers vector to have k decimals. +#' forces the output random numbers vector to have k decimals. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k. #' @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.rNorm} returns random number vectors with a normal distribution for each -#' study, taking into account the values specified in each parameter of the function. -#' The output vector is written to the server-side. -#' If requested, it also returned to the client-side the full 626 lengths random seed vector -#' generated in each source (see info for the argument \code{return.full.seed.as.set}). +#' @return \code{ds.rNorm} writes a random number vector with a normal distribution +#' to the server-side in each study and returns a list to the client-side containing +#' \code{integer.seed.as.set.by.source} (the trigger seed set in each source), +#' \code{random.vector.length.by.source} (the length of the vector created in each source) +#' and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set} +#' (the full 626 length random seed vector generated in each source). #' @examples #' \dontrun{ #' @@ -92,7 +93,7 @@ #' #' ds.rNorm(samp.size=c(10,20,45), #the length of the vector created in each source is different #' mean=c(1,6,4), #the mean of the Normal distribution changes in each server -#' sd=as.character(c(1,4,3)), #the sd of the Normal distribution changes in each server +#' sd=c(1,4,3), #the sd of the Normal distribution changes in each server #' newobj="Norm.dist", #' seed.as.integer=2345, #' return.full.seed.as.set=FALSE, @@ -114,20 +115,12 @@ #' datashield.logout(connections) #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export ds.rNorm<-function(samp.size=1,mean=0,sd=1, newobj="newObject", seed.as.integer=NULL, return.full.seed.as.set=FALSE, force.output.to.k.decimal.places=9,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) ######################## #TEST SEED PRIMING VALUE @@ -169,9 +162,14 @@ mess2<-("ERROR: appropriate values must be set for samp.size, mean, sd, and newo return(mess2) } +numsources<-length(datasources) +mean<-.expand_to_studies(mean, "mean", numsources) +sd<-.expand_to_studies(sd, "sd", numsources) +force.output.to.k.decimal.places<-.expand_to_studies(force.output.to.k.decimal.places, "force.output.to.k.decimal.places", numsources) + sd.valid<-1 if(is.numeric(sd)){ - if(sd<=0){ + if(any(sd<=0)){ sd.valid<-0 } } @@ -182,7 +180,7 @@ return(mess3) } decimal.places.valid<-1 -if(force.output.to.k.decimal.places<0||force.output.to.k.decimal.places>9){ +if(any(force.output.to.k.decimal.places<0|force.output.to.k.decimal.places>9)){ decimal.places.valid<-0 } @@ -220,8 +218,7 @@ if(seed.as.text=="NULL"){ message("NO SEED SET IN STUDY",study.id,"\n\n") } - calltext <- paste0("setSeedDS(", seed.as.text, ")") - ssDS.obj[[study.id]] <- DSI::datashield.aggregate(datasources[study.id], as.symbol(calltext)) + ssDS.obj[[study.id]] <- datashield.aggregate(datasources[study.id], call("setSeedDS", seedtext=seed.as.text)) } message("\n\n") @@ -237,104 +234,15 @@ samp.size<-rep(samp.size,numsources) } for(k in 1:numsources){ + datashield.assign(datasources[k], newobj, call("rNormDS", samp.size[k], mean=mean[k], sd=sd[k], force.output.to.k.decimal.places=force.output.to.k.decimal.places[k])) +} -toAssign<-paste0("rNormDS(",samp.size[k],",",mean, ",", sd, ",", force.output.to.k.decimal.places,")") - - - if(is.null(toAssign)){ - stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE) - } - - # now do the business - - DSI::datashield.assign(datasources[k], newobj, as.symbol(toAssign)) - } - -############################################################################################################# -#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 && !return.full.seed.as.set){ # - validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") # - return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, # - is.object.created=return.message,validity.check=validity.check)) # - } # - # - if(no.errors && return.full.seed.as.set){ # - validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") # - return(list(full.seed.as.set=ssDS.obj, # - integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, # - 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 # -############################################################################################################# - +if(return.full.seed.as.set){ +return(list(full.seed.as.set=ssDS.obj, + integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size)) +} +return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size)) } diff --git a/R/ds.rPois.R b/R/ds.rPois.R index 74be7fdf..e6ae42d4 100644 --- a/R/ds.rPois.R +++ b/R/ds.rPois.R @@ -29,7 +29,7 @@ #' #' @param samp.size an integer value or an integer vector that defines the length of the #' random numeric vector to be created in each source. -#' @param lambda the number of events mean per interval. +#' @param lambda the number of events mean per interval. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k. #' @param newobj a character string that provides the name for the output variable #' that is stored on the data servers. Default \code{newObject}. #' @param seed.as.integer an integer or a NULL value which provides the random seed @@ -41,12 +41,12 @@ #' @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.rPois} returns random number vectors with a Poisson distribution for each study, -#' taking into account the values specified in each parameter of the function. -#' The created vectors are stored in the server-side. -#' If requested, it also returned to the client-side the full -#' 626 lengths random seed vector generated in each source -#' (see info for the argument \code{return.full.seed.as.set}). +#' @return \code{ds.rPois} writes a random number vector with a Poisson distribution +#' to the server-side in each study and returns a list to the client-side containing +#' \code{integer.seed.as.set.by.source} (the trigger seed set in each source), +#' \code{random.vector.length.by.source} (the length of the vector created in each source) +#' and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set} +#' (the full 626 length random seed vector generated in each source). #' #' @examples #' @@ -81,7 +81,7 @@ #' #' # Generating the vectors in the Opal servers #' ds.rPois(samp.size=c(13,20,25), #the length of the vector created in each source is different -#' lambda=as.character(c(2,3,4)), #different mean per interval (2,3,4) in each source +#' lambda=c(2,3,4), #different mean per interval (2,3,4) in each source #' newobj="Pois.dist", #' seed.as.integer=1234, #' return.full.seed.as.set=FALSE, @@ -98,19 +98,11 @@ #' datashield.logout(connections) #' } #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export ds.rPois<-function(samp.size=1,lambda=1, newobj="newObject", seed.as.integer=NULL, return.full.seed.as.set=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) ######################## #TEST SEED PRIMING VALUE @@ -152,9 +144,12 @@ mess2<-("ERROR: appropriate values must be set for samp.size, lambda, and newobj return(mess2) } +numsources<-length(datasources) +lambda<-.expand_to_studies(lambda, "lambda", numsources) + lambda.valid<-1 if(is.numeric(lambda)){ - if(lambda<=0){ + if(any(lambda<=0)){ lambda.valid<-0 } } @@ -193,8 +188,7 @@ if(seed.as.text=="NULL"){ message("NO SEED SET IN STUDY",study.id,"\n\n") } - calltext <- paste0("setSeedDS(", seed.as.text, ")") - ssDS.obj[[study.id]] <- DSI::datashield.aggregate(datasources[study.id], as.symbol(calltext)) + ssDS.obj[[study.id]] <- datashield.aggregate(datasources[study.id], call("setSeedDS", seedtext=seed.as.text)) } message("\n\n") @@ -210,104 +204,15 @@ samp.size<-rep(samp.size,numsources) } for(k in 1:numsources){ + datashield.assign(datasources[k], newobj, call("rPoisDS", samp.size[k], lambda=lambda[k])) +} -toAssign<-paste0("rPoisDS(",samp.size[k],",",lambda, ")") - - - if(is.null(toAssign)){ - stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE) - } - - # now do the business - - DSI::datashield.assign(datasources[k], newobj, as.symbol(toAssign)) - } - -############################################################################################################# -#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 && !return.full.seed.as.set){ # - validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") # - return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, # - is.object.created=return.message,validity.check=validity.check)) # - } # - # - if(no.errors && return.full.seed.as.set){ # - validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") # - return(list(full.seed.as.set=ssDS.obj, # - integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, # - 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 # -############################################################################################################# - +if(return.full.seed.as.set){ +return(list(full.seed.as.set=ssDS.obj, + integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size)) +} +return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size)) } diff --git a/R/ds.rUnif.R b/R/ds.rUnif.R index ea74766b..bac2db04 100644 --- a/R/ds.rUnif.R +++ b/R/ds.rUnif.R @@ -43,10 +43,10 @@ #' #' @param samp.size an integer value or an integer vector that defines the #' length of the random numeric vector to be created in each source. -#' @param min a numeric scalar that specifies the minimum value of the -#' random numbers in the distribution. -#' @param max a numeric scalar that specifies the maximum value of the -#' random numbers in the distribution. +#' @param min a numeric value that specifies the minimum value of the +#' random numbers in the distribution. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k. +#' @param max a numeric value that specifies the maximum value of the +#' random numbers in the distribution. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k. #' @param newobj a character string that provides the name for the output variable #' that is stored on the data servers. Default \code{newObject}. #' @param seed.as.integer an integer or a NULL value which provides the random @@ -56,16 +56,17 @@ #' return the trigger seed value you have provided. Default is FALSE. #' @param force.output.to.k.decimal.places an integer or #' an integer vector that forces the output random -#' numbers vector to have k decimals. +#' numbers vector to have k decimals. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k. #' #' @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.Unif} returns random number vectors with a uniform distribution for each study, -#' taking into account the values specified in each parameter of the function. -#' The created vectors are stored in the server-side. If requested, it also returned to the -#' client-side the full 626 lengths random seed vector generated in each source -#' (see info for the argument \code{return.full.seed.as.set}). +#' @return \code{ds.rUnif} writes a random number vector with a uniform distribution +#' to the server-side in each study and returns a list to the client-side containing +#' \code{integer.seed.as.set.by.source} (the trigger seed set in each source), +#' \code{random.vector.length.by.source} (the length of the vector created in each source) +#' and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set} +#' (the full 626 length random seed vector generated in each source). #' @examples #' #' \dontrun{ @@ -99,8 +100,8 @@ #' # Generating the vectors in the Opal servers #' #' ds.rUnif(samp.size = c(12,20,4), #the length of the vector created in each source is different -#' min = as.character(c(0,2,5)), #different minumum value of the function in each source -#' max = as.character(c(2,5,9)), #different maximum value of the function in each source +#' min = c(0,2,5), #different minumum value of the function in each source +#' max = c(2,5,9), #different maximum value of the function in each source #' newobj = "Unif.dist", #' seed.as.integer = 234, #' return.full.seed.as.set = FALSE, @@ -122,20 +123,12 @@ #' } #' #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export ds.rUnif<-function(samp.size=1,min=0,max=1, newobj="newObject", seed.as.integer=NULL, return.full.seed.as.set=FALSE, force.output.to.k.decimal.places=9,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) ######################## #TEST SEED PRIMING VALUE @@ -178,11 +171,16 @@ mess2<-("ERROR: appropriate values must be set for samp.size, min, max, and newo return(mess2) } +numsources<-length(datasources) +min<-.expand_to_studies(min, "min", numsources) +max<-.expand_to_studies(max, "max", numsources) +force.output.to.k.decimal.places<-.expand_to_studies(force.output.to.k.decimal.places, "force.output.to.k.decimal.places", numsources) + minmax.valid<-1 if(is.numeric(min) && is.numeric(max)){ - if(min>=max){ + if(any(min>=max)){ minmax.valid<-0 } @@ -194,7 +192,7 @@ return(mess3) } decimal.places.valid<-1 -if(force.output.to.k.decimal.places<0||force.output.to.k.decimal.places>9){ +if(any(force.output.to.k.decimal.places<0|force.output.to.k.decimal.places>9)){ decimal.places.valid<-0 } @@ -235,10 +233,9 @@ if(seed.as.text=="NULL"){ message("NO SEED SET IN STUDY",study.id,"\n") } else { - calltext <- paste0("setSeedDS(", seed.as.text, ")") - ssDS.obj[[study.id]] <- DSI::datashield.aggregate(datasources[study.id], as.symbol(calltext)) + ssDS.obj[[study.id]] <- datashield.aggregate(datasources[study.id], call("setSeedDS", seedtext=seed.as.text)) +} } -} ############################## @@ -249,104 +246,15 @@ samp.size<-rep(samp.size,numsources) } for(k in 1:numsources){ + datashield.assign(datasources[k], newobj, call("rUnifDS", samp.size[k], min=min[k], max=max[k], force.output.to.k.decimal.places=force.output.to.k.decimal.places[k])) +} -toAssign<-paste0("rUnifDS(",samp.size[k],",",min, ",", max, ",", force.output.to.k.decimal.places,")") - - - if(is.null(toAssign)){ - stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE) - } - - # now do the business - - DSI::datashield.assign(datasources[k], newobj, as.symbol(toAssign)) - } - -############################################################################################################# -#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 && !return.full.seed.as.set){ # - validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") # - return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, # - is.object.created=return.message,validity.check=validity.check)) # - } # - # - if(no.errors && return.full.seed.as.set){ # - validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") # - return(list(full.seed.as.set=ssDS.obj, # - integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, # - 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 # -############################################################################################################# - +if(return.full.seed.as.set){ +return(list(full.seed.as.set=ssDS.obj, + integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size)) +} +return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size)) } diff --git a/R/ds.sample.R b/R/ds.sample.R index 9bd6780f..e52af826 100644 --- a/R/ds.sample.R +++ b/R/ds.sample.R @@ -123,27 +123,14 @@ #' progress. The default value for notify.of.progress is FALSE. #' @return the object specified by the argument (or default name #' 'newobj.sample') -#' which is written to the serverside. In addition, two validity messages are returned -#' indicating whether has been created in each data source and if so whether -#' it is in a valid form. If its form is not valid in at least one study - e.g. because -#' a disclosure trap was tripped and creation of the full output object was blocked - -#' ds.dataFrameSort() also returns any studysideMessages that may explain the error in creating -#' the full output object. We are currently working to extend the information that can -#' be returned to the clientside when an error occurs. +#' which is written to the serverside. #' @author Paul Burton, for DataSHIELD Development Team, 15/4/2020 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export ds.sample<-function(x=NULL, size=NULL, seed.as.integer=NULL, replace=FALSE, prob = NULL, newobj=NULL,datasources=NULL, notify.of.progress=FALSE){ - # 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 x if(is.null(x)){ @@ -210,12 +197,10 @@ if(seed.as.text=="NULL"){ message("NO SEED SET IN STUDY",study.id,"\n\n") } - calltext <- paste0("setSeedDS(", seed.as.text, ")") - if (notify.of.progress) - message(calltext) - - ssDS.obj[[study.id]] <- DSI::datashield.aggregate(datasources[study.id], as.symbol(calltext)) + message("setSeedDS(", seed.as.text, ")") + + ssDS.obj[[study.id]] <- datashield.aggregate(datasources[study.id], call("setSeedDS", seedtext=seed.as.text)) } if (notify.of.progress) message("\n\n") @@ -232,87 +217,6 @@ calltext <- call("sampleDS", x.transmit=x, size.transmit=size, replace.transmit= 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.sample diff --git a/R/ds.setSeed.R b/R/ds.setSeed.R index ee84a174..acd73f81 100644 --- a/R/ds.setSeed.R +++ b/R/ds.setSeed.R @@ -41,6 +41,7 @@ #' each source and also the integer vector of 626 elements #' that is \code{.Random.seed itself}. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @examples #' \dontrun{ #' ## Version 6, for version 5 see the Wiki @@ -86,16 +87,7 @@ #' @export ds.setSeed<-function(seed.as.integer=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) seed.valid<-0 @@ -116,8 +108,7 @@ mess1<-("ERROR terminated: seed.as.integer must be set as an integer [numeric] o return(mess1) } - calltext <- paste0("setSeedDS(", seed.as.text, ")") - ssDS.obj <- DSI::datashield.aggregate(datasources, as.symbol(calltext)) + ssDS.obj <- datashield.aggregate(datasources, call("setSeedDS", seedtext=seed.as.text)) return.message<-paste0("Trigger integer to prime random seed = ",seed.as.text) diff --git a/R/utils.R b/R/utils.R index 6c5a2364..019f55a3 100644 --- a/R/utils.R +++ b/R/utils.R @@ -113,3 +113,25 @@ cli_abort("Please provide the name of a data.frame or matrix!", call.=FALSE) } } + +#' Expand an Argument to One Value per Study +#' +#' Arguments that may differ between studies can be given either as a single +#' value, used for every study, or as a vector with one value per study. +#' +#' @param values A vector of length 1 or `num_studies`. +#' @param arg_name The name of the argument, used in the error message. +#' @param num_studies The number of studies being analysed. +#' @importFrom cli cli_abort +#' @return A vector of length `num_studies`. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.expand_to_studies <- function(values, arg_name, num_studies) { + if (length(values) == 1) { + return(rep(values, num_studies)) + } + if (length(values) != num_studies) { + cli_abort("'{arg_name}' must be length 1 or one value per study") + } + return(values) +} diff --git a/dsBase_7.0.0-permissive.tar.gz b/dsBase_7.0.0-permissive.tar.gz index d6a0129b..acf7b87e 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.rBinom.Rd b/man/ds.rBinom.Rd index 993083e1..7642073a 100644 --- a/man/ds.rBinom.Rd +++ b/man/ds.rBinom.Rd @@ -18,10 +18,10 @@ ds.rBinom( \item{samp.size}{an integer value or an integer vector that defines the length of the random numeric vector to be created in each source.} -\item{size}{a positive integer that specifies the number of Bernoulli trials.} +\item{size}{a positive integer that specifies the number of Bernoulli trials. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.} \item{prob}{a numeric scalar value or vector in range 0 > prob > 1 which specifies the -probability of a positive response (i.e. 1 rather than 0).} +probability of a positive response (i.e. 1 rather than 0). A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.} \item{newobj}{a character string that provides the name for the output variable that is stored on the data servers. Default \code{rbinom.newobj}.} @@ -38,13 +38,12 @@ 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.rBinom} returns random number vectors -with a Binomial distribution for each study, -taking into account the values specified in each parameter of the function. -The output vector is written to the server-side. -If requested, it also returned to the client-side the full 626 lengths -random seed vector generated in each source -(see info for the argument \code{return.full.seed.as.set}). +\code{ds.rBinom} writes a random number vector with a Binomial distribution +to the server-side in each study and returns a list to the client-side containing +\code{integer.seed.as.set.by.source} (the trigger seed set in each source), +\code{random.vector.length.by.source} (the length of the vector created in each source) +and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set} +(the full 626 length random seed vector generated in each source). } \description{ Generates random (pseudorandom) non-negative integers from a Binomial distribution. @@ -110,7 +109,7 @@ Server functions called: \code{rBinomDS} and \code{setSeedDS}. #Generating the vectors in the Opal servers ds.rBinom(samp.size=c(13,20,25), #the length of the vector created in each source is different - size=as.character(c(10,23,5)), #Bernoulli trials change in each source + size=c(10,23,5), #Bernoulli trials change in each source prob=c(0.6,0.1,0.5), #Probability changes in each source newobj="Binom.dist", seed.as.integer=45, @@ -132,4 +131,6 @@ Server functions called: \code{rBinomDS} and \code{setSeedDS}. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.rNorm.Rd b/man/ds.rNorm.Rd index f60071fb..c278d757 100644 --- a/man/ds.rNorm.Rd +++ b/man/ds.rNorm.Rd @@ -19,9 +19,9 @@ ds.rNorm( \item{samp.size}{an integer value or an integer vector that defines the length of the random numeric vector to be created in each source.} -\item{mean}{the mean value or vector of the Normal distribution to be created.} +\item{mean}{the mean value or vector of the Normal distribution to be created. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.} -\item{sd}{the standard deviation of the Normal distribution to be created.} +\item{sd}{the standard deviation of the Normal distribution to be created. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.} \item{newobj}{a character string that provides the name for the output variable that is stored on the data servers. Default \code{newObject}.} @@ -35,18 +35,19 @@ If FALSE it will only return the trigger seed value you have provided. Default is FALSE.} \item{force.output.to.k.decimal.places}{an integer vector that -forces the output random numbers vector to have k decimals.} +forces the output random numbers vector to have k decimals. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.} \item{datasources}{a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login. If the \code{datasources} argument is not specified the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.} } \value{ -\code{ds.rNorm} returns random number vectors with a normal distribution for each -study, taking into account the values specified in each parameter of the function. -The output vector is written to the server-side. -If requested, it also returned to the client-side the full 626 lengths random seed vector -generated in each source (see info for the argument \code{return.full.seed.as.set}). +\code{ds.rNorm} writes a random number vector with a normal distribution +to the server-side in each study and returns a list to the client-side containing +\code{integer.seed.as.set.by.source} (the trigger seed set in each source), +\code{random.vector.length.by.source} (the length of the vector created in each source) +and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set} +(the full 626 length random seed vector generated in each source). } \description{ Generates normally distributed random (pseudorandom) scalar numbers. @@ -122,7 +123,7 @@ Server functions called: \code{rNormDS} and \code{setSeedDS}. ds.rNorm(samp.size=c(10,20,45), #the length of the vector created in each source is different mean=c(1,6,4), #the mean of the Normal distribution changes in each server - sd=as.character(c(1,4,3)), #the sd of the Normal distribution changes in each server + sd=c(1,4,3), #the sd of the Normal distribution changes in each server newobj="Norm.dist", seed.as.integer=2345, return.full.seed.as.set=FALSE, @@ -146,4 +147,6 @@ Server functions called: \code{rNormDS} and \code{setSeedDS}. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.rPois.Rd b/man/ds.rPois.Rd index 7ce19a47..dc216bd8 100644 --- a/man/ds.rPois.Rd +++ b/man/ds.rPois.Rd @@ -17,7 +17,7 @@ ds.rPois( \item{samp.size}{an integer value or an integer vector that defines the length of the random numeric vector to be created in each source.} -\item{lambda}{the number of events mean per interval.} +\item{lambda}{the number of events mean per interval. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.} \item{newobj}{a character string that provides the name for the output variable that is stored on the data servers. Default \code{newObject}.} @@ -35,12 +35,12 @@ 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.rPois} returns random number vectors with a Poisson distribution for each study, -taking into account the values specified in each parameter of the function. -The created vectors are stored in the server-side. -If requested, it also returned to the client-side the full -626 lengths random seed vector generated in each source - (see info for the argument \code{return.full.seed.as.set}). +\code{ds.rPois} writes a random number vector with a Poisson distribution +to the server-side in each study and returns a list to the client-side containing +\code{integer.seed.as.set.by.source} (the trigger seed set in each source), +\code{random.vector.length.by.source} (the length of the vector created in each source) +and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set} +(the full 626 length random seed vector generated in each source). } \description{ Generates random (pseudorandom) non-negative integers @@ -103,7 +103,7 @@ Server functions called: \code{rPoisDS} and \code{setSeedDS}. # Generating the vectors in the Opal servers ds.rPois(samp.size=c(13,20,25), #the length of the vector created in each source is different - lambda=as.character(c(2,3,4)), #different mean per interval (2,3,4) in each source + lambda=c(2,3,4), #different mean per interval (2,3,4) in each source newobj="Pois.dist", seed.as.integer=1234, return.full.seed.as.set=FALSE, @@ -122,4 +122,6 @@ Server functions called: \code{rPoisDS} and \code{setSeedDS}. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.rUnif.Rd b/man/ds.rUnif.Rd index 0ffd62aa..622c4437 100644 --- a/man/ds.rUnif.Rd +++ b/man/ds.rUnif.Rd @@ -19,11 +19,11 @@ ds.rUnif( \item{samp.size}{an integer value or an integer vector that defines the length of the random numeric vector to be created in each source.} -\item{min}{a numeric scalar that specifies the minimum value of the -random numbers in the distribution.} +\item{min}{a numeric value that specifies the minimum value of the +random numbers in the distribution. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.} -\item{max}{a numeric scalar that specifies the maximum value of the -random numbers in the distribution.} +\item{max}{a numeric value that specifies the maximum value of the +random numbers in the distribution. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.} \item{newobj}{a character string that provides the name for the output variable that is stored on the data servers. Default \code{newObject}.} @@ -37,18 +37,19 @@ return the trigger seed value you have provided. Default is FALSE.} \item{force.output.to.k.decimal.places}{an integer or an integer vector that forces the output random -numbers vector to have k decimals.} +numbers vector to have k decimals. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.} \item{datasources}{a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login. If the \code{datasources} argument is not specified the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.} } \value{ -\code{ds.Unif} returns random number vectors with a uniform distribution for each study, -taking into account the values specified in each parameter of the function. -The created vectors are stored in the server-side. If requested, it also returned to the -client-side the full 626 lengths random seed vector generated in each source -(see info for the argument \code{return.full.seed.as.set}). +\code{ds.rUnif} writes a random number vector with a uniform distribution +to the server-side in each study and returns a list to the client-side containing +\code{integer.seed.as.set.by.source} (the trigger seed set in each source), +\code{random.vector.length.by.source} (the length of the vector created in each source) +and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set} +(the full 626 length random seed vector generated in each source). } \description{ Generates uniformly distributed random (pseudorandom) scalar numbers. @@ -127,8 +128,8 @@ Server functions called: \code{rUnifDS} and \code{setSeedDS}. # Generating the vectors in the Opal servers ds.rUnif(samp.size = c(12,20,4), #the length of the vector created in each source is different - min = as.character(c(0,2,5)), #different minumum value of the function in each source - max = as.character(c(2,5,9)), #different maximum value of the function in each source + min = c(0,2,5), #different minumum value of the function in each source + max = c(2,5,9), #different maximum value of the function in each source newobj = "Unif.dist", seed.as.integer = 234, return.full.seed.as.set = FALSE, @@ -152,4 +153,6 @@ Server functions called: \code{rUnifDS} and \code{setSeedDS}. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.sample.Rd b/man/ds.sample.Rd index 357882d5..2f801edc 100644 --- a/man/ds.sample.Rd +++ b/man/ds.sample.Rd @@ -91,13 +91,7 @@ progress. The default value for notify.of.progress is FALSE.} \value{ the object specified by the argument (or default name 'newobj.sample') -which is written to the serverside. In addition, two validity messages are returned -indicating whether has been created in each data source and if so whether -it is in a valid form. If its form is not valid in at least one study - e.g. because -a disclosure trap was tripped and creation of the full output object was blocked - -ds.dataFrameSort() also returns any studysideMessages that may explain the error in creating -the full output object. We are currently working to extend the information that can -be returned to the clientside when an error occurs. +which is written to the serverside. } \description{ draws a pseudorandom sample from a vector, dataframe or matrix @@ -162,4 +156,6 @@ why line 2 is inserted to create a copy with a shorter name. } \author{ Paul Burton, for DataSHIELD Development Team, 15/4/2020 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.setSeed.Rd b/man/ds.setSeed.Rd index 6dacac34..c8b52a69 100644 --- a/man/ds.setSeed.Rd +++ b/man/ds.setSeed.Rd @@ -101,4 +101,6 @@ Server function called: \code{setSeedDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv b/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv index 22b4e90d..68469819 100644 --- a/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv +++ b/tests/testthat/perf_files/armadillo_azure-pipeline_perf-profile.csv @@ -11,7 +11,7 @@ "ds.asMatrix::perf::0","17.44","0.5","2" "ds.asNumeric::perf:0","16.79","0.5","2" "ds.assign::perf::0","10.23","0.5","2" -"ds.Boole::perf::0","2.179","0.5","2" +"ds.Boole::perf::0","5.517","0.5","2" "ds.c::perf::0","10.23","0.5","2" "ds.cbind::perf::0","3.814","0.5","2" "ds.changeRefGroup::perf::0","17.98","0.5","2" diff --git a/tests/testthat/test-arg-per-study-arguments.R b/tests/testthat/test-arg-per-study-arguments.R new file mode 100644 index 00000000..c8ee48d3 --- /dev/null +++ b/tests/testthat/test-arg-per-study-arguments.R @@ -0,0 +1,207 @@ + +# +# Set up +# + +# context("per-study arguments::arg::setup") + +studies <- list(sim1 = "study1", sim2 = "study2", sim3 = "study3") + +# Replaces the server calls so a test can see exactly what each study is sent +record_server_calls <- function(env = parent.frame()) { + sent <- new.env() + sent$calls <- list() + testthat::local_mocked_bindings( + datashield.assign = function(conns, symbol, value, ...) { + sent$calls[[length(sent$calls) + 1]] <- value + invisible(NULL) + }, + datashield.aggregate = function(conns, expr, ...) list(), + .set_datasources = function(datasources) datasources, + .env = env + ) + sent +} + +# +# Tests +# + +# context("per-study arguments::arg::.expand_to_studies") +test_that(".expand_to_studies repeats a single value for every study", { + expect_equal(.expand_to_studies(5, "x", 3), c(5, 5, 5)) +}) + +test_that(".expand_to_studies keeps one value per study", { + expect_equal(.expand_to_studies(c(1, 2, 3), "x", 3), c(1, 2, 3)) +}) + +test_that(".expand_to_studies rejects any other length", { + expect_error(.expand_to_studies(c(1, 2), "x", 3), "'x' must be length 1 or one value per\\s+study") + expect_error(.expand_to_studies(c(1, 2, 3, 4), "x", 3), "'x' must be length 1 or one value per\\s+study") +}) + +# context("per-study arguments::arg::ds.rBinom") +test_that("ds.rBinom sends each study its own size and prob", { + sent <- record_server_calls() + suppressMessages(ds.rBinom(samp.size = 10, size = c(1, 10, 100), prob = c(0.1, 0.5, 0.9), newobj = "x", seed.as.integer = 27, datasources = studies)) + + expect_length(sent$calls, 3) + expect_equal(sent$calls[[1]], call("rBinomDS", 10, size = 1, prob = 0.1)) + expect_equal(sent$calls[[2]], call("rBinomDS", 10, size = 10, prob = 0.5)) + expect_equal(sent$calls[[3]], call("rBinomDS", 10, size = 100, prob = 0.9)) +}) + +test_that("ds.rBinom sends a single size and prob to every study", { + sent <- record_server_calls() + suppressMessages(ds.rBinom(samp.size = 10, size = 5, prob = 0.5, newobj = "x", seed.as.integer = 27, datasources = studies)) + + expect_length(sent$calls, 3) + for (k in 1:3) { + expect_equal(sent$calls[[k]], call("rBinomDS", 10, size = 5, prob = 0.5)) + } +}) + +test_that("ds.rBinom rejects size or prob with the wrong number of values", { + sent <- record_server_calls() + + expect_error(ds.rBinom(samp.size = 10, size = c(1, 10), prob = 0.5, newobj = "x", seed.as.integer = 27, datasources = studies), "'size' must be length 1 or one value per\\s+study") + expect_error(ds.rBinom(samp.size = 10, size = 5, prob = c(0.1, 0.5), newobj = "x", seed.as.integer = 27, datasources = studies), "'prob' must be length 1 or one value per\\s+study") + expect_length(sent$calls, 0) +}) + +test_that("ds.rBinom checks every study's prob", { + sent <- record_server_calls() + res <- ds.rBinom(samp.size = 10, size = 5, prob = c(0.5, 1.5, 0.5), newobj = "x", seed.as.integer = 27, datasources = studies) + + expect_equal(res, "ERROR: prob must lie in range 0 < prob < 1") + expect_length(sent$calls, 0) +}) + +# context("per-study arguments::arg::ds.rNorm") +test_that("ds.rNorm sends each study its own mean, sd and decimal places", { + sent <- record_server_calls() + suppressMessages(ds.rNorm(samp.size = 10, mean = c(0, 100, 200), sd = c(1, 2, 3), force.output.to.k.decimal.places = c(2, 4, 9), newobj = "x", seed.as.integer = 27, datasources = studies)) + + expect_length(sent$calls, 3) + expect_equal(sent$calls[[1]], call("rNormDS", 10, mean = 0, sd = 1, force.output.to.k.decimal.places = 2)) + expect_equal(sent$calls[[2]], call("rNormDS", 10, mean = 100, sd = 2, force.output.to.k.decimal.places = 4)) + expect_equal(sent$calls[[3]], call("rNormDS", 10, mean = 200, sd = 3, force.output.to.k.decimal.places = 9)) +}) + +test_that("ds.rNorm sends each study its own server-side object name", { + sent <- record_server_calls() + suppressMessages(ds.rNorm(samp.size = 10, mean = c("m1", "m2", "m3"), sd = 1, newobj = "x", seed.as.integer = 27, datasources = studies)) + + expect_length(sent$calls, 3) + expect_equal(sent$calls[[1]], call("rNormDS", 10, mean = "m1", sd = 1, force.output.to.k.decimal.places = 9)) + expect_equal(sent$calls[[2]], call("rNormDS", 10, mean = "m2", sd = 1, force.output.to.k.decimal.places = 9)) + expect_equal(sent$calls[[3]], call("rNormDS", 10, mean = "m3", sd = 1, force.output.to.k.decimal.places = 9)) +}) + +test_that("ds.rNorm sends a single mean, sd and decimal places to every study", { + sent <- record_server_calls() + suppressMessages(ds.rNorm(samp.size = 10, mean = 5, sd = 2, force.output.to.k.decimal.places = 4, newobj = "x", seed.as.integer = 27, datasources = studies)) + + expect_length(sent$calls, 3) + for (k in 1:3) { + expect_equal(sent$calls[[k]], call("rNormDS", 10, mean = 5, sd = 2, force.output.to.k.decimal.places = 4)) + } +}) + +test_that("ds.rNorm rejects mean, sd or decimal places with the wrong number of values", { + sent <- record_server_calls() + + expect_error(ds.rNorm(samp.size = 10, mean = c(0, 100), sd = 1, newobj = "x", seed.as.integer = 27, datasources = studies), "'mean' must be length 1 or one value per\\s+study") + expect_error(ds.rNorm(samp.size = 10, mean = 0, sd = c(1, 2), newobj = "x", seed.as.integer = 27, datasources = studies), "'sd' must be length 1 or one value per\\s+study") + expect_error(ds.rNorm(samp.size = 10, mean = 0, sd = 1, force.output.to.k.decimal.places = c(2, 4), newobj = "x", seed.as.integer = 27, datasources = studies), "'force.output.to.k.decimal.places' must be length 1 or one value per\\s+study") + expect_length(sent$calls, 0) +}) + +test_that("ds.rNorm checks every study's sd", { + sent <- record_server_calls() + res <- ds.rNorm(samp.size = 10, mean = 0, sd = c(1, -1, 1), newobj = "x", seed.as.integer = 27, datasources = studies) + + expect_equal(res, "ERROR: sd must be > 0") + expect_length(sent$calls, 0) +}) + +# context("per-study arguments::arg::ds.rPois") +test_that("ds.rPois sends each study its own lambda", { + sent <- record_server_calls() + suppressMessages(ds.rPois(samp.size = 10, lambda = c(1, 50, 100), newobj = "x", seed.as.integer = 27, datasources = studies)) + + expect_length(sent$calls, 3) + expect_equal(sent$calls[[1]], call("rPoisDS", 10, lambda = 1)) + expect_equal(sent$calls[[2]], call("rPoisDS", 10, lambda = 50)) + expect_equal(sent$calls[[3]], call("rPoisDS", 10, lambda = 100)) +}) + +test_that("ds.rPois sends a single lambda to every study", { + sent <- record_server_calls() + suppressMessages(ds.rPois(samp.size = 10, lambda = 4, newobj = "x", seed.as.integer = 27, datasources = studies)) + + expect_length(sent$calls, 3) + for (k in 1:3) { + expect_equal(sent$calls[[k]], call("rPoisDS", 10, lambda = 4)) + } +}) + +test_that("ds.rPois rejects lambda with the wrong number of values", { + sent <- record_server_calls() + + expect_error(ds.rPois(samp.size = 10, lambda = c(1, 50), newobj = "x", seed.as.integer = 27, datasources = studies), "'lambda' must be length 1 or one value per\\s+study") + expect_length(sent$calls, 0) +}) + +test_that("ds.rPois checks every study's lambda", { + sent <- record_server_calls() + res <- ds.rPois(samp.size = 10, lambda = c(1, 0, 1), newobj = "x", seed.as.integer = 27, datasources = studies) + + expect_equal(res, "ERROR: lambda must be > 0") + expect_length(sent$calls, 0) +}) + +# context("per-study arguments::arg::ds.rUnif") +test_that("ds.rUnif sends each study its own min, max and decimal places", { + sent <- record_server_calls() + suppressMessages(ds.rUnif(samp.size = 10, min = c(0, 2, 5), max = c(2, 5, 9), force.output.to.k.decimal.places = c(1, 2, 3), newobj = "x", seed.as.integer = 27, datasources = studies)) + + expect_length(sent$calls, 3) + expect_equal(sent$calls[[1]], call("rUnifDS", 10, min = 0, max = 2, force.output.to.k.decimal.places = 1)) + expect_equal(sent$calls[[2]], call("rUnifDS", 10, min = 2, max = 5, force.output.to.k.decimal.places = 2)) + expect_equal(sent$calls[[3]], call("rUnifDS", 10, min = 5, max = 9, force.output.to.k.decimal.places = 3)) +}) + +test_that("ds.rUnif sends a single min, max and decimal places to every study", { + sent <- record_server_calls() + suppressMessages(ds.rUnif(samp.size = 10, min = 0, max = 1, force.output.to.k.decimal.places = 2, newobj = "x", seed.as.integer = 27, datasources = studies)) + + expect_length(sent$calls, 3) + for (k in 1:3) { + expect_equal(sent$calls[[k]], call("rUnifDS", 10, min = 0, max = 1, force.output.to.k.decimal.places = 2)) + } +}) + +test_that("ds.rUnif rejects min, max or decimal places with the wrong number of values", { + sent <- record_server_calls() + + expect_error(ds.rUnif(samp.size = 10, min = c(0, 2), max = 10, newobj = "x", seed.as.integer = 27, datasources = studies), "'min' must be length 1 or one value per\\s+study") + expect_error(ds.rUnif(samp.size = 10, min = 0, max = c(2, 5), newobj = "x", seed.as.integer = 27, datasources = studies), "'max' must be length 1 or one value per\\s+study") + expect_error(ds.rUnif(samp.size = 10, min = 0, max = 1, force.output.to.k.decimal.places = c(1, 2), newobj = "x", seed.as.integer = 27, datasources = studies), "'force.output.to.k.decimal.places' must be length 1 or one value per\\s+study") + expect_length(sent$calls, 0) +}) + +test_that("ds.rUnif checks every study's min and max", { + sent <- record_server_calls() + res <- ds.rUnif(samp.size = 10, min = c(0, 5, 0), max = c(1, 2, 1), newobj = "x", seed.as.integer = 27, datasources = studies) + + expect_equal(res, "ERROR: max must be greater than min") + expect_length(sent$calls, 0) +}) + +# +# Done +# + +# context("per-study arguments::arg::done") diff --git a/tests/testthat/test-discctrl-ds.rBinom.R b/tests/testthat/test-discctrl-ds.rBinom.R index f8bc70d7..0cee6924 100644 --- a/tests/testthat/test-discctrl-ds.rBinom.R +++ b/tests/testthat/test-discctrl-ds.rBinom.R @@ -32,7 +32,8 @@ test_that("simple c", { expect_length(res_errors, 1) expect_length(res_errors$sim1, 1) - expect_equal(res_errors$sim1, "Command 'setSeedDS(27)' failed on 'sim1': Error while evaluating 'dsBase::setSeedDS(27)' -> Error in checkPermissivePrivacyControlLevel() : \n BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked\n", fixed = TRUE) + expect_match(res_errors$sim1, "BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked", fixed = TRUE) + expect_match(res_errors$sim1, "setSeedDS", fixed = TRUE) }) # diff --git a/tests/testthat/test-discctrl-ds.rNorm.R b/tests/testthat/test-discctrl-ds.rNorm.R index 153d84e0..3f75fe88 100644 --- a/tests/testthat/test-discctrl-ds.rNorm.R +++ b/tests/testthat/test-discctrl-ds.rNorm.R @@ -32,7 +32,8 @@ test_that("simple c", { expect_length(res_errors, 1) expect_length(res_errors$sim1, 1) - expect_equal(res_errors$sim1, "Command 'setSeedDS(27)' failed on 'sim1': Error while evaluating 'dsBase::setSeedDS(27)' -> Error in checkPermissivePrivacyControlLevel() : \n BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked\n", fixed = TRUE) + expect_match(res_errors$sim1, "BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked", fixed = TRUE) + expect_match(res_errors$sim1, "setSeedDS", fixed = TRUE) }) # diff --git a/tests/testthat/test-discctrl-ds.rPois.R b/tests/testthat/test-discctrl-ds.rPois.R index b0176ced..434d39c3 100644 --- a/tests/testthat/test-discctrl-ds.rPois.R +++ b/tests/testthat/test-discctrl-ds.rPois.R @@ -32,7 +32,8 @@ test_that("simple c", { expect_length(res_errors, 1) expect_length(res_errors$sim1, 1) - expect_equal(res_errors$sim1, "Command 'setSeedDS(27)' failed on 'sim1': Error while evaluating 'dsBase::setSeedDS(27)' -> Error in checkPermissivePrivacyControlLevel() : \n BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked\n", fixed = TRUE) + expect_match(res_errors$sim1, "BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked", fixed = TRUE) + expect_match(res_errors$sim1, "setSeedDS", fixed = TRUE) }) # diff --git a/tests/testthat/test-discctrl-ds.rUnif.R b/tests/testthat/test-discctrl-ds.rUnif.R index 7327f366..bd9aadf0 100644 --- a/tests/testthat/test-discctrl-ds.rUnif.R +++ b/tests/testthat/test-discctrl-ds.rUnif.R @@ -32,7 +32,8 @@ test_that("simple c", { expect_length(res_errors, 1) expect_length(res_errors$sim1, 1) - expect_equal(res_errors$sim1, "Command 'setSeedDS(27)' failed on 'sim1': Error while evaluating 'dsBase::setSeedDS(27)' -> Error in checkPermissivePrivacyControlLevel() : \n BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked\n", fixed = TRUE) + expect_match(res_errors$sim1, "BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked", fixed = TRUE) + expect_match(res_errors$sim1, "setSeedDS", fixed = TRUE) }) # diff --git a/tests/testthat/test-discctrl-ds.sample.R b/tests/testthat/test-discctrl-ds.sample.R index 863112a4..023ff884 100644 --- a/tests/testthat/test-discctrl-ds.sample.R +++ b/tests/testthat/test-discctrl-ds.sample.R @@ -32,7 +32,8 @@ test_that("simple c", { expect_length(res_errors, 1) expect_length(res_errors$sim1, 1) - expect_equal(res_errors$sim1, "Command 'setSeedDS(27)' failed on 'sim1': Error while evaluating 'dsBase::setSeedDS(27)' -> Error in checkPermissivePrivacyControlLevel() : \n BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked\n", fixed = TRUE) + expect_match(res_errors$sim1, "BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked", fixed = TRUE) + expect_match(res_errors$sim1, "setSeedDS", fixed = TRUE) }) # diff --git a/tests/testthat/test-discctrl-ds.setSeed.R b/tests/testthat/test-discctrl-ds.setSeed.R index f32371b6..b3e0edc2 100644 --- a/tests/testthat/test-discctrl-ds.setSeed.R +++ b/tests/testthat/test-discctrl-ds.setSeed.R @@ -32,11 +32,14 @@ test_that("simple c", { expect_length(res_errors, 3) expect_length(res_errors$sim1, 1) - expect_equal(res_errors$sim1, "Command 'setSeedDS(4321)' failed on 'sim1': Error while evaluating 'dsBase::setSeedDS(4321)' -> Error in checkPermissivePrivacyControlLevel() : \n BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked\n", fixed = TRUE) + expect_match(res_errors$sim1, "BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked", fixed = TRUE) + expect_match(res_errors$sim1, "setSeedDS", fixed = TRUE) expect_length(res_errors$sim2, 1) - expect_equal(res_errors$sim2, "Command 'setSeedDS(4321)' failed on 'sim2': Error while evaluating 'dsBase::setSeedDS(4321)' -> Error in checkPermissivePrivacyControlLevel() : \n BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked\n", fixed = TRUE) + expect_match(res_errors$sim2, "BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked", fixed = TRUE) + expect_match(res_errors$sim2, "setSeedDS", fixed = TRUE) expect_length(res_errors$sim3, 1) - expect_equal(res_errors$sim3, "Command 'setSeedDS(4321)' failed on 'sim3': Error while evaluating 'dsBase::setSeedDS(4321)' -> Error in checkPermissivePrivacyControlLevel() : \n BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked\n", fixed = TRUE) + expect_match(res_errors$sim3, "BLOCKED: The server is running in 'non-permissive' mode which has caused this method to be blocked", fixed = TRUE) + expect_match(res_errors$sim3, "setSeedDS", fixed = TRUE) }) # diff --git a/tests/testthat/test-perf-ds.rBinom.R b/tests/testthat/test-perf-ds.rBinom.R new file mode 100644 index 00000000..1fe34f15 --- /dev/null +++ b/tests/testthat/test-perf-ds.rBinom.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.rBinom::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC")) + +# +# Tests +# + +# context("ds.rBinom::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.rBinom(samp.size = 50, size = 50, prob = 0.25, newobj = "binom_dist", seed.as.integer = 27) + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.rBinom::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.rBinom::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.rBinom::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.rBinom::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.rBinom::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.rBinom::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.rBinom::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.rBinom::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.rBinom::perf::done") diff --git a/tests/testthat/test-perf-ds.rNorm.R b/tests/testthat/test-perf-ds.rNorm.R new file mode 100644 index 00000000..5a618d60 --- /dev/null +++ b/tests/testthat/test-perf-ds.rNorm.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.rNorm::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC")) + +# +# Tests +# + +# context("ds.rNorm::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.rNorm(samp.size = 50, mean = 10, sd = 5, newobj = "norm_dist", seed.as.integer = 27, force.output.to.k.decimal.places = 4) + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.rNorm::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.rNorm::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.rNorm::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.rNorm::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.rNorm::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.rNorm::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.rNorm::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.rNorm::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.rNorm::perf::done") diff --git a/tests/testthat/test-perf-ds.rPois.R b/tests/testthat/test-perf-ds.rPois.R new file mode 100644 index 00000000..381892dd --- /dev/null +++ b/tests/testthat/test-perf-ds.rPois.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.rPois::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC")) + +# +# Tests +# + +# context("ds.rPois::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.rPois(samp.size = 50, lambda = 1, newobj = "pois_dist", seed.as.integer = 27) + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.rPois::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.rPois::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.rPois::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.rPois::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.rPois::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.rPois::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.rPois::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.rPois::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.rPois::perf::done") diff --git a/tests/testthat/test-perf-ds.rUnif.R b/tests/testthat/test-perf-ds.rUnif.R new file mode 100644 index 00000000..ef0da14f --- /dev/null +++ b/tests/testthat/test-perf-ds.rUnif.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.rUnif::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC")) + +# +# Tests +# + +# context("ds.rUnif::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.rUnif(samp.size = 50, min = 0, max = 1, newobj = "unif_dist", seed.as.integer = 27, force.output.to.k.decimal.places = 4) + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.rUnif::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.rUnif::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.rUnif::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.rUnif::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.rUnif::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.rUnif::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.rUnif::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.rUnif::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.rUnif::perf::done") diff --git a/tests/testthat/test-perf-ds.sample.R b/tests/testthat/test-perf-ds.sample.R new file mode 100644 index 00000000..3ea06d17 --- /dev/null +++ b/tests/testthat/test-perf-ds.sample.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.sample::perf::setup") +connect.studies.dataset.survival(list("survtime", "time.id", "female")) + +# +# Tests +# + +# context("ds.sample::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.sample(x="D", size=30) + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.sample::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.sample::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.sample::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.sample::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.sample::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.sample::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.sample::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.sample::perf::shutdown") +disconnect.studies.dataset.survival() +# context("ds.sample::perf::done") diff --git a/tests/testthat/test-perf-ds.setSeed.R b/tests/testthat/test-perf-ds.setSeed.R new file mode 100644 index 00000000..87b6537e --- /dev/null +++ b/tests/testthat/test-perf-ds.setSeed.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.setSeed::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC")) + +# +# Tests +# + +# context("ds.setSeed::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.setSeed(1234) + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.setSeed::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.setSeed::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.setSeed::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.setSeed::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.setSeed::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.setSeed::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.setSeed::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.setSeed::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.setSeed::perf::done") diff --git a/tests/testthat/test-smk-ds.rBinom.R b/tests/testthat/test-smk-ds.rBinom.R index 65746693..3fecc749 100644 --- a/tests/testthat/test-smk-ds.rBinom.R +++ b/tests/testthat/test-smk-ds.rBinom.R @@ -29,7 +29,7 @@ test_that("setup", { test_that("simple test", { res <- ds.rBinom(samp.size = 50, size = 50, prob = 0.25, newobj = "binom_dist", seed.as.integer = 27) - expect_length(res, 4) + expect_length(res, 2) expect_length(res$integer.seed.as.set.by.source, 3) expect_equal(res$integer.seed.as.set.by.source[1], 27) expect_equal(res$integer.seed.as.set.by.source[2], 54) @@ -38,8 +38,33 @@ test_that("simple test", { expect_equal(res$random.vector.length.by.source[1], 50) expect_equal(res$random.vector.length.by.source[2], 50) expect_equal(res$random.vector.length.by.source[3], 50) - 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", "binom_dist")) +}) + +# context("ds.rBinom::smk::nonexistent object") +test_that("nonexistent server-side object", { + expect_error(ds.rBinom(samp.size = 50, size = "nonexistent_obj", prob = 0.25, newobj = "no.obj", seed.as.integer = 27), "There are some DataSHIELD errors, list them with datashield.errors()", fixed = TRUE) + + res.errors <- DSI::datashield.errors() + + expect_length(res.errors, 1) + expect_match(res.errors$sim1, "The server-side object 'nonexistent_obj' does not exist", fixed = TRUE) +}) + +# context("ds.rBinom::smk::one value per study") +test_that("one value per study", { + ds.rBinom(samp.size = 50, size = c(1, 10, 100), prob = 0.5, newobj = "binom_by_study", seed.as.integer = 27) + + res.mean <- ds.mean(x = "binom_by_study", type = "split") + + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[1]) - 0.5), 0.3) + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[2]) - 5), 1.5) + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[3]) - 50), 5) +}) + +# context("ds.rBinom::smk::wrong number of values") +test_that("wrong number of values per study", { + expect_error(ds.rBinom(samp.size = 50, size = c(1, 10), prob = 0.5, newobj = "no.obj", seed.as.integer = 27), "must be length 1 or one value per study") }) # @@ -49,7 +74,7 @@ test_that("simple test", { # context("ds.rBinom::smk::shutdown") test_that("shutdown", { - ds_expect_variables(c("D", "binom_dist")) + ds_expect_variables(c("D", "binom_dist", "binom_by_study")) }) disconnect.studies.dataset.cnsim() diff --git a/tests/testthat/test-smk-ds.rNorm.R b/tests/testthat/test-smk-ds.rNorm.R index cc63c1c0..1a08b928 100644 --- a/tests/testthat/test-smk-ds.rNorm.R +++ b/tests/testthat/test-smk-ds.rNorm.R @@ -29,7 +29,7 @@ test_that("setup", { test_that("simple test", { res <- ds.rNorm(samp.size = 50, mean = 10, sd = 5, newobj = "norm_dist", seed.as.integer = 27, force.output.to.k.decimal.places = 4) - expect_length(res, 4) + expect_length(res, 2) expect_length(res$integer.seed.as.set.by.source, 3) expect_equal(res$integer.seed.as.set.by.source[1], 27) expect_equal(res$integer.seed.as.set.by.source[2], 54) @@ -38,8 +38,33 @@ test_that("simple test", { expect_equal(res$random.vector.length.by.source[1], 50) expect_equal(res$random.vector.length.by.source[2], 50) expect_equal(res$random.vector.length.by.source[3], 50) - 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", "norm_dist")) +}) + +# context("ds.rNorm::smk::nonexistent object") +test_that("nonexistent server-side object", { + expect_error(ds.rNorm(samp.size = 50, mean = "nonexistent_obj", sd = 5, newobj = "no.obj", seed.as.integer = 27), "There are some DataSHIELD errors, list them with datashield.errors()", fixed = TRUE) + + res.errors <- DSI::datashield.errors() + + expect_length(res.errors, 1) + expect_match(res.errors$sim1, "The server-side object 'nonexistent_obj' does not exist", fixed = TRUE) +}) + +# context("ds.rNorm::smk::one value per study") +test_that("one value per study", { + ds.rNorm(samp.size = 50, mean = c(0, 100, 200), sd = 1, newobj = "norm_by_study", seed.as.integer = 27) + + res.mean <- ds.mean(x = "norm_by_study", type = "split") + + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[1]) - 0), 1) + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[2]) - 100), 1) + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[3]) - 200), 1) +}) + +# context("ds.rNorm::smk::wrong number of values") +test_that("wrong number of values per study", { + expect_error(ds.rNorm(samp.size = 50, mean = c(0, 100), sd = 1, newobj = "no.obj", seed.as.integer = 27), "must be length 1 or one value per study") }) # @@ -49,7 +74,7 @@ test_that("simple test", { # context("ds.rNorm::smk::shutdown") test_that("shutdown", { - ds_expect_variables(c("D", "norm_dist")) + ds_expect_variables(c("D", "norm_dist", "norm_by_study")) }) disconnect.studies.dataset.cnsim() diff --git a/tests/testthat/test-smk-ds.rPois.R b/tests/testthat/test-smk-ds.rPois.R index 68e74802..31baf262 100644 --- a/tests/testthat/test-smk-ds.rPois.R +++ b/tests/testthat/test-smk-ds.rPois.R @@ -29,7 +29,7 @@ test_that("setup", { test_that("simple test", { res <- ds.rPois(samp.size = 50, lambda = 1, newobj = "pois_dist", seed.as.integer = 27) - expect_length(res, 4) + expect_length(res, 2) expect_length(res$integer.seed.as.set.by.source, 3) expect_equal(res$integer.seed.as.set.by.source[1], 27) expect_equal(res$integer.seed.as.set.by.source[2], 54) @@ -38,8 +38,33 @@ test_that("simple test", { expect_equal(res$random.vector.length.by.source[1], 50) expect_equal(res$random.vector.length.by.source[2], 50) expect_equal(res$random.vector.length.by.source[3], 50) - 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", "pois_dist")) +}) + +# context("ds.rPois::smk::nonexistent object") +test_that("nonexistent server-side object", { + expect_error(ds.rPois(samp.size = 50, lambda = "nonexistent_obj", newobj = "no.obj", seed.as.integer = 27), "There are some DataSHIELD errors, list them with datashield.errors()", fixed = TRUE) + + res.errors <- DSI::datashield.errors() + + expect_length(res.errors, 1) + expect_match(res.errors$sim1, "The server-side object 'nonexistent_obj' does not exist", fixed = TRUE) +}) + +# context("ds.rPois::smk::one value per study") +test_that("one value per study", { + ds.rPois(samp.size = 50, lambda = c(1, 50, 100), newobj = "pois_by_study", seed.as.integer = 27) + + res.mean <- ds.mean(x = "pois_by_study", type = "split") + + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[1]) - 1), 0.5) + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[2]) - 50), 3) + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[3]) - 100), 5) +}) + +# context("ds.rPois::smk::wrong number of values") +test_that("wrong number of values per study", { + expect_error(ds.rPois(samp.size = 50, lambda = c(1, 50), newobj = "no.obj", seed.as.integer = 27), "must be length 1 or one value per study") }) # @@ -49,7 +74,7 @@ test_that("simple test", { # context("ds.rPois::smk::shutdown") test_that("shutdown", { - ds_expect_variables(c("D", "pois_dist")) + ds_expect_variables(c("D", "pois_dist", "pois_by_study")) }) disconnect.studies.dataset.cnsim() diff --git a/tests/testthat/test-smk-ds.rUnif.R b/tests/testthat/test-smk-ds.rUnif.R index f8fa681b..a296dfee 100644 --- a/tests/testthat/test-smk-ds.rUnif.R +++ b/tests/testthat/test-smk-ds.rUnif.R @@ -29,7 +29,7 @@ test_that("setup", { test_that("simple test", { res <- ds.rUnif(samp.size = 50, min = 0, max = 1, newobj = "unif_dist", seed.as.integer = 27, force.output.to.k.decimal.places = 4) - expect_length(res, 4) + expect_length(res, 2) expect_length(res$integer.seed.as.set.by.source, 3) expect_equal(res$integer.seed.as.set.by.source[1], 27) expect_equal(res$integer.seed.as.set.by.source[2], 54) @@ -38,8 +38,33 @@ test_that("simple test", { expect_equal(res$random.vector.length.by.source[1], 50) expect_equal(res$random.vector.length.by.source[2], 50) expect_equal(res$random.vector.length.by.source[3], 50) - 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", "unif_dist")) +}) + +# context("ds.rUnif::smk::nonexistent object") +test_that("nonexistent server-side object", { + expect_error(ds.rUnif(samp.size = 50, min = "nonexistent_obj", max = 1, newobj = "no.obj", seed.as.integer = 27), "There are some DataSHIELD errors, list them with datashield.errors()", fixed = TRUE) + + res.errors <- DSI::datashield.errors() + + expect_length(res.errors, 1) + expect_match(res.errors$sim1, "The server-side object 'nonexistent_obj' does not exist", fixed = TRUE) +}) + +# context("ds.rUnif::smk::one value per study") +test_that("one value per study", { + ds.rUnif(samp.size = 50, min = c(0, 10, 20), max = c(1, 11, 21), newobj = "unif_by_study", seed.as.integer = 27) + + res.mean <- ds.mean(x = "unif_by_study", type = "split") + + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[1]) - 0.5), 0.5) + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[2]) - 10.5), 0.5) + expect_lt(abs(as.numeric(res.mean$Mean.by.Study[3]) - 20.5), 0.5) +}) + +# context("ds.rUnif::smk::wrong number of values") +test_that("wrong number of values per study", { + expect_error(ds.rUnif(samp.size = 50, min = c(0, 10), max = 30, newobj = "no.obj", seed.as.integer = 27), "must be length 1 or one value per study") }) # @@ -49,7 +74,7 @@ test_that("simple test", { # context("ds.rUnif::smk::shutdown") test_that("shutdown", { - ds_expect_variables(c("D", "unif_dist")) + ds_expect_variables(c("D", "unif_dist", "unif_by_study")) }) disconnect.studies.dataset.cnsim() diff --git a/tests/testthat/test-smk-ds.sample.R b/tests/testthat/test-smk-ds.sample.R index 797caefa..aab0dc93 100644 --- a/tests/testthat/test-smk-ds.sample.R +++ b/tests/testthat/test-smk-ds.sample.R @@ -27,11 +27,8 @@ test_that("setup", { # context("ds.sample::smk::test") test_that("simple test", { - res1 <- ds.sample(x="D", size=30) - - expect_length(res1, 2) - expect_equal(res1$is.object.created, "A data object has been created in all specified data sources", fixed=TRUE) - expect_equal(res1$validity.check, " appears valid in all sources", fixed=TRUE) + ds.sample(x="D", size=30) + ds_expect_variables(c("D", "newobj.sample")) res1_length <- ds.length('newobj.sample') @@ -74,11 +71,8 @@ test_that("simple test", { expect_equal(res1_survtime_length$`length of newobj.sample$survtime in survival3`, 30) expect_equal(res1_survtime_length$`total length of newobj.sample$survtime in all studies combined`, 90) - res2 <- ds.sample(x="D$survtime", size=42, newobj="test.obj") - - expect_length(res2, 2) - expect_equal(res2$is.object.created, "A data object has been created in all specified data sources", fixed=TRUE) - expect_equal(res2$validity.check, " appears valid in all sources", fixed=TRUE) + ds.sample(x="D$survtime", size=42, newobj="test.obj") + ds_expect_variables(c("D", "newobj.sample", "test.obj")) res2_length <- ds.length('test.obj') @@ -128,6 +122,18 @@ test_that("simple test, error", { expect_match(res.errors$survival3, "* Error : FAILED: if sampling without replacement size must be less than or equal to length\\(x\\)*") }) +# context("ds.sample::smk::test nonexistent object") +test_that("simple test, nonexistent object", { + expect_error(ds.sample(x="nonexistent_obj", size=30, newobj="no.obj"), "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$survival1, "The server-side object 'nonexistent_obj' does not exist", fixed = TRUE) + expect_match(res.errors$survival2, "The server-side object 'nonexistent_obj' does not exist", fixed = TRUE) + expect_match(res.errors$survival3, "The server-side object 'nonexistent_obj' does not exist", fixed = TRUE) +}) + # # Done #