Пользовательская труба, чтобы заставить замолчать предупреждения

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

Я думаю, что подхожу к этому так, настроив трубы 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 2

Возвращаясь немного более опытным, я просто пропустил 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

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 в rhs_quo (который был quosure), прежде чем это было оценено, я не могу оценить rhs_quo первый (выдает ошибку, говоря a не найден в mutate(a=sqrt(a)))

• Обходной путь, который я придумал по очереди lhs а также rhs в строки, вставляет их "%>%"разбирает строку на quosureзатем, наконец, приборка оценивает quosure,

Answer 4

Я не уверен, что это решение работает отлично, но это начало:

`%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 5

Основываясь на ответе @dww, я создал пакет, который объединяет эту трубу с другими:

# devtools::install_github("moodymudskipper/mmpipe")
library(mmpipe)
library(dplyr)
data.frame(a= c(1,-1)) %W>% mutate(a=sqrt(a)) %>% cos
# a
# 1 0.5403023
# 2       NaN

Пакет предлагает также способ легко определить своих собственных операторов канала, если у нас еще не было %W>% мы могли бы сделать:

add_pipe(`%W2>%`, substitute(
  {options(warn = -1); on.exit(options(warn = w)); b},
  list(w = options()$warn, b = body)))

где второй аргумент создаст новое тело функции и переменную body это вызов, содержащий тело функции до изменения (в следующем случае это quote(mutate(.a=sqrt(a)))):

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

Больше примеров в файле readme mmpipe