diff --git a/NAMESPACE b/NAMESPACE index 88498755..646eb747 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -121,6 +121,9 @@ import(DSI) import(data.table) importFrom(DSI,datashield.connections_find) importFrom(cli,cli_abort) +importFrom(cli,cli_inform) +importFrom(cli,cli_verbatim) +importFrom(cli,cli_warn) importFrom(stats, as.formula, na.omit, diff --git a/R/ds.Boole.R b/R/ds.Boole.R index 881ebbb7..74326353 100644 --- a/R/ds.Boole.R +++ b/R/ds.Boole.R @@ -104,32 +104,24 @@ #' ds.Boole<-function(V1=NULL, V2=NULL, Boolean.operator=NULL, numeric.output=TRUE, na.assign="NA",newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of the column or scalar that holds V1 - if(is.null(V1)){ - stop("Please provide the name of the column or scalar that holds V1!", call.=FALSE) - } + .checkArgProvided(V1, "the name of the column or scalar that holds V1") # check if user has provided the name of a column or scalar holding V2 or has declared a scalar value: eg '3' - if(is.null(V2)){ - stop("Please provide the name of a column or scalar holding V2 or declare a scalar in character format: eg '3'", call.=FALSE) - } + .checkArgProvided(V2, "the name of a column or scalar that holds V2") # check if user has provided a Boolean operator in character format: eg '==' or '>=' or '<' or '!=' - if(is.null(Boolean.operator)){ - stop("Please provide a Boolean operator in character format: eg '==' or '>=' or '<' or '!='", call.=FALSE) - } + .checkArgProvided(Boolean.operator, "a Boolean operator in character format, such as '==' or '>='") #check if na.assign has legal value if(!(na.assign=="NA"||na.assign=="0"||na.assign=="1")){ - stop("Error: na.assign must be a character string taking value 'NA', '0' or '1'- if not specified default is 'NA'", call.=FALSE) + .abortInvalidChoice("na.assign", c("NA", "0", "1")) } # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "boole.newobj" - } + newobj <- .resolveNewobjName(newobj, "boole.newobj") #convert Boolean operator to numeric @@ -163,9 +155,7 @@ ds.Boole<-function(V1=NULL, V2=NULL, Boolean.operator=NULL, numeric.output=TRUE, } # if no value spcified for output object, then specify a default - if(is.null(newobj)){ - newobj <- paste0(V1,"_Boole") - } + newobj <- .resolveNewobjName(newobj, paste0(V1,"_Boole")) # CALL THE MAIN SERVER SIDE FUNCTION calltext <- call("BooleDS", V1, V2, BO.n, na.assign, numeric.output) diff --git a/R/ds.abs.R b/R/ds.abs.R index 625591a8..d07d82dd 100644 --- a/R/ds.abs.R +++ b/R/ds.abs.R @@ -73,15 +73,11 @@ #' ds.abs <- function(x=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input object!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input object") - if(is.null(newobj)){ - newobj <- "abs.newobj" - } + newobj <- .resolveNewobjName(newobj, "abs.newobj") cally <- call("absDS", x) DSI::datashield.assign(datasources, newobj, cally) diff --git a/R/ds.asCharacter.R b/R/ds.asCharacter.R index 700b90b1..63df864a 100644 --- a/R/ds.asCharacter.R +++ b/R/ds.asCharacter.R @@ -56,15 +56,11 @@ #' ds.asCharacter <- function(x.name=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x.name)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x.name, "the name of the input vector") - if(is.null(newobj)){ - newobj <- "ascharacter.newobj" - } + newobj <- .resolveNewobjName(newobj, "ascharacter.newobj") calltext <- call("asCharacterDS", x.name) DSI::datashield.assign(datasources, newobj, calltext) diff --git a/R/ds.asDataMatrix.R b/R/ds.asDataMatrix.R index 9126b9fc..a7d322ff 100644 --- a/R/ds.asDataMatrix.R +++ b/R/ds.asDataMatrix.R @@ -55,15 +55,11 @@ #' ds.asDataMatrix <- function(x.name=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x.name)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x.name, "the name of the input vector") - if(is.null(newobj)){ - newobj <- "asdatamatrix.newobj" - } + newobj <- .resolveNewobjName(newobj, "asdatamatrix.newobj") calltext <- call("asDataMatrixDS", x.name) DSI::datashield.assign(datasources, newobj, calltext) diff --git a/R/ds.asFactor.R b/R/ds.asFactor.R index a8ae29f4..023eb49c 100644 --- a/R/ds.asFactor.R +++ b/R/ds.asFactor.R @@ -188,12 +188,10 @@ ds.asFactor <- function(input.var.name=NULL, newobj.name=NULL, forced.factor.levels=NULL, fixed.dummy.vars=FALSE, baseline.level=1, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of the column that holds the input variable - if(is.null(input.var.name)){ - stop("Please provide the name of the variable that is to be converted to a factor e.g. 'varname'", call.=FALSE) - } + .checkArgProvided(input.var.name, "the name of the variable to convert to a factor") # check if user has provided the name of the input variable in a correct character format if(!is.character(input.var.name)){ diff --git a/R/ds.asFactorSimple.R b/R/ds.asFactorSimple.R index fc092d35..aecc1026 100644 --- a/R/ds.asFactorSimple.R +++ b/R/ds.asFactorSimple.R @@ -24,12 +24,10 @@ #' ds.asFactorSimple <- function(input.var.name=NULL, newobj.name=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of the column that holds the input variable - if(is.null(input.var.name)){ - stop("Please provide the name of the variable that is to be converted to a factor e.g. 'varname'", call.=FALSE) - } + .checkArgProvided(input.var.name, "the name of the variable to convert to a factor") # check if user has provided the name of the input variable in a correct character format if(!is.character(input.var.name)){ diff --git a/R/ds.asInteger.R b/R/ds.asInteger.R index bd5eb292..b34fe567 100644 --- a/R/ds.asInteger.R +++ b/R/ds.asInteger.R @@ -69,15 +69,11 @@ #' @export ds.asInteger <- function(x.name=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x.name)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x.name, "the name of the input vector") - if(is.null(newobj)){ - newobj <- "asinteger.newobj" - } + newobj <- .resolveNewobjName(newobj, "asinteger.newobj") calltext <- call("asIntegerDS", x.name) DSI::datashield.assign(datasources, newobj, calltext) diff --git a/R/ds.asList.R b/R/ds.asList.R index 516d51e3..88a4ea2d 100644 --- a/R/ds.asList.R +++ b/R/ds.asList.R @@ -57,15 +57,11 @@ #' ds.asList <- function(x.name=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x.name)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x.name, "the name of the input vector") - if(is.null(newobj)){ - newobj <- "aslist.newobj" - } + newobj <- .resolveNewobjName(newobj, "aslist.newobj") datashield.assign(datasources, newobj, call("asListDS", x.name)) diff --git a/R/ds.asLogical.R b/R/ds.asLogical.R index 89dfb255..cb8f6652 100644 --- a/R/ds.asLogical.R +++ b/R/ds.asLogical.R @@ -56,15 +56,11 @@ #' ds.asLogical <- function(x.name=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x.name)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x.name, "the name of the input vector") - if(is.null(newobj)){ - newobj <- "aslogical.newobj" - } + newobj <- .resolveNewobjName(newobj, "aslogical.newobj") calltext <- call("asLogicalDS", x.name) DSI::datashield.assign(datasources, newobj, calltext) diff --git a/R/ds.asMatrix.R b/R/ds.asMatrix.R index 1c97dbf1..67cf1d48 100644 --- a/R/ds.asMatrix.R +++ b/R/ds.asMatrix.R @@ -58,15 +58,11 @@ #' ds.asMatrix <- function(x.name=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x.name)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x.name, "the name of the input vector") - if(is.null(newobj)){ - newobj <- "asmatrix.newobj" - } + newobj <- .resolveNewobjName(newobj, "asmatrix.newobj") calltext <- call("asMatrixDS", x.name) DSI::datashield.assign(datasources, newobj, calltext) diff --git a/R/ds.asNumeric.R b/R/ds.asNumeric.R index 980a7117..7fadcfb5 100644 --- a/R/ds.asNumeric.R +++ b/R/ds.asNumeric.R @@ -70,15 +70,11 @@ #' ds.asNumeric <- function(x.name=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x.name)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x.name, "the name of the input vector") - if(is.null(newobj)){ - newobj <- "asnumeric.newobj" - } + newobj <- .resolveNewobjName(newobj, "asnumeric.newobj") calltext <- call("asNumericDS", x.name) DSI::datashield.assign(datasources, newobj, calltext) diff --git a/R/ds.assign.R b/R/ds.assign.R index c646e378..473a614f 100644 --- a/R/ds.assign.R +++ b/R/ds.assign.R @@ -57,16 +57,12 @@ #' ds.assign <- function(toAssign=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(toAssign)){ - stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE) - } + .checkArgProvided(toAssign, "the name of the object to assign or an expression to evaluate") # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "assign.newobj" - } + newobj <- .resolveNewobjName(newobj, "assign.newobj") # now do the business DSI::datashield.assign(datasources, newobj, as.symbol(toAssign)) diff --git a/R/ds.auc.R b/R/ds.auc.R index 8b16502b..fd4985d6 100644 --- a/R/ds.auc.R +++ b/R/ds.auc.R @@ -16,17 +16,13 @@ #' ds.auc <- function(pred=NULL, y=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # verify that 'pred' was set - if(is.null(pred)){ - stop("Please provide the name of the vector with predicted values", call.=FALSE) - } + .checkArgProvided(pred, "the name of the vector of predicted values") # verify that 'y' was set - if(is.null(y)){ - stop("Please provide the name of the outcome variable", call.=FALSE) - } + .checkArgProvided(y, "the name of the outcome variable") cally <- call('aucDS', pred, y) output <- DSI::datashield.aggregate(datasources, cally) diff --git a/R/ds.boxPlot.R b/R/ds.boxPlot.R index cb51d601..5a1da5bd 100644 --- a/R/ds.boxPlot.R +++ b/R/ds.boxPlot.R @@ -87,16 +87,16 @@ ds.boxPlot <- function(x, variables = NULL, group = NULL, group2 = NULL, xlabel = "x axis", ylabel = "y axis", type = "pooled", datasources = NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # Ensure type is 'pooled' or 'split' if((length(type) == 1) && (! any(type %in% c("pooled", "split")))){ - stop("[type] can only be set to 'pooled' or 'split'") + .abortInvalidChoice("type", c("pooled", "split")) } # Determine class of x for dispatch cls <- datashield.aggregate(datasources, call("classDS", x)) - .checkClassConsistency(lapply(cls, function(study.class) list(class = study.class)), object_name = x) + .checkClassConsistency(lapply(cls, function(study.class) list(class = study.class)), objectName = x) cls <- unique(unlist(cls)) if(!any(c("numeric", "data.frame") %in% cls)){ diff --git a/R/ds.boxPlotGG.R b/R/ds.boxPlotGG.R index e562d971..25f1d912 100644 --- a/R/ds.boxPlotGG.R +++ b/R/ds.boxPlotGG.R @@ -24,7 +24,7 @@ ds.boxPlotGG <- function(x, group = NULL, group2 = NULL, xlabel = "x axis", ylabel = "y axis", type = "pooled", datasources = NULL){ x_var <- lower <- upper <- ymin <- ymax <- middle <- fill <- NULL - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) plot_data <- datashield.aggregate(datasources, call("boxPlotGGDS", data_table.name=x, group=group, group2=group2)) @@ -132,7 +132,7 @@ ds.boxPlotGG <- function(x, group = NULL, group2 = NULL, xlabel = "x axis", ylab plt <- do.call(gridExtra::grid.arrange, plt) } - else{stop("Invalid type")} + else{.abortInvalidChoice("type", c("pooled", "split"))} return(plt) diff --git a/R/ds.boxPlotGG_data_Treatment.R b/R/ds.boxPlotGG_data_Treatment.R index 84d32e1a..204d21a2 100644 --- a/R/ds.boxPlotGG_data_Treatment.R +++ b/R/ds.boxPlotGG_data_Treatment.R @@ -20,7 +20,7 @@ ds.boxPlotGG_data_Treatment <- function(table, variables, group = NULL, group2 = NULL, datasources = NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) datashield.assign.expr(datasources, "boxPlotRawData", call("boxPlotGG_data_TreatmentDS", table.name = table, variables = variables, group = group, group2 = group2)) diff --git a/R/ds.boxPlotGG_data_Treatment_numeric.R b/R/ds.boxPlotGG_data_Treatment_numeric.R index b80baca6..066f1ca2 100644 --- a/R/ds.boxPlotGG_data_Treatment_numeric.R +++ b/R/ds.boxPlotGG_data_Treatment_numeric.R @@ -15,7 +15,7 @@ ds.boxPlotGG_data_Treatment_numeric <- function(vector, datasources = NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) datashield.assign.expr(datasources, "boxPlotRawDataNumeric", call("boxPlotGG_data_Treatment_numericDS", vector.name = vector)) diff --git a/R/ds.boxPlotGG_numeric.R b/R/ds.boxPlotGG_numeric.R index e3d4a679..c666c0f8 100644 --- a/R/ds.boxPlotGG_numeric.R +++ b/R/ds.boxPlotGG_numeric.R @@ -12,7 +12,7 @@ ds.boxPlotGG_numeric <- function(x, xlabel = "x axis", ylabel = "y axis", type = "pooled", datasources = NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) ds.boxPlotGG_data_Treatment_numeric(x, datasources) diff --git a/R/ds.boxPlotGG_table.R b/R/ds.boxPlotGG_table.R index 936caf76..667f00a8 100644 --- a/R/ds.boxPlotGG_table.R +++ b/R/ds.boxPlotGG_table.R @@ -18,7 +18,7 @@ ds.boxPlotGG_table <- function(x, variables, group = NULL, group2 = NULL, xlabel = "x axis", ylabel = "y axis", type = "pooled", datasources = NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) ds.boxPlotGG_data_Treatment(x, variables, group, group2, datasources) diff --git a/R/ds.bp_standards.R b/R/ds.bp_standards.R index fe9b69fa..efeb8bad 100644 --- a/R/ds.bp_standards.R +++ b/R/ds.bp_standards.R @@ -32,32 +32,22 @@ ds.bp_standards <- function(sex=NULL, age=NULL, height=NULL, bp=NULL, systolic=TRUE, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # verify that 'sex' was set - if(is.null(sex)){ - stop("Please provide the name of the sex variable", call.=FALSE) - } + .checkArgProvided(sex, "the name of the sex variable") # verify that 'age' was set - if(is.null(age)){ - stop("Please provide the name of the age in months variable", call.=FALSE) - } + .checkArgProvided(age, "the name of the age in months variable") # verify that 'height' was set - if(is.null(height)){ - stop("Please provide the name of the height in cm variable", call.=FALSE) - } + .checkArgProvided(height, "the name of the height in cm variable") # verify that 'bp' was set - if(is.null(bp)){ - stop("Please provide the name of the blood pressure variable", call.=FALSE) - } + .checkArgProvided(bp, "the name of the blood pressure variable") # if no output object specified then provide a default name - if(is.null(newobj)){ - newobj <- "bp.newobj" - } + newobj <- .resolveNewobjName(newobj, "bp.newobj") # call the server-side assign function cally <- call('bp_standardsDS', sex, age, height, bp, systolic) diff --git a/R/ds.c.R b/R/ds.c.R index 8a928413..519aec82 100644 --- a/R/ds.c.R +++ b/R/ds.c.R @@ -60,16 +60,12 @@ #' ds.c <- function(x=NULL, newobj=NULL, datasources=NULL, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("x=NULL. Please provide the names of the objects to concatenate!", call.=FALSE) - } + .checkArgProvided(x, "the names of the objects to concatenate") # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "c.newobj" - } + newobj <- .resolveNewobjName(newobj, "c.newobj") if(classConsistencyCheck){ for(i in seq_along(x)){ diff --git a/R/ds.cbind.R b/R/ds.cbind.R index 1af1737a..5209b37b 100644 --- a/R/ds.cbind.R +++ b/R/ds.cbind.R @@ -117,66 +117,23 @@ #' ds.cbind <- function(x=NULL, DataSHIELD.checks=FALSE, force.colnames=NULL, newobj=NULL, datasources=NULL, notify.of.progress=FALSE, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide a vector of character strings holding the name of the input elements!", call.=FALSE) - } + .checkArgProvided(x, "a vector of the names of the input elements") if(DataSHIELD.checks){ # call the internal function that checks the input object(s) is(are) of the same legal class in all studies. if(classConsistencyCheck){ - for(i in 1:length(x)){ - typ <- checkClass(datasources, x[i]) - if(!('data.frame' %in% typ) & !('matrix' %in% typ) & !('factor' %in% typ) & !('character' %in% typ) & !('numeric' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ)){ - stop("Only objects of type 'data.frame', 'matrix', 'numeric', 'integer', 'character', 'factor' and 'logical' are allowed.", call.=FALSE) - } - } - } - - # check that there are no duplicated column names in the input components - for(j in 1:length(datasources)){ - colNames <- list() - for(i in 1:length(x)){ - typ <- checkClass(datasources, x[i]) - if(any(typ %in% c('data.frame', 'matrix'))){ - colNames[[i]] <- ds.colnames(x=x[i], datasources=datasources[j]) - } - if(any(typ %in% c('factor', 'character', 'numeric', 'integer', 'logical'))){ - colNames[[i]] <- as.character(x[i]) - } - colNames <- unlist(colNames) - if(anyDuplicated(colNames) != 0){ - message("\n Warning: Some column names in study", j, "are duplicated and a suffix '.k' will be added to the kth replicate \n") - } - } + .checkObjectClasses(datasources, x) } - # check that the number of rows is the same in all componets to be cbind - for(j in 1:length(datasources)){ - nrows <- list() - for(i in 1:length(x)){ - typ <- checkClass(datasources, x[i]) - if(any(typ %in% c('data.frame', 'matrix'))){ - nrows[[i]] <- ds.dim(x=x[i], type='split', datasources=datasources[j])[[1]][1] - } - if(any(typ %in% c('factor', 'character', 'numeric', 'integer', 'logical'))){ - nrows[[i]] <- ds.length(x[i], type='split', datasources=datasources[j])[[1]] - } - } - nrows <- unlist(nrows) - if(any(nrows != nrows[1])){ - stop("The number of rows is not the same in all of the components to be cbind", call.=FALSE) - } - } + .checkMultiObjectConsistency(datasources, x) } # check newobj not actively declared as null - if(is.null(newobj)){ - newobj <- "cbind.newobj" - } + newobj <- .resolveNewobjName(newobj, "cbind.newobj") # CREATE THE VECTOR OF COLUMN NAMES colname.list <- list() diff --git a/R/ds.changeRefGroup.R b/R/ds.changeRefGroup.R index 2ce6136a..1ac677b1 100644 --- a/R/ds.changeRefGroup.R +++ b/R/ds.changeRefGroup.R @@ -112,20 +112,14 @@ #' @export ds.changeRefGroup <- function(x=NULL, ref=NULL, newobj=NULL, reorderByRef=FALSE, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of a vector of type factor!", call.=FALSE) - } + .checkArgProvided(x, "the name of a factor") - if(is.null(ref)){ - stop(" You must indicate a reference level - set the parameter 'ref'.", call.=FALSE) - } + .checkArgProvided(ref, "a reference level") # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "changerefgroup.newobj" - } + newobj <- .resolveNewobjName(newobj, "changerefgroup.newobj") if(reorderByRef){ warning("'reorderByRef' is set to TRUE. Please read the documentation for possible consequences!", call.=FALSE) diff --git a/R/ds.class.R b/R/ds.class.R index 299950a4..d6474cb9 100644 --- a/R/ds.class.R +++ b/R/ds.class.R @@ -55,11 +55,9 @@ #' ds.class <- function(x=NULL, datasources=NULL) { - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input object!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input object") cally <- call('classDS', x) output <- DSI::datashield.aggregate(datasources, cally) diff --git a/R/ds.colnames.R b/R/ds.colnames.R index 57157421..d13cbd9b 100644 --- a/R/ds.colnames.R +++ b/R/ds.colnames.R @@ -52,8 +52,8 @@ #' ds.colnames <- function(x=NULL, datasources=NULL) { - datasources <- .set_datasources(datasources) - .check_df_name_provided(x) + datasources <- .resolveDatasources(datasources) + .checkArgProvided(x, "the name of a data.frame or matrix") cally <- call("colnamesDS", x) column_names <- DSI::datashield.aggregate(datasources, cally) diff --git a/R/ds.completeCases.R b/R/ds.completeCases.R index 1a3d3f5a..369d9040 100644 --- a/R/ds.completeCases.R +++ b/R/ds.completeCases.R @@ -73,15 +73,11 @@ #' ds.completeCases <- function(x1=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x1)){ - return("Error: x1 must be a character string naming a serverside data.frame, matrix or vector") - } + .checkArgProvided(x1, "a character string that names a server-side data.frame, matrix or vector") - if(is.null(newobj)){ - newobj <- paste0(x1,"_complete.cases") - } + newobj <- .resolveNewobjName(newobj, paste0(x1,"_complete.cases")) calltext <- call("completeCasesDS", x1) DSI::datashield.assign(datasources, newobj, calltext) diff --git a/R/ds.contourPlot.R b/R/ds.contourPlot.R index 94dfa21b..fcae19b2 100644 --- a/R/ds.contourPlot.R +++ b/R/ds.contourPlot.R @@ -105,14 +105,10 @@ #' ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=20, method="smallCellsRule", k=3, noise=0.25, datasources=NULL, classConsistencyCheck=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("x=NULL. Please provide the names of two numeric vectors!", call.=FALSE) - } - if(is.null(y)){ - stop("y=NULL. Please provide the names of two numeric vectors!", call.=FALSE) - } + .checkArgProvided(x, "the name of a numeric vector") + .checkArgProvided(y, "the name of a numeric vector") # Save par and setup reseting of par values old_par <- graphics::par(no.readonly = TRUE) @@ -120,7 +116,7 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2 # the argument method must be either "smallCellsRule" or "deterministic" or "probabilistic" if(method != 'smallCellsRule' & method != 'deterministic' & method != 'probabilistic'){ - stop('Function argument "method" has to be either "smallCellsRule" or "deterministic" or "probabilistic"', call.=FALSE) + .abortInvalidChoice("method", c("smallCellsRule", "deterministic", "probabilistic")) } # extract the variable names to be used as labels in the plot @@ -145,8 +141,8 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2 # call the server-side function that generates the x and y coordinates of the centroids anonymous.data <- datashield.aggregate(datasources, call("heatmapPlotDS", x.name=x, y.name=y, k=k, noise=noise, method.indicator=method.indicator)) if(classConsistencyCheck){ - .checkClassConsistency(anonymous.data, field = "class.x", object_name = x) - .checkClassConsistency(anonymous.data, field = "class.y", object_name = y) + .checkClassConsistency(anonymous.data, field = "class.x", objectName = x) + .checkClassConsistency(anonymous.data, field = "class.y", objectName = y) } pooled.points.x <- c() @@ -164,8 +160,8 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2 # call the server-side function that generates the x and y coordinates of the anonymous.data anonymous.data <- datashield.aggregate(datasources, call("heatmapPlotDS", x.name=x, y.name=y, k=k, noise=noise, method.indicator=method.indicator)) if(classConsistencyCheck){ - .checkClassConsistency(anonymous.data, field = "class.x", object_name = x) - .checkClassConsistency(anonymous.data, field = "class.y", object_name = y) + .checkClassConsistency(anonymous.data, field = "class.x", objectName = x) + .checkClassConsistency(anonymous.data, field = "class.y", objectName = y) } pooled.points.x <- c() @@ -206,8 +202,8 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2 # generate the grid density object to plot grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=TRUE, x.min=x.global.min, x.max=x.global.max, y.min=y.global.min, y.max=y.global.max, numints=numints)) if(classConsistencyCheck){ - .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x) - .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y) + .checkClassConsistency(grid.density.obj, field = "class.x", objectName = x) + .checkClassConsistency(grid.density.obj, field = "class.y", objectName = y) } grid.density.obj <- lapply(grid.density.obj, function(r) r$grid) @@ -352,7 +348,7 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2 # plot a combined contour plot graphics::contour(x.zoomed,y.zoomed,z.zoomed, xlab=x.lab, ylab=y.lab, main="Contour Plot of the Pooled Data (zoomed)") }else{ - stop('Function argument "show" has to be either "all" or "zoomed"') + .abortInvalidChoice("show", c("all", "zoomed")) } } else if (type=='split') { @@ -361,8 +357,8 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2 # generate the grid density object to plot grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=numints)) if(classConsistencyCheck){ - .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x) - .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y) + .checkClassConsistency(grid.density.obj, field = "class.x", objectName = x) + .checkClassConsistency(grid.density.obj, field = "class.y", objectName = y) } grid.density.obj <- lapply(grid.density.obj, function(r) r$grid) numcol <- dim(grid.density.obj[[1]])[2] @@ -501,7 +497,7 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2 graphics::contour(x.zoomed,y.zoomed,z.zoomed, xlab=x.lab, ylab=y.lab, main=title) }else{ - stop('Function argument "show" has to be either "all" or "zoomed"') + .abortInvalidChoice("show", c("all", "zoomed")) } } @@ -589,11 +585,11 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2 graphics::contour(x.zoomed,y.zoomed,z.zoomed, xlab=x.lab, ylab=y.lab, main="Contour Plot of the Pooled Data") }else{ - stop('Function argument "show" has to be either "all" or "zoomed"') + .abortInvalidChoice("show", c("all", "zoomed")) } } }else{ - stop('Function argument "type" has to be either "combine" or "split"') + .abortInvalidChoice("type", c("combine", "split")) } } diff --git a/R/ds.cor.R b/R/ds.cor.R index 6043a511..d7984893 100644 --- a/R/ds.cor.R +++ b/R/ds.cor.R @@ -83,11 +83,9 @@ #' ds.cor <- function(x=NULL, y=NULL, type="split", datasources=NULL, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("x=NULL. Please provide the name of a matrix or dataframe or the names of two numeric vectors!", call.=FALSE) - } + .checkArgProvided(x, "the name of a matrix, data.frame or numeric vector") # name of the studies to be used in the output stdnames <- names(datasources) @@ -164,7 +162,7 @@ ds.cor <- function(x=NULL, y=NULL, type="split", datasources=NULL, classConsiste n4 <- "Correlation Matrix" names(results) <- c(n1, n2, n3, n4) }else{ - stop('Function argument "type" has to be either "combine" or "split"', call.=FALSE) + .abortInvalidChoice("type", c("combine", "split")) } } diff --git a/R/ds.corTest.R b/R/ds.corTest.R index 78c80216..4e6ea752 100644 --- a/R/ds.corTest.R +++ b/R/ds.corTest.R @@ -67,17 +67,13 @@ #' ds.corTest <- function(x=NULL, y=NULL, method="pearson", exact=NULL, conf.level=0.95, type='split', datasources=NULL, classConsistencyCheck=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("x=NULL. Please provide the names of the 1st numeric vector!", call.=FALSE) - } - if(is.null(y)){ - stop("y=NULL. Please provide the names of the 2nd numeric vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the first numeric vector") + .checkArgProvided(y, "the name of the second numeric vector") if(!(method %in% c("pearson", "kendall", "spearman"))){ - stop('Function argument "method" has to be either "pearson", "kendall" or "spearman"', call.=FALSE) + .abortInvalidChoice("method", c("pearson", "kendall", "spearman")) } # call the server side function @@ -132,7 +128,7 @@ ds.corTest <- function(x=NULL, y=NULL, method="pearson", exact=NULL, conf.level= return(out) } }else{ - stop('Function argument "type" has to be either "combine" or "split"', call.=FALSE) + .abortInvalidChoice("type", c("combine", "split")) } } diff --git a/R/ds.cov.R b/R/ds.cov.R index a35c9097..15b4f118 100644 --- a/R/ds.cov.R +++ b/R/ds.cov.R @@ -100,11 +100,9 @@ #' ds.cov <- function(x=NULL, y=NULL, naAction='pairwise.complete', type="split", datasources=NULL, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("x=NULL. Please provide the name of a matrix or dataframe or the names of two numeric vectors!", call.=FALSE) - } + .checkArgProvided(x, "the name of a matrix, data.frame or numeric vector") # name of the studies to be used in the output stdnames <- names(datasources) @@ -195,7 +193,7 @@ ds.cov <- function(x=NULL, y=NULL, naAction='pairwise.complete', type="split", d n5 <- "Error message" names(results) <- c(n1, n2, n3, n4, n5) }else{ - stop('Function argument "type" has to be either "combine" or "split"') + .abortInvalidChoice("type", c("combine", "split")) } } diff --git a/R/ds.dataFrame.R b/R/ds.dataFrame.R index c06322a5..802917b6 100644 --- a/R/ds.dataFrame.R +++ b/R/ds.dataFrame.R @@ -92,71 +92,26 @@ #' @export ds.dataFrame <- function(x=NULL, row.names=NULL, check.rows=FALSE, check.names=TRUE, stringsAsFactors=TRUE, completeCases=FALSE, DataSHIELD.checks=FALSE, newobj=NULL, datasources=NULL, notify.of.progress=FALSE, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the list that holds the input vectors!", call.=FALSE) - } + .checkArgProvided(x, "the name of the list that holds the input vectors") # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "dataframe.newobj" - } + newobj <- .resolveNewobjName(newobj, "dataframe.newobj") if(DataSHIELD.checks){ # call the internal function that checks the input object(s) is(are) of the same legal class in all studies. if(classConsistencyCheck){ - for(i in 1:length(x)){ - typ <- checkClass(datasources, x[i]) - if(!('data.frame' %in% typ) & !('matrix' %in% typ) & !('factor' %in% typ) & !('character' %in% typ) & !('numeric' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ)){ - stop("Only objects of type 'data.frame', 'matrix', 'numeric', 'integer', 'character', 'factor' and 'logical' are allowed.", call.=FALSE) - } + .checkObjectClasses(datasources, x) } - } - - # check that there are no duplicated column names in the input components - for(j in 1:length(datasources)){ - colNames <- list() - for(i in 1:length(x)){ - typ <- checkClass(datasources, x[i]) - if(typ %in% c('data.frame', 'matrix')){ - colNames[[i]] <- ds.colnames(x=x[i], datasources=datasources[j]) - } - if(typ %in% c('factor', 'character', 'numeric', 'integer', 'logical')){ - colNames[[i]] <- as.character(x[i]) - } - colNames <- unlist(colNames) - if(anyDuplicated(colNames) != 0){ - message("\n Warning: Some column names in study", j, "are duplicated and a suffix '.k' will be added to the kth replicate \n") - } - } - } - # check that the number of rows is the same in all componets to be cbind - for(j in 1:length(datasources)){ - nrows <- list() - for(i in 1:length(x)){ - typ <- checkClass(datasources, x[i]) - if(typ %in% c('data.frame', 'matrix')){ - nrows[[i]] <- ds.dim(x=x[i], type='split', datasources=datasources[j])[[1]][1] - } - if(typ %in% c('factor', 'character', 'numeric', 'integer', 'logical')){ - nrows[[i]] <- ds.length(x[i], type='split', datasources=datasources[j])[[1]] - } - } - nrows <- unlist(nrows) - if(any(nrows != nrows[1])){ - stop("The number of rows is not the same in all of the input components", call.=FALSE) - } - } + .checkMultiObjectConsistency(datasources, x) } # check newobj not actively declared as null - if(is.null(newobj)){ - newobj <- "df_new" - } + newobj <- .resolveNewobjName(newobj, "df_new") # CREATE THE VECTOR OF COLUMN NAMES colname.list <- list() diff --git a/R/ds.dataFrameSort.R b/R/ds.dataFrameSort.R index 3e41eccd..df807c51 100644 --- a/R/ds.dataFrameSort.R +++ b/R/ds.dataFrameSort.R @@ -83,7 +83,7 @@ ds.dataFrameSort<-function(df.name=NULL, sort.key.name=NULL, sort.descending=FALSE, sort.method="default", newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) if(is.null(sort.method)){ sort.method <- "default" @@ -105,7 +105,7 @@ ds.dataFrameSort<-function(df.name=NULL, sort.key.name=NULL, sort.descending=FAL sort.descending <- FALSE } - newobj <- .set_newobj_name(newobj, "dataframesort.newobj") + newobj <- .resolveNewobjName(newobj, "dataframesort.newobj") # Call to assign function calltext <- call("dataFrameSortDS", df.name, sort.key.name, sort.descending, sort.method) diff --git a/R/ds.dataFrameSubset.R b/R/ds.dataFrameSubset.R index c6603c41..a4452fd0 100644 --- a/R/ds.dataFrameSubset.R +++ b/R/ds.dataFrameSubset.R @@ -107,12 +107,10 @@ ds.dataFrameSubset<-function(df.name=NULL, V1.name=NULL, V2.name=NULL, Boolean.operator=NULL, keep.cols=NULL, rm.cols=NULL, keep.NAs=NULL, newobj=NULL, datasources=NULL, notify.of.progress=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of the data.frame to be subsetted - if(is.null(df.name)){ - stop("Please provide the name of the data.frame to be subsetted as a character string: eg 'xxx'", call.=FALSE) - } + .checkArgProvided(df.name, "the name of the data.frame to subset") # check if user has provided the name of the column or scalar that holds V1. If not # have they instead provided a non.null keep.cols or non.null rm.cols argument @@ -197,9 +195,7 @@ if(Boolean.operator == ">="){ } # if no value spcified for output object, then specify a default - if(is.null(newobj)){ - newobj <- "dataframesubset.newobj" - } + newobj <- .resolveNewobjName(newobj, "dataframesubset.newobj") if(!is.null(keep.cols)){ keep.cols<-paste0(as.character(keep.cols),collapse=",") diff --git a/R/ds.densityGrid.R b/R/ds.densityGrid.R index e2dcae6c..6b96cc69 100644 --- a/R/ds.densityGrid.R +++ b/R/ds.densityGrid.R @@ -86,15 +86,11 @@ #' ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasources=NULL, classConsistencyCheck=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the numeric vector 'x'!", call.=FALSE) - } + .checkArgProvided(x, "the name of a numeric vector") - if(is.null(y)){ - stop("Please provide the name of the numeric vector 'y'!", call.=FALSE) - } + .checkArgProvided(y, "the name of a numeric vector") # name of the studies to be used in the plots' titles stdnames <- names(datasources) @@ -129,8 +125,8 @@ ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasourc # generate the grid density object to plot grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=TRUE, x.min=x.global.min, x.max=x.global.max, y.min=y.global.min, y.max=y.global.max, numints=numints)) if(classConsistencyCheck){ - .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x) - .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y) + .checkClassConsistency(grid.density.obj, field = "class.x", objectName = x) + .checkClassConsistency(grid.density.obj, field = "class.y", objectName = y) } grid.density.obj <- lapply(grid.density.obj, function(r) r$grid) numcol <- dim(grid.density.obj[[1]])[2] @@ -153,8 +149,8 @@ ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasourc # generate the grid density object grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=numints)) if(classConsistencyCheck){ - .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x) - .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y) + .checkClassConsistency(grid.density.obj, field = "class.x", objectName = x) + .checkClassConsistency(grid.density.obj, field = "class.y", objectName = y) } grid.density.obj <- lapply(grid.density.obj, function(r) r$grid) numcol <- dim(grid.density.obj[[1]])[2] @@ -165,7 +161,7 @@ ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasourc } return(grid.density.obj) }else{ - stop('Function argument "type" has to be either "combine" or "split"') + .abortInvalidChoice("type", c("combine", "split")) } } diff --git a/R/ds.dim.R b/R/ds.dim.R index efafd586..d284eb9a 100644 --- a/R/ds.dim.R +++ b/R/ds.dim.R @@ -80,11 +80,9 @@ #' ds.dim <- function(x=NULL, type='both', datasources=NULL, classConsistencyCheck=TRUE) { - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of a data.frame or matrix!", call.=FALSE) - } + .checkArgProvided(x, "the name of a data.frame or matrix") ################################################################################################### #MODULE: EXTEND "type" argument to include "both" and enable valid aliases # @@ -130,7 +128,7 @@ ds.dim <- function(x=NULL, type='both', datasources=NULL, classConsistencyCheck= out <- c(dimensions, pooled.dim) names(out) <- c(outputnames, paste0('dimensions of ', x, ' in combined studies')) }else{ - stop('Function argument "type" has to be either "both", "combine" or "split"') + .abortInvalidChoice("type", c("both", "combine", "split")) } } } diff --git a/R/ds.dmtC2S.R b/R/ds.dmtC2S.R index 96d059e6..c520aea0 100644 --- a/R/ds.dmtC2S.R +++ b/R/ds.dmtC2S.R @@ -46,17 +46,13 @@ #' ds.dmtC2S <- function(dfdata=NA, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if a value has been provided for dfdata - if(is.null(dfdata)){ - return("Error: dfdata must be a character string, a numeric vector or a scalar") - } + .checkArgProvided(dfdata, "a character string, numeric vector or scalar") # if no value specified for output object, then specify a default - if(is.null(newobj)){ - newobj <- "dmt.copied.C2S" - } + newobj <- .resolveNewobjName(newobj, "dmt.copied.C2S") #Generate values for arguments reflecting the key characteristics of the #clientside matrix/data frame to be copied to the serverside @@ -86,8 +82,7 @@ if(dplyr::is.tbl(dfdata)) if(!is.matrix(dfdata) && !is.data.frame(dfdata) && !dplyr::is.tbl(dfdata)) { - message("\n FAILED: must either be a data.frame, matrix or tibble") - return('Please respecify') + cli_abort("{.arg dfdata} must be a data.frame, matrix or tibble.") } inout.object.transmit<-paste0(as.character(inout.object),collapse=",") diff --git a/R/ds.elspline.R b/R/ds.elspline.R index 40a77db4..e66daec4 100644 --- a/R/ds.elspline.R +++ b/R/ds.elspline.R @@ -28,24 +28,18 @@ #' ds.elspline <- function(x, n, marginal = FALSE, names = NULL, newobj = NULL, datasources = NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input variable x!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input variable") - if(is.null(n)){ - stop("Argument 'n' is missing, with no default!", call.=FALSE) - } + .checkArgProvided(n, "a number of knots") if(n < 2){ stop("'n' must be a value greater than or equal to 2!", call.=FALSE) } # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "elspline.newobj" - } + newobj <- .resolveNewobjName(newobj, "elspline.newobj") # now do the business calltext <- call("elsplineDS", x, n, marginal, names) diff --git a/R/ds.exists.R b/R/ds.exists.R index b7a37814..bf395d1b 100644 --- a/R/ds.exists.R +++ b/R/ds.exists.R @@ -62,11 +62,9 @@ #' ds.exists <- function(x=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input object!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input object") # call the server side function that does the job cally <- call("exists", x) diff --git a/R/ds.exp.R b/R/ds.exp.R index c23fbaba..19677532 100644 --- a/R/ds.exp.R +++ b/R/ds.exp.R @@ -58,15 +58,11 @@ #' ds.exp <- function(x=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input object!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input object") - if(is.null(newobj)){ - newobj <- "exp.newobj" - } + newobj <- .resolveNewobjName(newobj, "exp.newobj") cally <- call("expDS", x) DSI::datashield.assign(datasources, newobj, cally) diff --git a/R/ds.gamlss.R b/R/ds.gamlss.R index 4a0d040e..09468327 100644 --- a/R/ds.gamlss.R +++ b/R/ds.gamlss.R @@ -82,12 +82,10 @@ ds.gamlss <- function(formula = NULL, sigma.formula = '~1', nu.formula = '~1', i.control = c(0.001, 50, 30, 0.001), centiles = FALSE, xvar = NULL, newobj = NULL, datasources = NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # verify that 'formula' was set - if(is.null(formula)){ - stop(" Please provide a valid formula!", call.=FALSE) - } + .checkArgProvided(formula, "a valid formula") formula <- gsub("(", "left_parenthesis", formula, fixed = TRUE) formula <- gsub(")", "right_parenthesis", formula, fixed = TRUE) @@ -125,7 +123,7 @@ ds.gamlss <- function(formula = NULL, sigma.formula = '~1', nu.formula = '~1', # check if method is either 'RS', 'CG' or 'mixed if(!(method %in% c("RS", "CG", "mixed"))){ - stop("Argument 'method' must be either 'RS', 'CG' or 'mixed'", call.=FALSE) + .abortInvalidChoice("method", c("RS", "CG", "mixed")) } control <- paste0(as.character(control), collapse=",") @@ -158,9 +156,7 @@ ds.gamlss <- function(formula = NULL, sigma.formula = '~1', nu.formula = '~1', stop("Provide the name of the explanatory variable in 'xvar' argument", call.=FALSE) } - if(is.null(newobj)){ - newobj <- 'gamlss_res' - } + newobj <- .resolveNewobjName(newobj, 'gamlss_res') calltext <- call('gamlssDS', formula=formula, sigma.formula=sigma.formula, nu.formula=nu.formula, tau.formula=tau.formula, diff --git a/R/ds.getWGSR.R b/R/ds.getWGSR.R index f7fa79e3..cebf0449 100644 --- a/R/ds.getWGSR.R +++ b/R/ds.getWGSR.R @@ -103,22 +103,16 @@ #' ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, standing=NA, thirdPart=NA, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(sex)){ - stop("Please provide the column name of the 'sex' variable!", call.=FALSE) - } + .checkArgProvided(sex, "the name of the sex column") - if(is.null(firstPart)){ - stop("Please provide the column name of the 'firstPart' variable!", call.=FALSE) - } + .checkArgProvided(firstPart, "the name of the column that holds the first part") - if(is.null(secondPart)){ - stop("Please provide the column name of the 'secondPart' variable!", call.=FALSE) - } + .checkArgProvided(secondPart, "the name of the column that holds the second part") if(!any(index %in% c("bfa", "hca", "hfa", "lfa", "mfa", "ssa", "tsa", "wfa", "wfh", "wfl"))){ - stop("Please provide a correct abbreviation for the index!", call.=FALSE) + .abortInvalidChoice("index", c("bfa", "hca", "hfa", "lfa", "mfa", "ssa", "tsa", "wfa", "wfh", "wfl")) } # If 'thirdPart' (age) is missing for BMI-for-age return an error message @@ -132,9 +126,7 @@ ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, st } # check newobj not actively declared as null - if(is.null(newobj)){ - newobj <- "getWGSR.newobj" - } + newobj <- .resolveNewobjName(newobj, "getWGSR.newobj") cally <- call("getWGSRDS", sex, firstPart, secondPart, index, standing, thirdPart) DSI::datashield.assign(datasources, newobj, cally) diff --git a/R/ds.glm.R b/R/ds.glm.R index d6937795..2c068376 100644 --- a/R/ds.glm.R +++ b/R/ds.glm.R @@ -322,29 +322,19 @@ ds.glm <- function(formula=NULL, data=NULL, family=NULL, offset=NULL, weights=NULL, checks=FALSE, maxit=20, CI=0.95, viewIter=FALSE, viewVarCov=FALSE, viewCor=FALSE, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # verify that 'formula' was set - if(is.null(formula)){ - stop(" Please provide a valid regression formula!", call.=FALSE) - } + .checkArgProvided(formula, "a valid regression formula") # check if user gave offset or weights directly in formula, if so the argument 'offset' or 'weights' # to provide name of offset or weights variable - if(sum(as.numeric(grepl('offset', formula, ignore.case=TRUE)))>0 || - sum(as.numeric(grepl('weights', formula, ignore.case=TRUE)))>0){ - message("\n\n WARNING: you may have specified an offset or regression weights") - message("\n as part of the model formula. In ds.glm (unlike the usual glm in R)") - message("\n you must specify an offset or weights separately from the formula") - message("\n using the offset or weights argument.\n\n") - } + .warnOffsetInFormula(formula) formula <- stats::as.formula(formula) # check that 'family' was set - if(is.null(family)){ - stop(" Please provide a valid 'family' argument!", call.=FALSE) - } + .checkArgProvided(family, "a valid family") # beginning of optional checks - the process stops if any of these checks fails # if(checks){ @@ -426,36 +416,17 @@ ds.glm <- function(formula=NULL, data=NULL, family=NULL, offset=NULL, weights=NU errorMessage <- as.matrix(errorMessage) dimnames(errorMessage) <- list(names(datasources), "ERROR MESSAGES") - output.blocked.information.1 <- "MODEL FITTING TERMINATED AT FIRST ITERATION:" - output.blocked.information.2 <- "Any values of 1 in the following tables denote potential disclosure risks" - output.blocked.information.3 <- "please use the argument to include only valid studies." - output.blocked.information.4 <- "Errors by study are as follows:" if(sum.y.invalid>0||sum.Xpar.invalid>0||sum.w.invalid>0||sum.o.invalid>0||sum.glm.saturation.invalid>0||at.least.one.study.data.error==1){ - message("\n\nMODEL FITTING TERMINATED AT FIRST ITERATION:\n", - "Any values of 1 in the following tables denote potential disclosure risks\n", - "please use the argument to include only valid studies.\n", - "Errors by study are as follows:\n") - message(as.matrix(y.invalid)) - message(as.matrix(Xpar.invalid)) - message(as.matrix(w.invalid)) - message(as.matrix(o.invalid)) - message(as.matrix(glm.saturation.invalid)) - message(as.matrix(errorMessage)) - - return(list( - output.blocked.information.1, - output.blocked.information.2, - output.blocked.information.3, - output.blocked.information.4, - y.vector.error=y.invalid, - X.matrix.error=Xpar.invalid, - weight.vector.error=w.invalid, - offset.vector.error=o.invalid, - glm.overparameterized=glm.saturation.invalid, - errorMessage=errorMessage - )) - stop("DATA ERROR") + cli_inform(c("Model fitting terminated at the first iteration.", "i" = "Values of 1 in the following tables denote potential disclosure risks.", "*" = "Use {.arg datasources} to include only valid studies.")) + cli_verbatim(utils::capture.output(as.matrix(y.invalid))) + cli_verbatim(utils::capture.output(as.matrix(Xpar.invalid))) + cli_verbatim(utils::capture.output(as.matrix(w.invalid))) + cli_verbatim(utils::capture.output(as.matrix(o.invalid))) + cli_verbatim(utils::capture.output(as.matrix(glm.saturation.invalid))) + cli_verbatim(utils::capture.output(as.matrix(errorMessage))) + + cli_abort("Can't fit the model because of a data error.") } beta.vect.next <- rep(0, num.par.glm) @@ -506,34 +477,9 @@ ds.glm <- function(formula=NULL, data=NULL, family=NULL, offset=NULL, weights=NU dimnames(errorMessage2) <- list(names(datasources), "ERROR MESSAGES") if(disclosure.risk.total>0){ - message("Potential disclosure risk in y.vect, X.mat, w.vect or offset \n", - "or model overparameterized in at least one study.\n", - "In addition clientside function appears to have been modified\n", - "to avoid traps in first serverside function.\n", - "Score vectors and information matrices therefore destroyed in all invalid studies\n", - "and model fitting terminated. This error is recorded in the log file but\n", - "please report it to the DataSHIELD team as we need to understand how\n", - "the controlled shutdown traps in glmDS1 have been circumvented\n\n") - - output.blocked.information.1<-"Potential disclosure risk in y.vect, X.mat, w.vect or offset" - output.blocked.information.2<-"or model overparameterized in at least one study." - output.blocked.information.3<-"In addition clientside function appears to have been modified" - output.blocked.information.4<-"to avoid disclosure traps in first serverside function." - output.blocked.information.5<-"Score vectors and information matrices therefore destroyed in all invalid studies" - output.blocked.information.6<-"and model fitting terminated. This error is recorded in the log file but" - output.blocked.information.7<-"please also report it to the DataSHIELD team as we need to understand how" - output.blocked.information.8<-"the controlled shutdown traps in glmDS1 have been circumvented." - - - return(list(output.blocked.information.1, - output.blocked.information.2, - output.blocked.information.3, - output.blocked.information.4, - output.blocked.information.5, - output.blocked.information.6, - output.blocked.information.7, - output.blocked.information.8 - )) + cli_inform(c("Potential disclosure risk in y.vect, X.mat, w.vect or offset, or the model is overparameterized, in at least one study.", "x" = "The client-side function also appears to have been modified to avoid traps in the first server-side function.", "i" = "Score vectors and information matrices were destroyed in all invalid studies and model fitting was terminated.", "*" = "This error is recorded in the log file. Please report it to the DataSHIELD team, as we need to understand how the controlled shutdown traps in {.fn glmDS1} were circumvented.")) + + cli_abort("Can't fit the model because of a potential disclosure risk.") } diff --git a/R/ds.glmPredict.R b/R/ds.glmPredict.R index e7e0c02a..e967d1e3 100644 --- a/R/ds.glmPredict.R +++ b/R/ds.glmPredict.R @@ -128,27 +128,23 @@ ds.glmPredict <- function(glmname = NULL, newdataname = NULL, output.type = "res se.fit = FALSE, dispersion = NULL, terms = NULL, na.action = "na.pass", newobj = NULL, datasources = NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check that is set - if(is.null(glmname)){ - stop(" is not set, please specify it as a character string containing the name of a valid glm class object on the serverside", call.=FALSE) - } + .checkArgProvided(glmname, "the name of a glm object on the server") # check that is correctly set if((output.type!="link") && (output.type!="response") && (output.type!="terms")){ - stop(" is not correctly set, please specify it as one of three character strings: 'link', 'response', or 'terms'", call.=FALSE) + .abortInvalidChoice("output.type", c("link", "response", "terms")) } # check that is correctly set if((na.action!="na.fail")&&(na.action!="na.omit")&&(na.action!="na.exclude")&&(na.action!="na.pass")){ - stop(" is not correctly set, please specify it as one of four character strings: 'na.fail', 'na.omit', 'na.exclude' or 'na.pass'", call.=FALSE) + .abortInvalidChoice("na.action", c("na.fail", "na.omit", "na.exclude", "na.pass")) } # provide value for newobj if none specified - if(is.null(newobj)){ - newobj<-"predict_glm" - } + newobj <- .resolveNewobjName(newobj, "predict_glm") calltext <- call("glmPredictDS.as", glmname, newdataname, output.type, se.fit, dispersion, terms, na.action) DSI::datashield.assign(datasources, newobj, calltext) diff --git a/R/ds.glmSLMA.R b/R/ds.glmSLMA.R index b8627124..239cf1ac 100644 --- a/R/ds.glmSLMA.R +++ b/R/ds.glmSLMA.R @@ -370,31 +370,20 @@ ds.glmSLMA<-function(formula=NULL, family=NULL, offset=NULL, weights=NULL, combine.with.metafor=TRUE, newobj=NULL,dataName=NULL,checks=FALSE, maxit=30, notify.of.progress=FALSE, datasources=NULL) { - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # verify that 'formula' was set - if(is.null(formula)){ - stop(" Please provide a valid regression formula!", call.=FALSE) - } + .checkArgProvided(formula, "a valid regression formula") # check if user gave offset or weights directly in formula, if so the argument 'offset' or 'weights' # to provide name of offset or weights variable - if(sum(as.numeric(grepl('offset', formula, ignore.case=TRUE)))>0 || - sum(as.numeric(grepl('weights', formula, ignore.case=TRUE)))>0) -{ - message("\n\n WARNING: you may have specified an offset or regression weights") - message("\n as part of the model formula. In ds.glm (unlike the usual glm in R)") - message("\n you must specify an offset or weights separately from the formula") - message("\n using the offset or weights argument.\n\n") -} + .warnOffsetInFormula(formula) formula <- stats::as.formula(formula) # check that 'family' was set - if(is.null(family)){ - stop(" Please provide a valid 'family' argument!", call.=FALSE) - } + .checkArgProvided(family, "a valid family") ##################### #if family is non-standard (i.e.family includes calls to either link or variance) convert to transmittable form: @@ -531,31 +520,20 @@ dimnames(errorMessage)<-list(names(datasources),"ERROR MESSAGES") -output.blocked.information.1<-"EVERY STUDY HAS DATA THAT COULD BE POTENTIALLY DISCLOSIVE UNDER THE CURRENT MODEL:" -output.blocked.information.2<-"Any values of 1 in the following tables denote potential disclosure risks." -output.blocked.information.3<-"Please use the argument to include only valid studies." -output.blocked.information.4<-"Errors by study are as follows:" #CASE 1 - NO STUDIES VALID if(!at.least.one.study.valid) { - message("\n\nEVERY STUDY HAS DATA THAT COULD BE POTENTIALLY DISCLOSIVE UNDER THE CURRENT MODEL:\n", - "Any values of 1 in the following tables denote potential disclosure risks.\n", - "Errors by study are as follows:\n") - - - return(list( - output.blocked.information.1, - output.blocked.information.2, - output.blocked.information.4, - y.vector.error=y.invalid, - X.matrix.error=Xpar.invalid, - weight.vector.error=w.invalid, - offset.vector.error=o.invalid, - glm.overparameterized=glm.saturation.invalid, - errorMessage=errorMessage - )) + cli_inform(c("Every study has data that could be potentially disclosive under the current model.", "i" = "Values of 1 in the following tables denote potential disclosure risks.")) + + cli_verbatim(utils::capture.output(as.matrix(y.invalid))) + cli_verbatim(utils::capture.output(as.matrix(Xpar.invalid))) + cli_verbatim(utils::capture.output(as.matrix(w.invalid))) + cli_verbatim(utils::capture.output(as.matrix(o.invalid))) + cli_verbatim(utils::capture.output(as.matrix(glm.saturation.invalid))) + cli_verbatim(utils::capture.output(as.matrix(errorMessage))) + cli_abort("Can't fit the model because every study has data that could be disclosive.") } #CASE 2 - AT LEAST ONE STUDY VALID AND AT LEAST ONE INVALID @@ -591,9 +569,7 @@ if(at.least.one.study.data.error) #OBJECT ON SERVERSIDE # if no value specified for glm output object, then specify a default - if(is.null(newobj)){ - newobj <- "new.glm.obj" - } + newobj <- .resolveNewobjName(newobj, "new.glm.obj") if (notify.of.progress) { message("\n\nSAVING SERVERSIDE glm OBJECT AS: <",newobj,">\n\n") diff --git a/R/ds.glmSummary.R b/R/ds.glmSummary.R index 07747584..401c16be 100644 --- a/R/ds.glmSummary.R +++ b/R/ds.glmSummary.R @@ -79,7 +79,7 @@ #' ds.glmSummary <- function(x.name, newobj=NULL, datasources=NULL) { - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if a value has been provided for x if(is.null(x.name)||!is.character(x.name)){ @@ -87,9 +87,7 @@ ds.glmSummary <- function(x.name, newobj=NULL, datasources=NULL) { } # create a name by default if the user did not provide a name for the new object - if (is.null(newobj)) { - newobj <- "summary_glm.newobj" - } + newobj <- .resolveNewobjName(newobj, "summary_glm.newobj") # PREPARE AND CALL THE ASSIGN FUNCTION TO PREPARE THE summary_glm OBJECT ON THE SERVERSIDE calltext1 <- call("glmSummaryDS.as", x.name) diff --git a/R/ds.glmerSLMA.R b/R/ds.glmerSLMA.R index ed254a08..0dfe036a 100644 --- a/R/ds.glmerSLMA.R +++ b/R/ds.glmerSLMA.R @@ -247,30 +247,19 @@ ds.glmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.m start_theta = NULL, start_fixef = NULL, notify.of.progress=FALSE, assign=FALSE, newobj=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # verify that 'formula' was set - if(is.null(formula)){ - stop(" Please provide a valid regression formula!", call.=FALSE) - } + .checkArgProvided(formula, "a valid regression formula") # check if user gave offset or weights directly in formula, if so the argument 'offset' or 'weights' # to provide name of offset or weights variable - if(sum(as.numeric(grepl('offset', formula, ignore.case=TRUE)))>0 || - sum(as.numeric(grepl('weights', formula, ignore.case=TRUE)))>0) - { - message("\n\n WARNING: you may have specified an offset or regression weights") - message("\n as part of the model formula. In ds.glm (unlike the usual glm in R)") - message("\n you must specify an offset or weights separately from the formula") - message("\n using the offset or weights argument.\n\n") - } + .warnOffsetInFormula(formula) formula <- stats::as.formula(formula) # check that 'family' was set - if(is.null(family)){ - stop(" Please provide a valid 'family' argument!", call.=FALSE) - } + .checkArgProvided(family, "a valid family") # beginning of optional checks - the process stops if any of these checks fails # if(checks){ @@ -311,9 +300,7 @@ ds.glmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.m if(!is.null(control_type) && is.null(control_value)) { - errorMessage.cv<-"ERROR: if control_type is non-null, you must specify a valid control_value eg control_value<-1.0e-7" - # print(errorMessage.cv) - return(list(errorMessage=errorMessage.cv)) + cli_abort(c("{.arg control_value} must be set when {.arg control_type} is set.", "i" = "For example, {.code control_value = 1.0e-7}.")) } if(!is.null(control_value)) @@ -342,9 +329,7 @@ ds.glmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.m if(assign==TRUE){ - if(is.null(newobj)){ - newobj <- "new.glmer.obj" - } + newobj <- .resolveNewobjName(newobj, "new.glmer.obj") if (notify.of.progress) { diff --git a/R/ds.heatmapPlot.R b/R/ds.heatmapPlot.R index 33d402aa..645b7676 100644 --- a/R/ds.heatmapPlot.R +++ b/R/ds.heatmapPlot.R @@ -153,15 +153,11 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=20, method="smallCellsRule", k=3, noise=0.25, datasources=NULL, classConsistencyCheck=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("x=NULL. Please provide the names of the 1st numeric vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the first numeric vector") - if(is.null(y)){ - stop("y=NULL. Please provide the names of the 2nd numeric vector!", call.=FALSE) - } + .checkArgProvided(y, "the name of the second numeric vector") # Save par and setup reseting of par values old_par <- graphics::par(no.readonly = TRUE) @@ -169,7 +165,7 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2 # the argument method must be either "smallCellsRule" or "deterministic" or "probabilistic" if(method != 'smallCellsRule' & method != 'deterministic' & method != 'probabilistic'){ - stop('Function argument "method" has to be either "smallCellsRule" or "deterministic" or "probabilistic"', call.=FALSE) + .abortInvalidChoice("method", c("smallCellsRule", "deterministic", "probabilistic")) } # prepare the axis labels @@ -193,8 +189,8 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2 # call the server-side function that generates the x and y coordinates of the centroids anonymous.data <- datashield.aggregate(datasources, call("heatmapPlotDS", x.name=x, y.name=y, k=k, noise=noise, method.indicator=method.indicator)) if(classConsistencyCheck){ - .checkClassConsistency(anonymous.data, field = "class.x", object_name = x) - .checkClassConsistency(anonymous.data, field = "class.y", object_name = y) + .checkClassConsistency(anonymous.data, field = "class.x", objectName = x) + .checkClassConsistency(anonymous.data, field = "class.y", objectName = y) } pooled.points.x <- c() @@ -212,8 +208,8 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2 # call the server-side function that generates the x and y coordinates of the anonymous.data anonymous.data <- datashield.aggregate(datasources, call("heatmapPlotDS", x.name=x, y.name=y, k=k, noise=noise, method.indicator=method.indicator)) if(classConsistencyCheck){ - .checkClassConsistency(anonymous.data, field = "class.x", object_name = x) - .checkClassConsistency(anonymous.data, field = "class.y", object_name = y) + .checkClassConsistency(anonymous.data, field = "class.x", objectName = x) + .checkClassConsistency(anonymous.data, field = "class.y", objectName = y) } pooled.points.x <- c() @@ -254,8 +250,8 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2 # generate the grid density object to plot grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=TRUE, x.min=x.global.min, x.max=x.global.max, y.min=y.global.min, y.max=y.global.max, numints=numints)) if(classConsistencyCheck){ - .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x) - .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y) + .checkClassConsistency(grid.density.obj, field = "class.x", objectName = x) + .checkClassConsistency(grid.density.obj, field = "class.y", objectName = y) } grid.density.obj <- lapply(grid.density.obj, function(r) r$grid) @@ -404,7 +400,7 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2 fields::image.plot(x.zoomed, y.zoomed, z.zoomed, xlab=x.lab, ylab=y.lab, main="Heatmap Plot of the Pooled Data (zoomed)") }else{ - stop('Function argument "show" has to be either "all" or "zoomed"') + .abortInvalidChoice("show", c("all", "zoomed")) } } else if (type=='split') { @@ -413,8 +409,8 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2 # generate the grid density object to plot grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=numints)) if(classConsistencyCheck){ - .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x) - .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y) + .checkClassConsistency(grid.density.obj, field = "class.x", objectName = x) + .checkClassConsistency(grid.density.obj, field = "class.y", objectName = y) } grid.density.obj <- lapply(grid.density.obj, function(r) r$grid) @@ -557,7 +553,7 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2 fields::image.plot(x.zoomed, y.zoomed, z.zoomed, xlab = x.lab, ylab = y.lab, main = title) }else{ - stop('Function argument "show" has to be either "all" or "zoomed"') + .abortInvalidChoice("show", c("all", "zoomed")) } } @@ -651,11 +647,11 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2 fields::image.plot(x.zoomed, y.zoomed, z.zoomed, xlab = x.lab, ylab = y.lab, main = "Heatmap Plot of the Pooled Data") }else{ - stop('Function argument "show" has to be either "all" or "zoomed"') + .abortInvalidChoice("show", c("all", "zoomed")) } } }else{ - stop('Function argument "type" has to be either "combine" or "split"') + .abortInvalidChoice("type", c("combine", "split")) } } diff --git a/R/ds.hetcor.R b/R/ds.hetcor.R index 0a47676a..5fa2da67 100644 --- a/R/ds.hetcor.R +++ b/R/ds.hetcor.R @@ -32,11 +32,9 @@ #' ds.hetcor <- function(data=NULL, ML=TRUE, std.err=TRUE, bins=4, pd=TRUE, use="complete.obs", datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(data)){ - stop("Please provide the name of the input object!", call.=FALSE) - } + .checkArgProvided(data, "the name of the input object") calltext <- call('hetcorDS', data, ML, std.err, bins, pd, use) output <- DSI::datashield.aggregate(datasources, calltext) diff --git a/R/ds.histogram.R b/R/ds.histogram.R index d0f4a7f3..9737dcc4 100644 --- a/R/ds.histogram.R +++ b/R/ds.histogram.R @@ -155,11 +155,9 @@ #' ds.histogram <- function(x=NULL, type="split", num.breaks=10, method="smallCellsRule", k=3, noise=0.25, vertical.axis="Frequency", datasources=NULL, classConsistencyCheck=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input vector") # Save par and setup reseting of par values old_par <- graphics::par(no.readonly = TRUE) @@ -167,12 +165,12 @@ ds.histogram <- function(x=NULL, type="split", num.breaks=10, method="smallCells # the argument vertical.axis must be "Frequency" or "Density" if(vertical.axis != 'Frequency' & vertical.axis != 'Density'){ - stop('Function argument "vertical.axis" has to be either "Frequency" or "Density"', call.=FALSE) + .abortInvalidChoice("vertical.axis", c("Frequency", "Density")) } # the argument method must be either "smallCellsRule" or "deterministic" or "probabilistic" if(method != 'smallCellsRule' & method != 'deterministic' & method != 'probabilistic'){ - stop('Function argument "method" has to be either "smallCellsRule" or "deterministic" or "probabilistic"', call.=FALSE) + .abortInvalidChoice("method", c("smallCellsRule", "deterministic", "probabilistic")) } # name of the studies to be used in the plots' titles @@ -188,7 +186,7 @@ ds.histogram <- function(x=NULL, type="split", num.breaks=10, method="smallCells # call the server-side function that returns the range of the vector from each study histogram.ranges <- datashield.aggregate(datasources, call("histogramDS1", x=x, method.indicator=method.indicator, k=k, noise=noise)) if(classConsistencyCheck){ - .checkClassConsistency(histogram.ranges, object_name = x) + .checkClassConsistency(histogram.ranges, objectName = x) } ranges <- unique(unlist(lapply(histogram.ranges, function(r) r$range))) @@ -277,7 +275,7 @@ ds.histogram <- function(x=NULL, type="split", num.breaks=10, method="smallCells return(hist.objs[[1]]) } }else{ - stop('Function argument "type" has to be either "combine" or "split"') + .abortInvalidChoice("type", c("combine", "split")) } } diff --git a/R/ds.igb_standards.R b/R/ds.igb_standards.R index dd402304..4819a245 100644 --- a/R/ds.igb_standards.R +++ b/R/ds.igb_standards.R @@ -42,37 +42,29 @@ ds.igb_standards <- function(gagebrth=NULL, z=0, p=50, val=NULL, var=NULL, sex=NULL, fun='igb_value2zscore', newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of the input variables - if(is.null(gagebrth)){ - stop("Please provide the name of the gagebrth variable", call.=FALSE) - } - if(is.null(sex)){ - stop("Please provide the name of the sex variable", call.=FALSE) - } + .checkArgProvided(gagebrth, "the name of the gestational age variable") + .checkArgProvided(sex, "the name of the sex variable") # check if the provided fun is valid if(!(fun %in% c("igb_centile2value","igb_zscore2value","igb_value2zscore","igb_value2centile"))){ - stop("Please provide a valid fun", call.=FALSE) + .abortInvalidChoice("fun", c("igb_centile2value", "igb_zscore2value", "igb_value2zscore", "igb_value2centile")) } # check if val is provided if fun is either igb_value2zscore or igb_value2centile if(fun %in% c("igb_value2zscore","igb_value2centile")){ - if(is.null(val)){ - stop("Please provide the name of the val variable", call.=FALSE) - } + .checkArgProvided(val, "the name of the value variable") } # check if the provided var is valid if(!(var %in% c("lencm", "wtkg", "hcircm", "wlr"))){ - stop("Please provide a valid var", call.=FALSE) + .abortInvalidChoice("var", c("lencm", "wtkg", "hcircm", "wlr")) } # if no output variable specified then provide a default name - if(is.null(newobj)){ - newobj <- "igb.newobj" - } + newobj <- .resolveNewobjName(newobj, "igb.newobj") # call the server-side assign function cally <- call('igb_standardsDS', gagebrth, z, p, val, var, sex, fun) diff --git a/R/ds.isNA.R b/R/ds.isNA.R index 63ef2658..c6e5b1ed 100644 --- a/R/ds.isNA.R +++ b/R/ds.isNA.R @@ -59,11 +59,9 @@ #' ds.isNA <- function(x=NULL, datasources=NULL, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input vector") stdnames <- names(datasources) xnames <- extract(x) diff --git a/R/ds.isValid.R b/R/ds.isValid.R index da48891c..7527a6f9 100644 --- a/R/ds.isValid.R +++ b/R/ds.isValid.R @@ -59,11 +59,9 @@ #' ds.isValid <- function(x=NULL, datasources=NULL, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input vector") # call the server side function that does the job and return its output cally <- call("isValidDS", x) diff --git a/R/ds.kurtosis.R b/R/ds.kurtosis.R index 775f14d8..95ef3980 100644 --- a/R/ds.kurtosis.R +++ b/R/ds.kurtosis.R @@ -29,11 +29,9 @@ #' ds.kurtosis <- function(x=NULL, method=1, type='both', datasources=NULL, classConsistencyCheck=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input vector") if(!all(method %in% c(1,2,3))){ stop("method must be an integer between 1 and 3", call.=FALSE) @@ -44,7 +42,7 @@ ds.kurtosis <- function(x=NULL, method=1, type='both', datasources=NULL, classCo if(type == 'split' | type == 'splits' | type == 's') type <- 'split' if(type == 'both' | type == 'b' ) type <- 'both' if(type != 'combine' & type != 'split' & type != 'both'){ - stop('Function argument "type" has to be either "both", "combine" or "split"', call.=FALSE) + .abortInvalidChoice("type", c("both", "combine", "split")) } if (type=='split' | type=='both'){ diff --git a/R/ds.length.R b/R/ds.length.R index 5db7d1e3..4cc1edb2 100644 --- a/R/ds.length.R +++ b/R/ds.length.R @@ -75,11 +75,9 @@ #' ds.length <- function(x=NULL, type='both', datasources=NULL, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input object!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input object") ################################################################################################### # MODULE: EXTEND "type" argument to include "both" and enable valid aliases # @@ -87,7 +85,7 @@ ds.length <- function(x=NULL, type='both', datasources=NULL, classConsistencyChe if(type == 'split' | type == 'splits' | type == 's') type <- 'split' # if(type == 'both' | type == 'b' ) type <- 'both' # if(type != 'combine' & type != 'split' & type != 'both'){ # - stop('Function argument "type" has to be either "both", "combine" or "split"', call.=FALSE) # + .abortInvalidChoice("type", c("both", "combine", "split")) # } # call the server-side function @@ -123,7 +121,7 @@ ds.length <- function(x=NULL, type='both', datasources=NULL, classConsistencyChe out <- c(lengths, pooled.length) names(out) <- c(outputnames, paste0('total length of ', x, ' in all studies combined')) }else{ - stop('Function argument "type" has to be either "both", "combine" or "split"') + .abortInvalidChoice("type", c("both", "combine", "split")) } } } diff --git a/R/ds.levels.R b/R/ds.levels.R index 337a2759..f55adf91 100644 --- a/R/ds.levels.R +++ b/R/ds.levels.R @@ -59,11 +59,9 @@ #' ds.levels <- function(x=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input vector") cally <- call("levelsDS", x) results <- DSI::datashield.aggregate(datasources, cally) diff --git a/R/ds.lexis.R b/R/ds.lexis.R index fc0532c4..74aaf3b8 100644 --- a/R/ds.lexis.R +++ b/R/ds.lexis.R @@ -203,22 +203,16 @@ #' ds.lexis<-function(data=NULL, intervalWidth=NULL, idCol=NULL, entryCol=NULL, exitCol=NULL, statusCol=NULL, variables=NULL, expandDF=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user have provided the name of the column that holds the subject ids - if(is.null(idCol)){ - stop("Please provide the name of the column that holds the subject IDs!", call.=FALSE) - } + .checkArgProvided(idCol, "the name of the column that holds subject IDs") # check if user have provided the name of the column that holds failure information - if(is.null(statusCol)){ - stop("Please provide the name of the column that holds 'failure' information!", call.=FALSE) - } + .checkArgProvided(statusCol, "the name of the column that holds failure information") # check if user have provided the name of the column that holds exit times - if(is.null(exitCol)){ - stop("Please provide the name of the column that holds the exit times (i.e. end of follow up time)!", call.=FALSE) - } + .checkArgProvided(exitCol, "the name of the column that holds exit times") # if no valid value provided for 'intervalWidth' instruct user to specify one if(any(is.null(intervalWidth))||any(is.na(intervalWidth))||any(intervalWidth==0)){ diff --git a/R/ds.list.R b/R/ds.list.R index 3ec7707b..b75dac9f 100644 --- a/R/ds.list.R +++ b/R/ds.list.R @@ -56,16 +56,12 @@ #' ds.list <- function(x=NULL, newobj=NULL, datasources=NULL, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("x=NULL. Please provide the names of the objects to coerce into a list!", call.=FALSE) - } + .checkArgProvided(x, "the names of the objects to coerce into a list") # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "list.newobj" - } + newobj <- .resolveNewobjName(newobj, "list.newobj") # get the variable names xnames <- extract(x) diff --git a/R/ds.listDisclosureSettings.R b/R/ds.listDisclosureSettings.R index f115bdb2..af0350f1 100644 --- a/R/ds.listDisclosureSettings.R +++ b/R/ds.listDisclosureSettings.R @@ -101,7 +101,7 @@ #' } #' ds.listDisclosureSettings <- function(datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # CALL THE MAIN SERVER SIDE FUNCTION calltext <- call("listDisclosureSettingsDS") diff --git a/R/ds.lmerSLMA.R b/R/ds.lmerSLMA.R index 3f0f5cfc..5c42ab34 100644 --- a/R/ds.lmerSLMA.R +++ b/R/ds.lmerSLMA.R @@ -206,23 +206,14 @@ ds.lmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.me control_value = NULL, optimizer = NULL, verbose = 0, notify.of.progress=FALSE, assign=FALSE, newobj=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # verify that 'formula' was set - if(is.null(formula)){ - stop(" Please provide a valid regression formula!", call.=FALSE) - } + .checkArgProvided(formula, "a valid regression formula") # check if user gave offset or weights directly in formula, if so the argument 'offset' or 'weights' # to provide name of offset or weights variable - if(sum(as.numeric(grepl('offset', formula, ignore.case=TRUE)))>0 || - sum(as.numeric(grepl('weights', formula, ignore.case=TRUE)))>0) - { - message("\n\n WARNING: you may have specified an offset or regression weights") - message("\n as part of the model formula. In ds.glm (unlike the usual glm in R)") - message("\n you must specify an offset or weights separately from the formula") - message("\n using the offset or weights argument.\n\n") - } + .warnOffsetInFormula(formula) formula <- stats::as.formula(formula) @@ -255,8 +246,7 @@ ds.lmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.me if(!is.null(control_type) && is.null(control_value)) { - errorMessage.cv<-"ERROR: if control_type is non-null, you must specify a valid control_value eg control_value<-1.0e-7" - return(list(errorMessage=errorMessage.cv)) + cli_abort(c("{.arg control_value} must be set when {.arg control_type} is set.", "i" = "For example, {.code control_value = 1.0e-7}.")) } if(!is.null(control_value)) @@ -273,9 +263,7 @@ ds.lmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.me if(!is.null(optimizer)&&optimizer!="nloptwrap") { - errorMessage.opt<-"ERROR: the only optimizer currently available for lmer is 'nloptwrap', please respecify" - message("\n",errorMessage.opt,"\n") - return(list(errorMessage=errorMessage.opt)) + .abortInvalidChoice("optimizer", "nloptwrap") } @@ -286,9 +274,7 @@ ds.lmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.me if(assign==TRUE){ - if(is.null(newobj)){ - newobj <- "new.lmer.obj" - } + newobj <- .resolveNewobjName(newobj, "new.lmer.obj") if (notify.of.progress) { message("\n\nSAVING SERVERSIDE lmerMod OBJECT AS: <",newobj,">\n\n") diff --git a/R/ds.log.R b/R/ds.log.R index ca236461..b9663f07 100644 --- a/R/ds.log.R +++ b/R/ds.log.R @@ -58,15 +58,11 @@ #' ds.log <- function(x=NULL, base=exp(1), newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input vector") - if(is.null(newobj)){ - newobj <- "log.newobj" - } + newobj <- .resolveNewobjName(newobj, "log.newobj") cally <- call("logDS", x, base) DSI::datashield.assign(datasources, newobj, cally) diff --git a/R/ds.ls.R b/R/ds.ls.R index 7377d59e..677845b0 100644 --- a/R/ds.ls.R +++ b/R/ds.ls.R @@ -119,7 +119,7 @@ #' @export ds.ls <- function(search.filter=NULL, env.to.search=1L, search.GlobalEnv=TRUE, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # make default to .GlobalEnv unambiguous if(search.GlobalEnv||is.null(env.to.search)){ @@ -160,10 +160,7 @@ if(!is.null(transmit.object)) if(original.code.problem==TRUE) { - # return.message<-paste0("Warning: Code replacing wildcard (i.e. '",replacement string,"' appears in your original code -please respecify") - return.message<-paste0("Warning: Code replacing wildcard (i.e. '",input.string, - "') is '",replacement.string,"' but this appears in your original search filter string - please respecify") - return(return.message) + cli_abort(c("The code that replaces the wildcard ({.val {input.string}}) is {.val {replacement.string}}, which also appears in your search filter.", "i" = "Respecify the filter.")) } } } diff --git a/R/ds.lspline.R b/R/ds.lspline.R index 2fe8471b..b7c00591 100644 --- a/R/ds.lspline.R +++ b/R/ds.lspline.R @@ -25,20 +25,14 @@ #' ds.lspline <- function(x, knots = NULL, marginal = FALSE, names = NULL, newobj = NULL, datasources = NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input variable x!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input variable") - if(is.null(knots)){ - stop("Please provide a vector of knots!", call.=FALSE) - } + .checkArgProvided(knots, "a vector of knots") # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "lspline.newobj" - } + newobj <- .resolveNewobjName(newobj, "lspline.newobj") # now do the business calltext <- call("lsplineDS", x, knots, marginal, names) diff --git a/R/ds.make.R b/R/ds.make.R index 2e9cbea5..c396090f 100644 --- a/R/ds.make.R +++ b/R/ds.make.R @@ -132,16 +132,12 @@ #' ds.make<-function(toAssign=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(toAssign)){ - stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE) - } + .checkArgProvided(toAssign, "the name of the object to assign or an expression to evaluate") # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "make.newobj" - } + newobj <- .resolveNewobjName(newobj, "make.newobj") # now do the business DSI::datashield.assign(datasources, newobj, as.symbol(toAssign)) diff --git a/R/ds.matrix.R b/R/ds.matrix.R index 5813ebe0..01c62683 100644 --- a/R/ds.matrix.R +++ b/R/ds.matrix.R @@ -145,25 +145,19 @@ ds.matrix <- function(mdata = NA, from="clientside.scalar", nrows.scalar=NULL, ncols.scalar=NULL, byrow = FALSE, dimnames = NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if a value has been provided for mdata - if(is.null(mdata)){ - return("Error: mdata must be a character string, a numeric vector or a scalar") - } + .checkArgProvided(mdata, "a character string, numeric vector or scalar") # if no value spcified for output object, then specify a default - if(is.null(newobj)){ - newobj <- "matrix.newobj" - } + newobj <- .resolveNewobjName(newobj, "matrix.newobj") #process mdata to make transmittable depending on #Check that valid from has been specified if(from!="serverside.vector"&&from!="serverside.scalar"&&from!="clientside.scalar") { - message(" FAILED: must be specified as one of the following - 'serverside.vector', - 'serverside.scalar', 'clientside.scalar'\n\n") - return('Please respecify') + .abortInvalidChoice("from", c("serverside.vector", "serverside.scalar", "clientside.scalar")) } if(from=="serverside.vector"||from=="serverside.scalar"){ diff --git a/R/ds.matrixDet.R b/R/ds.matrixDet.R index 97bcbff3..da7bc604 100644 --- a/R/ds.matrixDet.R +++ b/R/ds.matrixDet.R @@ -81,12 +81,10 @@ #' ds.matrixDet<-function(M1=NULL, newobj=NULL, logarithm=FALSE, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of matrix representing M1 - if(is.null(M1)){ - return("Error: Please provide the name of the matrix representing M1") - } + .checkArgProvided(M1, "the name of the matrix that represents M1") # if no value or invalid value specified for logarithm, then specify a default if(is.null(logarithm)){ @@ -98,9 +96,7 @@ ds.matrixDet<-function(M1=NULL, newobj=NULL, logarithm=FALSE, datasources=NULL){ } # if no value specified for output object, then specify a default - if(is.null(newobj)){ - newobj <- "matrixdet.newobj" - } + newobj <- .resolveNewobjName(newobj, "matrixdet.newobj") # CALL THE MAIN SERVER SIDE ASSIGN FUNCTION calltext <- call("matrixDetDS2", M1, logarithm) diff --git a/R/ds.matrixDet.report.R b/R/ds.matrixDet.report.R index e2b8061c..0bc18729 100644 --- a/R/ds.matrixDet.report.R +++ b/R/ds.matrixDet.report.R @@ -77,12 +77,10 @@ #' ds.matrixDet.report<-function(M1=NULL, logarithm=FALSE, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of matrix representing M1 - if(is.null(M1)){ - return("Error: Please provide the name of the matrix representing M1") - } + .checkArgProvided(M1, "the name of the matrix that represents M1") # if no value or invalid value specified for logarithm, then specify a default if(is.null(logarithm)) diff --git a/R/ds.matrixDiag.R b/R/ds.matrixDiag.R index 4e03f1d0..a53ea007 100644 --- a/R/ds.matrixDiag.R +++ b/R/ds.matrixDiag.R @@ -175,28 +175,20 @@ #' ds.matrixDiag<-function(x1=NULL, aim=NULL, nrows.scalar=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if a value has been provided for x1 - if(is.null(x1)){ - return("Error: x1 must have a value which is a character string, a numeric vector or a scalar") - } + .checkArgProvided(x1, "a character string, numeric vector or scalar") # if no value spcified for output object, then specify a default - if(is.null(newobj)) - { - newobj <- "matrixdiag.newobj" - } + newobj <- .resolveNewobjName(newobj, "matrixdiag.newobj") #process x1 to make transmittable depending on aim #Check that valid aim has been specified if(aim!="serverside.vector.2.matrix"&&aim!="serverside.scalar.2.matrix"&&aim!="serverside.matrix.2.vector"&& aim!="clientside.vector.2.matrix"&&aim!="clientside.scalar.2.matrix") { - message(" FAILED: aim must be specified as one of the following - 'serverside.vector.2.matrix', - 'serverside.scalar.2.matrix', 'serverside.matrix.2.vector', - 'clientside.vector.2.matrix', 'clientside.scalar.2.matrix'\n\n") - return('Please respecify') + .abortInvalidChoice("aim", c("serverside.vector.2.matrix", "serverside.scalar.2.matrix", "serverside.matrix.2.vector", "clientside.vector.2.matrix", "clientside.scalar.2.matrix")) } if(aim=="serverside.vector.2.matrix"||aim=="serverside.scalar.2.matrix"||aim=="serverside.matrix.2.vector") diff --git a/R/ds.matrixDimnames.R b/R/ds.matrixDimnames.R index b5db1fee..88e0864a 100644 --- a/R/ds.matrixDimnames.R +++ b/R/ds.matrixDimnames.R @@ -83,17 +83,13 @@ ds.matrixDimnames<-function(M1=NULL, dimnames=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of matrix representing M1 - if(is.null(M1)){ - return("Error: Please provide the name of the matrix representing M1") - } + .checkArgProvided(M1, "the name of the matrix that represents M1") # if no value specified for output object, then specify a default - if(is.null(newobj)){ - newobj <- "matrixdimnames.newobj" - } + newobj <- .resolveNewobjName(newobj, "matrixdimnames.newobj") diff --git a/R/ds.matrixInvert.R b/R/ds.matrixInvert.R index a8902aac..7c81f02c 100644 --- a/R/ds.matrixInvert.R +++ b/R/ds.matrixInvert.R @@ -79,17 +79,13 @@ #' ds.matrixInvert<-function(M1=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of matrix representing M1 - if(is.null(M1)){ - return("Error: Please provide the name of the matrix representing M1") - } + .checkArgProvided(M1, "the name of the matrix that represents M1") # if no value specified for output object, then specify a default - if(is.null(newobj)){ - newobj <- "matrixinvert.newobj" - } + newobj <- .resolveNewobjName(newobj, "matrixinvert.newobj") # CALL THE MAIN SERVER SIDE FUNCTION calltext <- call("matrixInvertDS", M1) diff --git a/R/ds.matrixMult.R b/R/ds.matrixMult.R index bdef9abe..cb7c808d 100644 --- a/R/ds.matrixMult.R +++ b/R/ds.matrixMult.R @@ -94,26 +94,20 @@ #' ds.matrixMult<-function(M1=NULL, M2=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of matrix representing M1 - if(is.null(M1)){ - return("Error: Please provide the name of the matrix representing M1") - } + .checkArgProvided(M1, "the name of the matrix that represents M1") # check if user has provided the name of matrix representing M2 - if(is.null(M2)){ - return("Error: Please provide the name of the matrix representing M2") - } + .checkArgProvided(M2, "the name of the matrix that represents M2") # if no value spcified for output object, then specify a default - if(is.null(newobj)){ - newobj <- "matrixmult.newobj" - } + newobj <- .resolveNewobjName(newobj, "matrixmult.newobj") # CALL THE MAIN SERVER SIDE FUNCTION calltext <- call("matrixMultDS", M1, M2) diff --git a/R/ds.matrixTranspose.R b/R/ds.matrixTranspose.R index 9286bb28..a7dd8347 100644 --- a/R/ds.matrixTranspose.R +++ b/R/ds.matrixTranspose.R @@ -82,17 +82,13 @@ #' ds.matrixTranspose<-function(M1=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if user has provided the name of matrix representing M1 - if(is.null(M1)){ - return("Error: Please provide the name of the matrix representing M1") - } + .checkArgProvided(M1, "the name of the matrix that represents M1") # if no value spcified for output object, then specify a default - if(is.null(newobj)){ - newobj <- "matrixtranspose.newobj" - } + newobj <- .resolveNewobjName(newobj, "matrixtranspose.newobj") # CALL THE MAIN SERVER SIDE FUNCTION calltext <- call("matrixTransposeDS", M1) diff --git a/R/ds.mdPattern.R b/R/ds.mdPattern.R index 0c083e94..4418641b 100644 --- a/R/ds.mdPattern.R +++ b/R/ds.mdPattern.R @@ -115,11 +115,9 @@ #' ds.mdPattern <- function(x = NULL, type = 'split', datasources = NULL, classConsistencyCheck = TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of a data frame or matrix!", call.=FALSE) - } + .checkArgProvided(x, "the name of a data.frame or matrix") # Get study names study_names <- names(datasources) @@ -208,7 +206,7 @@ ds.mdPattern <- function(x = NULL, type = 'split', datasources = NULL, classCons )) } else { - stop("Argument 'type' must be either 'split' or 'combine'", call.=FALSE) + .abortInvalidChoice("type", c("split", "combine")) } } diff --git a/R/ds.mean.R b/R/ds.mean.R index accbc2c3..a83c8e73 100644 --- a/R/ds.mean.R +++ b/R/ds.mean.R @@ -97,11 +97,9 @@ #' ds.mean <- function(x=NULL, type='split', save.mean.Nvalid=FALSE, datasources=NULL, classConsistencyCheck=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input object!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input object") ################################################################################################### #MODULE: EXTEND "type" argument to include "both" and enable valid alisases # @@ -109,7 +107,7 @@ if(type == 'combine' | type == 'combined' | type == 'combines' | type == 'c') ty if(type == 'split' | type == 'splits' | type == 's') type <- 'split' # if(type == 'both' | type == 'b' ) type <- 'both' # if(type != 'combine' & type != 'split' & type != 'both'){ # - stop('Function argument "type" has to be either "both", "combine" or "split"', call.=FALSE) # + .abortInvalidChoice("type", c("both", "combine", "split")) # } cally <- call("meanDS", x) diff --git a/R/ds.meanSdGp.R b/R/ds.meanSdGp.R index 810c5c1b..07ea6279 100644 --- a/R/ds.meanSdGp.R +++ b/R/ds.meanSdGp.R @@ -103,15 +103,11 @@ #' ds.meanSdGp <- function(x=NULL, y=NULL, type='both', datasources=NULL, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input vector") - if(is.null(y)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(y, "the name of the input vector") # names of the studies stdnames <- names(datasources) @@ -130,8 +126,8 @@ ds.meanSdGp <- function(x=NULL, y=NULL, type='both', datasources=NULL, classCons if(classConsistencyCheck){ # check the summarised variable (x) and grouping factor (y) each have the # same class in all studies - .checkClassConsistency(output, field = "class.x", object_name = x) - .checkClassConsistency(output, field = "class.index", object_name = y) + .checkClassConsistency(output, field = "class.x", objectName = x) + .checkClassConsistency(output, field = "class.index", objectName = y) } numsources <- length(output) @@ -142,8 +138,7 @@ ds.meanSdGp <- function(x=NULL, y=NULL, type='both', datasources=NULL, classCons } if(all.tables.valid<1){ - warning.message<-"At least 1 cell count is 1-nfilter, please regroup" - return(warning.message) + cli_abort(c("At least one cell count is below {.code nfilter.tab}.", "i" = "Regroup the data and try again.")) } if(all.tables.valid==1){ diff --git a/R/ds.merge.R b/R/ds.merge.R index 2eae9620..3495e147 100644 --- a/R/ds.merge.R +++ b/R/ds.merge.R @@ -114,42 +114,30 @@ ds.merge <- function(x.name=NULL,y.name=NULL, by.x.names=NULL, by.y.names=NULL,all.x=FALSE,all.y=FALSE, sort=TRUE, suffixes = c(".x",".y"), no.dups=TRUE, incomparables=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # dataframe names - if(is.null(x.name)){ - stop("Please provide the name (eg 'name1') of first dataframe to be merged (called x) ", call.=FALSE) - } + .checkArgProvided(x.name, "the name of the first data.frame to merge") - if(is.null(y.name)){ - stop("Please provide the name (eg 'name2') of second dataframe to be merged (called y) ", call.=FALSE) - } + .checkArgProvided(y.name, "the name of the second data.frame to merge") # names of columns to merge on (may be more than one) - if(is.null(by.x.names)){ - stop("Please provide the names of columns in x dataframe on which to merge (eg c('id', 'time'))", call.=FALSE) - } + .checkArgProvided(by.x.names, "the names of the columns in x to merge on") - if(is.null(by.y.names)){ - stop("Please provide the names of columns in y dataframe on which to merge (eg c('id', 'time'))", call.=FALSE) - } + .checkArgProvided(by.y.names, "the names of the columns in y to merge on") # make transmittable via parser by.x.names.transmit <- paste(by.x.names, collapse=",") by.y.names.transmit <- paste(by.y.names, collapse=",") # suffixes - if(is.null(suffixes)){ - stop("Please provide the suffixes to append to disambiguate duplicate column names (default = c('.x','.y'))", call.=FALSE) - } + .checkArgProvided(suffixes, "the suffixes that separate duplicate column names") # make transmittable via parser suffixes.transmit <- paste(suffixes, collapse=",") # create a name by default if user did not provide a name for the new dataframe - if(is.null(newobj)){ - newobj <- "merge.newobj" - } + newobj <- .resolveNewobjName(newobj, "merge.newobj") # call the server side function calltext <- call("mergeDS", x.name, y.name, by.x.names.transmit, by.y.names.transmit, all.x, all.y, diff --git a/R/ds.metadata.R b/R/ds.metadata.R index 2e080f01..96846d41 100644 --- a/R/ds.metadata.R +++ b/R/ds.metadata.R @@ -50,13 +50,11 @@ ds.metadata = function(x=NULL, datasources=NULL) { - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) ##################################################################################### #MODULE 3: SET UP KEY VARIABLES ALLOWING FOR DIFFERENT INPUT FORMATS # - if (is.null(x)){ # - stop("Please provide the name of the object!", call.=FALSE) # - } # + .checkArgProvided(x, "the name of an object") # ##################################################################################### ##################################################################################### diff --git a/R/ds.mice.R b/R/ds.mice.R index 38e27157..795a1a30 100644 --- a/R/ds.mice.R +++ b/R/ds.mice.R @@ -49,12 +49,10 @@ ds.mice <- function(data=NULL, m=5, maxit=5, method=NULL, predictorMatrix=NULL, post=NULL, seed=NA, newobj_mids=NULL, newobj_df=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # verify that 'data' was set - if(is.null(data)){ - stop("Please provide the name of the dataframe or matrix that contains the incomplete data!", call.=FALSE) - } + .checkArgProvided(data, "the name of the data.frame or matrix that holds the incomplete data") if(!is.null(method)){ method <- paste0(as.character(method), collapse=",") diff --git a/R/ds.names.R b/R/ds.names.R index 1466ce8d..6d40a034 100644 --- a/R/ds.names.R +++ b/R/ds.names.R @@ -69,11 +69,9 @@ #' ds.names <- function(xname=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(xname)){ - stop("Please provide the name of the input list!", call.=FALSE) - } + .checkArgProvided(xname, "the name of the input list") calltext <- call("namesDS", xname) output <- DSI::datashield.aggregate(datasources, calltext) diff --git a/R/ds.ns.R b/R/ds.ns.R index e1e101ef..6dd598c6 100644 --- a/R/ds.ns.R +++ b/R/ds.ns.R @@ -36,12 +36,10 @@ ds.ns <- function(x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "ns.newobj" - } + newobj <- .resolveNewobjName(newobj, "ns.newobj") # now do the business calltext <- call("nsDS", x, df, knots, intercept, Boundary.knots) diff --git a/R/ds.numNA.R b/R/ds.numNA.R index b5ad89dc..9b1eceea 100644 --- a/R/ds.numNA.R +++ b/R/ds.numNA.R @@ -56,11 +56,9 @@ #' ds.numNA <- function(x=NULL, datasources=NULL, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of a vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of a vector") cally <- call("numNaDS", x) results <- DSI::datashield.aggregate(datasources, cally) diff --git a/R/ds.qlspline.R b/R/ds.qlspline.R index ca808fb0..9240a7f3 100644 --- a/R/ds.qlspline.R +++ b/R/ds.qlspline.R @@ -33,20 +33,14 @@ #' ds.qlspline <- function(x, q, na.rm = TRUE, marginal = FALSE, names = NULL, newobj = NULL, datasources = NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input variable x!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input variable") - if(is.null(q)){ - stop("Argument 'q' is missing, with no default!", call.=FALSE) - } + .checkArgProvided(q, "a number of quantiles") # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "qlspline.newobj" - } + newobj <- .resolveNewobjName(newobj, "qlspline.newobj") # now do the business calltext <- call("qlsplineDS", x, q, na.rm, marginal, names) diff --git a/R/ds.quantileMean.R b/R/ds.quantileMean.R index 4f037f1f..2702c887 100644 --- a/R/ds.quantileMean.R +++ b/R/ds.quantileMean.R @@ -69,14 +69,12 @@ #' ds.quantileMean <- function(x=NULL, type='combine', datasources=NULL, classConsistencyCheck=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input vector") if (! all(type %in% c("combine", "split"))) { - stop('Function argument "type" has to be either "combine" or "split"', call.=FALSE) + .abortInvalidChoice("type", c("combine", "split")) } # get the server function that produces the quantiles @@ -116,7 +114,7 @@ ds.quantileMean <- function(x=NULL, type='combine', datasources=NULL, classConsi if(type=="split"){ return(quants) }else{ - stop('Function argument "type" has to be either "combine" or "split"', call.=FALSE) + .abortInvalidChoice("type", c("combine", "split")) } } } diff --git a/R/ds.rBinom.R b/R/ds.rBinom.R index 35b8a3ad..c1b41eff 100644 --- a/R/ds.rBinom.R +++ b/R/ds.rBinom.R @@ -106,31 +106,14 @@ #' @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){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "rbinom.newobj" - } + newobj <- .resolveNewobjName(newobj, "rbinom.newobj") ######################## #TEST SEED PRIMING VALUE -seed.valid<-0 - -if(is.null(seed.as.integer)){ -seed.as.text<-"NULL" -seed.valid<-1 -} - -if(is.numeric(seed.as.integer)){ -seed.as.text<-as.character(seed.as.integer) -seed.valid<-1 -} - -if(seed.valid==0){ -mess1<-("ERROR failed: seed.as.integer must be set as an integer [numeric] or left NULL") -return(mess1) -} +seed.as.text <- .seedAsText(seed.as.integer) ################################################################################### #samp.size is either a numeric scalar or a numeric vector set @@ -142,20 +125,11 @@ return(mess1) #Such serverside vectors must be named in inverted commas. These get #stripped off when the vector name is passed to the serverside. -arguments.valid<-1 - -if(is.null(samp.size)||is.null(size)||is.null(prob)||is.null(newobj)){ -arguments.valid<-0 -} - -if(!arguments.valid){ -mess2<-("ERROR: appropriate values must be set for samp.size, size, prob, and newobj name") -return(mess2) -} +.checkArgsSet(samp.size = samp.size, size = size, prob = prob, newobj = newobj) numsources<-length(datasources) -size<-.expand_to_studies(size, "size", numsources) -prob<-.expand_to_studies(prob, "prob", numsources) +size<-.expandToStudies(size, "size", numsources) +prob<-.expandToStudies(prob, "prob", numsources) size.valid<-1 if(is.numeric(size)){ @@ -165,8 +139,7 @@ if(is.numeric(size)){ } if(!size.valid){ -mess3<-("ERROR: size must be > 0") -return(mess3) +cli_abort("{.arg size} must be greater than 0.") } prob.valid<-1 @@ -177,8 +150,7 @@ if(is.numeric(prob)){ } if(!prob.valid){ -mess4<-("ERROR: prob must lie in range 0 < prob < 1") -return(mess4) +cli_abort("{.arg prob} must be between 0 and 1.") } diff --git a/R/ds.rNorm.R b/R/ds.rNorm.R index d2e035b8..0aeec29a 100644 --- a/R/ds.rNorm.R +++ b/R/ds.rNorm.R @@ -120,26 +120,11 @@ 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){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) ######################## #TEST SEED PRIMING VALUE -seed.valid<-0 - -if(is.null(seed.as.integer)){ -seed.as.text<-"NULL" -seed.valid<-1 -} - -if(is.numeric(seed.as.integer)){ -seed.as.text<-as.character(seed.as.integer) -seed.valid<-1 -} - -if(seed.valid==0){ -mess1<-("ERROR failed: seed.as.integer must be set as an integer [numeric] or left NULL") -return(mess1) -} +seed.as.text <- .seedAsText(seed.as.integer) ################################################################################### #samp.size is either a numeric scalar or a numeric vector set @@ -151,21 +136,12 @@ return(mess1) #Such serverside vectors must be named in inverted commas. These get #stripped off when the vector name is passed to the serverside. -arguments.valid<-1 - -if(is.null(samp.size)||is.null(mean)||is.null(sd)||is.null(newobj)){ -arguments.valid<-0 -} - -if(!arguments.valid){ -mess2<-("ERROR: appropriate values must be set for samp.size, mean, sd, and newobj name") -return(mess2) -} +.checkArgsSet(samp.size = samp.size, mean = mean, sd = sd, newobj = newobj) 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) +mean<-.expandToStudies(mean, "mean", numsources) +sd<-.expandToStudies(sd, "sd", numsources) +force.output.to.k.decimal.places<-.expandToStudies(force.output.to.k.decimal.places, "force.output.to.k.decimal.places", numsources) sd.valid<-1 if(is.numeric(sd)){ @@ -175,8 +151,7 @@ if(is.numeric(sd)){ } if(!sd.valid){ -mess3<-("ERROR: sd must be > 0") -return(mess3) +cli_abort("{.arg sd} must be greater than 0.") } decimal.places.valid<-1 @@ -185,8 +160,7 @@ decimal.places.valid<-0 } if(!decimal.places.valid){ -mess4<-("ERROR: force.output.to.k.decimal.places must be an integer in range 0-9") -return(mess4) +cli_abort("{.arg force.output.to.k.decimal.places} must be an integer between 0 and 9.") } ################################################################################### diff --git a/R/ds.rPois.R b/R/ds.rPois.R index c4d56448..1b85d82c 100644 --- a/R/ds.rPois.R +++ b/R/ds.rPois.R @@ -102,26 +102,11 @@ #' @export ds.rPois<-function(samp.size=1,lambda=1, newobj="newObject", seed.as.integer=NULL, return.full.seed.as.set=FALSE, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) ######################## #TEST SEED PRIMING VALUE -seed.valid<-0 - -if(is.null(seed.as.integer)){ -seed.as.text<-"NULL" -seed.valid<-1 -} - -if(is.numeric(seed.as.integer)){ -seed.as.text<-as.character(seed.as.integer) -seed.valid<-1 -} - -if(seed.valid==0){ -mess1<-("ERROR failed: seed.as.integer must be set as an integer [numeric] or left NULL") -return(mess1) -} +seed.as.text <- .seedAsText(seed.as.integer) ################################################################################### #samp.size is either a numeric scalar or a numeric vector set @@ -133,19 +118,10 @@ return(mess1) #Such serverside vectors must be named in inverted commas. These get #stripped off when the vector name is passed to the serverside. -arguments.valid<-1 - -if(is.null(samp.size)||is.null(lambda)||is.null(newobj)){ -arguments.valid<-0 -} - -if(!arguments.valid){ -mess2<-("ERROR: appropriate values must be set for samp.size, lambda, and newobj name") -return(mess2) -} +.checkArgsSet(samp.size = samp.size, lambda = lambda, newobj = newobj) numsources<-length(datasources) -lambda<-.expand_to_studies(lambda, "lambda", numsources) +lambda<-.expandToStudies(lambda, "lambda", numsources) lambda.valid<-1 if(is.numeric(lambda)){ @@ -155,8 +131,7 @@ if(is.numeric(lambda)){ } if(!lambda.valid){ -mess3<-("ERROR: lambda must be > 0") -return(mess3) +cli_abort("{.arg lambda} must be greater than 0.") } ################################################################################### diff --git a/R/ds.rUnif.R b/R/ds.rUnif.R index e09ed491..3f047a2e 100644 --- a/R/ds.rUnif.R +++ b/R/ds.rUnif.R @@ -128,26 +128,11 @@ 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){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) ######################## #TEST SEED PRIMING VALUE -seed.valid<-0 - -if(is.null(seed.as.integer)){ -seed.as.text<-"NULL" -seed.valid<-1 -} - -if(is.numeric(seed.as.integer)){ -seed.as.text<-as.character(seed.as.integer) -seed.valid<-1 -} - -if(seed.valid==0){ -mess1<-("ERROR failed: seed.as.integer must be set as an integer [numeric] or left NULL") -return(mess1) -} +seed.as.text <- .seedAsText(seed.as.integer) ################################################################################### #samp.size is either a numeric scalar or a numeric vector set @@ -159,22 +144,12 @@ return(mess1) #Such serverside vectors must be named in inverted commas. These get #stripped off when the vector name is passed to the serverside. -arguments.valid<-1 - -if(is.null(samp.size)||is.null(min)||is.null(max)||is.null(newobj)){ -arguments.valid<-0 -} - - -if(!arguments.valid){ -mess2<-("ERROR: appropriate values must be set for samp.size, min, max, and newobj name") -return(mess2) -} +.checkArgsSet(samp.size = samp.size, min = min, max = max, newobj = newobj) 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) +min<-.expandToStudies(min, "min", numsources) +max<-.expandToStudies(max, "max", numsources) +force.output.to.k.decimal.places<-.expandToStudies(force.output.to.k.decimal.places, "force.output.to.k.decimal.places", numsources) minmax.valid<-1 @@ -187,8 +162,7 @@ if(is.numeric(min) && is.numeric(max)){ } if(!minmax.valid){ -mess3<-("ERROR: max must be greater than min") -return(mess3) +cli_abort("{.arg max} must be greater than {.arg min}.") } decimal.places.valid<-1 @@ -197,8 +171,7 @@ decimal.places.valid<-0 } if(!decimal.places.valid){ -mess4<-("ERROR: force.output.to.k.decimal.places must be an integer in range 0-9") -return(mess4) +cli_abort("{.arg force.output.to.k.decimal.places} must be an integer between 0 and 9.") } diff --git a/R/ds.rbind.R b/R/ds.rbind.R index 995b719e..af5086bd 100644 --- a/R/ds.rbind.R +++ b/R/ds.rbind.R @@ -83,30 +83,21 @@ ds.rbind<-function(x=NULL, DataSHIELD.checks=FALSE, force.colnames=NULL, newobj=NULL, datasources=NULL, notify.of.progress=FALSE, classConsistencyCheck=TRUE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide a vector of character strings holding the name of the input elements!", call.=FALSE) - } + .checkArgProvided(x, "a vector of the names of the input elements") if(DataSHIELD.checks){ # call the internal function that checks the input object(s) is(are) of the same legal class in all studies. if(classConsistencyCheck){ - for(i in 1:length(x)){ - typ <- checkClass(datasources, x[i]) - if(!('data.frame' %in% typ) & !('matrix' %in% typ) & !('factor' %in% typ) & !('character' %in% typ) & !('numeric' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ)){ - stop(" Only objects of type 'data.frame', 'matrix', 'numeric', 'integer', 'character', 'factor' and 'logical' are allowed.", call.=FALSE) - } - } + .checkObjectClasses(datasources, x) } } # check newobj not actively declared as null - if(is.null(newobj)){ - newobj <- "rbind.newobj" - } + newobj <- .resolveNewobjName(newobj, "rbind.newobj") #CREATE THE VECTOR OF COLUMN NAMES if(!is.null(force.colnames)){ diff --git a/R/ds.reShape.R b/R/ds.reShape.R index 209734f2..f19f2930 100644 --- a/R/ds.reShape.R +++ b/R/ds.reShape.R @@ -82,11 +82,9 @@ ds.reShape <- function(data.name=NULL, varying=NULL, v.names=NULL, timevar.name="time", idvar.name="id", drop=NULL, direction=NULL, sep=".", newobj="newObject", datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(data.name)){ - stop("Please provide the name of the list that holds the input vectors!", call.=FALSE) - } + .checkArgProvided(data.name, "the name of the list that holds the input vectors") if (!is.character(sep) || (nchar(sep) != 1)){ stop("'sep' must be a character string", call.=FALSE) diff --git a/R/ds.recodeValues.R b/R/ds.recodeValues.R index 4038c324..1fb3d5df 100644 --- a/R/ds.recodeValues.R +++ b/R/ds.recodeValues.R @@ -79,12 +79,10 @@ ds.recodeValues <- function(var.name=NULL, values2replace.vector=NULL, new.values.vector=NULL, missing=NULL, newobj=NULL, datasources=NULL, notify.of.progress=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check user has provided the name of the variable to be recoded - if(is.null(var.name)){ - stop("Please provide the name of the variable to be recoded: eg 'xxx'", call.=FALSE) - } + .checkArgProvided(var.name, "the name of the variable to recode") # check user has provided the vector specifying the set of values to be replaced if(is.null(values2replace.vector)){ @@ -120,9 +118,7 @@ ds.recodeValues <- function(var.name=NULL, values2replace.vector=NULL, new.value new.values.transmit <- NULL } - if(is.null(newobj)){ - newobj <- paste0(var.name, "_recoded") - } + newobj <- .resolveNewobjName(newobj, paste0(var.name, "_recoded")) calltext <- call("recodeValuesDS", var.name, values2replace.transmit, new.values.transmit, missing) DSI::datashield.assign(datasources, newobj, calltext) diff --git a/R/ds.rep.R b/R/ds.rep.R index 72c9177a..34464bcd 100644 --- a/R/ds.rep.R +++ b/R/ds.rep.R @@ -96,18 +96,13 @@ ds.rep<-function(x1=NULL, times=NA, length.out=NA, each=1, source.length.out=NULL,source.each=NULL, x1.includes.characters=FALSE,newobj=NULL,datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if a value has been provided for x1 - if(is.null(x1)){ - return("Error: x1 must have a value which is a character string, a numeric vector on the clientside or a scalar") - } + .checkArgProvided(x1, "a character string, a client-side numeric vector or a scalar") # if no value specified for output object, then specify a default - if(is.null(newobj)) - { - newobj <- paste0("seq.vect") - } + newobj <- .resolveNewobjName(newobj, paste0("seq.vect")) #set up aliases for 'clientside', 'serverside' as 'c' and 's' if(source.x1=='c')source.x1<-'clientside' @@ -141,9 +136,7 @@ if(source.each=='s')source.each<-'serverside' #Check that source has been specified if(source.x1!="serverside"&&source.x1!="clientside") { - message(" FAILED: if source.x1 is non-null it must be specified as - one of the following: 'clientside','serverside','c', or 's'\n\n") - return('Please respecify') + .abortInvalidChoice("source.x1", c("clientside", "serverside", "c", "s")) } #process appropriately for source @@ -164,9 +157,7 @@ if(source.each=='s')source.each<-'serverside' #Check that source has been specified if(source.times!="serverside"&&source.times!="clientside"&&!is.null(source.times)) { - message(" FAILED: if source.times is non-null it must be specified as - one of the following: 'clientside','serverside','c', or 's'\n\n") - return('Please respecify') + .abortInvalidChoice("source.times", c("clientside", "serverside", "c", "s")) } @@ -198,9 +189,7 @@ if(source.each=='s')source.each<-'serverside' #Check that source has been specified if(source.length.out!="serverside"&&source.length.out!="clientside"&&!is.null(source.length.out)) { - message(" FAILED: if source.length.out is non-null it must be specified as - one of the following: 'clientside','serverside','c', or 's'\n\n") - return('Please respecify') + .abortInvalidChoice("source.length.out", c("clientside", "serverside", "c", "s")) } @@ -233,9 +222,7 @@ if(source.each=='s')source.each<-'serverside' #Check that source has been specified if(source.each!="serverside"&&source.each!="clientside"&&!is.null(source.each)) { - message(" FAILED: if source.each is non-null it must be specified as - one of the following: 'clientside','serverside','c', or 's'\n\n") - return('Please respecify') + .abortInvalidChoice("source.each", c("clientside", "serverside", "c", "s")) } diff --git a/R/ds.replaceNA.R b/R/ds.replaceNA.R index 1ec2d3a9..a502ccc8 100644 --- a/R/ds.replaceNA.R +++ b/R/ds.replaceNA.R @@ -92,19 +92,14 @@ #' ds.replaceNA <- function(x=NULL, forNA=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of a vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of a vector") # check if replacement values have been provided - if(is.null(forNA)){ - stop("Please provide a list of replacement values!", call.=FALSE) - }else{ - if(length(forNA) != length(datasources)){ - stop("'forNA' must be of the same length as the number of datasources/studies!", call.=FALSE) - } + .checkArgProvided(forNA, "a list of replacement values") + if(length(forNA) != length(datasources)){ + cli_abort("{.arg forNA} must have one element per study.") } for(i in 1:length(datasources)){ @@ -119,9 +114,7 @@ ds.replaceNA <- function(x=NULL, forNA=NULL, newobj=NULL, datasources=NULL){ } } - if(is.null(newobj)){ - newobj <- "replacena.newobj" - } + newobj <- .resolveNewobjName(newobj, "replacena.newobj") # call the server side function and doo the replacement for each server for(i in 1:length(datasources)){ diff --git a/R/ds.rm.R b/R/ds.rm.R index 9e104228..e923aec3 100644 --- a/R/ds.rm.R +++ b/R/ds.rm.R @@ -69,11 +69,9 @@ ds.rm<-function(x.names=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if (is.null(x.names)) { - stop("Please provide the names of the objects to be deleted (eg 'object.name') as the x.names argument", call.=FALSE) - } + .checkArgProvided(x.names, "the names of the objects to delete") #make transmittable via parser x.names.transmit <- paste(x.names,collapse=",") diff --git a/R/ds.rowColCalc.R b/R/ds.rowColCalc.R index 7aecbba0..629e1575 100644 --- a/R/ds.rowColCalc.R +++ b/R/ds.rowColCalc.R @@ -68,11 +68,9 @@ #' ds.rowColCalc <- function(x=NULL, operation=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of a data.frame or matrix!", call.=FALSE) - } + .checkArgProvided(x, "the name of a data.frame or matrix") ops <- c("rowSums","colSums","rowMeans","colMeans") if(is.null(operation)){ @@ -81,7 +79,7 @@ ds.rowColCalc <- function(x=NULL, operation=NULL, newobj=NULL, datasources=NULL) stop("'operation' = NULL. Please set it to 'rowSums', 'colSums', 'rowMeans' or 'colMeans'", call.=FALSE) }else{ if(!any(operation %in% ops)){ - stop("'operation' must be set to: 'rowSums', 'colSums', 'rowMeans' or 'colMeans'") + .abortInvalidChoice("operation", ops) } } @@ -89,9 +87,7 @@ ds.rowColCalc <- function(x=NULL, operation=NULL, newobj=NULL, datasources=NULL) indx <- which(ops == operation) # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "rowcolcalc.newobj" - } + newobj <- .resolveNewobjName(newobj, "rowcolcalc.newobj") # call the server side function that does the job DSI::datashield.assign(datasources, newobj, call("rowColCalcDS", dataset.name=x, operation=indx)) diff --git a/R/ds.sample.R b/R/ds.sample.R index 9128a9e1..422d9e26 100644 --- a/R/ds.sample.R +++ b/R/ds.sample.R @@ -130,44 +130,24 @@ ds.sample<-function(x=NULL, size=NULL, seed.as.integer=NULL, replace=FALSE, prob = NULL, newobj=NULL,datasources=NULL, notify.of.progress=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if a value has been provided for x - if(is.null(x)){ - return("Error: x must denote a character string naming the serverside object to be sampled or an integer N denoting permute 1:N") - } + .checkArgProvided(x, "a character string that names a server-side object, or an integer N to permute 1:N") # check if a valid value has been provided for size if x denotes a vector, # matrix or data.frame on the serverside if(is.character(x)&&is.null(size)){ - return("Error: size must have a value which is an integer denoting how many records to be sampled") + cli_abort("{.arg size} must be an integer that sets how many records to sample.") } # if no value specified for output object, then specify a default - if(is.null(newobj)) - { - newobj <- "newobj.sample" - } + newobj <- .resolveNewobjName(newobj, "newobj.sample") ######################## #TEST SEED PRIMING VALUE -seed.valid<-0 - -if(is.null(seed.as.integer)){ -seed.as.text<-"NULL" -seed.valid<-1 -} - -if(is.numeric(seed.as.integer)){ -seed.as.text<-as.character(seed.as.integer) -seed.valid<-1 -} - -if(seed.valid==0){ -mess1<-("ERROR failed: seed.as.integer must be set as an integer [numeric] or left NULL") -return(mess1) -} +seed.as.text <- .seedAsText(seed.as.integer) ############################################################# #SET SEED IN EACH STUDY AS IN PSEUDORANDOM NUMBER GENERATORS diff --git a/R/ds.scatterPlot.R b/R/ds.scatterPlot.R index 6a76d798..11a0a724 100644 --- a/R/ds.scatterPlot.R +++ b/R/ds.scatterPlot.R @@ -131,15 +131,11 @@ #' ds.scatterPlot <- function(x=NULL, y=NULL, method='deterministic', k=3, noise=0.25, type="split", return.coords=FALSE, datasources=NULL, classConsistencyCheck=FALSE){ - if(is.null(x)){ - stop("Please provide the name of the x-variable", call.=FALSE) - } + .checkArgProvided(x, "the name of the x variable") - if(is.null(y)){ - stop("Please provide the name of the y-variable", call.=FALSE) - } + .checkArgProvided(y, "the name of the y variable") - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # Save par and setup reseting of par values old_par <- graphics::par(no.readonly = TRUE) @@ -163,8 +159,8 @@ ds.scatterPlot <- function(x=NULL, y=NULL, method='deterministic', k=3, noise=0. # call the server-side function that generates the x and y coordinates of the centroids output <- datashield.aggregate(datasources, call("scatterPlotDS", x.name=x, y.name=y, method.indicator=method.indicator, k=k, noise=noise)) if(classConsistencyCheck){ - .checkClassConsistency(output, field = "class.x", object_name = x) - .checkClassConsistency(output, field = "class.y", object_name = y) + .checkClassConsistency(output, field = "class.x", objectName = x) + .checkClassConsistency(output, field = "class.y", objectName = y) } pooled.points.x <- c() @@ -214,7 +210,7 @@ ds.scatterPlot <- function(x=NULL, y=NULL, method='deterministic', k=3, noise=0. return(message=return.message) } }else{ - stop('Function argument "type" has to be either "combine" or "split"') + .abortInvalidChoice("type", c("combine", "split")) } } } diff --git a/R/ds.seq.R b/R/ds.seq.R index 13fc644a..e6a0cad5 100644 --- a/R/ds.seq.R +++ b/R/ds.seq.R @@ -117,7 +117,7 @@ ds.seq<-function(FROM.value.char = "1", BY.value.char = "1", TO.value.char=NULL, LENGTH.OUT.value.char = NULL, ALONG.WITH.name=NULL, newobj="newObj", datasources=NULL) { ###datasources - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) ###FROM.value.char # check FROM.value.char is valid @@ -127,7 +127,7 @@ ds.seq<-function(FROM.value.char = "1", BY.value.char = "1", TO.value.char=NULL, if(!is.numeric(eval(parse(text=FROM.value.char))))FROM.valid<-0 } if(!FROM.valid){ - return("Error: If FROM.value.char is non.NULL, it must be a real number in inverted commas eg '-3.7' or '0'") + cli_abort(c("{.arg FROM.value.char} must be a real number in inverted commas.", "i" = "For example, {.val -3.7} or {.val 0}.")) } ###TO.value.char @@ -138,7 +138,7 @@ ds.seq<-function(FROM.value.char = "1", BY.value.char = "1", TO.value.char=NULL, if(!is.numeric(eval(parse(text=TO.value.char))))TO.valid<-0 } if(!TO.valid){ - return("Error: If TO.value.char is non.NULL, it must be a real number in inverted commas eg '-3.7' or '0'") + cli_abort(c("{.arg TO.value.char} must be a real number in inverted commas.", "i" = "For example, {.val -3.7} or {.val 0}.")) } ###BY.value.char @@ -149,7 +149,7 @@ ds.seq<-function(FROM.value.char = "1", BY.value.char = "1", TO.value.char=NULL, if(!is.numeric(eval(parse(text=BY.value.char))))BY.valid<-0 } if(!BY.valid){ - return("Error: If FROM.value.char is non.NULL, it must be a real number in inverted commas eg '5' or '-98.7321'") + cli_abort(c("{.arg BY.value.char} must be a real number in inverted commas.", "i" = "For example, {.val 5} or {.val -98.7321}.")) } ###LENGTH.OUT.value.char @@ -160,19 +160,19 @@ ds.seq<-function(FROM.value.char = "1", BY.value.char = "1", TO.value.char=NULL, if(!is.numeric(eval(parse(text=LENGTH.OUT.value.char))))LENGTH.OUT.valid<-0 } if(!LENGTH.OUT.valid){ - return("Error: If LENGTH.OUT.value.char is non.NULL, it must be an integer in inverted commas eg '87187'") + cli_abort(c("{.arg LENGTH.OUT.value.char} must be an integer in inverted commas.", "i" = "For example, {.val 87187}.")) } ###ALONG.WITH.name # check if user has correctly provided the name of a column to hold ALONG.WITH.name if(!(is.null(ALONG.WITH.name) || is.character(ALONG.WITH.name))){ - return("Error: If ALONG.WITH.name is non.NULL, it must specify the name of a serverside vector in inverted commas") + cli_abort("{.arg ALONG.WITH.name} must be the name of a server-side vector in inverted commas.") } ###Either LENGTH.OUT.value.char or ALONG.WITH.name must be non-NULL if(is.null(TO.value.char)&&is.null(LENGTH.OUT.value.char)&&is.null(ALONG.WITH.name)){ - return("Error: Either TO.value.char or LENGTH.OUT.value.char or ALONG.WITH.name must be non-NULL, they cannot both be NULL") + cli_abort("One of {.arg TO.value.char}, {.arg LENGTH.OUT.value.char} or {.arg ALONG.WITH.name} must be set.") } diff --git a/R/ds.setSeed.R b/R/ds.setSeed.R index 5192f753..e14b275f 100644 --- a/R/ds.setSeed.R +++ b/R/ds.setSeed.R @@ -87,26 +87,10 @@ #' @export ds.setSeed<-function(seed.as.integer=NULL,datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) -seed.valid<-0 - -if(is.null(seed.as.integer)){ -seed.as.text<-"NULL" -seed.valid<-1 -} - -if(is.numeric(seed.as.integer)){ -seed.as.text<-as.character(seed.as.integer) -seed.valid<-1 -} - - -if(seed.valid==0){ -mess1<-("ERROR terminated: seed.as.integer must be set as an integer [numeric] or as being NULL") -return(mess1) -} +seed.as.text <- .seedAsText(seed.as.integer) ssDS.obj <- datashield.aggregate(datasources, call("setSeedDS", seedtext=seed.as.text)) diff --git a/R/ds.skewness.R b/R/ds.skewness.R index 52f0c87a..324f0510 100644 --- a/R/ds.skewness.R +++ b/R/ds.skewness.R @@ -81,11 +81,9 @@ #' ds.skewness <- function(x=NULL, method=1, type='both', datasources=NULL, classConsistencyCheck=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input vector") if(!all(method %in% c(1,2,3))){ stop("method must be an integer between 1 and 3", call.=FALSE) @@ -96,7 +94,7 @@ ds.skewness <- function(x=NULL, method=1, type='both', datasources=NULL, classCo if(type == 'split' | type == 'splits' | type == 's') type <- 'split' if(type == 'both' | type == 'b' ) type <- 'both' if(type != 'combine' & type != 'split' & type != 'both') - stop('Function argument "type" has to be either "both", "combine" or "split"', call.=FALSE) + .abortInvalidChoice("type", c("both", "combine", "split")) if (type=='split' | type=='both'){ calltext.split <- call("skewnessDS1", x, method) diff --git a/R/ds.sqrt.R b/R/ds.sqrt.R index 76a7538e..376fa212 100644 --- a/R/ds.sqrt.R +++ b/R/ds.sqrt.R @@ -71,15 +71,11 @@ #' ds.sqrt <- function(x=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input object!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input object") - if(is.null(newobj)){ - newobj <- "sqrt.newobj" - } + newobj <- .resolveNewobjName(newobj, "sqrt.newobj") cally <- call("sqrtDS", x) DSI::datashield.assign(datasources, newobj, cally) diff --git a/R/ds.summary.R b/R/ds.summary.R index bac5cb62..d6824a74 100644 --- a/R/ds.summary.R +++ b/R/ds.summary.R @@ -67,11 +67,9 @@ #' ds.summary <- function(x=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input vector") # check the type of x to drive client-side dispatch typ <- checkClass(datasources, x) diff --git a/R/ds.table.R b/R/ds.table.R index 328925aa..605ba1c8 100644 --- a/R/ds.table.R +++ b/R/ds.table.R @@ -191,27 +191,25 @@ ds.table <- function(rvar=NULL, cvar=NULL, stvar=NULL, report.chisq.tests=FALSE, table.assign=FALSE, newobj=NULL, datasources=NULL, force.nfilter=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) # check if a value has been provided for rvar - if(is.null(rvar)){ - return("Error: rvar must have a value which is a character string naming the row variable for the table") - } + .checkArgProvided(rvar, "a character string that names the row variable") if(!is.null(cvar)&&!is.character(cvar)){ - return("Error: if cvar is not null, it must have a value which is a character string naming the column variable for the table") + cli_abort("{.arg cvar} must be a character string that names the column variable.") } if(!is.null(stvar)&&!is.character(stvar)){ - return("Error: if stvar is not null, it must have a value which is a character string naming the variable coding separate tables for the table") + cli_abort("{.arg stvar} must be a character string that names the variable that codes the separate tables.") } if(useNA!="no" && useNA!="always"){ - stop("useNA must be either 'no' or 'always'.") + .abortInvalidChoice("useNA", c("no", "always")) } if(!is.null(force.nfilter)&&!is.character(force.nfilter)){ - return("Error: if force.nfilter is not null, it must have a value which is a character string specifying an integer for the forced value of the nfilter") + cli_abort("{.arg force.nfilter} must be a character string that specifies an integer.") } @@ -332,10 +330,7 @@ ds.table <- function(rvar=NULL, cvar=NULL, stvar=NULL, report.chisq.tests=FALSE, if(table.assign) { - if(is.null(newobj)) - { - newobj<-"table.newobj" - } + newobj <- .resolveNewobjName(newobj, "table.newobj") # CALL THE MAIN SERVER SIDE ASSIGN FUNCTION @@ -405,14 +400,8 @@ if(num.valid.studies==0) { if ((! table.assign) || report.chisq.tests) { - validity.message<-"All studies failed for reasons identified below" - message("\n",validity.message,"\n\n") - for(ns in 1:numsources.orig) - { - message("\nStudy",ns,": ",error.messages[[ns]],"\n") - } - - return(list(validity.message=validity.message,error.messages=error.messages)) + failures <- paste0(names(error.messages), ": ", unlist(error.messages)) + cli_abort(c("All studies failed.", "x" = "{failures}")) } else { @@ -501,8 +490,7 @@ if(numsources>1) if(table.dimensions[ns]!=table.dimensions[ns+1]) { all.dims.same<-FALSE - return.message<-"Warning: tables in different sources have different numbers of dimensions. Please analyse and combine yourself from study.specific tables above" - return(return.message) + cli_abort(c("Tables in different sources have different numbers of dimensions.", "i" = "Analyse and combine them yourself from the study-specific tables.")) } } @@ -718,9 +706,7 @@ for(oo in 1:length(table.current.study[,1])) if(d1.a!=d1||d2.a!=d2||d3.a!=d3) { - return.message= "Dimensions of tables not behaving sensibly across studies.Please check the data in each study and calculate counts and percentages, yourself, using the counts from the individual studies" - message(return.message) - return(return.message) + cli_abort(c("Table dimensions differ across studies.", "i" = "Check the data in each study and calculate counts and percentages yourself from the counts in each study.")) } #dimension markers match so allocate count to correct cell @@ -939,9 +925,7 @@ for(oo in 1:length(table.current.study[,1])) if(d1.a!=d1||d2.a!=d2) { - return.message= "Dimensions of tables not behaving sensibly across studies.Please check the data in each study and calculate counts and percentages, yourself, using the counts from the individual studies" - message(return.message) - return(return.message) + cli_abort(c("Table dimensions differ across studies.", "i" = "Check the data in each study and calculate counts and percentages yourself from the counts in each study.")) } #dimension markers match so allocate count to correct cell @@ -1133,9 +1117,7 @@ for(oo in 1:length(table.current.study[,1])) if(d1.a!=d1) { - return.message= "Dimensions of tables not behaving sensibly across studies.Please check the data in each study and calculate counts and percentages, yourself, using the counts from the individual studies" - message(return.message) - return(return.message) + cli_abort(c("Table dimensions differ across studies.", "i" = "Check the data in each study and calculate counts and percentages yourself from the counts in each study.")) } #dimension markers match so allocate count to correct cell diff --git a/R/ds.tapply.R b/R/ds.tapply.R index 5342c332..0ca7829e 100644 --- a/R/ds.tapply.R +++ b/R/ds.tapply.R @@ -125,21 +125,16 @@ ds.tapply <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, datasources=NULL){ ###datasources - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) ###X.name # check if user has provided the name of the column that holds X.name - if(is.null(X.name)){ - return("Error: Please provide the name of the variable to be summarized, as a character string") - } + .checkArgProvided(X.name, "the name of the variable to summarise, as a character string") ###INDEX.names # check if user has provided the name of the column(s) that holds INDEX.names if(is.null(INDEX.names)){ - Err.1 <- "Error: Please provide the name of the single factor or" - Err.2 <- "the list of factors to index the variable to be summarized." - Err.3 <- "In either case the argument must be specified in inverted commas" - return(list(Error.message=Err.1, Err.cont2=Err.2, Err.cont3=Err.3)) + cli_abort("{.arg INDEX.names} must name a single factor or a list of factors, in inverted commas.") } # check if the vector or list of INDEX.names includes up to two names @@ -156,9 +151,7 @@ ds.tapply <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, datasources= ###FUN.name # check if user has provided a valid summarizing function - if(is.null(FUN.name)){ - return("Error: Please provide a valid summarizing function, as a character string") - } + .checkArgProvided(FUN.name, "a valid summarising function, as a character string") # CALL THE PRIMARY SERVER SIDE FUNCTION calltext <- call("tapplyDS", X.name, INDEX.names.transmit, FUN.name) diff --git a/R/ds.tapply.assign.R b/R/ds.tapply.assign.R index 14722a94..9438b21a 100644 --- a/R/ds.tapply.assign.R +++ b/R/ds.tapply.assign.R @@ -130,21 +130,16 @@ ds.tapply.assign <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, newobj=NULL, datasources=NULL){ ###datasources - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) ###X.name # check if user has provided the name of the column that holds X.name - if(is.null(X.name)){ - return("Error: Please provide the name of the variable to be summarized, as a character string") - } + .checkArgProvided(X.name, "the name of the variable to summarise, as a character string") ###INDEX.names # check if user has provided the name of the column(s) that holds INDEX.names if(is.null(INDEX.names)){ - Err.1 <- "Error: Please provide the name of the single factor or" - Err.2 <- "the list of factors to index the variable to be summarized." - Err.3 <- "In either case the argument must be specified in inverted commas" - return(list(Error.message=Err.1, Err.cont2=Err.2, Err.cont3=Err.3)) + cli_abort("{.arg INDEX.names} must name a single factor or a list of factors, in inverted commas.") } # check if the vector or list of INDEX.names includes up to two names @@ -161,14 +156,10 @@ ds.tapply.assign <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, newob ###FUN.name # check if user has provided a valid summarizing function - if(is.null(FUN.name)){ - return("Error: Please provide a valid summarizing function, as a character string") - } + .checkArgProvided(FUN.name, "a valid summarising function, as a character string") # create a name by default if user did not provide a name for the new tapply object - if(is.null(newobj)){ - newobj <- "tapply.assign.newobj" - } + newobj <- .resolveNewobjName(newobj, "tapply.assign.newobj") # CALL THE PRIMARY SERVER SIDE FUNCTION calltext <- call("tapplyDS.assign", X.name, INDEX.names.transmit, FUN.name) diff --git a/R/ds.unList.R b/R/ds.unList.R index 6f98fddd..3df4dd01 100644 --- a/R/ds.unList.R +++ b/R/ds.unList.R @@ -70,17 +70,13 @@ #' @export ds.unList <- function(x.name=NULL, newobj=NULL, datasources=NULL){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x.name)){ - stop("Please provide the name of the input vector!", call.=FALSE) - } + .checkArgProvided(x.name, "the name of the input vector") # create a name by default if user did not provide a name for the new variable - if(is.null(newobj)){ - newobj <- "unlist.newobj" - } + newobj <- .resolveNewobjName(newobj, "unlist.newobj") # call the server side function calltext <- call("unListDS", x.name) diff --git a/R/ds.unique.R b/R/ds.unique.R index 07ceced2..4c09b74f 100644 --- a/R/ds.unique.R +++ b/R/ds.unique.R @@ -48,15 +48,11 @@ #' ds.unique <- function(x.name = NULL, newobj = NULL, datasources = NULL) { - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if (is.null(x.name)) { - stop("x.name=NULL. Please provide the names of the objects to de-duplicated!", call. = FALSE) - } + .checkArgProvided(x.name, "the names of the objects to de-duplicate") - if (is.null(newobj)) { - newobj <- "unique.newobj" - } + newobj <- .resolveNewobjName(newobj, "unique.newobj") cally <- call('uniqueDS', x.name) DSI::datashield.assign(datasources, newobj, cally) diff --git a/R/ds.var.R b/R/ds.var.R index 4247e024..4266f57e 100644 --- a/R/ds.var.R +++ b/R/ds.var.R @@ -75,11 +75,9 @@ #' ds.var <- function(x=NULL, type='split', datasources=NULL, classConsistencyCheck=FALSE){ - datasources <- .set_datasources(datasources) + datasources <- .resolveDatasources(datasources) - if(is.null(x)){ - stop("Please provide the name of the input object!", call.=FALSE) - } + .checkArgProvided(x, "the name of the input object") ################################################################################################### #MODULE: EXTEND "type" argument to include "both" and enable valid alisases # diff --git a/R/utils.R b/R/utils.R index db6ac35d..faad6c42 100644 --- a/R/utils.R +++ b/R/utils.R @@ -6,7 +6,7 @@ #' @return A list of data sources. #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @noRd -.get_datasources <- function(datasources) { +.getDatasources <- function(datasources) { if (is.null(datasources)) { datasources <- datashield.connections_find() } @@ -16,13 +16,14 @@ #' Verify that the provided data sources are of class 'DSConnection'. #' #' @param datasources A list of data sources. +#' @param call The frame to report the error from. #' @importFrom cli cli_abort #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @noRd -.verify_datasources <- function(datasources) { - is_connection_class <- sapply(datasources, function(x) inherits(unlist(x), "DSConnection")) - if (!all(is_connection_class)) { - cli_abort("The 'datasources' were expected to be a list of DSConnection-class objects") +.verifyDatasources <- function(datasources, call = parent.frame()) { + isConnectionClass <- vapply(datasources, function(x) inherits(unlist(x), "DSConnection"), logical(1)) + if (!all(isConnectionClass)) { + cli_abort("{.arg datasources} must be a list of {.cls DSConnection} objects.", call = call) } } @@ -30,12 +31,13 @@ #' #' @param datasources An optional list of data sources. If not provided, the function will attempt #' to find available data sources. +#' @param call The frame to report the error from. #' @return A list of verified data sources. #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @noRd -.set_datasources <- function(datasources) { - datasources <- .get_datasources(datasources) - .verify_datasources(datasources) +.resolveDatasources <- function(datasources, call = parent.frame()) { + datasources <- .getDatasources(datasources) + .verifyDatasources(datasources, call = call) return(datasources) } @@ -48,17 +50,20 @@ #' @param results A named list of server-side aggregate results, one per study, #' each containing the class field named by `field`. #' @param field The name of the element holding the class. Default `"class"`. -#' @param object_name Optional name of the input object, used to make the error +#' @param objectName Optional name of the input object, used to make the error #' message specific. If `NULL` a generic message is used. +#' @param call The frame to report the error from. #' @importFrom cli cli_abort #' @return Invisibly returns `NULL`. Called for its side effect (error checking). #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @noRd -.checkClassConsistency <- function(results, field = "class", object_name = NULL) { +.checkClassConsistency <- function(results, field = "class", objectName = NULL, call = parent.frame()) { classes <- lapply(results, function(r) r[[field]]) if (length(unique(lapply(classes, sort))) > 1) { - subject <- if (is.null(object_name)) "The input object" else paste0("'", object_name, "'") - cli_abort("{subject} is not of the same class in all studies!") + if (is.null(objectName)) { + cli_abort("The input object must have the same class in all studies.", call = call) + } + cli_abort("{.val {objectName}} must have the same class in all studies.", call = call) } } @@ -69,13 +74,14 @@ #' user-friendly error. #' #' @param newobj A character string naming the object to be created server-side. +#' @param call The frame to report the error from. #' @importFrom cli cli_abort #' @return Invisibly returns `NULL`. Called for its side effect (error checking). #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @noRd -.check_newobj_name <- function(newobj) { +.checkNewobjName <- function(newobj, call = parent.frame()) { if (!is.character(newobj) || length(newobj) != 1) { - cli_abort("'newobj' must be a single character string") + cli_abort("{.arg newobj} must be a single character string.", call = call) } } @@ -88,50 +94,169 @@ #' @param newobj A character string naming the object to be created server-side, #' or `NULL` to use `default`. #' @param default The name to use when `newobj` is `NULL`. +#' @param call The frame to report the error from. #' @return A validated, single character string. #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @noRd -.set_newobj_name <- function(newobj, default) { +.resolveNewobjName <- function(newobj, default, call = parent.frame()) { if (is.null(newobj)) { newobj <- default } - .check_newobj_name(newobj) + .checkNewobjName(newobj, call = call) return(newobj) } -#' Check That a Data Frame Name Is Provided +#' Check That a Required Argument Is Provided #' -#' Internal helper that checks whether a data frame or matrix object -#' has been provided. If `NULL`, it aborts with a user-friendly error. +#' Internal helper that aborts if a required argument is `NULL`, naming the +#' argument as it was passed by the calling function. #' -#' @param df A data.frame or matrix. +#' @param x The argument to check. +#' @param description What the argument must be, e.g. "the name of the input vector". +#' @param call The frame to report the error from. +#' @importFrom cli cli_abort +#' @return Invisibly returns `NULL`. Called for its side effect (error checking). +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.checkArgProvided <- function(x, description, call = parent.frame()) { + if (is.null(x)) { + cli_abort("{.arg {deparse(substitute(x))}} must be {description}, not {.code NULL}.", call = call) + } +} + +#' Check That Required Arguments Are All Set +#' +#' @param ... The arguments to check, named as the user knows them. +#' @param call The frame to report the error from. +#' @importFrom cli cli_abort #' @return Invisibly returns `NULL`. Called for its side effect (error checking). #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @noRd -.check_df_name_provided <- function(df) { - if(is.null(df)){ - cli_abort("Please provide the name of a data.frame or matrix!") +.checkArgsSet <- function(..., call = parent.frame()) { + args <- list(...) + if (any(vapply(args, is.null, logical(1)))) { + cli_abort("{.arg {names(args)}} must all be set.", call = call) + } +} + +#' Convert a Seed to the Text Sent to the Server +#' +#' @param seed.as.integer A number, or `NULL` for no seed. +#' @param call The frame to report the error from. +#' @importFrom cli cli_abort +#' @return The seed as a character string, or `"NULL"` when no seed was given. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.seedAsText <- function(seed.as.integer, call = parent.frame()) { + if (is.null(seed.as.integer)) { + return("NULL") + } + if (!is.numeric(seed.as.integer)) { + cli_abort("{.arg seed.as.integer} must be an integer or {.code NULL}.", call = call) + } + return(as.character(seed.as.integer)) +} + +#' Warn About an Offset or Weights Written Into a Model Formula +#' +#' @param formula The model formula, as a character string or formula. +#' @param call The frame to report the warning from. +#' @importFrom cli cli_warn +#' @return Invisibly returns `NULL`. Called for its side effect. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.warnOffsetInFormula <- function(formula, call = parent.frame()) { + if (any(grepl("offset|weights", formula, ignore.case = TRUE))) { + cli_warn(c( + "You may have specified an offset or regression weights in the model formula.", + "i" = "Specify them separately with the {.arg offset} and {.arg weights} arguments." + ), call = call) } } +#' Check That Each Object Has a Class That Can Be Combined +#' +#' @param datasources A list of data sources. +#' @param x The names of the server-side objects. +#' @param call The frame to report the error from. +#' @importFrom cli cli_abort +#' @return Invisibly returns `NULL`. Called for its side effect (error checking). +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.checkObjectClasses <- function(datasources, x, call = parent.frame()) { + allowed <- c("data.frame", "matrix", "numeric", "integer", "character", "factor", "logical") + for (name in x) { + if (!any(allowed %in% checkClass(datasources, name))) { + cli_abort("Each object must be of class {.or {.val {allowed}}}.", call = call) + } + } +} + +#' Check That Objects to Be Bound Together Fit in Every Study +#' +#' Warns if column names are duplicated, and aborts if the objects differ in +#' their number of rows. +#' +#' @param datasources A list of data sources. +#' @param x The names of the server-side objects. +#' @param call The frame to report the error from. +#' @importFrom cli cli_abort cli_warn +#' @return Invisibly returns `NULL`. Called for its side effect. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.checkMultiObjectConsistency <- function(datasources, x, call = parent.frame()) { + isTable <- vapply(x, function(name) any(checkClass(datasources, name) %in% c("data.frame", "matrix")), logical(1)) + for (j in seq_along(datasources)) { + study <- datasources[j] + columns <- lapply(seq_along(x), function(i) { + if (isTable[[i]]) ds.colnames(x = x[i], datasources = study) else as.character(x[i]) + }) + if (anyDuplicated(unlist(columns)) != 0) { + cli_warn("Some column names in study {j} are duplicated, so a suffix {.val .k} is added to the kth replicate.", call = call) + } + rows <- vapply(seq_along(x), function(i) { + if (isTable[[i]]) { + return(as.numeric(ds.dim(x = x[i], type = "split", datasources = study)[[1]][1])) + } + as.numeric(ds.length(x[i], type = "split", datasources = study)[[1]]) + }, numeric(1)) + if (any(rows != rows[1])) { + cli_abort("All components must have the same number of rows.", call = call) + } + } +} + +#' Abort Because an Argument Is Not One of the Allowed Values +#' +#' @param argName The name of the argument. +#' @param choices A character vector of the allowed values. +#' @param call The frame to report the error from. +#' @importFrom cli cli_abort cli_inform cli_verbatim cli_warn +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @noRd +.abortInvalidChoice <- function(argName, choices, call = parent.frame()) { + cli_abort("{.arg {argName}} must be {.or {.val {choices}}}.", call = call) +} + #' 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. +#' @param values A vector of length 1 or `numStudies`. +#' @param argName The name of the argument, used in the error message. +#' @param numStudies The number of studies being analysed. +#' @param call The frame to report the error from. #' @importFrom cli cli_abort -#' @return A vector of length `num_studies`. +#' @return A vector of length `numStudies`. #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @noRd -.expand_to_studies <- function(values, arg_name, num_studies) { +.expandToStudies <- function(values, argName, numStudies, call = parent.frame()) { if (length(values) == 1) { - return(rep(values, num_studies)) + return(rep(values, numStudies)) } - if (length(values) != num_studies) { - cli_abort("'{arg_name}' must be length 1 or one value per study") + if (length(values) != numStudies) { + cli_abort("{.arg {argName}} must have length 1 or one value per study.", call = call) } return(values) } diff --git a/tests/testthat/test-_-utils.R b/tests/testthat/test-_-utils.R new file mode 100644 index 00000000..1586c8e0 --- /dev/null +++ b/tests/testthat/test-_-utils.R @@ -0,0 +1,64 @@ +# +# Tests +# + +# context("utils::.checkArgProvided") +test_that(".checkArgProvided names the argument and reports the calling function", { + check <- function(x) .checkArgProvided(x, "the name of the input vector") + + expect_null(check("a")) + error <- expect_error(check(NULL), "`x` must be the name of the input vector") + expect_equal(error$call, quote(check(NULL))) +}) + +# context("utils::.abortInvalidChoice") +test_that(".abortInvalidChoice lists the allowed values", { + expect_error(.abortInvalidChoice("type", c("combine", "split")), "`type` must be \"combine\" or \"split\"") + expect_error(.abortInvalidChoice("type", c("both", "combine", "split")), "`type` must be \"both\", \"combine\", or \"split\"") +}) + +# context("utils::.resolveNewobjName") +test_that(".resolveNewobjName applies the default before validating", { + expect_equal(.resolveNewobjName(NULL, "x.newobj"), "x.newobj") + expect_equal(.resolveNewobjName("my.obj", "x.newobj"), "my.obj") +}) + +test_that(".resolveNewobjName rejects anything but a single character string", { + expect_error(.resolveNewobjName(23, "x.newobj"), "`newobj` must be a single character string") + expect_error(.resolveNewobjName(c("a", "b"), "x.newobj"), "`newobj` must be a single character string") +}) + +# context("utils::.verifyDatasources") +test_that(".verifyDatasources rejects objects that are not connections", { + expect_error(.verifyDatasources(list(1)), "`datasources` must be a list of objects") +}) + +# context("utils::.checkClassConsistency") +test_that(".checkClassConsistency compares the chosen field across studies", { + same <- list(a = list(class = "numeric"), b = list(class = "numeric")) + different <- list(a = list(class = "numeric"), b = list(class = "factor")) + + expect_null(.checkClassConsistency(same)) + expect_error(.checkClassConsistency(different), "The input object must have the same class") + expect_error(.checkClassConsistency(different, objectName = "D"), "\"D\" must have the same class") +}) + +# context("utils::.seedAsText") +test_that(".seedAsText converts the seed and rejects anything that isn't a number", { + expect_equal(.seedAsText(NULL), "NULL") + expect_equal(.seedAsText(27), "27") + expect_error(.seedAsText("a"), "`seed.as.integer` must be an integer or `NULL`") +}) + +# context("utils::.checkArgsSet") +test_that(".checkArgsSet names every argument", { + expect_null(.checkArgsSet(a = 1, b = 2)) + expect_error(.checkArgsSet(a = NULL, b = 2), "`a` and `b` must all be set") +}) + +# context("utils::.warnOffsetInFormula") +test_that(".warnOffsetInFormula looks for an offset or weights in the formula", { + expect_no_warning(.warnOffsetInFormula("y~x")) + expect_warning(.warnOffsetInFormula("y~offset(x)"), "offset or regression weights") + expect_warning(.warnOffsetInFormula("y~x+WEIGHTS"), "offset or regression weights") +}) diff --git a/tests/testthat/test-arg-ds.Boole.R b/tests/testthat/test-arg-ds.Boole.R index d8fb3bed..eecb996c 100644 --- a/tests/testthat/test-arg-ds.Boole.R +++ b/tests/testthat/test-arg-ds.Boole.R @@ -21,10 +21,10 @@ connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) # context("ds.Boole::arg::test errors") test_that("Boole_erros", { - expect_error(ds.Boole(), "Please provide the name of the column or scalar that holds V1!", fixed=TRUE) - expect_error(ds.Boole(V1="D$LAB_TSC"), "Please provide the name of a column or scalar holding V2 or declare a scalar in character format: eg '3'", fixed=TRUE) - expect_error(ds.Boole(V1="D$LAB_TSC", V2="LAB_TRIG"), "Please provide a Boolean operator in character format: eg '==' or '>=' or '<' or '!='", fixed=TRUE) - expect_error(ds.Boole(V1="D$LAB_TSC", V2="LAB_TRIG", Boolean.operator="==", na.assign=2), "Error: na.assign must be a character string taking value 'NA', '0' or '1'- if not specified default is 'NA'", fixed=TRUE) + expect_error(ds.Boole(), "must be the name of the column or scalar that holds V1", fixed=TRUE) + expect_error(ds.Boole(V1="D$LAB_TSC"), "must be the name of a column or scalar that holds V2", fixed=TRUE) + expect_error(ds.Boole(V1="D$LAB_TSC", V2="LAB_TRIG"), "must be a Boolean operator in character format", fixed=TRUE) + expect_error(ds.Boole(V1="D$LAB_TSC", V2="LAB_TRIG", Boolean.operator="==", na.assign=2), "must be \"NA\", \"0\", or \"1\"", fixed=TRUE) expect_error(ds.Boole(V1="D$LAB_TSC", V2="LAB_TRIG", Boolean.operator="AA"), "An unrecognized Boolean operator, AA, has provide", fixed=TRUE) }) diff --git a/tests/testthat/test-arg-ds.abs.R b/tests/testthat/test-arg-ds.abs.R index cfe0a49a..c09eb917 100644 --- a/tests/testthat/test-arg-ds.abs.R +++ b/tests/testthat/test-arg-ds.abs.R @@ -10,7 +10,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.abs::arg::test errors") test_that("abs_errors", { - expect_error(ds.abs(), "Please provide the name of the input object!", fixed=TRUE) + expect_error(ds.abs(), "must be the name of the input object", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.asCharacter.R b/tests/testthat/test-arg-ds.asCharacter.R index 8d7d3544..b3de6cbe 100644 --- a/tests/testthat/test-arg-ds.asCharacter.R +++ b/tests/testthat/test-arg-ds.asCharacter.R @@ -21,7 +21,7 @@ connect.discordant.dataset.simple(list("A", "B", "C")) # context("ds.asCharacter::arg::test errors") test_that("asCharacter_erros", { - expect_error(ds.asCharacter(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.asCharacter(), "must be the name of the input vector", fixed=TRUE) }) # context("ds.asCharacter::arg::discordant errors") diff --git a/tests/testthat/test-arg-ds.asDataMatrix.R b/tests/testthat/test-arg-ds.asDataMatrix.R index ca65f6cb..c102de73 100644 --- a/tests/testthat/test-arg-ds.asDataMatrix.R +++ b/tests/testthat/test-arg-ds.asDataMatrix.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.asDataMatrix::arg::test errors") test_that("asDataMatrix_erros", { - expect_error(ds.asDataMatrix(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.asDataMatrix(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.asFactor.R b/tests/testthat/test-arg-ds.asFactor.R index a264b040..5f433fdc 100644 --- a/tests/testthat/test-arg-ds.asFactor.R +++ b/tests/testthat/test-arg-ds.asFactor.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.asFactor::arg::test errors") test_that("asFactor_erros", { - expect_error(ds.asFactor(), "Please provide the name of the variable that is to be converted to a factor e.g. 'varname'", fixed=TRUE) + expect_error(ds.asFactor(), "must be the name of the variable to convert", fixed=TRUE) expect_error(ds.asFactor(input.var.name=1), "Please provide the name of the variable that is to be converted to a factor in character format e.g. 'varname'", fixed=TRUE) expect_error(ds.asFactor(input.var.name=NA), "Please provide the name of the variable that is to be converted to a factor in character format e.g. 'varname'", fixed=TRUE) }) diff --git a/tests/testthat/test-arg-ds.asInteger.R b/tests/testthat/test-arg-ds.asInteger.R index c6305012..fb11796a 100644 --- a/tests/testthat/test-arg-ds.asInteger.R +++ b/tests/testthat/test-arg-ds.asInteger.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.asInteger::arg::test errors") test_that("asInteger_erros", { - expect_error(ds.asInteger(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.asInteger(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.asList.R b/tests/testthat/test-arg-ds.asList.R index 92640188..4deb3e77 100644 --- a/tests/testthat/test-arg-ds.asList.R +++ b/tests/testthat/test-arg-ds.asList.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.asList::arg::test errors") test_that("asList_erros", { - expect_error(ds.asList(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.asList(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.asLogical.R b/tests/testthat/test-arg-ds.asLogical.R index 39056cc3..18f06c35 100644 --- a/tests/testthat/test-arg-ds.asLogical.R +++ b/tests/testthat/test-arg-ds.asLogical.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.asLogical::arg::test errors") test_that("asLogical_erros", { - expect_error(ds.asLogical(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.asLogical(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.asMatrix.R b/tests/testthat/test-arg-ds.asMatrix.R index 4a199dd0..af186d4f 100644 --- a/tests/testthat/test-arg-ds.asMatrix.R +++ b/tests/testthat/test-arg-ds.asMatrix.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.asMatrix::arg::test errors") test_that("asMatrix_erros", { - expect_error(ds.asMatrix(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.asMatrix(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.asNumeric.R b/tests/testthat/test-arg-ds.asNumeric.R index 27626075..d8fe241b 100644 --- a/tests/testthat/test-arg-ds.asNumeric.R +++ b/tests/testthat/test-arg-ds.asNumeric.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.asNumeric::arg::test errors") test_that("asNumeric_erros", { - expect_error(ds.asNumeric(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.asNumeric(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.assign.R b/tests/testthat/test-arg-ds.assign.R index 4fbd06c4..41bbbb30 100644 --- a/tests/testthat/test-arg-ds.assign.R +++ b/tests/testthat/test-arg-ds.assign.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.assign::arg::test errors") test_that("assign_erros", { - expect_error(ds.assign(), "Please give the name of object to assign or an expression to evaluate and assign.!\n") + expect_error(ds.assign(), "must be the name of the object to assign") }) # diff --git a/tests/testthat/test-arg-ds.auc.R b/tests/testthat/test-arg-ds.auc.R index 55978417..a37b7526 100644 --- a/tests/testthat/test-arg-ds.auc.R +++ b/tests/testthat/test-arg-ds.auc.R @@ -25,8 +25,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) test_that("ds.auc errors for null pred or y", { - expect_error(ds.auc(pred=NULL, y='y'), "Please provide the name of the vector with predicted values", fixed=TRUE) - expect_error(ds.auc(pred='pred', y=NULL), "Please provide the name of the outcome variable", fixed=TRUE) + expect_error(ds.auc(pred=NULL, y='y'), "must be the name of the vector of predicted values", fixed=TRUE) + expect_error(ds.auc(pred='pred', y=NULL), "must be the name of the outcome variable", fixed=TRUE) }) diff --git a/tests/testthat/test-arg-ds.c.R b/tests/testthat/test-arg-ds.c.R index 7a85cecb..50b674b6 100644 --- a/tests/testthat/test-arg-ds.c.R +++ b/tests/testthat/test-arg-ds.c.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.c::arg::test errors") test_that("simple c errors", { - expect_error(ds.c(), "x=NULL. Please provide the names of the objects to concatenate!") + expect_error(ds.c(), "must be the names of the objects to concatenate") }) # diff --git a/tests/testthat/test-arg-ds.cbind.R b/tests/testthat/test-arg-ds.cbind.R index a5198813..d32131c3 100644 --- a/tests/testthat/test-arg-ds.cbind.R +++ b/tests/testthat/test-arg-ds.cbind.R @@ -23,8 +23,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) test_that("cbind_erros", { ds.asList(x='D$LAB_TSC', newobj="as_list") - expect_error(ds.cbind(), "Please provide a vector of character strings holding the name of the input elements!", fixed=TRUE) - expect_error(ds.cbind(x="as_list", DataSHIELD.checks=TRUE), "Only objects of type 'data.frame', 'matrix', 'numeric', 'integer', 'character', 'factor' and 'logical' are allowed.", fixed=TRUE) + expect_error(ds.cbind(), "must be a vector of the names of the input elements", fixed=TRUE) + expect_error(ds.cbind(x="as_list", DataSHIELD.checks=TRUE), "Each object must be of class", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.changeRefGroup.R b/tests/testthat/test-arg-ds.changeRefGroup.R index e1a9977b..1f72dc8b 100644 --- a/tests/testthat/test-arg-ds.changeRefGroup.R +++ b/tests/testthat/test-arg-ds.changeRefGroup.R @@ -21,8 +21,8 @@ connect.studies.dataset.cnsim(list("DIS_AMI", "LAB_TSC")) # context("ds.changeRefGroup::arg::test errors") test_that("changeRefGroup_erros", { - expect_error(ds.changeRefGroup(), "Please provide the name of a vector of type factor!") - expect_error(ds.changeRefGroup(x="D$DIS_AMI"), " You must indicate a reference level - set the parameter 'ref'.") + expect_error(ds.changeRefGroup(), "must be the name of a factor") + expect_error(ds.changeRefGroup(x="D$DIS_AMI"), "must be a reference level") expect_error(ds.changeRefGroup(x="D$LAB_TSC", ref="LAB_TSC"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) diff --git a/tests/testthat/test-arg-ds.class.R b/tests/testthat/test-arg-ds.class.R index c0bf5c7d..dfe92485 100644 --- a/tests/testthat/test-arg-ds.class.R +++ b/tests/testthat/test-arg-ds.class.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.class::arg::test errors") test_that("class_erros", { - expect_error(ds.class(), "Please provide the name of the input object!", fixed=TRUE) + expect_error(ds.class(), "must be the name of the input object", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.completeCases.R b/tests/testthat/test-arg-ds.completeCases.R index 8bb99733..81661f3f 100644 --- a/tests/testthat/test-arg-ds.completeCases.R +++ b/tests/testthat/test-arg-ds.completeCases.R @@ -21,8 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.completeCases::arg::test errors") test_that("completeCases_errors", { - res <- ds.completeCases() - expect_equal(res, "Error: x1 must be a character string naming a serverside data.frame, matrix or vector", fixed = TRUE) + expect_error(ds.completeCases(), "must be a character string that names a server-side") }) # diff --git a/tests/testthat/test-arg-ds.cor.R b/tests/testthat/test-arg-ds.cor.R index 25acd2f3..5d6156a4 100644 --- a/tests/testthat/test-arg-ds.cor.R +++ b/tests/testthat/test-arg-ds.cor.R @@ -21,8 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) # context("ds.cor::arg::test errors") test_that("cor_erros", { - expect_error(ds.cor(), 'x=NULL. Please provide the name of a matrix or dataframe or the names of two numeric vectors!', fixed=TRUE) - expect_error(ds.cor(x='D$LAB_TSC', y='D$LAB_TRIG', type='datashield'), 'Function argument "type" has to be either "combine" or "split"', fixed=TRUE) + expect_error(ds.cor(), "must be the name of a matrix, data.frame or numeric vector", fixed=TRUE) + expect_error(ds.cor(x='D$LAB_TSC', y='D$LAB_TRIG', type='datashield'), "must be \"combine\" or \"split\"", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.corTest.R b/tests/testthat/test-arg-ds.corTest.R index 76adc6f1..ba1711b2 100644 --- a/tests/testthat/test-arg-ds.corTest.R +++ b/tests/testthat/test-arg-ds.corTest.R @@ -22,8 +22,8 @@ connect.studies.dataset.survival(list("survtime", "time.id")) # context("ds.corTest::arg") test_that("simple arg test", { - expect_error(ds.corTest(), "x=NULL. Please provide the names of the 1st numeric vector!", fixed=TRUE) - expect_error(ds.corTest(x="D$survtime"), "y=NULL. Please provide the names of the 2nd numeric vector!", fixed=TRUE) + expect_error(ds.corTest(), "must be the name of the first numeric vector", fixed=TRUE) + expect_error(ds.corTest(x="D$survtime"), "must be the name of the second numeric vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.cov.R b/tests/testthat/test-arg-ds.cov.R index d713fe36..341d7411 100644 --- a/tests/testthat/test-arg-ds.cov.R +++ b/tests/testthat/test-arg-ds.cov.R @@ -21,8 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) # context("ds.cov::arg::test errors") test_that("cov_erros", { - expect_error(ds.cov(), 'x=NULL. Please provide the name of a matrix or dataframe or the names of two numeric vectors!', fixed=TRUE) - expect_error(ds.cov(x='D$LAB_TSC', y='D$LAB_TRIG', type='datashield'), 'Function argument "type" has to be either "combine" or "split"', fixed=TRUE) + expect_error(ds.cov(), "must be the name of a matrix, data.frame or numeric vector", fixed=TRUE) + expect_error(ds.cov(x='D$LAB_TSC', y='D$LAB_TRIG', type='datashield'), "must be \"combine\" or \"split\"", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.dataFrame.R b/tests/testthat/test-arg-ds.dataFrame.R index 33fa65cf..1f966e4f 100644 --- a/tests/testthat/test-arg-ds.dataFrame.R +++ b/tests/testthat/test-arg-ds.dataFrame.R @@ -21,10 +21,10 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.dataFrame::arg::test errors") test_that("dataframe_erros", { - expect_error(ds.dataFrame(), "Please provide the name of the list that holds the input vectors!", fixed=TRUE) + expect_error(ds.dataFrame(), "must be the name of the list that holds the input vectors", fixed=TRUE) ds.asList(x='D$LAB_TSC', newobj="as_list") - expect_error(ds.dataFrame("as_list", DataSHIELD.checks=TRUE), "Only objects of type 'data.frame', 'matrix', 'numeric', 'integer', 'character', 'factor' and 'logical' are allowed.", fixed=TRUE) + expect_error(ds.dataFrame("as_list", DataSHIELD.checks=TRUE), "Each object must be of class", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.dataFrameSubset.R b/tests/testthat/test-arg-ds.dataFrameSubset.R index 0799acf9..9119fe81 100644 --- a/tests/testthat/test-arg-ds.dataFrameSubset.R +++ b/tests/testthat/test-arg-ds.dataFrameSubset.R @@ -28,7 +28,7 @@ test_that("setup", { # context("ds.dataFrameSubset::arg::missing 'ds.name' arg errors") test_that("dataFrameSubset_erros", { - expect_error(ds.dataFrameSubset(), "Please provide the name of the data.frame to be subsetted as a character string: eg 'xxx'", fixed=TRUE) + expect_error(ds.dataFrameSubset(), "must be the name of the data.frame to subset", fixed=TRUE) }) # context("ds.dataFrameSubset::arg::missing 'V1' arg error") diff --git a/tests/testthat/test-arg-ds.dim.R b/tests/testthat/test-arg-ds.dim.R index 2fa7d228..4ebcfc3b 100644 --- a/tests/testthat/test-arg-ds.dim.R +++ b/tests/testthat/test-arg-ds.dim.R @@ -21,8 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.dim::arg::test errors") test_that("dim_erros", { - expect_error(ds.dim(), "Please provide the name of a data.frame or matrix!", fixed=TRUE) - expect_error(ds.dim(x="D", type = "other"), 'Function argument "type" has to be either "both", "combine" or "split"', fixed=TRUE) + expect_error(ds.dim(), "must be the name of a data.frame or matrix", fixed=TRUE) + expect_error(ds.dim(x="D", type = "other"), "must be \"both\", \"combine\", or \"split\"", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.exists.R b/tests/testthat/test-arg-ds.exists.R index 8ae2070d..2ab9f06d 100644 --- a/tests/testthat/test-arg-ds.exists.R +++ b/tests/testthat/test-arg-ds.exists.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.exists::arg::test errors") test_that("simple exists errors", { - expect_error(ds.exists(), "Please provide the name of the input object!") + expect_error(ds.exists(), "must be the name of the input object") }) # diff --git a/tests/testthat/test-arg-ds.exp.R b/tests/testthat/test-arg-ds.exp.R index c851bba3..c947b1d7 100644 --- a/tests/testthat/test-arg-ds.exp.R +++ b/tests/testthat/test-arg-ds.exp.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.exp::arg::test errors") test_that("exp_erros", { - expect_error(ds.exp(), "Please provide the name of the input object!", fixed=TRUE) + expect_error(ds.exp(), "must be the name of the input object", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.gamlss.R b/tests/testthat/test-arg-ds.gamlss.R index c24f41ef..609c281c 100644 --- a/tests/testthat/test-arg-ds.gamlss.R +++ b/tests/testthat/test-arg-ds.gamlss.R @@ -21,8 +21,8 @@ connect.studies.dataset.gamlss(list("e3_bw", "e3_gac_None")) # context("ds.gamlss::arg::test errors") test_that("gamlss_errors", { - expect_error(ds.gamlss(), " Please provide a valid formula!", fixed=TRUE) - expect_error(ds.gamlss(formula="e3_bw ~ e3_gac_None", method="RG"), "Argument 'method' must be either 'RS', 'CG' or 'mixed'", fixed=TRUE) + expect_error(ds.gamlss(), "must be a valid formula", fixed=TRUE) + expect_error(ds.gamlss(formula="e3_bw ~ e3_gac_None", method="RG"), "must be \"RS\", \"CG\", or \"mixed\"", fixed=TRUE) expect_error(ds.gamlss(formula="e3_bw ~ e3_gac_None", method="RS", centiles=TRUE), "Provide the name of the explanatory variable in 'xvar' argument", fixed=TRUE) }) diff --git a/tests/testthat/test-arg-ds.glm.R b/tests/testthat/test-arg-ds.glm.R index fbf1a880..e4221bbc 100644 --- a/tests/testthat/test-arg-ds.glm.R +++ b/tests/testthat/test-arg-ds.glm.R @@ -21,8 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.glm::arg::test errors") test_that("glm_errors", { - expect_error(ds.glm(), " Please provide a valid regression formula!", fixed=TRUE) - expect_error(ds.glm("D$LAB_TSC~D$LAB_TSC"), " Please provide a valid 'family' argument!", fixed=TRUE) + expect_error(ds.glm(), "must be a valid regression formula", fixed=TRUE) + expect_error(ds.glm("D$LAB_TSC~D$LAB_TSC"), "must be a valid family", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.glmPredict.R b/tests/testthat/test-arg-ds.glmPredict.R index f0a2f285..dab0976f 100644 --- a/tests/testthat/test-arg-ds.glmPredict.R +++ b/tests/testthat/test-arg-ds.glmPredict.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG", "DIS_AMI", "DIS_DIAB", # context("ds.glmPredict::arg::test _glmname_ arg is correct object") test_that("glmPredict_errors", { - expect_error(ds.glmPredict(), " is not set, please specify it as a character string containing the name of a valid glm class object on the serverside", fixed=TRUE) + expect_error(ds.glmPredict(), "must be the name of a glm object on the server", fixed=TRUE) }) # context("ds.glmPredict::arg::setting up glm obj for further testing") @@ -47,7 +47,7 @@ test_that("glmPredict_errors", { # context("ds.glmPredict::arg::test _output.type_ arg is correct object") test_that("glmPredict_errors", { expect_error(ds.glmPredict("gaussian.glmslma.obj", newdataname = NULL, output.type = NULL), "missing value where TRUE/FALSE needed", fixed=TRUE) - expect_error(ds.glmPredict("gaussian.glmslma.obj", newdataname = NULL, output.type = 'blah'), " is not correctly set, please specify it as one of three character strings: 'link', 'response', or 'terms'", fixed=TRUE) + expect_error(ds.glmPredict("gaussian.glmslma.obj", newdataname = NULL, output.type = 'blah'), "must be \"link\", \"response\", or \"terms\"", fixed=TRUE) }) # context("ds.glmPredict::arg::test _se.fit_ arg is correct object") @@ -71,7 +71,7 @@ test_that("glmPredict_errors", { # context("ds.glmPredict::arg::test _na.action_ arg is correct object") test_that("glmPredict_errors", { - expect_error(ds.glmPredict("gaussian.glmslma.obj", newdataname = NULL, output.type = "response", se.fit = FALSE, dispersion = NULL, terms=NULL, na.action= "na.other"), " is not correctly set, please specify it as one of four character strings: 'na.fail', 'na.omit', 'na.exclude' or 'na.pass'", fixed = TRUE) + expect_error(ds.glmPredict("gaussian.glmslma.obj", newdataname = NULL, output.type = "response", se.fit = FALSE, dispersion = NULL, terms=NULL, na.action= "na.other"), "must be \"na.fail\"", fixed = TRUE) }) diff --git a/tests/testthat/test-arg-ds.glmSLMA.R b/tests/testthat/test-arg-ds.glmSLMA.R index 4180f91a..29d072cf 100644 --- a/tests/testthat/test-arg-ds.glmSLMA.R +++ b/tests/testthat/test-arg-ds.glmSLMA.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.glmSLMA::arg::test errors") test_that("glmSLMA_errors", { - expect_error(ds.glmSLMA(), " Please provide a valid regression formula!", fixed=TRUE) + expect_error(ds.glmSLMA(), "must be a valid regression formula", fixed=TRUE) expect_error(ds.glmSLMA('D$LAB_TSC~D$LAB_TRIG', family="gaussian", newobj="gaussian.glmslma.obj"), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) res.errors<-datashield.errors() diff --git a/tests/testthat/test-arg-ds.glmerSLMA.R b/tests/testthat/test-arg-ds.glmerSLMA.R index 36c80bb5..52421dcf 100644 --- a/tests/testthat/test-arg-ds.glmerSLMA.R +++ b/tests/testthat/test-arg-ds.glmerSLMA.R @@ -27,7 +27,7 @@ test_that("setup", { # context("ds.glmerSLMA::arg::testing") test_that("simple glmerSLMA tesing (mis)use of arguments", { - expect_error(ds.glmerSLMA(formula = 'incid_rate ~ trtGrp + Male + (1|idDoctor)', dataName = 'D'), " Please provide a valid 'family' argument!", fixed=TRUE) + expect_error(ds.glmerSLMA(formula = 'incid_rate ~ trtGrp + Male + (1|idDoctor)', dataName = 'D'), "must be a valid family", fixed=TRUE) expect_error(ds.glmerSLMA(formula = 'diab_dis ~ trtGrp + Male + (1|idDoctor)', family='poisson', dataName = 'D'), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) @@ -37,8 +37,7 @@ test_that("simple glmerSLMA tesing (mis)use of arguments", { expect_length(errs$sim2, 0) expect_length(errs$sim3, 0) - res <- ds.glmerSLMA(formula = 'incid_rate ~ trtGrp + Male + (1|idDoctor)', family='poisson', dataName = 'D', control_type = 'xtol_rel') - expect_equal(res$errorMessage, "ERROR: if control_type is non-null, you must specify a valid control_value eg control_value<-1.0e-7",fixed=TRUE) + expect_error(ds.glmerSLMA(formula = 'incid_rate ~ trtGrp + Male + (1|idDoctor)', family='poisson', dataName = 'D', control_type = 'xtol_rel'), "must be set when") expect_error(ds.glmerSLMA(formula = 'incid_rate ~ trtGrp + Male + (1|idDoctor)', family='poisson', dataName = 'D', control_type = 'check.conv.grad',control_value = 'nothing'), "There are some DataSHIELD errors, list them with datashield.errors()", fixed=TRUE) errs <- datashield.errors() @@ -47,7 +46,7 @@ test_that("simple glmerSLMA tesing (mis)use of arguments", { expect_length(errs$sim2, 0) expect_length(errs$sim3, 0) - expect_error(ds.glmerSLMA(), " Please provide a valid regression formula!", fixed=TRUE) + expect_error(ds.glmerSLMA(), "must be a valid regression formula", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.isNA.R b/tests/testthat/test-arg-ds.isNA.R index 433857a7..50a2bc9d 100644 --- a/tests/testthat/test-arg-ds.isNA.R +++ b/tests/testthat/test-arg-ds.isNA.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_HDL")) # context("ds.isNA::arg::errors") test_that("isNA errors", { - expect_error(ds.isNA(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.isNA(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.isValid.R b/tests/testthat/test-arg-ds.isValid.R index 4d97f1fa..65e81ee4 100644 --- a/tests/testthat/test-arg-ds.isValid.R +++ b/tests/testthat/test-arg-ds.isValid.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_HDL")) # context("ds.isValid::arg::errors") test_that("isValid errors", { - expect_error(ds.isValid(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.isValid(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.kurtosis.R b/tests/testthat/test-arg-ds.kurtosis.R index 0d8118e1..677fb2c5 100644 --- a/tests/testthat/test-arg-ds.kurtosis.R +++ b/tests/testthat/test-arg-ds.kurtosis.R @@ -27,10 +27,10 @@ test_that("setup", { # context("ds.kurtosis::arg::test errors") test_that("kurtosis_erros", { - expect_error(ds.kurtosis(), "Please provide the name of the input vector!", fixed=TRUE) - expect_error(ds.kurtosis(x='D$LAB_TSC', type='datashield'), "Function argument \"type\" has to be either \"both\", \"combine\" or \"split\"", fixed=TRUE) - expect_error(ds.kurtosis(x='D$LAB_TSC', method="0"), "method must be an integer between 1 and 3", fixed=TRUE) - expect_error(ds.kurtosis(x='D$LAB_TSC', method="4"), "method must be an integer between 1 and 3", fixed=TRUE) + expect_error(ds.kurtosis(), "must be the name of the input vector", fixed=TRUE) + expect_error(ds.kurtosis(x='D$LAB_TSC', type='datashield'), "must be \"both\", \"combine\", or \"split\"", fixed=TRUE) + expect_error(ds.kurtosis(x='D$LAB_TSC', method="0"), "must be an integer between 1 and 3", fixed=TRUE) + expect_error(ds.kurtosis(x='D$LAB_TSC', method="4"), "must be an integer between 1 and 3", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.length.R b/tests/testthat/test-arg-ds.length.R index 7e997842..36785af1 100644 --- a/tests/testthat/test-arg-ds.length.R +++ b/tests/testthat/test-arg-ds.length.R @@ -21,8 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.length::arg::test errors") test_that("length_erros", { - expect_error(ds.length(), "Please provide the name of the input object!", fixed=TRUE) - expect_error(ds.length(x='D$LAB_TSC', type='datashield'), 'Function argument "type" has to be either "both", "combine" or "split"', fixed=TRUE) + expect_error(ds.length(), "must be the name of the input object", fixed=TRUE) + expect_error(ds.length(x='D$LAB_TSC', type='datashield'), "must be \"both\", \"combine\", or \"split\"", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.levels.R b/tests/testthat/test-arg-ds.levels.R index ad2f5bde..f35810f0 100644 --- a/tests/testthat/test-arg-ds.levels.R +++ b/tests/testthat/test-arg-ds.levels.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.levels::arg") test_that("simple levels", { - expect_error(ds.levels(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.levels(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.lexis.R b/tests/testthat/test-arg-ds.lexis.R index 52d1657d..c0f5ca66 100644 --- a/tests/testthat/test-arg-ds.lexis.R +++ b/tests/testthat/test-arg-ds.lexis.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.lexis::arg::test errors") test_that("lexis_erros", { - expect_error(ds.lexis(), "Please provide the name of the column that holds the subject IDs!", fixed=TRUE) + expect_error(ds.lexis(), "must be the name of the column that holds subject IDs", fixed=TRUE) }) # context("ds.lexis::arg::test intervalWidth") diff --git a/tests/testthat/test-arg-ds.list.R b/tests/testthat/test-arg-ds.list.R index b2bc229d..8ef1525b 100644 --- a/tests/testthat/test-arg-ds.list.R +++ b/tests/testthat/test-arg-ds.list.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.list::arg::test errors") test_that("simple ds.list errors", { - expect_error(ds.list(), "x=NULL. Please provide the names of the objects to coerce into a list!") + expect_error(ds.list(), "must be the names of the objects to coerce into a list") }) # diff --git a/tests/testthat/test-arg-ds.lmerSLMA.R b/tests/testthat/test-arg-ds.lmerSLMA.R index d5f6510d..2b593753 100644 --- a/tests/testthat/test-arg-ds.lmerSLMA.R +++ b/tests/testthat/test-arg-ds.lmerSLMA.R @@ -38,13 +38,10 @@ test_that("simple lmerSLMA tesing (mis)use of arguments", { expect_length(errs$sim2, 0) expect_length(errs$sim3, 0) - res <- ds.lmerSLMA(formula = 'incid_rate ~ trtGrp + Male + (1|idDoctor)', dataName = 'D', control_type = 'xtol_rel') - expect_equal(res$errorMessage, "ERROR: if control_type is non-null, you must specify a valid control_value eg control_value<-1.0e-7", fixed=TRUE) -# res <- ds.lmerSLMA(formula = 'incid_rate ~ trtGrp + Male + (1|idDoctor)', dataName = 'D', control_type = 'xtol_rel',control_value = 'nothing') -# expect_equal(res$study1$errorMessage, "REAL() can only be applied to a 'numeric', not a 'logical'", fixed=TRUE) + expect_error(ds.lmerSLMA(formula = 'incid_rate ~ trtGrp + Male + (1|idDoctor)', dataName = 'D', control_type = 'xtol_rel'), "must be set when") - expect_error(ds.lmerSLMA(), " Please provide a valid regression formula!", fixed=TRUE) + expect_error(ds.lmerSLMA(), "must be a valid regression formula", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.log.R b/tests/testthat/test-arg-ds.log.R index b51cdf7d..167fc075 100644 --- a/tests/testthat/test-arg-ds.log.R +++ b/tests/testthat/test-arg-ds.log.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.log::arg::test errors") test_that("log_erros", { - expect_error(ds.log(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.log(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.ls.R b/tests/testthat/test-arg-ds.ls.R index bf24b112..f305751d 100644 --- a/tests/testthat/test-arg-ds.ls.R +++ b/tests/testthat/test-arg-ds.ls.R @@ -27,20 +27,11 @@ test_that("setup", { # context("ds.ls::arg") test_that("containing escape sequence", { - res1 <- ds.ls(search.filter="_:A:_Environment") + expect_error(ds.ls(search.filter="_:A:_Environment"), "also appears") - expect_length(res1, 1) - expect_equal(res1, "Warning: Code replacing wildcard (i.e. '*') is '_:A:_' but this appears in your original search filter string - please respecify") + expect_error(ds.ls(search.filter="Envir_:A:_oment"), "also appears") - res2 <- ds.ls(search.filter="Envir_:A:_oment") - - expect_length(res2, 1) - expect_equal(res2, "Warning: Code replacing wildcard (i.e. '*') is '_:A:_' but this appears in your original search filter string - please respecify") - - res3 <- ds.ls(search.filter="Environment_:A:_") - - expect_length(res3, 1) - expect_equal(res3, "Warning: Code replacing wildcard (i.e. '*') is '_:A:_' but this appears in your original search filter string - please respecify") + expect_error(ds.ls(search.filter="Environment_:A:_"), "also appears") }) # diff --git a/tests/testthat/test-arg-ds.make.R b/tests/testthat/test-arg-ds.make.R index 170b6f11..c23ee9f8 100644 --- a/tests/testthat/test-arg-ds.make.R +++ b/tests/testthat/test-arg-ds.make.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.make::arg::test errors") test_that("make_erros", { - expect_error(ds.make(), "Please give the name of object to assign or an expression to evaluate and assign.!\n", fixed=TRUE) + expect_error(ds.make(), "must be the name of the object to assign", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.matrix.R b/tests/testthat/test-arg-ds.matrix.R index c6cf9089..ece36354 100644 --- a/tests/testthat/test-arg-ds.matrix.R +++ b/tests/testthat/test-arg-ds.matrix.R @@ -21,9 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.matrix::arg::test errors") test_that("matrix_erros", { - res <- ds.matrix(mdata=NULL) + expect_error(ds.matrix(mdata=NULL), "must be a character string, numeric vector or scalar") - expect_equal(res, "Error: mdata must be a character string, a numeric vector or a scalar") }) # diff --git a/tests/testthat/test-arg-ds.matrixDet.R b/tests/testthat/test-arg-ds.matrixDet.R index c598d81b..265a8005 100644 --- a/tests/testthat/test-arg-ds.matrixDet.R +++ b/tests/testthat/test-arg-ds.matrixDet.R @@ -21,9 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.matrixDet::arg::test errors") test_that("matrixDet_erros", { - res <- ds.matrixDet() + expect_error(ds.matrixDet(), "must be the name of the matrix that represents M1") - expect_equal(res, "Error: Please provide the name of the matrix representing M1") }) # diff --git a/tests/testthat/test-arg-ds.matrixDet.report.R b/tests/testthat/test-arg-ds.matrixDet.report.R index d76b9239..10d028ce 100644 --- a/tests/testthat/test-arg-ds.matrixDet.report.R +++ b/tests/testthat/test-arg-ds.matrixDet.report.R @@ -22,9 +22,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.matrixDet.report::arg::test errors") test_that("ds.matixDet.report erros", { - res <- ds.matrixDet.report(M1=NULL) + expect_error(ds.matrixDet.report(M1=NULL), "must be the name of the matrix that represents M1") - expect_equal(res, "Error: Please provide the name of the matrix representing M1") }) # diff --git a/tests/testthat/test-arg-ds.matrixDiag.R b/tests/testthat/test-arg-ds.matrixDiag.R index 0dc152ff..9003e658 100644 --- a/tests/testthat/test-arg-ds.matrixDiag.R +++ b/tests/testthat/test-arg-ds.matrixDiag.R @@ -21,10 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.matrixDiag::arg::test errors") test_that("matrixDiag_erros", { - res <- ds.matrixDiag() + expect_error(ds.matrixDiag(), "must be a character string, numeric vector or scalar") - expect_length(res, 1) - expect_equal(res, "Error: x1 must have a value which is a character string, a numeric vector or a scalar", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.matrixDimnames.R b/tests/testthat/test-arg-ds.matrixDimnames.R index c6da0934..5f149cdb 100644 --- a/tests/testthat/test-arg-ds.matrixDimnames.R +++ b/tests/testthat/test-arg-ds.matrixDimnames.R @@ -21,9 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.matrixDimnames::arg::test errors") test_that("matrixDimnames_erros", { - res <- ds.matrixDimnames() + expect_error(ds.matrixDimnames(), "must be the name of the matrix that represents M1") - expect_equal(res, "Error: Please provide the name of the matrix representing M1") }) # diff --git a/tests/testthat/test-arg-ds.matrixInvert.R b/tests/testthat/test-arg-ds.matrixInvert.R index dfed18dd..afc50a1d 100644 --- a/tests/testthat/test-arg-ds.matrixInvert.R +++ b/tests/testthat/test-arg-ds.matrixInvert.R @@ -21,9 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.matrixInvert::arg::test errors") test_that("matrixInvert_erros", { - res <- ds.matrixInvert() + expect_error(ds.matrixInvert(), "must be the name of the matrix that represents M1") - expect_equal(res, "Error: Please provide the name of the matrix representing M1") }) # diff --git a/tests/testthat/test-arg-ds.matrixMult.R b/tests/testthat/test-arg-ds.matrixMult.R index 95564e0d..9e5274d3 100644 --- a/tests/testthat/test-arg-ds.matrixMult.R +++ b/tests/testthat/test-arg-ds.matrixMult.R @@ -21,9 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.matrixMult::arg::test errors") test_that("matrixMult_erros", { - res <- ds.matrixMult() + expect_error(ds.matrixMult(), "must be the name of the matrix that represents M1") - expect_equal(res, "Error: Please provide the name of the matrix representing M1") }) # diff --git a/tests/testthat/test-arg-ds.matrixTranspose.R b/tests/testthat/test-arg-ds.matrixTranspose.R index d78c6904..d9d2e785 100644 --- a/tests/testthat/test-arg-ds.matrixTranspose.R +++ b/tests/testthat/test-arg-ds.matrixTranspose.R @@ -21,9 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.matrixTranspose::arg::test errors") test_that("matrixTranspose_erros", { - res <- ds.matrixTranspose() + expect_error(ds.matrixTranspose(), "must be the name of the matrix that represents M1") - expect_equal(res, "Error: Please provide the name of the matrix representing M1") }) # diff --git a/tests/testthat/test-arg-ds.mean.R b/tests/testthat/test-arg-ds.mean.R index 36c365bc..f9996111 100644 --- a/tests/testthat/test-arg-ds.mean.R +++ b/tests/testthat/test-arg-ds.mean.R @@ -21,8 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.mean::arg::test errors") test_that("mean_erros", { - expect_error(ds.mean(), "Please provide the name of the input object!", fixed=TRUE) - expect_error(ds.mean(x='D$LAB_TSC', type='datashield'), 'Function argument "type" has to be either "both", "combine" or "split"', fixed=TRUE) + expect_error(ds.mean(), "must be the name of the input object", fixed=TRUE) + expect_error(ds.mean(x='D$LAB_TSC', type='datashield'), "must be \"both\", \"combine\", or \"split\"", fixed=TRUE) }) #context("ds.mean::arg::discordant errors") diff --git a/tests/testthat/test-arg-ds.meanSdGp.R b/tests/testthat/test-arg-ds.meanSdGp.R index bac7b2c4..23db6fde 100644 --- a/tests/testthat/test-arg-ds.meanSdGp.R +++ b/tests/testthat/test-arg-ds.meanSdGp.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.meanSdGp::arg::test errors") test_that("meanSdGp_erros", { - expect_error(ds.meanSdGp(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.meanSdGp(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.merge.R b/tests/testthat/test-arg-ds.merge.R index 03a6967a..19d3a54c 100644 --- a/tests/testthat/test-arg-ds.merge.R +++ b/tests/testthat/test-arg-ds.merge.R @@ -21,11 +21,11 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.merge::arg::test errors") test_that("merge_erros", { - expect_error(ds.merge(), "Please provide the name (eg 'name1') of first dataframe to be merged (called x) ", fixed=TRUE) - expect_error(ds.merge(x.name="A"), "Please provide the name (eg 'name2') of second dataframe to be merged (called y) ", fixed=TRUE) + expect_error(ds.merge(), "must be the name of the first data.frame to merge", fixed=TRUE) + expect_error(ds.merge(x.name="A"), "must be the name of the second data.frame to merge", fixed=TRUE) expect_error(ds.merge(x.name="D$LAB_TSC", y.name="B", by.x.names="LAB_TSC", by.y.names="LAB_TSC"), "DataSHIELD errors") - expect_error(ds.merge(x.name="D$LAB_TSC", y.name="D$LAB_TSC", by.x.names="C"), "Please provide the names of columns in y dataframe on which to merge (eg c('id', 'time'))", fixed=TRUE) - expect_error(ds.merge(x.name="D$LAB_TSC", y.name="D$LAB_TSC", by.x.names="D$LAB_TSC", by.y.names="D", suffixes=NULL), "Please provide the suffixes to append to disambiguate duplicate column names (default = c('.x','.y'))", fixed=TRUE) + expect_error(ds.merge(x.name="D$LAB_TSC", y.name="D$LAB_TSC", by.x.names="C"), "must be the names of the columns in y to merge on", fixed=TRUE) + expect_error(ds.merge(x.name="D$LAB_TSC", y.name="D$LAB_TSC", by.x.names="D$LAB_TSC", by.y.names="D", suffixes=NULL), "must be the suffixes that separate duplicate column names", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.mice.R b/tests/testthat/test-arg-ds.mice.R index a90c9c16..84bf9d7a 100644 --- a/tests/testthat/test-arg-ds.mice.R +++ b/tests/testthat/test-arg-ds.mice.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.mice::arg::test errors") test_that("mice_errors", { - expect_error(ds.mice(), "Please provide the name of the dataframe or matrix that contains the incomplete data!", fixed=TRUE) + expect_error(ds.mice(), "must be the name of the data.frame or matrix", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.names.R b/tests/testthat/test-arg-ds.names.R index 3faa397a..62d72c4c 100644 --- a/tests/testthat/test-arg-ds.names.R +++ b/tests/testthat/test-arg-ds.names.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.names::arg::test errors") test_that("simple ds.names errors", { - expect_error(ds.names(), "Please provide the name of the input list!", fixed=TRUE) + expect_error(ds.names(), "must be the name of the input list", fixed=TRUE) res.errors <- DSI::datashield.errors() diff --git a/tests/testthat/test-arg-ds.ns.R b/tests/testthat/test-arg-ds.ns.R index 56fb58f5..ff83bf88 100644 --- a/tests/testthat/test-arg-ds.ns.R +++ b/tests/testthat/test-arg-ds.ns.R @@ -28,7 +28,7 @@ test_that("setup", { # context("ds.ns::arg::test errors") test_that("ns_errors", { expect_error(ds.ns(), "argument \"x\" is missing, with no default", fixed=TRUE) - expect_error(ds.qlspline(x=NULL), "Please provide the name of the input variable x!", fixed=TRUE) + expect_error(ds.qlspline(x=NULL), "must be the name of the input variable", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.numNA.R b/tests/testthat/test-arg-ds.numNA.R index be436303..bdfd0294 100644 --- a/tests/testthat/test-arg-ds.numNA.R +++ b/tests/testthat/test-arg-ds.numNA.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.numNA::arg::test errors") test_that("simple ds.numNA errors", { - expect_error(ds.numNA(), "Please provide the name of a vector!") + expect_error(ds.numNA(), "must be the name of a vector") }) # diff --git a/tests/testthat/test-arg-ds.qlspline.R b/tests/testthat/test-arg-ds.qlspline.R index c7ff7650..3dacd636 100644 --- a/tests/testthat/test-arg-ds.qlspline.R +++ b/tests/testthat/test-arg-ds.qlspline.R @@ -28,9 +28,9 @@ test_that("setup", { # context("ds.qlspline::arg::test errors") test_that("qlspline_errors", { expect_error(ds.qlspline(), "argument \"x\" is missing, with no default", fixed=TRUE) - expect_error(ds.qlspline(x=NULL), "Please provide the name of the input variable x!", fixed=TRUE) + expect_error(ds.qlspline(x=NULL), "must be the name of the input variable", fixed=TRUE) expect_error(ds.qlspline(x='D$PM_BMI_CONTINUOUS'), "argument \"q\" is missing, with no default", fixed=TRUE) - expect_error(ds.qlspline(x='D$PM_BMI_CONTINUOUS', q=NULL), "Argument 'q' is missing, with no default!", fixed=TRUE) + expect_error(ds.qlspline(x='D$PM_BMI_CONTINUOUS', q=NULL), "must be a number of quantiles", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.quantileMean.R b/tests/testthat/test-arg-ds.quantileMean.R index ef778434..e762218a 100644 --- a/tests/testthat/test-arg-ds.quantileMean.R +++ b/tests/testthat/test-arg-ds.quantileMean.R @@ -21,8 +21,8 @@ connect.studies.dataset.cnsim(list('LAB_HDL')) # context("ds.quantileMean::arg::test errors") test_that("quantileMean_erros", { - expect_error(ds.quantileMean(), "Please provide the name of the input vector!", fixed=TRUE) - expect_error(ds.quantileMean(x='D$LAB_HDL', type='datashield'), 'Function argument "type" has to be either "combine" or "split"', fixed=TRUE) + expect_error(ds.quantileMean(), "must be the name of the input vector", fixed=TRUE) + expect_error(ds.quantileMean(x='D$LAB_HDL', type='datashield'), "must be \"combine\" or \"split\"", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.rBinom.R b/tests/testthat/test-arg-ds.rBinom.R index 8d4100bd..bb5119f0 100644 --- a/tests/testthat/test-arg-ds.rBinom.R +++ b/tests/testthat/test-arg-ds.rBinom.R @@ -21,10 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.rBinom::arg::test errors") test_that("rBinom_erros", { - error.message <- ds.rBinom(seed.as.integer='Value') - - expect_equal(class(error.message), 'character') - expect_equal(error.message, 'ERROR failed: seed.as.integer must be set as an integer [numeric] or left NULL') + expect_error(ds.rBinom(seed.as.integer='Value'), "must be an integer or") }) # diff --git a/tests/testthat/test-arg-ds.rNorm.R b/tests/testthat/test-arg-ds.rNorm.R index d4ec8075..215dfd3b 100644 --- a/tests/testthat/test-arg-ds.rNorm.R +++ b/tests/testthat/test-arg-ds.rNorm.R @@ -21,10 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.rNorm::arg::test errors") test_that("rNorm_erros", { - error.message <- ds.rNorm(seed.as.integer='Value') - - expect_equal(class(error.message), 'character') - expect_equal(error.message, 'ERROR failed: seed.as.integer must be set as an integer [numeric] or left NULL') + expect_error(ds.rNorm(seed.as.integer='Value'), "must be an integer or") }) # diff --git a/tests/testthat/test-arg-ds.rPois.R b/tests/testthat/test-arg-ds.rPois.R index 707ca381..18177209 100644 --- a/tests/testthat/test-arg-ds.rPois.R +++ b/tests/testthat/test-arg-ds.rPois.R @@ -21,10 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.rPois::arg::test errors") test_that("rPois_erros", { - error.message <- ds.rPois(seed.as.integer='Value') - - expect_equal(class(error.message), 'character') - expect_equal(error.message, 'ERROR failed: seed.as.integer must be set as an integer [numeric] or left NULL') + expect_error(ds.rPois(seed.as.integer='Value'), "must be an integer or") }) # diff --git a/tests/testthat/test-arg-ds.rUnif.R b/tests/testthat/test-arg-ds.rUnif.R index be046e8e..48f3024a 100644 --- a/tests/testthat/test-arg-ds.rUnif.R +++ b/tests/testthat/test-arg-ds.rUnif.R @@ -21,10 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.rUnif::arg::test errors") test_that("rUnif_erros", { - error.message <- ds.rUnif(seed.as.integer='Value') - - expect_equal(class(error.message), 'character') - expect_equal(error.message, 'ERROR failed: seed.as.integer must be set as an integer [numeric] or left NULL') + expect_error(ds.rUnif(seed.as.integer='Value'), "must be an integer or") }) # diff --git a/tests/testthat/test-arg-ds.rbind.R b/tests/testthat/test-arg-ds.rbind.R index 3a4ed9f2..c7da6de8 100644 --- a/tests/testthat/test-arg-ds.rbind.R +++ b/tests/testthat/test-arg-ds.rbind.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.rbind::arg::test errors") test_that("rbind_erros", { - expect_error(ds.rbind(), "Please provide a vector of character strings holding the name of the input elements!", fixed=TRUE) + expect_error(ds.rbind(), "must be a vector of the names of the input elements", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.reShape.R b/tests/testthat/test-arg-ds.reShape.R index ed8e8102..288f9862 100644 --- a/tests/testthat/test-arg-ds.reShape.R +++ b/tests/testthat/test-arg-ds.reShape.R @@ -21,10 +21,10 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.reShape::arg::test errors") test_that("reShape_erros", { - expect_error(ds.reShape(), "Please provide the name of the list that holds the input vectors!", fixed=TRUE) - expect_error(ds.reShape(data.name="test", sep=TRUE), "'sep' must be a character string", fixed=TRUE) - expect_error(ds.reShape(data.name="test", sep=""), "'sep' must be a character string", fixed=TRUE) - expect_error(ds.reShape(data.name="test", sep="ts"), "'sep' must be a character string", fixed=TRUE) + expect_error(ds.reShape(), "must be the name of the list that holds the input vectors", fixed=TRUE) + expect_error(ds.reShape(data.name="test", sep=TRUE), "must be a character string", fixed=TRUE) + expect_error(ds.reShape(data.name="test", sep=""), "must be a character string", fixed=TRUE) + expect_error(ds.reShape(data.name="test", sep="ts"), "must be a character string", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.recodeValues.R b/tests/testthat/test-arg-ds.recodeValues.R index 74a2da50..2bb7fd90 100644 --- a/tests/testthat/test-arg-ds.recodeValues.R +++ b/tests/testthat/test-arg-ds.recodeValues.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.recodeValues::arg::test errors") test_that("recodeValues_erros", { - expect_error(ds.recodeValues(), "Please provide the name of the variable to be recoded: eg 'xxx'", fixed=TRUE) + expect_error(ds.recodeValues(), "must be the name of the variable to recode", fixed=TRUE) expect_error(ds.recodeValues('D$LAB_TSC'), "Please provide a vector in the 'values2replace.vector' argument specifying\n the values to be replaced eg c(1,7)", fixed=TRUE) expect_error(ds.recodeValues('D$LAB_TSC', values2replace.vector=c(0,1)), "Please ensure that values2replace.vector and new.values.vector have same length and are in the same order", fixed=TRUE) expect_error(ds.recodeValues('D$LAB_TSC', values2replace.vector=c(0,1), new.values.vector=c(-10)), "Please ensure that values2replace.vector and new.values.vector have same length and are in the same order", fixed=TRUE) diff --git a/tests/testthat/test-arg-ds.rep.R b/tests/testthat/test-arg-ds.rep.R index f9c2ec6b..0791c2be 100644 --- a/tests/testthat/test-arg-ds.rep.R +++ b/tests/testthat/test-arg-ds.rep.R @@ -24,9 +24,8 @@ connect.studies.dataset.survival(list("survtime", "time.id", "female")) # context("ds.rep::arg::test errors") test_that("ds.rep erros", { - res <- ds.rep() + expect_error(ds.rep(), "must be a character string, a client-side numeric vector") - expect_equal(res, "Error: x1 must have a value which is a character string, a numeric vector on the clientside or a scalar", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.replaceNA.R b/tests/testthat/test-arg-ds.replaceNA.R index acd8c7b7..6cff90c4 100644 --- a/tests/testthat/test-arg-ds.replaceNA.R +++ b/tests/testthat/test-arg-ds.replaceNA.R @@ -21,8 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.replaceNA::arg::test errors") test_that("simple ds.replaceNA errors", { - expect_error(ds.replaceNA(), "Please provide the name of a vector!", fixed=TRUE) - expect_error(ds.replaceNA(x="D$LAB_TSC"), "Please provide a list of replacement values!", fixed=TRUE) + expect_error(ds.replaceNA(), "must be the name of a vector", fixed=TRUE) + expect_error(ds.replaceNA(x="D$LAB_TSC"), "must be a list of replacement values", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.rm.R b/tests/testthat/test-arg-ds.rm.R index bb674bca..22d50b8d 100644 --- a/tests/testthat/test-arg-ds.rm.R +++ b/tests/testthat/test-arg-ds.rm.R @@ -22,7 +22,7 @@ connect.studies.dataset.survival(list("survtime", "time.id", "female")) # context("ds.rm::arg::test errors") test_that("ds.rm erros", { - expect_error(ds.rm(), "Please provide the names of the objects to be deleted (eg 'object.name') as the x.names argument", fixed=TRUE) + expect_error(ds.rm(), "must be the names of the objects to delete", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.rowColCalc.R b/tests/testthat/test-arg-ds.rowColCalc.R index 76b8604b..a5a473f6 100644 --- a/tests/testthat/test-arg-ds.rowColCalc.R +++ b/tests/testthat/test-arg-ds.rowColCalc.R @@ -21,9 +21,9 @@ connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_HDL")) # context("ds.rowColCalc::arg::test errors") test_that("rowColCalc_errors", { - expect_error(ds.rowColCalc(), "Please provide the name of a data.frame or matrix!", fixed=TRUE) + expect_error(ds.rowColCalc(), "must be the name of a data.frame or matrix", fixed=TRUE) expect_error(ds.rowColCalc(x='D', newobj="rsum_hdl_tsc"), "'operation' = NULL. Please set it to 'rowSums', 'colSums', 'rowMeans' or 'colMeans'", fixed=TRUE) - expect_error(ds.rowColCalc(x='D', newobj="rsum_hdl_tsc", operation="datashield"), "'operation' must be set to: 'rowSums', 'colSums', 'rowMeans' or 'colMeans'", fixed=TRUE) + expect_error(ds.rowColCalc(x='D', newobj="rsum_hdl_tsc", operation="datashield"), "must be \"rowSums\", \"colSums\", \"rowMeans\", or \"colMeans\"", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.sample.R b/tests/testthat/test-arg-ds.sample.R index f84f4c3e..6b19a43b 100644 --- a/tests/testthat/test-arg-ds.sample.R +++ b/tests/testthat/test-arg-ds.sample.R @@ -23,12 +23,9 @@ connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG")) # context("ds.sample::arg::test errors") test_that("cov_erros", { - res1 <- ds.sample() - expect_equal(res1, 'Error: x must denote a character string naming the serverside object to be sampled or an integer N denoting permute 1:N', fixed=TRUE) - res2 <- ds.sample(x='D$LAB_TSC') - expect_equal(res2, 'Error: size must have a value which is an integer denoting how many records to be sampled', fixed=TRUE) - res3 <- ds.sample(x='D$LAB_TSC', size=1234, seed.as.integer="FooBar") - expect_equal(res3, 'ERROR failed: seed.as.integer must be set as an integer [numeric] or left NULL', fixed=TRUE) + expect_error(ds.sample(), "must be a character string that names a server-side object") + expect_error(ds.sample(x='D$LAB_TSC'), "must be an integer that sets how many records") + expect_error(ds.sample(x='D$LAB_TSC', size=1234, seed.as.integer="FooBar"), "must be an integer or") }) # diff --git a/tests/testthat/test-arg-ds.setSeed.R b/tests/testthat/test-arg-ds.setSeed.R index 1bf41b5c..4d501040 100644 --- a/tests/testthat/test-arg-ds.setSeed.R +++ b/tests/testthat/test-arg-ds.setSeed.R @@ -21,9 +21,8 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.setSeed::arg::test errors") test_that("setSeed_erros", { - res <- ds.setSeed(seed.as.integer="Test") + expect_error(ds.setSeed(seed.as.integer="Test"), "must be an integer or") - expect_equal(res, "ERROR terminated: seed.as.integer must be set as an integer [numeric] or as being NULL") }) # diff --git a/tests/testthat/test-arg-ds.skewness.R b/tests/testthat/test-arg-ds.skewness.R index 6a9440cc..070d551d 100644 --- a/tests/testthat/test-arg-ds.skewness.R +++ b/tests/testthat/test-arg-ds.skewness.R @@ -27,10 +27,10 @@ test_that("setup", { # context("ds.skewness::arg::test errors") test_that("skewness_erros", { - expect_error(ds.skewness(), "Please provide the name of the input vector!", fixed=TRUE) - expect_error(ds.skewness(x='D$LAB_TSC', type='datashield'), "Function argument \"type\" has to be either \"both\", \"combine\" or \"split\"", fixed=TRUE) - expect_error(ds.skewness(x='D$LAB_TSC', method="0"), "method must be an integer between 1 and 3", fixed=TRUE) - expect_error(ds.skewness(x='D$LAB_TSC', method="4"), "method must be an integer between 1 and 3", fixed=TRUE) + expect_error(ds.skewness(), "must be the name of the input vector", fixed=TRUE) + expect_error(ds.skewness(x='D$LAB_TSC', type='datashield'), "must be \"both\", \"combine\", or \"split\"", fixed=TRUE) + expect_error(ds.skewness(x='D$LAB_TSC', method="0"), "must be an integer between 1 and 3", fixed=TRUE) + expect_error(ds.skewness(x='D$LAB_TSC', method="4"), "must be an integer between 1 and 3", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.sqrt.R b/tests/testthat/test-arg-ds.sqrt.R index ce424864..5905864c 100644 --- a/tests/testthat/test-arg-ds.sqrt.R +++ b/tests/testthat/test-arg-ds.sqrt.R @@ -10,7 +10,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.sqrt::arg::test errors") test_that("sqrt_errors", { - expect_error(ds.sqrt(), "Please provide the name of the input object!", fixed=TRUE) + expect_error(ds.sqrt(), "must be the name of the input object", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.summary.R b/tests/testthat/test-arg-ds.summary.R index e3d38656..78158c33 100644 --- a/tests/testthat/test-arg-ds.summary.R +++ b/tests/testthat/test-arg-ds.summary.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.summary::arg::test errors") test_that("summary_erros", { - expect_error(ds.summary(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.summary(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.table.R b/tests/testthat/test-arg-ds.table.R index ae781fe2..eaf9b326 100644 --- a/tests/testthat/test-arg-ds.table.R +++ b/tests/testthat/test-arg-ds.table.R @@ -21,33 +21,30 @@ connect.studies.dataset.cnsim(list("DIS_CVA", "DIS_AMI", "LAB_TSC", "LAB_HDL")) # context("ds.table::arg::test rvar has value") test_that("table rvar has value", { - res <- ds.table() + expect_error(ds.table(), "must be a character string that names the row variable") - expect_equal(res, "Error: rvar must have a value which is a character string naming the row variable for the table", fixed=TRUE) }) # context("ds.table::arg::test cvar has value") test_that("table cvar has value", { - res <- ds.table(rvar="D$LAB_TSC", cvar=30) + expect_error(ds.table(rvar="D$LAB_TSC", cvar=30), "must be a character string that names the column variable") - expect_equal(res, "Error: if cvar is not null, it must have a value which is a character string naming the column variable for the table", fixed=TRUE) }) # context("ds.table::arg::test stvar has value") test_that("table stvar has value", { - res <- ds.table(rvar="D$LAB_TSC", cvar=NULL, stvar=25) + expect_error(ds.table(rvar="D$LAB_TSC", cvar=NULL, stvar=25), "must be a character string that names the variable") - expect_equal(res, "Error: if stvar is not null, it must have a value which is a character string naming the variable coding separate tables for the table", fixed=TRUE) }) # context("ds.table::arg::test stvar has CORRECT value") test_that("table useNA has value", { - expect_error(ds.table(rvar="D$LAB_TSC", cvar=NULL, stvar=NULL, useNA = c("BEN")), "useNA must be either 'no' or 'always'.", fixed = TRUE) + expect_error(ds.table(rvar="D$LAB_TSC", cvar=NULL, stvar=NULL, useNA = c("BEN")), "must be \"no\" or \"always\"", fixed = TRUE) }) # context("ds.table::arg::test force.nfilter has value") test_that("table force.nfilter has value", { - expect_error(ds.table(rvar="D$LAB_TSC", cvar=NULL, stvar=NULL, useNA = c("ifany"), force.nfilter =30), "useNA must be either 'no' or 'always'.", fixed = TRUE) + expect_error(ds.table(rvar="D$LAB_TSC", cvar=NULL, stvar=NULL, useNA = c("ifany"), force.nfilter =30), "must be \"no\" or \"always\"", fixed = TRUE) }) diff --git a/tests/testthat/test-arg-ds.tapply.R b/tests/testthat/test-arg-ds.tapply.R index 5ac42edf..2bbca9ad 100644 --- a/tests/testthat/test-arg-ds.tapply.R +++ b/tests/testthat/test-arg-ds.tapply.R @@ -21,22 +21,14 @@ connect.studies.dataset.cnsim(list("LAB_TSC", "GENDER")) # context("ds.tapply::arg::test errors") test_that("tapply_erros", { - res1 <- ds.tapply() + expect_error(ds.tapply(), "must be the name of the variable to summarise") - expect_length(res1, 1) - expect_equal(res1, "Error: Please provide the name of the variable to be summarized, as a character string") - res2 <- ds.tapply('D$LAB_TSC') + expect_error(ds.tapply('D$LAB_TSC'), "must name a single factor or a list of factors") - expect_length(res2, 3) - expect_equal(res2$Error.message, "Error: Please provide the name of the single factor or") - expect_equal(res2$Err.cont2, "the list of factors to index the variable to be summarized.") - expect_equal(res2$Err.cont3, "In either case the argument must be specified in inverted commas") - res3 <- ds.tapply('D$LAB_TSC', 'D$GENDER') + expect_error(ds.tapply('D$LAB_TSC', 'D$GENDER'), "must be a valid summarising function") - expect_length(res3, 1) - expect_equal(res3, "Error: Please provide a valid summarizing function, as a character string") }) # diff --git a/tests/testthat/test-arg-ds.tapply.assign.R b/tests/testthat/test-arg-ds.tapply.assign.R index 14ea8389..b14bad48 100644 --- a/tests/testthat/test-arg-ds.tapply.assign.R +++ b/tests/testthat/test-arg-ds.tapply.assign.R @@ -21,22 +21,14 @@ connect.studies.dataset.cnsim(list("LAB_TSC", "GENDER")) # context("ds.tapply.assign::arg::test errors") test_that("tapply_erros", { - res1 <- ds.tapply.assign() + expect_error(ds.tapply.assign(), "must be the name of the variable to summarise") - expect_length(res1, 1) - expect_equal(res1, "Error: Please provide the name of the variable to be summarized, as a character string") - res2 <- ds.tapply.assign('D$LAB_TSC') + expect_error(ds.tapply.assign('D$LAB_TSC'), "must name a single factor or a list of factors") - expect_length(res2, 3) - expect_equal(res2$Error.message, "Error: Please provide the name of the single factor or") - expect_equal(res2$Err.cont2, "the list of factors to index the variable to be summarized.") - expect_equal(res2$Err.cont3, "In either case the argument must be specified in inverted commas") - res3 <- ds.tapply.assign('D$LAB_TSC', 'D$GENDER') + expect_error(ds.tapply.assign('D$LAB_TSC', 'D$GENDER'), "must be a valid summarising function") - expect_length(res3, 1) - expect_equal(res3, "Error: Please provide a valid summarizing function, as a character string") }) # diff --git a/tests/testthat/test-arg-ds.unList.R b/tests/testthat/test-arg-ds.unList.R index 2d3aa487..9016b05c 100644 --- a/tests/testthat/test-arg-ds.unList.R +++ b/tests/testthat/test-arg-ds.unList.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.unList::arg::test errors") test_that("unList_erros", { - expect_error(ds.unList(), "Please provide the name of the input vector!", fixed=TRUE) + expect_error(ds.unList(), "must be the name of the input vector", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-ds.unique.R b/tests/testthat/test-arg-ds.unique.R index a0e112a5..ba207f71 100644 --- a/tests/testthat/test-arg-ds.unique.R +++ b/tests/testthat/test-arg-ds.unique.R @@ -21,12 +21,12 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.unique::arg::no arguments") test_that("simple ds.unique no arguments", { - expect_error(ds.unique(), "x.name=NULL. Please provide the names of the objects to de-duplicated!", fixed = TRUE) + expect_error(ds.unique(), "must be the names of the objects to de-duplicate", fixed = TRUE) }) # context("ds.unique::arg::NULL arguments") test_that("simple ds.unique NULL arguments", { - expect_error(ds.unique(NULL), "x.name=NULL. Please provide the names of the objects to de-duplicated!", fixed = TRUE) + expect_error(ds.unique(NULL), "must be the names of the objects to de-duplicate", fixed = TRUE) }) # diff --git a/tests/testthat/test-arg-ds.var.R b/tests/testthat/test-arg-ds.var.R index e745cbcf..27ab699a 100644 --- a/tests/testthat/test-arg-ds.var.R +++ b/tests/testthat/test-arg-ds.var.R @@ -21,7 +21,7 @@ connect.studies.dataset.cnsim(list("LAB_TSC")) # context("ds.var::arg::test errors") test_that("var_erros", { - expect_error(ds.var(), "Please provide the name of the input object!", fixed=TRUE) + expect_error(ds.var(), "must be the name of the input object", fixed=TRUE) }) # diff --git a/tests/testthat/test-arg-per-study-arguments.R b/tests/testthat/test-arg-per-study-arguments.R index c8ee48d3..afea544d 100644 --- a/tests/testthat/test-arg-per-study-arguments.R +++ b/tests/testthat/test-arg-per-study-arguments.R @@ -17,7 +17,7 @@ record_server_calls <- function(env = parent.frame()) { invisible(NULL) }, datashield.aggregate = function(conns, expr, ...) list(), - .set_datasources = function(datasources) datasources, + .resolveDatasources = function(datasources) datasources, .env = env ) sent @@ -27,18 +27,18 @@ record_server_calls <- function(env = parent.frame()) { # 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)) +# context("per-study arguments::arg::.expandToStudies") +test_that(".expandToStudies repeats a single value for every study", { + expect_equal(.expandToStudies(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(".expandToStudies keeps one value per study", { + expect_equal(.expandToStudies(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") +test_that(".expandToStudies rejects any other length", { + expect_error(.expandToStudies(c(1, 2), "x", 3), "must have length 1") + expect_error(.expandToStudies(c(1, 2, 3, 4), "x", 3), "must have length 1") }) # context("per-study arguments::arg::ds.rBinom") @@ -65,16 +65,15 @@ test_that("ds.rBinom sends a single size and prob to every study", { 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_error(ds.rBinom(samp.size = 10, size = c(1, 10), prob = 0.5, newobj = "x", seed.as.integer = 27, datasources = studies), "must have length 1") + expect_error(ds.rBinom(samp.size = 10, size = 5, prob = c(0.1, 0.5), newobj = "x", seed.as.integer = 27, datasources = studies), "must have length 1") 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_error(ds.rBinom(samp.size = 10, size = 5, prob = c(0.5, 1.5, 0.5), newobj = "x", seed.as.integer = 27, datasources = studies), "must be between 0 and 1") - expect_equal(res, "ERROR: prob must lie in range 0 < prob < 1") expect_length(sent$calls, 0) }) @@ -112,17 +111,16 @@ test_that("ds.rNorm sends a single mean, sd and decimal places to every study", 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_error(ds.rNorm(samp.size = 10, mean = c(0, 100), sd = 1, newobj = "x", seed.as.integer = 27, datasources = studies), "must have length 1") + expect_error(ds.rNorm(samp.size = 10, mean = 0, sd = c(1, 2), newobj = "x", seed.as.integer = 27, datasources = studies), "must have length 1") + 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), "must have length 1") 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_error(ds.rNorm(samp.size = 10, mean = 0, sd = c(1, -1, 1), newobj = "x", seed.as.integer = 27, datasources = studies), "must be greater than 0") - expect_equal(res, "ERROR: sd must be > 0") expect_length(sent$calls, 0) }) @@ -150,15 +148,14 @@ test_that("ds.rPois sends a single lambda to every study", { 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_error(ds.rPois(samp.size = 10, lambda = c(1, 50), newobj = "x", seed.as.integer = 27, datasources = studies), "must have length 1") 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_error(ds.rPois(samp.size = 10, lambda = c(1, 0, 1), newobj = "x", seed.as.integer = 27, datasources = studies), "must be greater than 0") - expect_equal(res, "ERROR: lambda must be > 0") expect_length(sent$calls, 0) }) @@ -186,17 +183,16 @@ test_that("ds.rUnif sends a single min, max and decimal places to every study", 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_error(ds.rUnif(samp.size = 10, min = c(0, 2), max = 10, newobj = "x", seed.as.integer = 27, datasources = studies), "must have length 1") + expect_error(ds.rUnif(samp.size = 10, min = 0, max = c(2, 5), newobj = "x", seed.as.integer = 27, datasources = studies), "must have length 1") + 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), "must have length 1") 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_error(ds.rUnif(samp.size = 10, min = c(0, 5, 0), max = c(1, 2, 1), newobj = "x", seed.as.integer = 27, datasources = studies), "must be greater than") - expect_equal(res, "ERROR: max must be greater than min") expect_length(sent$calls, 0) }) diff --git a/tests/testthat/test-disc-ds.table.R b/tests/testthat/test-disc-ds.table.R index b51a75f9..b60b6b93 100644 --- a/tests/testthat/test-disc-ds.table.R +++ b/tests/testthat/test-disc-ds.table.R @@ -98,15 +98,8 @@ test_that("setup", { # context("ds.table::disc::tests::phase 2::table.assign=FALSE") test_that("table disclosure, table.assign=FALSE", { - table.res <- ds.table(rvar='D$GENDER', cvar="D$DIS_AMI", table.assign=FALSE, newobj="new_table3") - - expect_length(table.res, 2) - expect_length(table.res$validity.message, 1) - expect_equal(table.res$validity.message, "All studies failed for reasons identified below", fixed = TRUE) - expect_length(table.res$error.message, 3) - expect_equal(table.res$error.message$sim1, "Failed: at least one cell has a non-zero count less than nfilter.tab i.e. 3", fixed = TRUE) - expect_equal(table.res$error.message$sim2, "Failed: at least one cell has a non-zero count less than nfilter.tab i.e. 3", fixed = TRUE) - expect_equal(table.res$error.message$sim3, "Failed: at least one cell has a non-zero count less than nfilter.tab i.e. 3", fixed = TRUE) + error <- expect_error(ds.table(rvar='D$GENDER', cvar="D$DIS_AMI", table.assign=FALSE, newobj="new_table3"), "All studies failed") + expect_match(conditionMessage(error), "non-zero count less than nfilter.tab") }) # context("ds.table::disc::tests::phase 2::table.assign=TRUE") diff --git a/tests/testthat/test-smk-ds.lmerSLMA.R b/tests/testthat/test-smk-ds.lmerSLMA.R index 620abc63..63943d39 100644 --- a/tests/testthat/test-smk-ds.lmerSLMA.R +++ b/tests/testthat/test-smk-ds.lmerSLMA.R @@ -51,8 +51,7 @@ test_that("alternative formulae for nested groups", { test_that("server side error", { res = ds.lmerSLMA(formula = 'BMI ~ trtGrp + Male + (1|idSurgery)', dataName = 'D', optimizer = 'nloptwrap') expect_equal(res$Convergence.error.message[2], "Study2: no convergence error reported") - res=ds.lmerSLMA(formula = 'BMI ~ trtGrp + Male + (1|idSurgery)', dataName = 'D', optimizer = 'not_this_one') - expect_equal(res$errorMessage, "ERROR: the only optimizer currently available for lmer is 'nloptwrap', please respecify") + expect_error(ds.lmerSLMA(formula = 'BMI ~ trtGrp + Male + (1|idSurgery)', dataName = 'D', optimizer = 'not_this_one'), "must be \"nloptwrap\"") res = ds.lmerSLMA(formula = 'BMI ~ trtGrp + Male + (1|idDoctor)', dataName = "D", REML = FALSE) expect_equal(res$output.summary$study1$methTitle, "Linear mixed model fit by maximum likelihood ") }) diff --git a/tests/testthat/test-smk-ds.mdPattern.R b/tests/testthat/test-smk-ds.mdPattern.R index 077012c3..57006845 100644 --- a/tests/testthat/test-smk-ds.mdPattern.R +++ b/tests/testthat/test-smk-ds.mdPattern.R @@ -90,7 +90,7 @@ test_that("class consistency check aborts when classes differ across studies", { ds.asDataMatrix(x.name = "D", newobj = "mixed.class", datasources = ds.test_env$connections[1]) ds.assign(toAssign = "D", newobj = "mixed.class", datasources = ds.test_env$connections[2:3]) - expect_error(ds.mdPattern(x = "mixed.class"), "not of the same class in all studies") + expect_error(ds.mdPattern(x = "mixed.class"), "must have the same class in all studies") expect_no_error(ds.mdPattern(x = "mixed.class", classConsistencyCheck = FALSE)) }) diff --git a/tests/testthat/test-smk-ds.rBinom.R b/tests/testthat/test-smk-ds.rBinom.R index 3fecc749..5f3f14ab 100644 --- a/tests/testthat/test-smk-ds.rBinom.R +++ b/tests/testthat/test-smk-ds.rBinom.R @@ -64,7 +64,7 @@ test_that("one value per study", { # 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") + expect_error(ds.rBinom(samp.size = 50, size = c(1, 10), prob = 0.5, newobj = "no.obj", seed.as.integer = 27), "must have length 1") }) # diff --git a/tests/testthat/test-smk-ds.rNorm.R b/tests/testthat/test-smk-ds.rNorm.R index 1a08b928..b12f9508 100644 --- a/tests/testthat/test-smk-ds.rNorm.R +++ b/tests/testthat/test-smk-ds.rNorm.R @@ -64,7 +64,7 @@ test_that("one value per study", { # 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") + expect_error(ds.rNorm(samp.size = 50, mean = c(0, 100), sd = 1, newobj = "no.obj", seed.as.integer = 27), "must have length 1") }) # diff --git a/tests/testthat/test-smk-ds.rPois.R b/tests/testthat/test-smk-ds.rPois.R index 31baf262..7ad6fad3 100644 --- a/tests/testthat/test-smk-ds.rPois.R +++ b/tests/testthat/test-smk-ds.rPois.R @@ -64,7 +64,7 @@ test_that("one value per study", { # 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") + expect_error(ds.rPois(samp.size = 50, lambda = c(1, 50), newobj = "no.obj", seed.as.integer = 27), "must have length 1") }) # diff --git a/tests/testthat/test-smk-ds.rUnif.R b/tests/testthat/test-smk-ds.rUnif.R index a296dfee..80ff2442 100644 --- a/tests/testthat/test-smk-ds.rUnif.R +++ b/tests/testthat/test-smk-ds.rUnif.R @@ -64,7 +64,7 @@ test_that("one value per study", { # 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") + expect_error(ds.rUnif(samp.size = 50, min = c(0, 10), max = 30, newobj = "no.obj", seed.as.integer = 27), "must have length 1") }) #