从父函数抛出错误（同时忽略子函数）

Question

前提

我正在设计一个自定义 R 函数（称为 oedipus()）以终止其父级并出现错误。现在显然，对stop() within oedipus() 的简单调用将满足该要求：

oedipus <- function() {
  stop("Ow, my eyes!")
}

laius <- function() {
  oedipus()
}



laius()
#> Error in oedipus() : Ow, my eyes!
#> 
#>   3. stop("Ow, my eyes!")
#>   2. oedipus()
#>   1. laius()

扭曲

但是，我希望错误看起来好像它源自父级，而不是从调用堆栈中记录的子级“冒泡”。也就是说，我希望将错误归因于laius()，就像这样

laius()
#> Error in laius() : Ow, my eyes!

理想情况下，我希望从调用堆栈中完全省略 oedipus()：

laius()
#> Error in laius() : Ow, my eyes!
#> 
#>   2. stop("Ow, my eyes!")
#>   1. laius()

理论上是否可以设计出这样的...COMPLEX oedipus() 函数？

也许oedipus() 可以用evalq() 和on.exit() 修改laius()，这样laius() 会在调用堆栈“死”之前修改它？

奖金

是否可以设计oedipus() 使其可以从调用堆栈中的任意（nth）“祖先”抛出错误？

oedipus <- function(n) {
  # ...
  #  ?
  # ...
}

laius <- function(...) {
  oedipus(...)
}

labdacus <- function(...) {
  laius(...)
}

polydorus <- function(...) {
  labdacus(...)
}



polydorus(0)
#> Error in oedipus(...) : Ow, my eyes!

polydorus(1)
#> Error in laius(...) : Ow, my eyes!

polydorus(2)
#> Error in labdacus(...) : Ow, my eyes!

polydorus(3)
#> Error in polydorus(3) : Ow, my eyes!

Answer 1

这是一个自定义函数oedipus()，它利用rlang 来定位给定的nth 祖先。

解决方案

该方法的关键是在祖先的on.exit()“队列”前面使用do.call()“注入”一个stop()调用作为“错误抛出者”；然后使用rlang::return_from() 使祖先立即触发错误引发器。

注意：为了稳定起见，oedipus() 旨在保留其祖先的“退出队列”。

oedipus <- function(n) {
  # Target the ancestor from which the error should be thrown.
  from_env <- rlang::caller_env(n = n)
  # Construct the error thrower.
  from_err <- rlang::expr(stop("Ow, my eyes!"))
  
  # Inject the error thrower into the ancestor's exit queue.
  do.call(
    what = on.exit,
    args = list(
      expr = from_err,
      # Preserve the existing exit queue...
      add = TRUE,
      # ...while injecting the thrower at the front; so the error occurs
      # immediately and is followed by the rest of the queue, just as if
      # 'stop()' had been called in the middle of the ancestor's body.
      after = FALSE
    ),
    quote = FALSE,
    envir = from_env
  )
  
  # Immediately return from that function (with an inert value), and so
  # trigger the error thrower.
  rlang::return_from(
    frame = from_env,
    value = rlang::expr(invisible(NULL))
  )
}

结果

简单

按照您问题的Twist部分定义的祖先

laius <- function(...) {
  oedipus(...)
}

labdacus <- function(...) {
  laius(...)
}

polydorus <- function(...) {
  labdacus(...)
}

然后oedipus() 将产生您想要的结果：

polydorus(0)
#> Error in oedipus(...) : Ow, my eyes! 

polydorus(1)
#> Error in laius(...) : Ow, my eyes!

polydorus(2)
#> Error in labdacus(...) : Ow, my eyes! 

polydorus(3)
#> Error in polydorus(3) : Ow, my eyes!

详细

为了便于说明，让oedipus() 的祖先用“退出队列”重新定义如下：

laius <- function(...) {
  # Test that the exit queue behaves normally.
  on.exit(cat("'laius()' should display this message on exit.\n"))
  
  oedipus(...)
}

labdacus <- function(...) {
  # Test that the exit queue behaves normally.
  on.exit(cat("'labdacus()' should display this message on exit.\n"))
  
  laius(...)
}

polydorus <- function(...) {
  # Test that the exit queue behaves normally.
  on.exit(cat("'polydorus()' should display this message on exit.\n"))
  
  labdacus(...)
}

那么oedipus() 应该会产生以下结果，并显示回溯：

polydorus(0)
#> Error in oedipus(...) : Ow, my eyes!
#> 
#>   5. stop("Ow, my eyes!")
#>   4. oedipus(...)
#>   3. laius(...)
#>   2. labdacus(...)
#>   1. polydorus(0)
#> 
#> 'laius()' should display this message on exit.
#> 'labdacus()' should display this message on exit.
#> 'polydorus()' should display this message on exit.


polydorus(1)
#> Error in laius(...) : Ow, my eyes!
#> 
#>   4. stop("Ow, my eyes!")
#>   3. laius(...)
#>   2. labdacus(...)
#>   1. polydorus(1)
#> 
#> 'laius()' should display this message on exit.
#> 'labdacus()' should display this message on exit.
#> 'polydorus()' should display this message on exit.


polydorus(2)
#> Error in labdacus(...) : Ow, my eyes!
#>   
#>   3. stop("Ow, my eyes!")
#>   2. labdacus(...)
#>   1. polydorus(2)
#> 
#> 'labdacus()' should display this message on exit.
#> 'polydorus()' should display this message on exit.

 
polydorus(3)
#> Error in polydorus(3) : Ow, my eyes!
#> 
#> 'polydorus()' should display this message on exit.