R中的条件（condition）系统提供了一组成对的工具，提示函数正在发生异常情况，并允许该函数的用户处理它

19.1 signals conditions

Show the code
stop("This is what an error looks like")
#> Error: This is what an error looks like


warning("This is what a warning looks like")


message("This is what a message looks like")

print("Running...")
#> [1] "Running..."
cat("Running...\n")
#> Running...

19.1.1 error

停止执行并返回到顶部

Show the code
h <- function() stop("This is an error!")
h()
#> Error in h(): This is an error!

# 不包含调用信息
h <- function() stop("This is an error!", call. = FALSE)
h()
#> Error: This is an error!

h <- function() rlang::abort("This is an error!")
h()
#> Error in `h()`:
#> ! This is an error!

19.1.2 warning

捕获警告并聚合显示

  • 要使警告立即显示，请设置 options(warn = 1)

  • 要将警告转换为错误，请设置 options(warn = 2)。这通常是 调试警告的最简单方法，因为一旦出现错误，就可以 使用工具，例如查找源头traceback()

  • 使用 options(warn = 0)恢复默认行为。

Show the code
fw <- function() {
  cat("1\n")
  warning("W1")
  cat("2\n")
  warning("W2")
  cat("3\n")
  warning("W3",call. = FALSE)
}
fw()
#> 1
#> 2
#> 3

fw <- function() {
  cat("1\n")
  rlang::warn("W1")
  cat("2\n")
  rlang::warn("W2")
  cat("3\n")
  rlang::warn("W3")
}
fw()
#> 1
#> 2
#> 3

19.1.3 message

消息立即显示

参数quiet = TRUE 抑制所有消息suppressMessages()

Show the code
# 无 call. 参数
fm <- function() {
  cat("1\n")
  message("M1")
  cat("2\n")
  message("M2")
  cat("3\n")
  message("M3")
}

fm()
#> 1
#> 2
#> 3

19.2 忽略信息

19.3 条件处理程序

19.3.1 条件对象

Show the code
cnd <- rlang::catch_cnd(stop("An error"))
str(cnd)
#> List of 2
#>  $ message: chr "An error"
#>  $ call   : language force(expr)
#>  - attr(*, "class")= chr [1:3] "simpleError" "error" "condition"

conditionMessage(cnd)
#> [1] "An error"
conditionCall(cnd)
#> force(expr)

19.3.2 退出处理程序

处理条件信息

tryCatch()定义exitinghandlers，，通常用于处理错误情况。它允许您覆盖默认的错误行为。

Show the code
tryCatch(
  error = function(cnd) {
    # code to run when error is thrown
  },
  code_to_run_while_handlers_are_active
)
Show the code
f3 <- function(x) {
  tryCatch(
    error = function(cnd) NA,
    log(x)
  )
}

f3("x")
#> [1] NA

在发出条件信号后，控制权将传递给处理程序，并且永远不会返回到原始代码，这实际上意味着代码退出

Show the code
tryCatch(
  message = function(cnd) "There",
  {
    message("Here")
    stop("This code is never run!")
  }
)
#> [1] "There"

类似Python的

try: 
    {}
finally:
    {}
Show the code
tryCatch(
  {
    write.table("Hi!", "data/异常处理.csv")
  },
  finally = {
    # always run
    x <- read.table("data/异常处理.csv")
    print("你好")
  }
)
#> [1] "你好"

19.3.3 调用处理程序

withCallingHandlers()定义callinghandlers，适合处理非错误条件，一旦处理程序返回，代码执行将正常继续

Show the code
withCallingHandlers(
  warning = function(cnd) {
    # code to run when warning is signalled
  },
  message = function(cnd) {
    # code to run when message is signalled
  },
  code_to_run_while_handlers_are_active
)
Show the code
tryCatch(
  message = function(cnd) cat("Caught a message!\n"), 
  {
    message("Someone there?")
    message("Why, yes!")
  }
)
#> Caught a message!


withCallingHandlers(
  message = function(cnd) cat("Caught a message!\n"), 
  {
    message("Someone there?")
    message("Why, yes!")
  }
)
#> Caught a message!
#> Caught a message!

19.4 自定义条件

Show the code
library(rlang)

my_log <- function(x, base = exp(1)) {
  if (!is.numeric(x)) {
    abort(paste0(
      "`x` must be a numeric vector; not ", typeof(x), "."
    ))
  }
  if (!is.numeric(base)) {
    abort(paste0(
      "`base` must be a numeric vector; not ", typeof(base), "."
    ))
  }

  base::log(x, base = base)
}
Show the code
my_log(letters)
#> Error in `my_log()`:
#> ! `x` must be a numeric vector; not character.
my_log(1:10, base = letters)
#> Error in `my_log()`:
#> ! `base` must be a numeric vector; not character.
Show the code
abort_bad_argument <- function(arg, must, not = NULL) {
  msg <- glue::glue("`{arg}` must {must}")
  if (!is.null(not)) {
    not <- typeof(not)
    msg <- glue::glue("{msg}; not {not}.")
  }
  
  abort("error_bad_argument", 
    message = msg, 
    arg = arg, 
    must = must, 
    not = not
  )
}

stop_custom <- function(.subclass, message, call = NULL, ...) {
  err <- structure(
    list(
      message = message,
      call = call,
      ...
    ),
    class = c(.subclass, "error", "condition")
  )
  stop(err)
}

