自定义管道以消除警告消息

Question

与这个问题相关。

我想要构建一个自定义的管道%W>%，可以使得一次操作中的警告被忽略。

library(magrittr)
data.frame(a= c(1,-1)) %W>% mutate(a=sqrt(a)) %>% cos

将等同于：

w <- options()$warn
data.frame(a= c(1,-1)) %T>% {options(warn=-1)} %>%
  mutate(a=sqrt(a))    %T>% {options(warn=w)}  %>%
  cos

这两个 Trie 不起作用:

`%W>%` <- function(lhs,rhs){
  w <- options()$warn
  on.exit(options(warn=w))
  options(warn=-1)
  lhs %>% rhs
}

`%W>%` <- function(lhs,rhs){
  lhs <- quo(lhs)
  rhs <- quo(rhs)
  w <- options()$warn
  on.exit(options(warn=w))
  options(warn=-1)
  (!!lhs) %>% (!!rhs)
}

我如何将这个代码用 rlang 转化为可运行的形式？

- moodymudskipper

---

大多数人点赞是因为使用了“rlang”作为动词。 - crazybilly

你可能想要查看rmonad::包的intro vignette（以及其他内容）。这是一种很好的处理错误的方式，对于警告也可能同样有效。可能有些过度，但值得考虑。 - lefft

确实非常有趣。它甚至可能包含我这个老问题的答案：https://stackoverflow.com/questions/44831342/use-multiple-command-chains-with-piping - moodymudskipper

Answer 1

我认为我会这样做，通过调整magrittr pipes来包含这个新选项。这种方式应该相当强大。

首先，我们需要在magrittr的函数is_pipe中插入一个新选项，以确定某个函数是否是管道。我们需要让它识别%W>% 。

new_is_pipe = function (pipe)
{
  identical(pipe, quote(`%>%`)) || identical(pipe, quote(`%T>%`)) ||
    identical(pipe, quote(`%W>%`)) ||
    identical(pipe, quote(`%<>%`)) || identical(pipe, quote(`%$%`))
}
assignInNamespace("is_pipe", new_is_pipe, ns="magrittr", pos="package:magrittr")
`%W>%` = magrittr::`%>%`

我们还需要一个新的辅助函数来检查正在处理的管道是否为%W>%。

is_W = function(pipe) identical(pipe, quote(`%W>%`))
environment(is_W) = asNamespace('magrittr')

最后，我们需要在magrittr:::wrap_function中加入一个新的分支，检查这是否是一个%W>%管道。如果是，则在函数调用体中插入options(warn=-1)和on.exit(options(warn=w))。

new_wrap_function = function (body, pipe, env)
{
  w <- options()$warn
  if (magrittr:::is_tee(pipe)) {
    body <- call("{", body, quote(.))
  }
  else if (magrittr:::is_dollar(pipe)) {
    body <- substitute(with(., b), list(b = body))
  }
  else if (is_W(pipe)) {
    body <- as.call(c(as.name("{"), expression(options(warn=-1)), parse(text=paste0('on.exit(options(warn=', w, '))')), body))
  }
  eval(call("function", as.pairlist(alist(. = )), body), env, env)
}
assignInNamespace("wrap_function", new_wrap_function, ns="magrittr", pos="package:magrittr")

测试这个是否有效：

data.frame(a= c(1,-1)) %W>% mutate(a=sqrt(a)) %>% cos
#           a
# 1 0.5403023
# 2       NaN

与...相比较，...

data.frame(a= c(1,-1)) %>% mutate(a=sqrt(a)) %>% cos
#           a
# 1 0.5403023
# 2       NaN
# Warning message:
# In sqrt(a) : NaNs produced

- dww

---

哇，这真的很酷！了解maggritr的核心信息非常有用！我唯一担心的是如何加载它，因为我可以将其他解决方案与我的其他自定义函数一起放在脚本中进行源代码处理，但这个必须访问magrittr命名空间。我应该在加载magrittr之后再加载它吗？我该如何将这些函数放入一个包中？ - moodymudskipper

我认为在加载magrittr之前或之后运行这段代码并不重要。虽然我想不出任何特定的原因先这么做，但是考虑到你需要加载该包才能运行这些函数，所以先后顺序似乎也没什么影响。此外，我也没有想到将其放入程序包中会有任何问题。我稍后会再思考一下，如果你遇到了任何问题，请告诉我。 - dww

也许这可以帮到你？https://dev59.com/_lHTa4cB1Zd3GeqPRGU7 - dww

是的，谢谢。看起来（未经测试）我可以在一个传统命名为zzz.R的R文件中使用以下函数.onLoad <- function(libname, pkgname) {the_3_instructions}。 - moodymudskipper

@Moody_Mudskipper 如果你把它打包了，我会非常感兴趣看看你是如何做的。你有没有可能把这个放到gist或github上？ - Dan Chaltiel

