R/ArgCheck.R

In guiboucher/INESSS-inesss: INESSS

### Fonctions nécessaire à la vérification d'arguments ou de fonctions. Permet d'afficher des messages,
### des avertissements ou des erreurs.


#' newArgCheck
#'
#' Cré l'environnement où les messages seront stockés.
#'
#' @keywords internal
#' @export
#' @examples
#' check <- newArgCheck()
newArgCheck <- function () {
  argcheck <- new.env()
  assign("n_warn", 0, envir = argcheck)
  assign("warn_msg", NULL, envir = argcheck)
  assign("n_error", 0, envir = argcheck)
  assign("error_msg", NULL, envir = argcheck)
  assign("n_message", 0, envir = argcheck)
  assign("message_msg", NULL, envir = argcheck)
  class(argcheck) <- c("ArgCheck", "environment")
  return(argcheck)
}

#' finishArgCheck
#'
#' Vérification finale qui renvoie les messages, les avertissements ou les erreurs. S'il y a des erreurs, la fonction est arrêtée.
#'
#' @param argcheck Variable créé à partir de \code{newArgCheck}.
#'
#' @keywords internal
#' @export
#' @examples
#' f1 <- function(){
#'   check <- newArgCheck()
#'   addMessage("Ceci est un message", check)
#'   addWarning("Ceci est un avertissement", check)
#'   addError("Ceci est une erreur", check)
#'   finishArgCheck(check)
#' }
#' f1()
finishArgCheck <- function (argcheck) {
  fn_call <- sys.call(-1)
  fn_call <- utils::capture.output(fn_call)
  if (!"ArgCheck" %in% class(argcheck))
    stop("'argcheck' must be an object of class 'ArgCheck'")
  argcheck <- mget(ls(envir = argcheck), envir = argcheck)
  if (argcheck$n_warn > 0)
    warning(paste0(c("", fn_call, paste0(1:argcheck$n_warn,
                                         ": ", argcheck$warn_msg)), collapse = "\n"), call. = FALSE)
  if (argcheck$n_message > 0)
    message(paste0(c("", fn_call, paste0(1:argcheck$n_message,
                                         ": ", argcheck$message_msg)), collapse = "\n"))
  if (argcheck$n_error > 0)
    stop(paste0(c("", fn_call, paste0(1:argcheck$n_error,
                                      ": ", argcheck$error_msg)), collapse = "\n"), call. = FALSE)
}

#' addError
#'
#' Ajout d'une erreur. La fonction sera arrêtée lors de la vérification.
#'
#' @param msg Message à afficher.
#' @param argcheck Variable stockant les erreurs.
#'
#' @keywords internal
#' @export
#' @examples
#' f1 <- function(){
#'   check <- newArgCheck()
#'   addMessage("Ceci est un message", check)
#'   addWarning("Ceci est un avertissement", check)
#'   addError("Ceci est une erreur", check)
#'   finishArgCheck(check)
#' }
#' f1()
addError <- function (msg, argcheck) {
  if (!"ArgCheck" %in% class(argcheck))
    stop("'argcheck' must be an object of class 'ArgCheck'")
  assign("n_error", get("n_error", envir = argcheck) + 1, envir = argcheck)
  assign("error_msg", c(get("error_msg", envir = argcheck),
                        msg), envir = argcheck)
}

#' addMessage
#'
#' Ajout d'un message.
#'
#' @param msg Message à afficher.
#' @param argcheck Variable stockant les messages.
#'
#' @keywords internal
#' @export
#' @examples
#' f1 <- function(){
#'   check <- newArgCheck()
#'   addMessage("Ceci est un message", check)
#'   addWarning("Ceci est un avertissement", check)
#'   addError("Ceci est une erreur", check)
#'   finishArgCheck(check)
#' }
#' f1()
addMessage <- function (msg, argcheck) {
  if (!"ArgCheck" %in% class(argcheck))
    stop("'argcheck' must be an object of class 'ArgCheck'")
  assign("n_message", get("n_message", envir = argcheck) +
           1, envir = argcheck)
  assign("message_msg", c(get("message_msg", envir = argcheck),
                          msg), envir = argcheck)
}

#' addWarning
#'
#' Ajout d'unavertissement.
#'
#' @param msg Message à afficher.
#' @param argcheck Variable stockant les avertissements.
#'
#' @keywords internal
#' @export
#' @examples
#' f1 <- function(){
#'   check <- newArgCheck()
#'   addMessage("Ceci est un message", check)
#'   addWarning("Ceci est un avertissement", check)
#'   addError("Ceci est une erreur", check)
#'   finishArgCheck(check)
#' }
#' f1()
addWarning <- function (msg, argcheck) {
  if (!"ArgCheck" %in% class(argcheck))
    stop("'argcheck' must be an object of class 'ArgCheck'")
  assign("n_warn", get("n_warn", envir = argcheck) + 1, envir = argcheck)
  assign("warn_msg", c(get("warn_msg", envir = argcheck), msg),
         envir = argcheck)
}