China-R-2015_P9_2_Rmagic_YanLinlin.Rmd

---
title: 解构R语言中的“黑魔法”
author: 颜林林
date: 2015年6月7日 @ 北京大学
output:
  slidy_presentation:
    css: styles.css
    highlight: pygments
    mathjax: null
---

```{r init, echo = FALSE, message = FALSE}
library(knitr)
options(width = 60)

# load chunks
rmdLines <- readLines(current_input())
slideNos <- cumsum(rmdLines == "---")
chunkMarks <- matrix(grep("^\\s*```", rmdLines), nrow = 2)
chunkLabels <- all_labels()
run_chunk <- function(label) {
	index <- which(all_labels() == label)
	eval.parent(parse(text = rmdLines[(chunkMarks[1, index] + 1) : (chunkMarks[2, index] - 1)]))
}

# count code lines
library(dplyr)
CODE <- data.frame(slide = slideNos[chunkMarks[1,]],
				   lines = apply(chunkMarks, 2, diff) - 1,
				   visible = !grepl(", echo = FALSE", rmdLines[chunkMarks[1,]])) %>%
	filter(visible) %>%
    group_by(slide) %>%
    summarize(lines = sum(lines))
```

# 主要内容{.toc}

- 魔法初窥
- 魔法拆解
- 魔法实战

---

# 魔法初窥：图形语法 (Grammar of Graphics)

```{r ggplot_1, message = FALSE}
library(ggplot2)
```
```{r ggplot_2}
g <- ggplot(CODE, aes(x = slide, y = lines)) + # 用“+”指定绘图参数
    geom_point(size = 3, color = "red") +
    xlab("页码") + ylab("代码行数") + labs(title = "本幻灯片的R代码")
```
```{r ggplot_3, fig.width = 8, fig.height = 3}
g # 变量显示即绘图，结果输出到图形窗口，而非终端
```

---

# 魔法初窥：缓存化 (Cache)

```{r cache_1}
foo <- function(x) { Sys.sleep(1); return(x) } # 原始函数，无缓存
```
```{r cache_2}
library(memoise)
Foo <- memoise(foo) # 构建一个有缓存的新函数
```
```{r cache_3, eval = FALSE}
for (x in rep(1:4, 3)) {
	system.time(foo(x)) # 无缓存
	system.time(Foo(x)) # 有缓存
}
```
```{r cache_4, echo = FALSE, message = FALSE, cache = TRUE, fig.width = 8, fig.height = 3}
a <- t(sapply(rep(1:4, 3), function(x) {
	c(foo = system.time(foo(x))[[3]],
	  Foo = system.time(Foo(x))[[3]])
}))

library(reshape2)
a <- melt(a, c("Run", "Function"), value.name = "Elapse")

library(ggplot2)
ggplot(a, aes(x = Run, y = Elapse,
			  group = Function, color = Function)) +
	geom_point(size = 3) + geom_line() +
	xlab("函数调用") + ylab("耗时(秒)") +
	guides(color = guide_legend(title = "函数"))
```

---

# 魔法初窥：管道 (Pipe)

- 多层函数调用
	```{r pipe_1}
# 计算代码最多的三张幻灯片的总代码行数
sum(head(sort(CODE$lines, decreasing = TRUE), 3))
```
    ```{r pipe_2, results = "hide"}
t1 <- sort(CODE$lines, decreasing = TRUE)
t2 <- head(t1, 3)
sum(t2)
```

- 管道写法
	```{r pipe_3}
library(magrittr) # 或 library(dplyr)
```
	```{r pipe_4, results = "hide"}
CODE$lines %>%
    sort(decreasing = TRUE) %>%
    head(3) %>%
    sum
```

---

# 魔法初窥：管道

- 另外两种管道写法
	```{r pipe_5, results = "hide"}
library(pipeR)
```
	```{r pipe_6, results = "hide"}
Pipe(CODE$lines) $
    sort(decreasing = TRUE) $
    head(3) $
    sum
```
	```{r pipe_7, results = "hide"}
