R 语言 | 自定义R中的管道符 `%＞＞2%`

1. R中的管道符

R 有magrittr包提供的管道符 %>%，也有最近原生提供的 |>。

附: 已有的管道符的功能和差异

本文向探究一下它们是怎么实现的。
本文只用R语言实现简单的管道符功能。复杂的以后再说。//todo

目标效果如下：

(1) R包magrittr提供的管道符 %>%

> library(magrittr)
> iris %>% dim %>% sum
[1] 155
> iris %>% dim() %>% sum()
[1] 155

> iris %>% dim() %>% sum(100,2000) #额外加2个参数
[1] 2255

(2) R 原生管道符 |>

> iris |> dim() |> sum(100,2000)
[1] 2255

(3) 查看源代码

> `%>%`
function (lhs, rhs) 
{
    lhs <- substitute(lhs)
    rhs <- substitute(rhs)
    kind <- 1L
    env <- parent.frame()
    lazy <- TRUE
    .External2(magrittr_pipe)
}
<bytecode: 0x55efd70e97b0>
<environment: namespace:magrittr>


> `|>`
Error: object '|>' not found

> `+` #能看到+也是一个函数，Primitive类型，可能是C写的
function (e1, e2)  .Primitive("+")

从交互界面看不到管道符的源码。
不过有一点需要注意：函数内第一步就是使用 substitute() 函数转换参数！

magrittr包的源码在github上，链接见末尾。Rcpp的代码还好，C语言的和R底层联系太深，目前还看不懂。//todo

2. 尝试

• https://stackoverflow.com/questions/13354048/r-pipelining-functions

(1) version1: 不支持圆括号，那么就无法设置更多参数了

"%>>%" <- function(x, fun){
  if(is.function(x)) {
    function(...) fun(x(...))
  } else {
    fun(x)
  }
}

> iris %>>% dim %>>% sum
[1] 155


> iris %>>% dim() %>>% sum() #不能加圆括号，更不用说其他参数了
Error in dim() : 0 arguments passed to 'dim' which requires 1

另一个写法，相当于把多个函数合并，没法使用额外的参数；用着也挺别扭。

"%|>%" <- function(fun1, fun2){
    function(x){fun2(fun1(x))}
}
> fn001=dim %|>% sum  #合并函数
> fn001(iris)
[1] 155

3.我的实现

主要是2个R函数。
目前只实现了%>%的最简单功能。
测试环境： Ubuntu 20.04 + R 4.1.1

# helper: 把函数调用转为字符串，拆分出函数名并整合参数列表
parse_func=function(x2){
  if(!is.character(x2)){
    stop("must input a character!")
  }

  fname=-1
  arg.str=""
  if( endsWith(x2, ")") ){
    #找到第一个(
    start=grepRaw("\\(", x2);
    fname=substr(x2, 1, start-1)
    arg.str=substr(x2, start+1, nchar(x2)-1)
  }else{
    #没有() 时是不是函数?怎么判断
    tryCatch({
      if( is.function(eval(parse(text=x2)) ) ){
        fname=x2;
      }
    })
  }
  # string to list
  if(fname!="")
    arg.list=parse(text = paste0( "list(", arg.str, ")" ))
  else{
    fname=-1
    arg.list=""
  }
  #
  return(list(
    fname=fname,
    args=arg.list
  ))
}


# 主函数
"%>>2%" <- function(x, fun){
  # 1. 函数调用表达式 to 字符串
  x2=deparse(substitute(x));
  fun2=deparse(substitute(fun));
  # 2.提取函数名字和参数列表
  x3=parse_func(x2);
  fun3=parse_func(fun2);
  # 3.调用函数: 第2个的函数名( 第一个参数作为第一个参数，紧随第二个函数的其余参数)
  arg.list=c( list(eval(parse(text=x2))), eval(fun3$args) ) #如果参数中有表达式，这样写有问题，加上x就没问题了
  do.call(fun3$fname, arg.list)
};

# 主函数：这个是补充。todo: 合并到上面
"%>>3%" <- function(x, fun){
  # 1. 函数调用表达式 to 字符串
  x2=deparse(substitute(x));
  fun2=deparse(substitute(fun));
  # 2.提取函数名字和参数列表
  x3=parse_func(x2);
  fun3=parse_func(fun2);
  # 3.调用函数: 第2个的函数名( 第一个参数作为第一个参数，紧随第二个函数的其余参数)
  arg.list=c( list(eval(parse(text=x2))), eval(fun3$args, x) ) #如果参数中有表达式，这样写有问题，加上x就没问题了
  do.call(fun3$fname, arg.list)
};


