自定义管道以消除警告答案

【问题标题】：Custom pipe to silence warnings自定义管道以消除警告
【发布时间】：2018-05-08 15:00:15
【问题描述】：

我想构建一个自定义管道%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

这两次尝试都不行：

`%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 变成有效的东西？

【问题讨论】：

赞成将rlang用作动词。
您可能想看看rmonad:: 包intro vignette（和其他）。这是一种处理错误的好方法，并且可能同样适用于警告。可能有点矫枉过正，但需要考虑。
确实很有趣。它甚至可能包含我这个老问题的答案：stackoverflow.com/questions/44831342/…

标签： r dplyr magrittr rlang

【解决方案1】：

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

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

这似乎适用于以下 2 个示例：

> 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

【讨论】：

谢谢！在接下来的几天里，我将在真实案例中对其进行测试。
我认为这可能会落在某些极端情况下，例如 data.frame(a = c(1,-1)) %W>% print() 或 data.frame(a = c(1,-1)) %W>% expression()

【解决方案2】：

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 和@987654329 @。
我不知道如何将 lhs_quo/lhs 输入到 rhs_quo（这是一个 quosure）在评估之前，我也无法评估rhs_quo first（抛出一个错误说a not found in mutate(a=sqrt(a))）
我想出的解决方法将lhs 和rhs 转换为字符串，用"%>%" 粘贴它们，将字符串解析为quosure，然后最后整理评估quosure。

【讨论】：

谢谢，这有助于我更好地理解rlang方言

【解决方案3】：

我想我会像这样处理它，通过调整 magrittr 管道以包含这个新选项。这种方式应该很健壮。

首先我们需要在 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

【讨论】：

哇，这真的很酷！了解maggritr 内心的好信息！我唯一关心的是如何加载它，而我可以将其他解决方案与我的其他自定义函数一起放入我源代码的脚本中，这个必须访问magrittr 命名空间。我应该仅在加载 magrittr 之后加载它吗？我如何将这些功能放在一个包中？
我认为在加载 magrittr 之前或之后运行此代码并不重要。虽然我想不出任何特别的理由首先这样做，因为您需要加载包来运行这些功能。另外，我想不出把它放进一个包里有什么麻烦。稍后我会再考虑一下，但如果您遇到任何问题，请告诉我。
我会的。我可能会在一周内打包这个。
其实我还是一头雾水，如果我想把这个放在一个包里，我该怎么处理你assignInNamespace和environment的说明？到目前为止，我只将常规函数放在包中，它们应该设置为在调用library 时运行的指令吗？如果它太宽泛，我可以将其作为一个单独的问题发布
也许这有帮助？ stackoverflow.com/questions/4019049/…

【解决方案4】：

回来有点经验，我只是错过了eval.parent和substitute组合，不需要rlang：

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

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

【讨论】：