pipeline({
    CODE$lines
    sort(decreasing = TRUE)
    head(3)
    sum
})
```

---

# 魔法拆解

- 对象封装

- 运算符重载

- 函数与闭包 (Closure)

- 自定义运算符

- 惰性求值 (Lazy evaluation)

- 元编程 (Meta programming)

---

# 对象封装：S3类的定义

```{r obj_1}
a <- CODE$lines        # 创建一个简单对象
class(a) <- "my_plot"  # 定义S3类对象（S3类其实只是属性）
```
```{r obj_2}
a  # 显示变量内容，相当于调用了 print(a)
```

---

# 对象封装：S3类的函数调用

```{r obj_3}
print  # 查看print()的实现
```
```{r obj_4, eval = FALSE}
# 根据a的class属性，依次进行如下尝试：
print.my_plot(a)
print.default(a)
```

---

# 对象封装：拆解ggplot的实现

```{r obj_5}
print.my_plot <- function(x) {
    plot(x, col = "red") # 画图或其它操作
}
```
```{r obj_6, fig.width = 6, fig.height = 4}
a # 再次显示变量，就变成了图形输出
```

---

# 运算符重载：运算符皆函数

```{r op_1, results = "hide"}
`+`(2, 3)    # 2 + 3
`<-`(x, 1:5) # x <- 1:5
`[`(x, 3)    # x[3]
```

---

# 运算符重载：拆解ggplot的实现

```{r op_2}
`+.my_plot` <- function(obj, opt) {
    attr(obj, names(opt)) <- opt
    return(obj)
}
```
```{r op_3}
print.my_plot <- function(x) {
    plot(x, type = attr(x, "type"), col = attr(x, "col"))
}
```
```{r op_4, fig.width = 6, fig.height = 4}
a + c(type = "b") + c(col = "blue") # 如此，就可以通过"+"追加绘图参数
```

---

# 函数与闭包：缓存的实现

```{r cache_impl_1, eval = FALSE}
foo <- function(x) { Sys.sleep(1); return(x) } # 原始函数，无缓存
```
```{r cache_impl_2}
cache <- list() # 缓存变量
Foo <- function(x) {
    key <- as.character(x) # 用参数做主键
    if (!is.null(cache[[key]])) { # 检查是否已计算过
        return(cache[[key]]) # 返回缓存值
    } else {
        res <- foo(x) # 调用原始函数进行计算
        cache[[key]] <<- res # 保存至缓存
        return(res)
    }
}
```

---

# 函数与闭包：把函数作为返回值

```{r cache_impl_3, eval = FALSE}
library(memoise)
Foo <- memoise(foo) # 创建带缓存的函数
```
```{r cache_impl_4}
my_memoise <- function(f) {
    cache <- list() # 缓存变量
    return(function(x) {
        key <- as.character(x) # 用参数做主键
        if (!is.null(cache[[key]])) { # 检查是否已计算过
            return(cache[[key]]) # 返回缓存值
        } else {
            res <- f(x) # 调用原始函数进行计算
            cache[[key]] <<- res # 保存至缓存
            return(res)
        }
    })
}
```

---

# 函数与闭包：拆解“缓存化”的实现

```{r cache_impl_5}
Foo <- my_memoise(foo)
```
```{r cache_impl_6, eval = FALSE}
for (x in rep(1:4, 3)) {
	system.time(foo(x)) # 无缓存
	system.time(Foo(x)) # 有缓存
}
```
```{r cache_impl_7, echo = FALSE, message = FALSE, cache = TRUE, fig.width = 8, fig.height = 3}
a <- t(sapply(rep(1:4, 3), function(x) {
	c(foo = system.time(foo(x))[[3]],
	  Foo = system.time(Foo(x))[[3]])
}))

library(reshape2)
a <- melt(a, c("Run", "Function"), value.name = "Elapse")

library(ggplot2)
ggplot(a, aes(x = Run, y = Elapse,
			  group = Function, color = Function)) +
	geom_point(size = 3) + geom_line() +
	xlab("函数调用") + ylab("耗时(秒)") +
	guides(color = guide_legend(title = "函数"))
