自定义管道以静音警告

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

这两个尝试都不行:

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

Answer 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

Answer 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 和 rhs.

我不知道如何将 lhs_quo/lhs 送入 rhs_quo（这是一个 quosure）在被评估之前，我也不能先评估rhs_quo（抛出一个错误说a not found in mutate(a=sqrt(a))）

我想出的变通办法是把lhs和rhs变成字符串，用"%>%"粘贴，把字符串解析成quosure ，然后最后 tidy 评估 quosure.

Answer 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

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

自定义管道以静音警告

Custom pipe to silence warnings

r

dplyr

magrittr

rlang