err <- catch_cnd(
  stop_custom("error_new", "This is a custom error", x = 10)
)
class(err)
#> [1] "error_new" "error"     "condition"
err$x
#> [1] 10

重写my_log

Show the code
my_log <- function(x, base = exp(1)) {
  if (!is.numeric(x)) {
    abort_bad_argument("x", must = "be numeric", not = x)
  }
  if (!is.numeric(base)) {
    abort_bad_argument("base", must = "be numeric", not = base)
  }

  base::log(x, base = base)
}
Show the code
my_log(letters)
#> Error in `abort_bad_argument()`:
#> ! `x` must be numeric; not character.
my_log(letters)
#> Error in `abort_bad_argument()`:
#> ! `x` must be numeric; not character.

19.5 Debugging

traceback(): 函数调用栈

Show the code
lm(y ~ x)
#> Error in eval(predvars, data, env): object 'y' not found
traceback() 
#> No traceback available

表示第7次调用函数出现错误。

debug() : 标记函数，调用函数时出现错误自动进入browser，输入 n 一行一行运行直到出现错误

Show the code
debug(lm)
lm(y ~ x)
#> debugging in: lm(y ~ x)
#> debug: {
#>     ret.x <- x
#>     ret.y <- y
#>     cl <- match.call()
#>     mf <- match.call(expand.dots = FALSE)
#>     m <- match(c("formula", "data", "subset", "weights", "na.action", 
#>         "offset"), names(mf), 0L)
#>     mf <- mf[c(1L, m)]
#>     mf$drop.unused.levels <- TRUE
#>     mf[[1L]] <- quote(stats::model.frame)
#>     mf <- eval(mf, parent.frame())
#>     if (method == "model.frame") 
#>         return(mf)
#>     else if (method != "qr") 
#>         warning(gettextf("method = '%s' is not supported. Using 'qr'", 
#>             method), domain = NA)
#>     mt <- attr(mf, "terms")
#>     y <- model.response(mf, "numeric")
#>     w <- as.vector(model.weights(mf))
#>     if (!is.null(w) && !is.numeric(w)) 
#>         stop("'weights' must be a numeric vector")
#>     offset <- model.offset(mf)
#>     mlm <- is.matrix(y)
#>     ny <- if (mlm) 
#>         nrow(y)
#>     else length(y)
#>     if (!is.null(offset)) {
#>         if (!mlm) 
#>             offset <- as.vector(offset)
#>         if (NROW(offset) != ny) 
#>             stop(gettextf("number of offsets is %d, should equal %d (number of observations)", 
#>                 NROW(offset), ny), domain = NA)
#>     }
#>     if (is.empty.model(mt)) {
#>         x <- NULL
#>         z <- list(coefficients = if (mlm) matrix(NA_real_, 0, 
#>             ncol(y)) else numeric(), residuals = y, fitted.values = 0 * 
#>             y, weights = w, rank = 0L, df.residual = if (!is.null(w)) sum(w != 
#>             0) else ny)
#>         if (!is.null(offset)) {
#>             z$fitted.values <- offset
#>             z$residuals <- y - offset
#>         }
#>     }
#>     else {
#>         x <- model.matrix(mt, mf, contrasts)
#>         z <- if (is.null(w)) 
#>             lm.fit(x, y, offset = offset, singular.ok = singular.ok, 
#>                 ...)
#>         else lm.wfit(x, y, w, offset = offset, singular.ok = singular.ok, 
#>             ...)
#>     }
#>     class(z) <- c(if (mlm) "mlm", "lm")
#>     z$na.action <- attr(mf, "na.action")
#>     z$offset <- offset
#>     z$contrasts <- attr(x, "contrasts")
#>     z$xlevels <- .getXlevels(mt, mf)
#>     z$call <- cl
#>     z$terms <- mt
#>     if (model) 
#>         z$model <- mf
#>     if (ret.x) 
#>         z$x <- x
#>     if (ret.y) 
#>         z$y <- y
#>     if (!qr) 
#>         z$qr <- NULL
#>     z
#> }
#> debug: ret.x <- x
#> debug: ret.y <- y
#> debug: cl <- match.call()
#> debug: mf <- match.call(expand.dots = FALSE)
#> debug: m <- match(c("formula", "data", "subset", "weights", "na.action", 
#>     "offset"), names(mf), 0L)
#> debug: mf <- mf[c(1L, m)]
#> debug: mf$drop.unused.levels <- TRUE
#> debug: mf[[1L]] <- quote(stats::model.frame)
#> debug: mf <- eval(mf, parent.frame())
#> Error in eval(predvars, data, env): object 'y' not found


# Browse[1]> n
# debug: ret.x <- x
# Browse[1]> n
# debug: ret.y <- y
# Browse[1]> n
# debug: cl <- match.call()
# Browse[1]> n
# debug: mf <- match.call(expand.dots = FALSE)
# Browse[1]> n
# debug: m <- match(c("formula", "data", "subset", "weights", "na.action", 
#     "offset"), names(mf), 0L)
# Browse[1]> n
# debug: mf <- mf[c(1L, m)]
# Browse[1]> n
# debug: mf$drop.unused.levels <- TRUE
# Browse[1]> n
# debug: mf[[1L]] <- quote(stats::model.frame)
# Browse[1]> n
# debug: mf <- eval(mf, parent.frame())
# Browse[1]> n
# Error in eval(predvars, data, env) : object 'y' not found


undebug(lm)