```

---

# 函数与闭包：闭包 = 函数 + 环境

```{r cache_impl_8}
Foo
environment(Foo)
ls(envir = environment(Foo))
```

---

# 函数与闭包：函数皆闭包

```{r cache_impl_9}
foo
environment(foo)
```

---

# 自定义运算符

```{r custom_op_1}
`%+%` <- function(a, b) paste(a, b)
"hello" %+% "magic"
`%+%`("hello", "magic")
```

---

# 运算符的本质

- 改变函数调用的书写方式及顺序

	```{r custom_op_2, echo = FALSE, fig.width = 6, fig.height = 2}
circle <- function(x, y, r, label = "", col = "white", fill = "gray22", ..., n = 100) {
	polygon(x + r * sin(2 * pi * (1:n) / n),
			y + r * cos(2 * pi * (1:n) / n),
			border = col, col = fill, ...)
	if (label != "") {
		text(x, y, label, adj = c(.5, .5), col = col, ...)
	}
}
circle_box <- function(x, y, r, w, label = "", col = "white", fill = "gray22", ..., n = 100) {
	polygon(c(x + w / 2 + r * sin(pi * (0:n) / n),
			  x - w / 2 - r * sin(pi * (0:n) / n)),
			c(y + r * cos(pi * (0:n) / n),
			  y - r * cos(pi * (0:n) / n)),
			border = col, col = fill, ...)
	if (label != "") {
		text(x, y, label, adj = c(.5, .5), col = col, ...)
	}
}
par(mar = rep(0, 4), bg = "transparent", fg = "white")
plot.new()
plot.window(c(0, 6), c(0.5, 2.5))
circle_box(1.2, 2, .3, .6, "运算符", cex = 1.5, font = 2)
circle_box(0.5, 1, .3, .4, "左值", cex = 1.5, font = 2)
circle_box(1.9, 1, .3, .4, "右值", cex = 1.5, font = 2)
circle(4,   2, .3, "+", cex = 2)
circle(3.5, 1, .3, "a", cex = 2)
circle(4.5, 1, .3, "b", cex = 2)
segments(c(0.7, 1.7, 3.7, 4.3),
         c(1.4, 1.4, 1.4, 1.4),
         c(0.9, 1.5, 3.8, 4.2),
         c(1.6, 1.6, 1.6, 1.6))
```

	- 前缀表示：`+` `a` `b`  ，或写成函数形式：`+(a, b)`
	- 中缀表示：`a` `+` `b`
	- 后缀表示：`a` `b` `+`

---

# 自定义运算符：拆解“管道”魔法

```{r custom_op_3}
`%|%` <- function(x, fun) fun(x)
```
```{r custom_op_4, fig.width = 6, fig.height = 4}
# plot(sort(CODE$lines))
CODE$lines %|% sort %|% plot
```

---

# “管道”魔法的未解之谜

```{r custom_op_5, eval = FALSE}
# plot(sort(CODE$lines))
CODE$lines %|% sort %|% plot # 不带其它参数
```
```{r custom_op_6, eval = FALSE}
# sum(head(sort(CODE$lines, decreasing = TRUE), 3))
CODE$lines %>%
    sort(decreasing = TRUE) %>% # 带有其它参数
    head(3) %>%
    sum
```
```{r custom_op_7, error = TRUE}
sort(decreasing = TRUE) # 并不是可以正确运行的完整语句
```

---

# 惰性求值

- 下面的语句中，两个加法运算都会被执行吗？

	```{r lazy_eval_1, results = "hide"}
ifelse(TRUE, 1 + 2, 3 + 4)
```

---

# 惰性求值

- 揭示真相

	```{r lazy_eval_2, error = TRUE}
suppressWarnings(rm(a, b))
ifelse(TRUE, a, b)
ifelse(FALSE, a, b)
```

---

# 惰性求值

- 再来一个自定义函数
	```{r lazy_eval_4}
foo <- function(arg) {
    cat("I don't care the 'arg'\n")
}
foo(a_variable-that.does$not%%exist)
```

---

# 惰性求值：“管道”实现

- 对于语句：
    ```{r lazy_eval_5, eval = FALSE}
CODE$lines %>% sort(decreasing = TRUE)
```
- 相当于：
	```{r lazy_eval_6, eval = FALSE}
