library(dbplyr)
con <- simulate_postgres()
translate_sql(x^2, con = con)
#> <SQL> POWER(`x`, 2.0)
translate_sql(x < 5 & !is.na(x), con = con)
#> <SQL> `x` < 5.0 AND NOT((`x` IS NULL))
translate_sql(!first %in% c("John", "Roger", "Robert"), con = con)
#> <SQL> NOT(`first` IN ('John', 'Roger', 'Robert'))
translate_sql(select == 7, con = con)
#> <SQL> `select` = 7.021 Translating R code
Introduction
first-class环境，词法作用域，元编程组成了一套实现将R代码转换为其他语言的工具箱。例如，dbplyr为dplyr处理数据库提供了支持，允许用R语言表达数据操作并自动将其翻译成SQL，可以使用translate_sql()一览其关键思想：
由于SQL语言有许多特性，将R语言翻译成SQL语言的机制非常复杂，因此本章我们介绍两种简单但有用的领域特定语言(DSL): 一种用于生成HTML, 另一种用于在LaTeX中生成数学方程。
Outline
21.2节：介绍创建HTML。
21.2节：介绍创建LaTeX。
Prerequisites
学习本章，你需要了解：环境、表达式、整洁评估、泛函编程、元编程、S3面向对象等。
library(rlang)
library(purrr)
#>
#> Attaching package: 'purrr'
#> The following objects are masked from 'package:rlang':
#>
#> %@%, flatten, flatten_chr, flatten_dbl, flatten_int,
#> flatten_lgl, flatten_raw, invoke, spliceHTML
HTML文件是网站的底层核心，是一种特殊的标记语言（SGML，Standard Generalised Markup Language），它和XML相似但不等同。
<body>
<h1 id='first'>A heading</h1>
<p>Some text & <b>some bold text.</b></p>
<img src='myimg.png' width='100' height='100' />
</body>HTML文件中的关键组件是标签（tag），形如<tag></tag>或<tag/>。标签可以嵌套在其他标签中，并与文本交织在一起。HTML标签有超过100个，但在本章中，我们只关注其中的少数几个：
<body>：文档的主体，包含文档所有内容的顶级标签。<h1>：文档的标题级别。<p>：段落。<b>：粗体。<img>：图片。
标签具有带名字的属性，形如<tag name1='value1' name2='value2'/></tag>。其中有两个重要的属性——id和class，它们会与CSS联合使用来控制页面的外观。
<img>标签不包裹任何内容，它只能被写作<img />而不能写成<img></img>，类似<img>的标签被称为空标签（Void tags）。因为它们不能包裹内容，所以它们的属性非常重要，<img>有三个常被使用的属性：scr控制图片路径，width和height控制图片大小。
因为<和>是HTML中的特殊字符，想要在文本中书写它们，必须用转义符<和>来代替。同样，&也必须用转义符&来代替。
Goal
我们的目标是使用R生成上面的模板html文档。类似：
with_html(
body(
h1("A heading", id = "first"),
p("Some text &", b("some bold text.")),
img(src = "myimg.png", width = 100, height = 100)
)
)它有三个特点：
- 函数名与标签名相同。
- 未命名参数成为标签的内容，而命名参数成为其属性。
- & 和其他特殊字符会自动转义。
Escaping
转义功能对于代码“翻译”至关重要，它有两个难点：
对输入的字符进行自动转义，
&,<,>。正确识别是否需要转义，防止
&变为&amp;。
解决这两个难点的最简单方法是使用S3面向对象，区分要进行转义的普通字符，和已经转义的字符（类）。
html <- function(x) structure(x, class = "advr_html")
print.advr_html <- function(x, ...) {
out <- paste0("<HTML> ", x)
cat(paste(strwrap(out), collapse = "\n"), "\n", sep = "")
}创建转义泛函和它针对两种类的方法：
escape.character()：对普通字符进行转义。escape.advr_html()：对已经转义的字符不做任何处理。
escape <- function(x) UseMethod("escape")
escape.character <- function(x) {
x <- gsub("&", "&", x)
x <- gsub("<", "<", x)
x <- gsub(">", ">", x)
html(x)
}
escape.advr_html <- function(x) x检查它是否运行成功：
escape("This is some text.")
#> <HTML> This is some text.
escape("x > 1 & y < 2")
#> <HTML> x > 1 & y < 2
# Double escaping is not a problem
escape(escape("This is some text. 1 > 2"))
#> <HTML> This is some text. 1 > 2
# And text we know is HTML doesn't get escaped.
escape(html("<hr />"))
#> <HTML> <hr />Basic tag functions
接下来，我们将手动编写一个单标签函数，然后弄清楚如何对其进行泛化，这样我们就可以用代码为每个标签生成一个函数。
我们以<p>标签为例。HTML的标签可以同时具有属性和子标签（<b>,<i>）。考虑到属性有name，子标签没有，我们可以将它们类比为函数参数，在函数内部处理两种类型的参数。p()函数的使用方法可能会类似于：
p("Some text. ", b(i("some bold italic text")), class = "mypara")考虑到标签拥有的属性数目不同，子标签的数量也会不同。我们需要使用...来获取参数，然后根据是否有name属性进行分类。
dots_partition <- function(...) {
dots <- list2(...)
if (is.null(names(dots))) {
is_named <- rep(FALSE, length(dots))
} else {
is_named <- names(dots) != ""
}
list(
named = dots[is_named],
unnamed = dots[!is_named]
)
}
str(dots_partition(a = 1, 2, b = 3, 4))
#> List of 2
#> $ named :List of 2
#> ..$ a: num 1
#> ..$ b: num 3
#> $ unnamed:List of 2
#> ..$ : num 2
#> ..$ : num 4现在我们可以创建p()函数了。示例中引入了一些新的函数，这里不再详细讨论。
html_attributes <- function(list) {
if (length(list) == 0) {
return("")
}
attr <- map2_chr(names(list), list, html_attribute)
paste0(" ", unlist(attr), collapse = "")
}
html_attribute <- function(name, value = NULL) {
if (length(value) == 0) {
return(name)
} # for attributes with no value
if (length(value) != 1) stop("`value` must be NULL or length 1")
if (is.logical(value)) {
# Convert T and F to true and false
value <- tolower(value)
} else {
value <- escape_attr(value)
}
paste0(name, "='", value, "'")
}
escape_attr <- function(x) {
x <- escape.character(x)
x <- gsub("\'", "'", x)
x <- gsub("\"", """, x)
x <- gsub("\r", " ", x)
x <- gsub("\n", " ", x)
x
}
p <- function(...) {
dots <- dots_partition(...)
attribs <- html_attributes(dots$named)
children <- map_chr(dots$unnamed, escape)
html(paste0(
"<p",
attribs,
">",
paste(children, collapse = ""),
"</p>"
))
}
p("Some text")
#> <HTML> <p>Some text</p>
p("Some text", id = "myid")
#> <HTML> <p id='myid'>Some text</p>
p("Some text", class = "important", `data-value` = 10)
#> <HTML> <p class='important' data-value='10'>Some text</p>Tag functions
创建其他的标签函数，我们只需要替换p即可。所以tag()接受一个标签参数，返回一个rlang::new_function()创建的函数。new_function()内使用exprs(... = )来捕获参数。
tag <- function(tag) {
new_function(
exprs(... = ),
expr({
dots <- dots_partition(...)
attribs <- html_attributes(dots$named)
children <- map_chr(dots$unnamed, escape)
html(paste0(
!!paste0("<", tag),
attribs,
">",
paste(children, collapse = ""),
!!paste0("</", tag, ">")
))
}),
caller_env()
)
}
tag("b")
#> function (...)
#> {
#> dots <- dots_partition(...)
#> attribs <- html_attributes(dots$named)
#> children <- map_chr(dots$unnamed, escape)
#> html(paste0("<b", attribs, ">", paste(children, collapse = ""),
#> "</b>"))
#> }现在可以复现上面的函数样式了：
p <- tag("p")
b <- tag("b")
i <- tag("i")
p("Some text. ", b(i("some bold italic text")), class = "mypara")
#> <HTML> <p class='mypara'>Some text. <b><i>some bold italic
#> text</i></b></p>在创建所有HTML标签函数前，需要为空标签类型创建泛函void_tag()。它与tag()函数类似，但在出现子标签时报错。
void_tag <- function(tag) {
new_function(
exprs(... = ),
expr({
dots <- dots_partition(...)
if (length(dots$unnamed) > 0) {
abort(!!paste0("<", tag, "> must not have unnamed arguments"))
}
attribs <- html_attributes(dots$named)
html(paste0(!!paste0("<", tag), attribs, " />"))
}),
caller_env()
)
}
img <- void_tag("img")
img
#> function (...)
#> {
#> dots <- dots_partition(...)
#> if (length(dots$unnamed) > 0) {
#> abort("<img> must not have unnamed arguments")
#> }
#> attribs <- html_attributes(dots$named)
#> html(paste0("<img", attribs, " />"))
#> }
img(src = "myimage.png", width = 100, height = 100)
#> <HTML> <img src='myimage.png' width='100' height='100' />LaTeX
使用R语言生成LaTeX语句会麻烦一些，因为要同时处理函数名和参数的转换。这意味着，我们需要使用抽象语法树（AST）来修改代码。
LaTeX mathematics
在开始之前，先简单介绍一下LaTeX中公式的表达方式。完整的标准非常复杂，但幸运的是，相关文档非常详细，而且最常见的命令结构相当简单：
大多数简单的数学方程写法与在R中输入它们的方式相同：
x * y，z ^ 5。下标使用_（例如，x_1）。特殊符号使用
\转义：\pi= ，pm= 。LaTeX中有大量这种符号，可以在网上搜索，或者使用http://detexify.kirelabs.org/classify.html。复杂函数，形如
\name{arg1}{arg2}。例如，分数\frac{a}{b}，开方\sqrt{a}。使用
{}将元素分组：x ^ a + b与x ^ {a + b}。区分函数与变量。使用
\textrm{f}(a * b)来标识f是函数，a * b是变量，不然无法确定f是函数还是变量。
Goal
我们的目标是使用这些规则自动将R表达式转换为适当的LaTeX表示形式。我们将分四个阶段处理这个问题：
转换已知的符号：
pi->\pi保留其他符号不变：
x->x，y->y转换已知的函数为特殊符号：
sqrt(frac(a,b))->\sqrt{\frac{a}{b}}使用
\textrm{}标识其他函数：f(a)->\textrm{f}(a)
to_math()
首先，我们封装一个函数，将R表达式转换为LaTeX数学表达式。这将类似于to_html()，通过捕获未计算的表达式并在特殊环境中对其进行计算来实现。主要有两个区别：
评估环境不再是恒定的，因为它必须根据输入而变化。这对于处理未知符号和函数是必要的。
我们从不在参数环境中计算，因为我们将每个函数都转换为LaTeX表达式。用户需要使用
!!才能正常计算。
to_math <- function(x) {
expr <- enexpr(x)
out <- eval_bare(expr, latex_env(expr))
latex(out)
}
latex <- function(x) structure(x, class = "advr_latex")
print.advr_latex <- function(x) {
cat("<LATEX> ", x, "\n", sep = "")
}我们会逐步构建latex_env()。
Known symbols
第一步，创建一个能生成在LaTeX中用来表示希腊字符的特殊字符的环境。如，pi转换为\pi。
greek <- c(
"alpha", "theta", "tau", "beta", "vartheta", "pi", "upsilon", "gamma",
"varpi", "phi", "delta", "kappa", "rho", "varphi", "epsilon", "lambda",
"varrho", "chi", "varepsilon", "mu", "sigma", "psi", "zeta", "nu",
"varsigma", "omega", "eta", "xi", "Gamma", "Lambda", "Sigma", "Psi",
"Delta", "Xi", "Upsilon", "Omega", "Theta", "Pi", "Phi"
)
greek_list <- set_names(paste0("\\", greek), greek)
greek_env <- as_environment(greek_list)
latex_env <- function(expr) {
greek_env
}
to_math(pi)
#> <LATEX> \pi
to_math(beta)
#> <LATEX> \betaUnknown symbols
第二步，保留不是希腊字符的符号为原样。但有个问题是：我们无法预先知道输入的符号是什么，没法创建类似greek_env的环境。幸运的是，我们可以使用抽象语法树提取“表达式”中的字符。
expr_type <- function(x) {
if (rlang::is_syntactic_literal(x)) {
"constant"
} else if (is.symbol(x)) {
"symbol"
} else if (is.call(x)) {
"call"
} else if (is.pairlist(x)) {
"pairlist"
} else {
typeof(x)
}
}
switch_expr <- function(x, ...) {
switch(expr_type(x),
...,
stop("Don't know how to handle type ", typeof(x), call. = FALSE)
)
}
flat_map_chr <- function(.x, .f, ...) {
purrr::flatten_chr(purrr::map(.x, .f, ...))
}
all_names_rec <- function(x) {
switch_expr(
x,
constant = character(),
symbol = as.character(x),
call = flat_map_chr(as.list(x[-1]), all_names)
)
}
all_names <- function(x) {
unique(all_names_rec(x))
}
all_names(expr(x + y + f(a, b, c, 10)))
#> [1] "x" "y" "a" "b" "c"现在，我们可以从输入的“表达式”中提取所有符号并创建环境。
latex_env <- function(expr) {
names <- all_names(expr)
symbol_env <- as_environment(set_names(names))
symbol_env
}
to_math(x)
#> <LATEX> x
to_math(longvariablename)
#> <LATEX> longvariablename
to_math(pi)
#> <LATEX> pi接下来，我们需要将两个环境结合，将symbol_env设置为greek_env的父环境。
latex_env <- function(expr) {
# Unknown symbols
names <- all_names(expr)
symbol_env <- as_environment(set_names(names))
# Known symbols
env_clone(greek_env, parent = symbol_env)
}
to_math(x)
#> <LATEX> x
to_math(longvariablename)
#> <LATEX> longvariablename
to_math(pi)
#> <LATEX> \piKnown functions
第三步，添加函数。
首先，我们将介绍一些辅助函数，它们可以轻松地添加新的一元和二元运算符。这些函数非常简单：它们只是组合字符串。
unary_op <- function(left, right) {
new_function(
exprs(e1 = ),
expr(
paste0(!!left, e1, !!right)
),
caller_env()
)
}
binary_op <- function(sep) {
new_function(
exprs(e1 = , e2 = ),
expr(
paste0(e1, !!sep, e2)
),
caller_env()
)
}
unary_op("\\sqrt{", "}")
#> function (e1)
#> paste0("\\sqrt{", e1, "}")
binary_op("+")
#> function (e1, e2)
#> paste0(e1, "+", e2)使用这些辅助函数，我们可以映射一些将R转换为LaTeX的示例。请注意，有了R的词法作用域规则的帮助，我们可以轻松地为标准函数如+、-和*, 甚至(和{提供新的含义。
# Binary operators
f_env <- child_env(
.parent = empty_env(),
`+` = binary_op(" + "),
`-` = binary_op(" - "),
`*` = binary_op(" * "),
`/` = binary_op(" / "),
`^` = binary_op("^"),
`[` = binary_op("_"),
# Grouping
`{` = unary_op("\\left{ ", " \\right}"),
`(` = unary_op("\\left( ", " \\right)"),
paste = paste,
# Other math functions
sqrt = unary_op("\\sqrt{", "}"),
sin = unary_op("\\sin(", ")"),
log = unary_op("\\log(", ")"),
abs = unary_op("\\left| ", "\\right| "),
frac = function(a, b) {
paste0("\\frac{", a, "}{", b, "}")
},
# Labelling
hat = unary_op("\\hat{", "}"),
tilde = unary_op("\\tilde{", "}")
)我们再次修改latex_env()以包含这个环境。这应该是R查找名称的最后一个环境，这样像sin(sin)这样的表达式才能工作。
latex_env <- function(expr) {
# Known functions
f_env
# Default symbols
names <- all_names(expr)
symbol_env <- as_environment(set_names(names), parent = f_env)
# Known symbols
greek_env <- env_clone(greek_env, parent = symbol_env)
greek_env
}
to_math(sin(x + pi))
#> <LATEX> \sin(x + \pi)
to_math(log(x[i]^2))
#> <LATEX> \log(x_i^2)
to_math(sin(sin))
#> <LATEX> \sin(sin)Unknown functions
第四步，添加未知函数到环境中。同样，我们再次使用抽象语法树来提取：
all_calls_rec <- function(x) {
switch_expr(x, constant = , symbol = character(), call = {
fname <- as.character(x[[1]])
children <- flat_map_chr(as.list(x[-1]), all_calls)
c(fname, children)
})
}
all_calls <- function(x) {
unique(all_calls_rec(x))
}
all_calls(expr(f(g + b, c, d(a))))
#> [1] "f" "+" "d"创建一个闭包函数生成未知函数：
unknown_op <- function(op) {
new_function(
exprs(... = ),
expr({
contents <- paste(..., collapse = ", ")
paste0(!!paste0("\\mathrm{", op, "}("), contents, ")")
})
)
}
unknown_op("foo")
#> function (...)
#> {
#> contents <- paste(..., collapse = ", ")
#> paste0("\\mathrm{foo}(", contents, ")")
#> }
#> <environment: 0x0000020234685060>更新latex_env()：
latex_env <- function(expr) {
calls <- all_calls(expr)
call_list <- map(set_names(calls), unknown_op)
call_env <- as_environment(call_list)
# Known functions
f_env <- env_clone(f_env, call_env)
# Default symbols
names <- all_names(expr)
symbol_env <- as_environment(set_names(names), parent = f_env)
# Known symbols
greek_env <- env_clone(greek_env, parent = symbol_env)
greek_env
}测试：
to_math(sin(pi) + f(a))
#> <LATEX> \sin(\pi) + \mathrm{f}(a)你可以进一步拓展这个想法，翻译数学表达式的类型，但你应该不再需要任何额外的元编程工具了。