定制管道以消除警告

Moo*_*per 13 r dplyr magrittr rlang

此问题相关.

我想构建一个自定义管道%W>%,可以使一个操作的警告静音

library(magrittr)
data.frame(a= c(1,-1)) %W>% mutate(a=sqrt(a)) %>% cos
Run Code Online (Sandbox Code Playgroud)

将相当于:

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

这两次尝试不起作用:

`%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)
}
Run Code Online (Sandbox Code Playgroud)

我怎么能把rlang它变成有效的东西呢?

dww*_*dww 6

我想我会这样做,通过调整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::`%>%`
Run Code Online (Sandbox Code Playgroud)

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

is_W = function(pipe) identical(pipe, quote(`%W>%`))
environment(is_W) = asNamespace('magrittr')
Run Code Online (Sandbox Code Playgroud)

最后,我们需要设置一个新的分支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")
Run Code Online (Sandbox Code Playgroud)

测试工作原理:

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

相比...

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