`%>%` <- function(x, exp) {
    # 刚进入此函数时：
    #  x 值为 CODE$lines
    #  y 值为 sort(decreasing = TRUE)
    # 都还没有进行任何计算。此时有机会重新调整代码，使其能够被正确执行
    ...
}
```

---

# 元编程：操作代码的代码

- 语法解析：substitute(), parse(), deparse()

- 表达式构造：quote(), as.call()

- 表达式求值：eval(), source()

- 函数信息：match.call(), match.fun()

---

# 元编程：拆解“管道”魔法

```{r metaprog_1}
`%|%` <- function(x, exp) {
    f <- as.list(substitute(exp))   # list(head, 3)
    f <- c(f[1], substitute(x), f[-1]) # list(head, quote(1:5), 3)
    eval(as.call(f), envir = parent.frame()) # head(1:5, 3)
}
CODE$lines %|% head(3)
```

---

# 另外两种管道写法

```{r show_pipe_1, eval = FALSE}
library(pipeR)
Pipe(CODE$lines) $
    sort(decreasing = TRUE) $
    head(3) $
    sum
```
```{r show_pipe_2, eval = FALSE}
library(pipeR)
pipeline({
    CODE$lines
    sort(decreasing = TRUE)
    head(3)
    sum
})
```

---

# 解构第三种管道写法

```{r show_pipe_3}
as.list(substitute({
	cmd1
	cmd2(arg)
	cmd3
}))
```

---

# 魔法实战：构造一个“阅后即焚”的函数

```{r bomb_func_1, echo = FALSE}
run_chunk("bomb_func_4")
```
```{r bomb_func_2}
foo <- function() {
    cat("Hi, I am disappearing...\n")
}
bomb(foo) # 预埋焚毁装置
```
```{r bomb_func_3, error = TRUE}
foo() # 第一次调用
foo() # 第二次调用
```

---

# 魔法实战：“阅后即焚”实现

```{r bomb_func_4, eval = FALSE}
bomb <- function(func) {
    a <- deparse(func)
    a <- c(head(a, -1),
           quote(rm(list = as.character(match.call()[[1]]),
                    envir = sys.frame(-1))),
           tail(a, 1))
    assign(as.character(substitute(func)),
           eval(parse(text = a)),
           envir = environment(func))
}
```

---

# 魔法实战：伎俩暴露

```{r bomb_func_5}
foo <- function() {
    cat("Hi, I am disappearing...\n")
}
bomb(foo)
foo
```

---

# 魔法实战：隐藏踪迹

```{r bomb_func_6}
Bomb <- function(func) {
    a <- deparse(func)
    a <- c(head(a, -1),
           quote(rm(list = as.character(match.call()[[1]]),
                    envir = sys.frame(-1))),
           tail(a, 1))
    assign(as.character(substitute(func)),
           eval(parse(text = a)),
           envir = environment(func))
	eval(parse(text = paste0("class(",
							 as.character(substitute(func)),
							 ") <- 'bombed'")),
		 envir = environment(func))
}
```
```{r bomb_func_7}
print.bombed <- function(f) {
	a <- deparse(unclass(f))
	a <- c(head(a, -2), tail(a, 1))
	cat(a, sep = "\n")
}
```

---

# 魔法实战：最终效果

```{r bomb_func_8, error = TRUE}
foo <- function() {
    cat("Hi, I am disappearing...\n")
}
Bomb(foo)
foo
foo()
foo()
```

---

# 总结

- 解构：ggplot画图、缓存化、管道

- 学习：对象封装、运算符重载、闭包、惰性求值、元编程

- 未涉及：更底层的R实现、R与其它语言的结合

- 方法：“重新发明轮子”

---

# 谢谢！{.acknowledge}

http://github.com/yanlinlin82/Rmagic

---

# 参考文献及网站

- Hadley Wickham, [Advanced R](http://adv-r.had.co.nz/)
- Joseph Adler, [R in a nutshell](http://www.amazon.com/R-Nutshell-In-OReilly/dp/144931208X), 2ed, O'Reilly, 2012
- [R Language Definition](http://cran.r-project.org/doc/manuals/R-lang.html)
- [R Internals](http://cran.r-project.org/doc/manuals/R-ints.html)

---

# 附：我的R环境

```{r sessionInfo, collapse = TRUE}
sessionInfo()
```