+ - 0:00:00
Notes for current slide
Notes for next slide

Chapter 21: Translating R Code

Pavitra Chakravarty

R4DS Reading Group

1 / 13

Translating R code {#translation}

Introduction

The combination of first-class environments, lexical scoping, and metaprogramming gives us a powerful toolkit for translating R code into other languages. One fully-fledged example of this idea is dbplyr, which powers the database backends for dplyr, allowing you to express data manipulation in R and automatically translate it into SQL. You can see the key idea in translate_sql() which takes R code and returns the equivalent SQL:

translate_sql(x ^ 2)
## <SQL> POWER(`x`, 2.0)
translate_sql(x < 5 & !is.na(x))
## <SQL> `x` < 5.0 AND NOT(((`x`) IS NULL))
translate_sql(!first %in% c("John", "Roger", "Robert"))
## <SQL> NOT(`first` IN ('John', 'Roger', 'Robert'))
translate_sql(select == 7)
## <SQL> `select` = 7.0
2 / 13

S3 CLASSES

The easiest way to do this is to create an S3 class that distinguishes between regular text (that needs escaping) and HTML (that doesn't).

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 = "")
}
html("1")
## <HTML> 1
3 / 13

We then write an escape generic. It has two important methods:

  • escape.character() takes a regular character vector and returns an HTML vector with special characters (&, <, >) escaped.

  • escape.advr_html() leaves already escaped HTML alone.

escape <- function(x) UseMethod("escape")
escape.character <- function(x) {
x <- gsub("&", "&amp;", x)
x <- gsub("<", "&lt;", x)
x <- gsub(">", "&gt;", x)
html(x)
}
escape.advr_html <- function(x) x

Some examples

escape("This is some text.")
## <HTML> This is some text.
escape("x > 1 & y < 2")
## <HTML> x &gt; 1 &amp; y &lt; 2
escape(escape("This is some text. 1 > 2"))
## <HTML> This is some text. 1 &gt; 2
escape(html("<hr />"))
## <HTML> <hr />
4 / 13

Basic tag functions

Now, lets look at the other tags in a html doc

<p>- HTML tag can have both attributes (e.g., id or class) and children (like <b> or <i>). Given that attributes are named and children are not, it seems natural to use named and unnamed arguments for them respectively. For example, a call to p() might look like:

p("Some text. ", b(i("some bold italic text")), class = "mypara")

We could list all the possible attributes of the <p> tag in the function definition, but that's hard because there are many. Instead, we'll use ... and separate the components based on whether or not they are named. With this in mind, we create a helper function that wraps around rlang::list2()

5 / 13

Lets refer back to 19.6 ... (dot-dot-dot)

One place we could use list2() is to create a wrapper around attributes() that allows us to set attributes flexibly:

numeric <- function(...) {
dots <- list2(...)
num <- as.numeric(dots)
set_names(num, names(dots))
}
x<-numeric(a=1,b=2,c=3,d=4)
x
## a b c d
## 1 2 3 4
test <- "q"
numeric( 1,!!!x,!!test:=9)
## a b c d q
## 1 1 2 3 4 9
6 / 13

Getting back to getting attributes

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
7 / 13

<p></p>

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", 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>
8 / 13

Now for the children tags

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>"))
## }
9 / 13

Void Tags

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>
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' />
10 / 13

Lets pull in all tags

tags <- c("a", "abbr", "address", "article", "aside", "audio",
"b","bdi", "bdo", "blockquote", "body", "button", "canvas",
"caption","cite", "code", "colgroup", "data", "datalist",
"dd", "del","details", "dfn", "div", "dl", "dt", "em",
"eventsource","fieldset", "figcaption", "figure", "footer",
"form", "h1", "h2", "h3", "h4", "h5", "h6", "head", "header",
"hgroup", "html", "i","iframe", "ins", "kbd", "label",
"legend", "li", "mark", "map","menu", "meter", "nav",
"noscript", "object", "ol", "optgroup", "option", "output",
"p", "pre", "progress", "q", "ruby", "rp","rt", "s", "samp",
"script", "section", "select", "small", "span", "strong",
"style", "sub", "summary", "sup", "table", "tbody", "td",
"textarea", "tfoot", "th", "thead", "time", "title", "tr",
"u", "ul", "var", "video"
)
void_tags <- c("area", "base", "br", "col", "command", "embed",
"hr", "img", "input", "keygen", "link", "meta", "param",
"source", "track", "wbr"
)
11 / 13

A lot of these tags are the same as base R function

So do not include in global environment or in a package

html_tags <- c(
tags %>% set_names() %>% map(tag),
void_tags %>% set_names() %>% map(void_tag)
)
12 / 13

Finally the DSL

with_html <- function(code) {
code <- enquo(code)
eval_tidy(code, html_tags)
}

Lets execute our DSL

with_html(
body(
h1("A heading", id = "first"),
p("Some text &", b("some bold text.")),
img(src = "myimg.png", width = 100, height = 100)
)
)
## <HTML> <body><h1 id='first'>A heading</h1><p>Some text &amp;<b>some
## bold text.</b></p><img src='myimg.png' width='100' height='100'
## /></body>
with_html(
body(
title("facebook", lang = "en", dir = "ltr"),
p("This is &", b("Facebook")),
img(src = "myimg.png", width = 100, height = 100)
)
)
## <HTML> <body><title lang='en' dir='ltr'>facebook</title><p>This is
## &amp;<b>Facebook</b></p><img src='myimg.png' width='100' height='100'
## /></body>
13 / 13

Translating R code {#translation}

Introduction

The combination of first-class environments, lexical scoping, and metaprogramming gives us a powerful toolkit for translating R code into other languages. One fully-fledged example of this idea is dbplyr, which powers the database backends for dplyr, allowing you to express data manipulation in R and automatically translate it into SQL. You can see the key idea in translate_sql() which takes R code and returns the equivalent SQL:

translate_sql(x ^ 2)
## <SQL> POWER(`x`, 2.0)
translate_sql(x < 5 & !is.na(x))
## <SQL> `x` < 5.0 AND NOT(((`x`) IS NULL))
translate_sql(!first %in% c("John", "Roger", "Robert"))
## <SQL> NOT(`first` IN ('John', 'Roger', 'Robert'))
translate_sql(select == 7)
## <SQL> `select` = 7.0
2 / 13
Paused

Help

Keyboard shortcuts

, , Pg Up, k Go to previous slide
, , Pg Dn, Space, j Go to next slide
Home Go to first slide
End Go to last slide
Number + Return Go to specific slide
b / m / f Toggle blackout / mirrored / fullscreen mode
c Clone slideshow
p Toggle presenter mode
t Restart the presentation timer
?, h Toggle this help
Esc Back to slideshow