Chapter 21: Translating R CodePavitra ChakravartyR4DS Reading Group1 / 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

- HTML tag can have both attributes (e.g., id or class) and children (like  or ). 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  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 <- 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

Introduction

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

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

Clone slideshow

Toggle presenter mode

Restart the presentation timer

?, h

Toggle this help

Chapter 21: Translating R Code

Pavitra Chakravarty

R4DS Reading Group

Translating R code {#translation}

Introduction

S3 CLASSES

Basic tag functions

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

Getting back to getting attributes

<p></p>

Now for the children tags

Void Tags

Lets pull in all tags

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

Finally the DSL

Translating R code {#translation}

Introduction

Help

`<p></p>`