Add exception in unnecessary_nesting_linter() for paired stop()/warning() branches

[MichaelChirico]

Hopefully the to-be-squashed commit 35ab376d3ec1204c02dd6da220178bb02b3b336c survives as a reference for the implementation.

The description of the issue is as follows:

if (A) {
  stop("A is bad!")
} else {
  warning("!A is worrying, but not catastrophic!")
}

Is a common pattern that could in principle be unnested:

if (A) {
  stop("A is bad!")
}
warning("!A is worrying, but not catastrophic!")

But this format is a bit more awkward / doesn't leverage the clear if/else structure to make it clear what's happening.

We should do the following:

1. Decide when exactly this reasoning applies. The example above is very clear, but what about if there's intervening code before/after warning() in the latter branch?
2. Decide how to expose this to users. In principle there could be two parameters to this function [1] "exit" calls like stop()/q() that are guaranteed to terminate a branch [2] "signal" calls that can be "companion" calls to an "exit call", e.g. warning()

[MichaelChirico]

I think for (1) the only rule that makes sense is matching the last expression. I think there's too much subtlety to the parallelism in other cases. Would we count <expr> and require the same count? But what if one of those <expr> has a big nested if/else? What about comments? It just gets too messy.

For (2), I think what makes sense is exposing exit_calls in the same way we do return_functions= for return_linter() , i.e., as "additional" calls the user can customize, and parallel_exit_calls (name?) to list out calls valid in "parallel" structures.

[AshesITR]

Do you have a production example for the problem illustrated?

[MichaelChirico]

Sure, here's a few:

.UpdateProgressBar <- function(self, private, len = 1) {
  # ...
  if (private$current >= private$maxProgress) {
    private$complete <- TRUE
    .Call(R_FinishProgressBar, private$barPtr)
    cat("\n")
  } else {
    .Call(R_SetProgress, private$barPtr, private$current)
    return(invisible(self))
  }
}

flags.check <- function(warn.only = FALSE) {
  # ...

  if (!all(...)) {
    if (warn.only) {
      warning(message)
    } else {
      stop(message)
    }
  }

  unknown.flags <- ...
  if (length(unknown.flags) > 0) {
    message <- paste("Unknown flag(s) specified:", toString(unknown.flags))
    if (warn.only) {
      warning(message)
    } else {
      stop(message)
    }
  }
  return(invisible())
}

LoadNativeExtension <- function(chname, package, lib.loc, ...) {
  ...

  if (...) {
    if (RunningInteractively()) {
      warning(...)
    } else {
      stop(...)
    }
  }

  ...
}

StopOrWarn <- function(...) {
  if (force) {
    warning(..., call. = FALSE)
  } else {
    stop(
      ...,
      "\nTo proceed anyway, rerun with '--force'.",
      call. = FALSE
    )
  }
}

ggsave.<method> <-
  function(file,
           plot = ggplot2::last_plot(),
           ...
           overwrite = FALSE, ...) {

    existing_file <- ...
    if (overwrite) {
      if (nrow(existing_file) > 0) {
        if (nrow(existing_file) > 1) {
          cat(
            crayon::yellow(
              "Found more than one files with the same name.",
              "The latest one will be updated.", "\n"
            )
          )
          existing_file <- dplyr::slice(existing_file, 1)
        }
        up_file <- ggsave(...)
        return(invisible(up_file))
      } else {
        cat(
          crayon::yellow(
            "No existing file with the same name is found.",
            "A new file with the name will be created.", "\n"
          )
        )
      }
    }
    ...
  }

CheckModelUsesCorrectWeights <- function(model_function, units) {
  result0 <- try(model_function(units), silent = TRUE)
  if (inherits(result0, "try-error")) {
    if (attr(result0, "condition")$message == "FOO is called") {
      message(
        "CheckModelUsesCorrectWeights: FOO is called by ",
        "`model_function`"
      )
    } else {
      # Another error was encountered and we fail with it.
      stop(result0)
    }
  } else {
    stop(
      "`FOO` is not called by the custom `model_function`. ",
      "Please use `FOO` to calculate model weights."
    )
  }

  units_duplicated <- rbind(units, units)
  model1 <- model_function(units_duplicated)$model.stats
  units_replicates <- dplyr::mutate(units, .replicates = 2L)
  result2 <- model_function(units_replicates)$model.stats
  if (isTRUE(all.equal(result1, result2, tolerance = 1e-5))) {
    message(
      "CheckModelUsesCorrectWeights: `model_function` respects ",
      "`.replicates` column"
    )
  } else {
    stop(
      "`model_function` gives different `model.stats` results with ",
      "rows included twice or `.replicates` column equal to 2, but ",
      "the results should be equal"
    )
  }
  message(
    "CheckModelUsesCorrectWeights: `model_function` successfully passed ",
    "the checks."
  )
}

Plenty more...

---

And one from r-devel where I can share full context:

if(spar.is.lambda || sml) {
    ## used to give warning too and mean() as below, but that's rubbish
    stop(wtxt)
} else {
    fit$ty <- rep(mean(y), nx) ## would be df = 1
    df <- 1
    warning(wtxt,"\nsetting df = 1  __use with care!__")
}