Custom pipe to silence warnings
Coming back a little more experienced, I just missed an eval.parent
and substitute
combo, no need for 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
I'm not sure this solution works perfectly, but it's a start:
`%W>%` <- function(lhs, rhs) {
call <- substitute(`%>%`(lhs, rhs))
eval(withr::with_options(c("warn" = -1), eval(call)), parent.frame())
}
This seems to work for the following 2 examples:
> 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
I think I would approach it like this, by tweaking the magrittr pipes to include this new option. This way should be pretty robust.
First we need to insert a new option into magrittr's function is_pipe
by which it is determined whether a certain function is a pipe. We need it to recognise %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::`%>%`
We also need a new helper function that checks whether the pipe being processed is a %W>%
is_W = function(pipe) identical(pipe, quote(`%W>%`))
environment(is_W) = asNamespace('magrittr')
Finally, we need to put a new branch into magrittr:::wrap_function
which checks if this is a %W>%
pipe. If so, it inserts options(warn = -1)
and on.exit(options(warn = w)
into the body of the function call.
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")
Testing this works:
data.frame(a= c(1,-1)) %W>% mutate(a=sqrt(a)) %>% cos
# a
# 1 0.5403023
# 2 NaN
compared to...
data.frame(a= c(1,-1)) %>% mutate(a=sqrt(a)) %>% cos
# a
# 1 0.5403023
# 2 NaN
# Warning message:
# In sqrt(a) : NaNs produced
Perhaps something like this with 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
Result:
a
1 0.5403023
2 NaN
Note:
You need
enquo
instead ofquo
because you are quoting the code that was supplied tolhs
andrhs
, not the literalslhs
andrhs
.I couldn't figure out how to feed
lhs_quo
/lhs
intorhs_quo
(which was aquosure
) before it was evaluated, neither can I evaluaterhs_quo
first (throws an error sayinga
not found inmutate(a=sqrt(a))
)The workaround that I came up with turns
lhs
andrhs
into strings, pastes them with"%>%"
, parses the string toquosure
, then finally tidy evaluates thequosure
.