21.Rmd (13921B)
1 --- 2 engine: knitr 3 title: Translating R code 4 --- 5 6 ## Learning objectives: 7 8 - Build DSL (domain specific languages) to aid interoperability between R, HTML and LaTeX 9 - Reinforce metaprogramming concepts (expressions, quasiquotation, evaluation) 10 11 ```{r, echo = FALSE, eval = TRUE} 12 DiagrammeR::mermaid(" 13 graph LR 14 15 expressions --> R 16 quasiquotation --> R 17 evaluation --> R 18 19 R --> HTML 20 R --> LaTeX 21 ") 22 ``` 23 24 <details> 25 <summary>Mermaid code</summary> 26 ```{r, echo = TRUE, eval = FALSE} 27 DiagrammeR::mermaid(" 28 graph LR 29 30 expressions --> R 31 quasiquotation --> R 32 evaluation --> R 33 34 R --> HTML 35 R --> LaTeX 36 ") 37 ``` 38 39 </details> 40 41 <details> 42 <summary>Session Info</summary> 43 ```{r, message = FALSE, warning = FALSE} 44 library(DiagrammeR) #for Mermaid flowchart 45 library(lobstr) #abstract syntax trees 46 library(purrr) #functional programming 47 library(rlang) #tidy evaluation 48 49 # from section 18.5 50 expr_type <- function(x) { 51 if (rlang::is_syntactic_literal(x)) { 52 "constant" 53 } else if (is.symbol(x)) { 54 "symbol" 55 } else if (is.call(x)) { 56 "call" 57 } else if (is.pairlist(x)) { 58 "pairlist" 59 } else { 60 typeof(x) 61 } 62 } 63 flat_map_chr <- function(.x, .f, ...) { 64 purrr::flatten_chr(purrr::map(.x, .f, ...)) 65 } 66 switch_expr <- function(x, ...) { 67 switch(expr_type(x), 68 ..., 69 stop("Don't know how to handle type ", typeof(x), call. = FALSE) 70 ) 71 } 72 ``` 73 74 ```{r} 75 utils::sessionInfo() 76 ``` 77 78 </details> 79 80 ## Case Study: MCQ 81 82 We are going to use R code to generate HTML or LaTeX to produce multiple-choice questions such as 83 84 ### Pop Quiz! 85 86 1. What is the **derivative** of $f(x) = 1 + 2\cos(3\pi x + 4)$? 87 88 a. $f'(x) = 6\pi\sin(3\pi x + 4)$ 89 b. $f'(x) = -6\pi\sin(3\pi x + 4)$ 90 c. $f'(x) = 24\pi\sin(3\pi x + 4)$ 91 d. $f'(x) = -24\pi\sin(3\pi x + 4)$ 92 93 94 95  96 97 --- 98 99 As developers, we may be asking ourselves: 100 101 * What are the expressions? 102 * What are the symbols? 103 * Will we have to quote inputs from the user (math teacher)? 104 105 106 ## HTML 107 108 We are trying to produce 109 110 ```{} 111 <body> 112 <h1 id = 'pop_quiz'>Pop Quiz</h1> 113 <ol> 114 <li>What is the <b>derivative</b> of $f(x) = 1 + 2\cos(3\pi x + 4)$?</li> 115 <ol> 116 <li>$f'(x) = 6\pi\sin(3\pi x + 4)$</li> 117 <li>$f'(x) = -6\pi\sin(3\pi x + 4)$</li> 118 <li>$f'(x) = 24\pi\sin(3\pi x + 4)$</li> 119 <li>$f'(x) = -24\pi\sin(3\pi x + 4)$</li> 120 </ol> 121 </ol> 122 <img src = 'calculus_cat.png' width = '100' height = '100' /> 123 </body> 124 ``` 125 126 using DSL 127 128 ```{r, eval = FALSE} 129 with_html( 130 body( 131 h1("Pop quiz!", id = "pop_quiz"), 132 ol( 133 li("What is the ", b("derivative"), "of $f(x) = 1 + 2cos(3pi x + 4)$?"), 134 ol( 135 li("$f'(x) = 6pi*sin(3pi x + 4)$"), 136 li("$f'(x) = -6pi*sin(3pi x + 4)$"), 137 li("$f'(x) = 24pi*sin(3pi x + 4)$"), 138 li("$f'(x) = -24pi*sin(3pi x + 4)$") 139 ) 140 ), 141 img(src = "images/translating/calculus_cat.png", width = 100, height = 100) 142 ) 143 ) 144 ``` 145 146 In particular, 147 148 * **tags** such as `<b></b>` have *attributes* 149 * **void tags** such as `<img />` 150 * special characters: `&`, `<`, and `>` 151 152 153 <details> 154 <summary>HTML verification</summary> 155 156 ```{=html} 157 <body> 158 <h1 id = 'pop_quiz'>Pop Quiz</h1> 159 <ol> 160 <li>What is the <b>derivative</b> of $f(x) = 1 + 2\cos(3\pi x + 4)$?</li> 161 <ol> 162 <li>$f'(x) = 6\pi\sin(3\pi x + 4)$</li> 163 <li>$f'(x) = -6\pi\sin(3\pi x + 4)$</li> 164 <li>$f'(x) = 24\pi\sin(3\pi x + 4)$</li> 165 <li>$f'(x) = -24\pi\sin(3\pi x + 4)$</li> 166 </ol> 167 </ol> 168 <img src = 'images/translating/calculus_cat.png' width = '100' height = '100' /> 169 </body> 170 ``` 171 172 </details> 173 174 175 ## Escaping 176 177 * need to escape `&`, `<`, and `>` 178 * don't "double escape" 179 * leave HTML alone 180 181 ### S3 Class 182 183 ```{r} 184 html <- function(x) structure(x, class = "advr_html") 185 186 #dispatch 187 print.advr_html <- function(x, ...) { 188 out <- paste0("<HTML> ", x) 189 cat(paste(strwrap(out), collapse = "\n"), "\n", sep = "") 190 } 191 ``` 192 193 ### Generic 194 195 ```{r} 196 escape <- function(x) UseMethod("escape") 197 escape.character <- function(x) { 198 x <- gsub("&", "&", x) 199 x <- gsub("<", "<", x) 200 x <- gsub(">", ">", x) 201 html(x) 202 } 203 escape.advr_html <- function(x) x 204 ``` 205 206 ### Checks 207 208 ```{r} 209 escape("This is some text.") 210 escape("x > 1 & y < 2") 211 escape(escape("This is some text. 1 > 2")) #double escape 212 escape(html("<hr />")) #already html 213 ``` 214 215 216 ## Named Components 217 218 ```{} 219 li("What is the ", b("derivative"), "of $f(x) = 1 + 2\cos(3\pi x + 4)$?") 220 ``` 221 222 * aiming to classify `li` and `b` as **named components** 223 224 ```{r} 225 dots_partition <- function(...) { 226 dots <- list2(...) 227 228 if (is.null(names(dots))) { 229 is_named <- rep(FALSE, length(dots)) 230 } else { 231 is_named <- names(dots) != "" 232 } 233 234 list( 235 named = dots[is_named], 236 unnamed = dots[!is_named] 237 ) 238 } 239 ``` 240 241 ### Check 242 243 ```{r} 244 str(dots_partition(company = "Posit", 245 software = "RStudio", 246 "DSLC", 247 "Cohort 9")) 248 ``` 249 250 <details> 251 <summary>HTML Attributes</summary> 252 253 Found among the textbook's [source code](https://github.com/hadley/adv-r/blob/master/dsl-html-attributes.r) 254 255 ```{r} 256 html_attributes <- function(list) { 257 if (length(list) == 0) return("") 258 259 attr <- map2_chr(names(list), list, html_attribute) 260 paste0(" ", unlist(attr), collapse = "") 261 } 262 html_attribute <- function(name, value = NULL) { 263 if (length(value) == 0) return(name) # for attributes with no value 264 if (length(value) != 1) stop("`value` must be NULL or length 1") 265 266 if (is.logical(value)) { 267 # Convert T and F to true and false 268 value <- tolower(value) 269 } else { 270 value <- escape_attr(value) 271 } 272 paste0(name, "='", value, "'") 273 } 274 escape_attr <- function(x) { 275 x <- escape.character(x) 276 x <- gsub("\'", ''', x) 277 x <- gsub("\"", '"', x) 278 x <- gsub("\r", ' ', x) 279 x <- gsub("\n", ' ', x) 280 x 281 } 282 ``` 283 284 285 </details> 286 287 288 ## Tags (calls) 289 290 ```{r} 291 tag <- function(tag) { 292 new_function( 293 exprs(... = ), #arguments of new function 294 expr({ #body of the new function 295 296 #classify tags as named components 297 dots <- dots_partition(...) 298 299 #focus on named components as the tags 300 attribs <- html_attributes(dots$named) 301 302 # otherwise, nested code 303 children <- map_chr(dots$unnamed, escape) 304 305 # paste brackets, tag names, and attributes together 306 # then unquote user arguments 307 html(paste0( 308 !!paste0("<", tag), attribs, ">", 309 paste(children, collapse = ""), 310 !!paste0("</", tag, ">") 311 )) 312 }), 313 caller_env() #return the environment 314 ) 315 } 316 ``` 317 318 <details> 319 <summary>Void tags</summary> 320 321 ```{r} 322 void_tag <- function(tag) { 323 new_function( 324 exprs(... = ), #allows for missing arguments 325 expr({ 326 dots <- dots_partition(...) 327 328 # error check 329 if (length(dots$unnamed) > 0) { 330 abort(!!paste0("<", tag, "> must not have unnamed arguments")) 331 } 332 attribs <- html_attributes(dots$named) 333 334 html(paste0(!!paste0("<", tag), attribs, " />")) 335 }), 336 caller_env() 337 ) 338 } 339 ``` 340 341 </details> 342 343 ### Checks 344 345 ```{r} 346 tag("ol") 347 ``` 348 349 ```{r} 350 img <- void_tag("img") 351 ``` 352 353 ```{r, error = TRUE, results = "asis"} 354 img() 355 ``` 356 357 ```{r} 358 img(src = "images/translating/calculus_cat.png", 359 width = 100, 360 height = 100) 361 ``` 362 363 364 ## Tags (processing) 365 366 <details> 367 <summary>Venn Diagram</summary> 368  369 ```{r} 370 tags <- c("a", "abbr", "address", "article", "aside", "audio", 371 "b","bdi", "bdo", "blockquote", "body", "button", "canvas", 372 "caption","cite", "code", "colgroup", "data", "datalist", 373 "dd", "del","details", "dfn", "div", "dl", "dt", "em", 374 "eventsource","fieldset", "figcaption", "figure", "footer", 375 "form", "h1", "h2", "h3", "h4", "h5", "h6", "head", "header", 376 "hgroup", "html", "i","iframe", "ins", "kbd", "label", 377 "legend", "li", "mark", "map","menu", "meter", "nav", 378 "noscript", "object", "ol", "optgroup", "option", "output", 379 "p", "pre", "progress", "q", "ruby", "rp","rt", "s", "samp", 380 "script", "section", "select", "small", "span", "strong", 381 "style", "sub", "summary", "sup", "table", "tbody", "td", 382 "textarea", "tfoot", "th", "thead", "time", "title", "tr", 383 "u", "ul", "var", "video" 384 ) 385 386 void_tags <- c("area", "base", "br", "col", "command", "embed", 387 "hr", "img", "input", "keygen", "link", "meta", "param", 388 "source", "track", "wbr" 389 ) 390 ``` 391 392 </details> 393 394 ```{r} 395 html_tags <- c( 396 tags |> #list of tag names from HTML 397 set_names() |> #named variable to avoid reserved words! 398 map(tag), #make them function calls 399 void_tags |> 400 set_names() |> 401 map(void_tag) 402 ) 403 ``` 404 405 406 ### Example 407 408 ```{r} 409 html_tags$ol( 410 html_tags$li("What is the ", 411 html_tags$b("derivative"), 412 "of $f(x) = 1 + 2cos(3pi x + 4)$?")) 413 ``` 414 415 416 ## Bringing the HTML Together 417 418 ```{r} 419 with_html <- function(code) { 420 eval_tidy(enquo(code), html_tags) 421 } 422 ``` 423 424 ### Main Example 425 426 ```{r} 427 with_html( 428 body( 429 h1("Pop quiz!", id = "pop_quiz"), 430 ol( 431 li("What is the ", b("derivative"), "of $f(x) = 1 + 2cos(3pi x + 4)$?"), 432 ol( 433 li("$f'(x) = 6pi*sin(3pi x + 4)$"), 434 li("$f'(x) = -6pi*sin(3pi x + 4)$"), 435 li("$f'(x) = 24pi*sin(3pi x + 4)$"), 436 li("$f'(x) = -24pi*sin(3pi x + 4)$") 437 ) 438 ), 439 img(src = "images/translating/calculus_cat.png", width = 100, height = 100) 440 ) 441 ) 442 ``` 443 444 ### Check 445 446 ```{=html} 447 <h1 id='pop_quiz'>Pop quiz!</h1><ol><li>What is the <b>derivative</b> of $f(x) = 1 + 2cos(3pi x + 4)$?</li><ol><li>$f'(x) = 6pi*sin(3pi x + 4)$</li><li>$f'(x) = -6pi*sin(3pi x + 4)$</li><li>$f'(x) = 24pi*sin(3pi x + 4)$</li><li>$f'(x) = -24pi*sin(3pi x + 4)$</li></ol></ol><img src='images/translating/calculus_cat.png' width='100' height='100' /> 448 ``` 449 450 451 ## LaTeX 452 453 ```{r} 454 latex <- function(x) structure(x, class = "advr_latex") 455 print.advr_latex <- function(x) { cat("<LATEX> ", x, "\n", sep = "") } 456 ``` 457 458 ### to_math 459 460 ```{r, eval = FALSE} 461 to_math <- function(x) { 462 expr <- enexpr(x) 463 latex( #return LaTeX code 464 eval_bare( #eval_bare to ensure use of latex environment 465 expr, #expression (not quosure) 466 latex_env(expr) #need to define latex_env 467 )) 468 } 469 ``` 470 471 ## Known Symbols 472 473 ```{r} 474 greek_letters <- c( 475 "alpha", "beta", "chi", "delta", "Delta", "epsilon", "eta", 476 "gamma", "Gamma", "iota", "kappa", "lambda", "Lambda", "mu", 477 "nu", "omega", "Omega", "phi", "Phi", "pi", "Pi", "psi", "Psi", 478 "rho", "sigma", "Sigma", "tau", "theta", "Theta", "upsilon", 479 "Upsilon", "varepsilon", "varphi", "varrho", "vartheta", "xi", 480 "Xi", "zeta" 481 ) 482 483 greek_env <- rlang::as_environment( 484 rlang::set_names( 485 paste0("\\", greek_letters), #latex values 486 greek_letters #R names 487 ) 488 ) 489 ``` 490 491 ```{r} 492 str(as.list(greek_env)) 493 ``` 494 495 496 ## Known Functions 497 498 ### Unary Operations 499 500 ```{r} 501 unary_op <- function(left, right) { 502 new_function( 503 exprs(e1 = ), 504 expr( 505 paste0(!!left, e1, !!right) 506 ), 507 caller_env() 508 ) 509 } 510 ``` 511 512 ```{r} 513 #example 514 unary_op("\\sqrt{", "}") 515 ``` 516 517 ### Binary Operations 518 519 ```{r} 520 binary_op <- function(sep) { 521 new_function( 522 exprs(e1 = , e2 = ), 523 expr( 524 paste0(e1, !!sep, e2) 525 ), 526 caller_env() 527 ) 528 } 529 ``` 530 531 ```{r} 532 #example 533 binary_op("+") 534 ``` 535 536 <details> 537 <summary>Even more LaTeX syntax</summary> 538 539 ```{r} 540 known_func_env <- child_env( 541 .parent = empty_env(), 542 543 # Binary operators 544 `+` = binary_op(" + "), 545 `-` = binary_op(" - "), 546 `*` = binary_op(" * "), 547 `/` = binary_op(" / "), 548 `^` = binary_op("^"), 549 `[` = binary_op("_"), 550 551 # Grouping 552 `{` = unary_op("\\left{ ", " \\right}"), 553 `(` = unary_op("\\left( ", " \\right)"), 554 paste = paste, 555 556 # Other math functions 557 sqrt = unary_op("\\sqrt{", "}"), 558 sin = unary_op("\\sin(", ")"), 559 cos = unary_op("\\cos(", ")"), 560 tan = unary_op("\\tan(", ")"), 561 log = unary_op("\\log(", ")"), 562 abs = unary_op("\\left| ", "\\right| "), 563 frac = function(a, b) { 564 paste0("\\frac{", a, "}{", b, "}") 565 }, 566 567 # Labelling 568 hat = unary_op("\\hat{", "}"), 569 tilde = unary_op("\\tilde{", "}") 570 ) 571 ``` 572 573 </details> 574 575 576 ## Unknown Symbols 577 578 ```{r} 579 names_grabber <- function(x) { 580 switch_expr(x, 581 constant = character(), 582 symbol = as.character(x), 583 call = flat_map_chr(as.list(x[-1]), names_grabber) 584 ) |> 585 unique() 586 } 587 ``` 588 589 $$x + y + f(a, b, c, 10)$$ 590 591 ```{r} 592 names_grabber(expr(x + y + f(a, b, c, 10))) 593 ``` 594 595 ```{r} 596 lobstr::ast(expr(x + y + f(a, b, c, 10))) 597 ``` 598 599 600 ## Unknown Functions 601 602 ```{r} 603 calls_grabber <- function(x) { 604 switch_expr(x, 605 constant = , 606 symbol = character(), 607 call = { 608 fname <- as.character(x[[1]]) 609 children <- flat_map_chr(as.list(x[-1]), calls_grabber) 610 c(fname, children) 611 } 612 ) |> 613 unique() 614 } 615 ``` 616 617 $$f(g + b, c, d(a))$$ 618 619 ```{r} 620 names_grabber(expr(f(g + b, c, d(a)))) 621 calls_grabber(expr(f(g + b, c, d(a)))) 622 lobstr::ast(expr(f(g + b, c, d(a)))) 623 ``` 624 625 --- 626 627 ```{r} 628 seek_closure <- function(op) { 629 # change math font for function names 630 # apply ending parenthesis 631 new_function( 632 exprs(... = ), 633 expr({ 634 contents <- paste(..., collapse = ", ") 635 paste0(!!paste0("\\mathrm{", op, "}("), contents, ")") 636 }) 637 ) 638 } 639 ``` 640 641 ## Bringing the LaTeX Together 642 643 ```{r} 644 latex_env <- function(expr) { 645 646 # Unknown Functions 647 calls <- calls_grabber(expr) 648 call_list <- map(set_names(calls), seek_closure) 649 call_env <- as_environment(call_list) 650 651 # Known Functions 652 known_func_env <- env_clone(known_func_env, call_env) 653 654 # Unknown Symbols 655 names <- names_grabber(expr) 656 symbol_env <- as_environment(set_names(names), parent = known_func_env) 657 658 # Known symbols 659 greek_env <- env_clone(greek_env, parent = symbol_env) 660 greek_env 661 } 662 663 to_math <- function(x) { 664 expr <- enexpr(x) 665 latex( #return LaTeX code 666 eval_bare( #eval_bare to ensure use of latex environment 667 expr, #expression (not quosure) 668 latex_env(expr) #need to define latex_env 669 )) 670 } 671 ``` 672 673 ### Check 674 675 ```{r} 676 to_math(sin(pi) + f(a)) 677 ``` 678 679 ## Finishing the Example 680 681 (TO DO)