# helper: 支持按列选择数据 http://adv-r.had.co.nz/Computing-on-the-language.html
select <- function(df, vars) {
  vars <- substitute(vars)
  var_pos <- setNames(as.list(seq_along(df)), names(df))
  pos <- eval(vars, var_pos)
  df[, pos, drop = FALSE]
}

4.测试

(1) 显示前n行

> iris %>>2% head(n=3)
  Sepal.Length Sepal.Width Petal.Length Petal.Width Species
1          5.1         3.5          1.4         0.2  setosa
2          4.9         3.0          1.4         0.2  setosa
3          4.7         3.2          1.3         0.2  setosa

> iris %>>2% head() %>>2% dim() %>>2% sum()
[1] 11

> iris %>>2% dim() %>>2% sum(100,2000)
[1] 2255

(2)支持设置参数: 修改列名

> iris %>% setNames( paste0("c",c(1,2,3,4, 5))) %>>2% head(n=3)
   c1  c2  c3  c4     c5
1 5.1 3.5 1.4 0.2 setosa
2 4.9 3.0 1.4 0.2 setosa
3 4.7 3.2 1.3 0.2 setosa

(3)使用 ggplot2 绘图

> library(ggplot2)
> mtcars %>>2% head(n=30) %>%
  ggplot(aes(wt, mpg, col=factor(gear) )) + geom_point()

(4)按列名选择

> mtcars %>>2% head(n=3) %>>2% select(c("wt", "am", "mpg"))
                 wt am  mpg
Mazda RX4     2.620  1 21.0
Mazda RX4 Wag 2.875  1 21.0
Datsun 710    2.320  1 22.8

(5) 可以使用表达式参数 // todo

更多对比测试，输出结果相同:

> subset(iris, Petal.Length>6.5)
> iris %>% subset( Petal.Length>6.5)
> iris %>>3% subset( Petal.Length>6.5)
    Sepal.Length Sepal.Width Petal.Length Petal.Width   Species
106          7.6         3.0          6.6         2.1 virginica
118          7.7         3.8          6.7         2.2 virginica
119          7.7         2.6          6.9         2.3 virginica
123          7.7         2.8          6.7         2.0 virginica

> iris %>>2% subset( Petal.Length>6.5)  #todo: 怎么把2个函数统一起来
Error in eval(fun3$args) : object 'Petal.Length' not found

(6) %>>3% 也有问题

> library(magrittr)
> iris %>>3% head() %>>3% subset(Sepal.Length>5)
  Sepal.Length Sepal.Width Petal.Length Petal.Width Species
1          5.1         3.5          1.4         0.2  setosa
6          5.4         3.9          1.7         0.4  setosa
> iris %>>3% head() %>>3% subset(Sepal.Length>5) %>>3% dim()
[1] 2 5
> iris %>>3% head() %>>3% subset(Sepal.Length>5) %>>3% dim() %>>3% sum() #not work
Error in eval(fun3$args, x) : numeric 'envir' arg not of length one
> iris %>>3% head() %>>3% subset(Sepal.Length>5) %>>3% dim() %>>2% sum() #换成 %>>2%就可以了
[1] 7
> #
> iris %>>3% head() %>>3% subset(Sepal.Length>5) %>>3% dim() %>% sum()
[1] 7
> iris %>>3% head() %>>3% subset(Sepal.Length>5) %>>3% dim() |> sum()
[1] 7

todo

• 已经测试到的 bug 怎么解决？
• 不支持占位符等。

Ref

• https://oomake.com/question/3745806
• http://adv-r.had.co.nz/Computing-on-the-language.html
• R中2种管道符的差异 https://stackoverflow.com/questions/67633022/what-are-the-differences-between-rs-new-native-pipe-and-the-magrittr-pipe
  • https://github.com/tidyverse/magrittr/blob/main/R/pipe.R
  • https://github.com/tidyverse/magrittr/blob/main/src/pipe.c
• Pyhton 中的管道操作 https://zhuanlan.zhihu.com/p/446002988
  • https://zhuanlan.zhihu.com/p/432755818

以后逐步完善。这就是R的元编程，操作对象是语言本身。