Refactor/cli messages

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,

R/checkClass.R

@@ -6,20 +6,19 @@
 #' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login. If the <datasources>
 #' the default set of connections will be used: see \link[DSI]{datashield.connections_default}.
 #' @param obj a string character, the name of the object to check for.
+#' @param call The frame to report the error from.
 #' @keywords internal
 #' @return a message or the class of the object if the object has the same class in all studies.
 #'
 #'
-checkClass <- function(datasources=NULL, obj=NULL){
+checkClass <- function(datasources=NULL, obj=NULL, call=parent.frame()){
   # check the class of the input object
   cally <- call("classDS", obj)
   classesBy <- DSI::datashield.aggregate(datasources, cally)
   classes <- unique(unlist(classesBy))
   for (n in names(classesBy)) {
     if (!all(classes == classesBy[[n]])) {
-      message("The input data is not of the same class in all studies!")
-      message("Use the function 'ds.class' to verify the class of the input object in each study.")
-      stop(" End of process!", call.=FALSE)
+      cli_abort(c("{.val {obj}} must have the same class in all studies.", .describeStudyClasses(classesBy)), call = call)
     }
   }
   return(classes)

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 <na.action> 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
 
@@ -159,13 +151,11 @@ ds.Boole<-function(V1=NULL, V2=NULL, Boolean.operator=NULL, numeric.output=TRUE,
   }
 
   if(BO.n == 0){
-    stop(paste0("An unrecognized Boolean operator, ", Boolean.operator, ", has provide"), call.=FALSE)
+    .abortInvalidChoice("Boolean.operator", c("==", "!=", "<", "<=", ">", ">="))
   }
 
   # 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)

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)

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)

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)

R/ds.asFactor.R

@@ -188,16 +188,15 @@
 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)){
-    stop("Please provide the name of the variable that is to be converted to a factor in character format e.g. 'varname'", call.=FALSE)
+    supplied <- .describeSupplied(input.var.name)
+    cli_abort("{.arg input.var.name} must be a character string, such as {.val varname}, not {supplied}.")
   }
 
   # if no output variable specified then provide a default name
@@ -217,7 +216,9 @@
       failed.levels <- TRUE
   }
   if (failed.levels) {
-    stop("Failed to obtain levels: ", paste0(unlist(all.levels), collapse=", "), call. = TRUE)
+    messages <- unlist(all.levels)
+    bullets <- stats::setNames(paste0("{messages[", seq_along(messages), "]}"), rep("x", length(messages)))
+    cli_abort(c("Can't obtain the factor levels.", bullets))
   }
 
   numstudies <- length(datasources)

R/ds.asFactorSimple.R

@@ -24,16 +24,15 @@
 #'
 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)){
-    stop("Please provide the name of the variable that is to be converted to a factor in character format e.g. 'varname'", call.=FALSE)
+    supplied <- .describeSupplied(input.var.name)
+    cli_abort("{.arg input.var.name} must be a character string, such as {.val varname}, not {supplied}.")
   }
 
   # if no output variable specified then provide a default name

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)

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))
 

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)

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)

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)

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))

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)

R/ds.boxPlot.R

@@ -87,20 +87,20 @@
 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)){
-    stop("The selected object is not a data frame nor a numerical vector")
+    cli_abort("{.arg x} must be a {.cls data.frame} or {.cls numeric} vector, not {.cls {cls}}.")
   }
 
   # Once all checks are passed, call the appropiate server functions

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)
 

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))
 

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))