Answer 2

我不确定这个解决方案是否完美，但它是一个开始：

`%W>%` <- function(lhs, rhs) {
  call <- substitute(`%>%`(lhs, rhs))
  eval(withr::with_options(c("warn" = -1), eval(call)), parent.frame())
}

以下两个示例似乎可以工作：

> data.frame(a= c(1,-1)) %W>% mutate(a=sqrt(a)) %>% cos
          a
1 0.5403023
2       NaN
> c(1,-1) %W>% sqrt()
[1]   1 NaN

- F. Privé

---

谢谢！我会在接下来的几天里用真实案例进行测试。 - moodymudskipper

我认为这可能会在某些边缘情况下出现问题，例如data.frame(a = c(1，-1))%W>% print()或data.frame(a = c(1，-1))%W>% expression()。 - dww

Answer 3

也许可以用rlang做出类似这样的东西：

library(rlang)
library(magrittr)

`%W>%` <- function(lhs, rhs){
  w <- options()$warn
  on.exit(options(warn=w))
  options(warn=-1)
  lhs_quo = quo_name(enquo(lhs))
  rhs_quo = quo_name(enquo(rhs))
  pipe = paste(lhs_quo, "%>%", rhs_quo)
  return(eval_tidy(parse_quosure(pipe)))
}

data.frame(a= c(1,-1)) %W>% mutate(a=sqrt(a)) %>% cos

结果：

          a
1 0.5403023
2       NaN

注意：

• 你需要使用 enquo 替代 quo，因为你引用的是传递给 lhs 和 rhs 的代码，而不是字面量 lhs 和 rhs。

• 我无法想出如何将 lhs_quo/lhs 馈送到在它被评估之前就是一个 quosure 的 rhs_quo 中，也不能先评估 rhs_quo（会抛出一个错误，说 mutate(a=sqrt(a)) 中找不到 a）

• 我想出的解决方法是将 lhs 和 rhs 转换为字符串，用 "%>%" 连接它们，将字符串解析为 quosure，最后使用整洁评估这个 quosure。

- acylam

---

谢谢，这让我更好地理解了“rlang”方言。 - moodymudskipper

Answer 4

经过一些经验的积累，我刚刚错过了使用eval.parent和substitute组合的机会，不需要使用rlang：

`%W>%` <- function(lhs,rhs){
  # `options()` changes options but returns value BEFORE change
  opts <- options(warn = -1) 
  on.exit(options(warn=opts$warn))
  eval.parent(substitute(lhs %>% rhs))
}

data.frame(a= c(1,-1)) %W>% mutate(a=sqrt(a)) %>% cos
#           a
# 1 0.5403023
# 2       NaN

- moodymudskipper

---

请问您能否解释一下函数中 eval.parent 的每个部分的作用？我理解得对吗，w <- options()$warn 记录了当前警告显示的状态，on.exit(options(warn = w)) 在函数完成后返回该选项的状态，并且 options(warn = -1) 在函数执行期间将警告静音。 - its.me.adam

你的理解是正确的，我稍微修改了一下代码，使其更符合惯用语法。substitute()构建了一个管道表达式，在这种情况下是quote(data.frame(a= c(1,-1)) %>% mutate(a=sqrt(a)))，eval.parent()在调用者环境中对其进行评估，如果我们将%W>%替换为%>%，则会调用data.frame(a= c(1,-1)) %>% mutate(a=sqrt(a))。 - moodymudskipper

尝试运行 opts <- 1; data.frame(a= c(opts,-opts)) %W>% mutate(a=sqrt(a)) %>% cos，然后将其中的 eval.parent() 替换为 eval()，看看会发生什么。如果您不理解，请告诉我，我很乐意提供进一步的帮助。 - moodymudskipper

我们得到了 Error in -opts: invalid argument to unary operator，就像运行 opts <- options(warn = -1); -opts 一样。我现在遇到的问题是 substitute。为什么不能使用 quote？我不知道 ?substitute 中的解析树或第二个子句的含义，它说“substitute返回表达式expr的解析树（未求值），替换在env中绑定的任何变量。” - its.me.adam

尝试定义"%W>%" <- function(lhs, rhs) substitute(lhs %>% rhs)，然后再定义"%W>%" <- function(lhs, rhs) quote(lhs %>% rhs)，并在data.frame(a= c(1,-1)) %W>% mutate(a=sqrt(a))上测试它们。你会发现quote()捕获了表达式，而substitute()则用作为参数给出的表达式替换符号。 - moodymudskipper

替代函数的文档很混乱，而且你不需要理解什么是解析树就能使用该函数。从根本上讲，调用是一棵树，因为它具有层次性，试试lobstr::ast(data.frame(a= c(1,-1)) %W>% mutate(a=sqrt(a)))，你会看到在执行之前如何解析该调用。 - moodymudskipper