How can I combine errors?-CodePudding

It's frustrating to have to fix issues one by one when the code had all the info to give exhaustive help from the first run.

and1 <- function(a , b) {
  stopifnot(is.logical(a), is.logical(b))
  a & b
}

and1(0, 1)     # nope
#> Error in and1(1, 2): is.logical(a) is not TRUE

# fix it
and1(FALSE, 1) # still not good
#> Error in and1(FALSE, 2): is.logical(b) is not TRUE

# fix again
and1(FALSE, TRUE) # finally works
#> [1] FALSE

We can design complex combination but this looks bad and with more checks it would become very complicated very fast.

and2 <- function(a , b) {
  if (!is.logical(a)) {
    if (!is.logical(b)) {
      stop("\n`a` must be logical\n`b` must be logical")
    }
    stop("`a` must be logical")
  }
  if (!is.logical(b)) {
    stop("`b` must be logical")
  }
  stopifnot(is.logical(a), is.logical(b))
  a & b
}

and2(1,2)
#> Error in and2(1, 2): 
#> `a` must be logical
#> `b` must be logical

What's a good way to do this without the messy code ?

CodePudding user response：

I'd probably make a named logical vector and then check that vector

and1 <- function(a,b){
  
  checks <- c(
    "`a` must be logical" = !is.logical(a),
    "`b` must be logical" = !is.logical(b)
  )
  
  if(any(checks)) {
    paste("\n",names(checks[which(checks)]), collapse = "") |> 
      stop()
  }

  a & b
}

and1(1,2)
#> Error in and1(1, 2) : 
#> `a` must be logical
#> `b` must be logical

(format the error message as desired)

CodePudding user response：

You can convert the logical tests to integer, generating unique values for each combination of the tests which can then be found in a lookup table. (Just multiply the nth logical test by 2^(n-1)). Effectively you are converting your logical tests to n bits and counting in binary.

This might sound complex, but it's straightforward in practice and turns a branching problem into a linear one:

and <- function(a, b) {
  
  if((valid <- is.logical(a)   2 * is.logical(b)) < 3) 
    stop(c('Neither A nor B are logical', 
           "A is logical but B isn't",
           "B is logical but A isn't")[valid   1])
  
  a & b
}

and(1, 0)
#> Error in and(1, 0) : Neither A nor B are logical
and(TRUE, 0)
#> Error in and(TRUE, 0) : A is logical but B isn't
and(0, TRUE)
#> Error in and(0, TRUE) : B is logical but A isn't
and(FALSE, TRUE)
#> [1] FALSE

Note that the error codes are fully informative, each is put out by the same call to stop, and there are no conditional branches beyond the single if statement at the top, which catches all the errors, allowing non-conditional code to be run at the end of your function.

Another option is to build the error message as you go along:

and <- function(a, b) {
  err <- ''
  if(!is.logical(a)) err <- paste0(err, "\n'a' is not logical")
  if(!is.logical(b)) err <- paste0(err, "\n'b' is not logical")
  
  if(nchar(err)) stop(err)
  
  a & b
}

and(1, 0)
#> Error in and(1, 0) : 
#> 'a' is not logical
#> 'b' is not logical
and(TRUE, 0)
#> Error in and(TRUE, 0) : 
#> 'b' is not logical
and(0, TRUE)
#> Error in and(0, TRUE) : 
#> 'a' is not logical
and(TRUE, TRUE)
#> [1] TRUE

CodePudding user response：

Here's a solution using {rlang}.

We feed unnamed expressions to the dots, they are tried separately and error messages are combined.

It wraps rlang::abort() and forwards its arguments to it (including named arguments passed to dots, such as class for instance).

I've added an optional header argument too.

combine_errors <- function(
    ..., # unnamed expressions and named args to forward to abort()
    class = NULL,
    call,
    header = NULL,
    body = NULL,
    footer = NULL,
    trace = NULL,
    parent = NULL,
    use_cli_format = NULL,
    .internal = FALSE,
    .file = NULL,
    .frame = parent.frame(),
    .trace_bottom = NULL) {
  env <- parent.frame()
  dots <- eval(substitute(alist(...)))
  unnamed_dots <- dots[rlang::names2(dots) == ""]
  named_dots <- dots[rlang::names2(dots) != ""]
  named_dots <- eval(named_dots, env)
  err <- header
  for (expr in unnamed_dots) {
    new_err <- try(eval(expr, env), silent = TRUE)
    if (inherits(new_err, "try-error")) {
      err <- c(err, "!" = attr(new_err, "condition")$message)
    }
  }
  if (!is.null(err)) {
    names(err)[1] <- ""
    do.call(rlang::abort, c(list(
      err, 
      class = class,
      call = if (missing(call)) env else call,
      body = body,
      footer = footer,
      trace = trace,
      parent = parent,
      use_cli_format = use_cli_format,
      .internal = .internal,
      .file = .file,
      .frame = .frame,
      .trace_bottom = .trace_bottom
    ),
    named_dots))
  }
}

and3 <- function(a , b) {
  # should work with rlang or base
  combine_errors(
    header = "Multiple issues found:",
    if (!is.logical(a)) rlang::abort(c("`a` must be logical", i = "some info")),
    if (!is.logical(b)) stop("`b` must be logical")
  )
  a & b
}

and3(1,TRUE)
#> Error in `and3()`:
#> ! Multiple issues found:
#> ! `a` must be logical
#> ℹ some info
and3(FALSE,2)
#> Error in `and3()`:
#> ! Multiple issues found:
#> ! `b` must be logical
and3(1,2) 
#> Error in `and3()`:
#> ! Multiple issues found:
#> ! `a` must be logical
#> ℹ some info
#> ! `b` must be logical

CodePudding user response：

You can use makeAssertCollection from checkmate:

and1 <- function(a , b) {
  logical_assertion <- checkmate::makeAssertCollection()
  checkmate::assert_logical(a, add = logical_assertion)
  checkmate::assert_logical(b, add = logical_assertion)
  checkmate::reportAssertions(logical_assertion)
  a & b
}

and1(0, 1)
#> Error in and1(0, 1) : 2 assertions failed:
#>  * Variable 'a': Must be of type 'logical', not 'double'.
#>  * Variable 'b': Must be of type 'logical', not 'double'.

and1(FALSE, 1)
#> Error in and1(FALSE, 1) : 1 assertions failed:
#>  * Variable 'b': Must be of type 'logical', not 'double'.

and1(FALSE, TRUE)
#> [1] FALSE

^{Created on 2022-10-04 by the reprex package (v1.0.0)}

CodePudding user response：

Can't we just make an {rlang} stop_if_not function?

stop_if_not <- function(...) {
  parent_env <- rlang::caller_env()
  dots <- rlang::enquos(...)
  
  idx <- !purrr::map_lgl(dots, rlang::eval_tidy)
  if (any(idx)) {
    error_msg <- purrr::map2(unname(dots[idx]),
                                 names(dots)[idx],
                                ~ c(x = paste0(
                                  deparse(rlang::get_expr(.x)),
                                  " is not TRUE"),
                                    if (nchar(.y) > 0) {
                                      c(i = .y)
                                      })
                             )

    rlang::abort(c(i = "Error in the following condition(s):",
                  unlist(error_msg)),
                  call = parent_env)
  }
}


and1 <- function(a , b) {
  stop_if_not(
    "`a` must be logical" = is.logical(a),
    is.logical(b)
    )
  a & b
}

and1(1, 2)
#> Error in `and1()`:
#> ! ℹ Error in the following condition(s):
#> ✖ is.logical(a) is not TRUE
#> ℹ `a` must be logical
#> ✖ is.logical(b) is not TRUE

and1(1, FALSE)
#> Error in `and1()`:
#> ! ℹ Error in the following condition(s):
#> ✖ is.logical(a) is not TRUE
#> ℹ `a` must be logical

and1(FALSE, TRUE)
#> [1] FALSE

^{Created on 2022-10-04 by the reprex package (v0.3.0)}