1#' @import utils digest 2NULL 3 4# Like base::paste, but converts all string args to UTF-8 first. 5paste8 <- function(..., sep = " ", collapse = NULL) { 6 args <- c( 7 lapply(list(...), enc2utf8), 8 list( 9 sep = if (is.null(sep)) sep else enc2utf8(sep), 10 collapse = if (is.null(collapse)) collapse else enc2utf8(collapse) 11 ) 12 ) 13 14 do.call(paste, args) 15} 16 17# A special case of paste8 that employs paste0. Avoids the overhead of lapply. 18concat8 <- function(...) { 19 enc2utf8(paste0(...)) 20} 21 22# Reusable function for registering a set of methods with S3 manually. The 23# methods argument is a list of character vectors, each of which has the form 24# c(package, genname, class). 25registerMethods <- function(methods) { 26 lapply(methods, function(method) { 27 pkg <- method[[1]] 28 generic <- method[[2]] 29 class <- method[[3]] 30 func <- get(paste(generic, class, sep=".")) 31 if (pkg %in% loadedNamespaces()) { 32 registerS3method(generic, class, func, envir = asNamespace(pkg)) 33 } 34 setHook( 35 packageEvent(pkg, "onLoad"), 36 function(...) { 37 registerS3method(generic, class, func, envir = asNamespace(pkg)) 38 } 39 ) 40 }) 41} 42 43.onLoad <- function(...) { 44 # htmltools provides methods for knitr::knit_print, but knitr isn't a Depends or 45 # Imports of htmltools, only an Enhances. Therefore, the NAMESPACE file has to 46 # declare it as an export, not an S3method. That means that R will only know to 47 # use our methods if htmltools is actually attached, i.e., you have to use 48 # library(htmltools) in a knitr document or else you'll get escaped HTML in your 49 # document. This code snippet manually registers our methods with S3 once both 50 # htmltools and knitr are loaded. 51 registerMethods(list( 52 # c(package, genname, class) 53 c("knitr", "knit_print", "html"), 54 c("knitr", "knit_print", "shiny.tag"), 55 c("knitr", "knit_print", "shiny.tag.list") 56 )) 57 58 # TODO: After rlang >= 0.4.12 hits CRAN, remove this and replace 59 # with ` #' @importFrom rlang obj_address` 60 # (lionel says rlang:::sexp_address() will be available for the next few years) 61 assign("obj_address", getFromNamespace("sexp_address", "rlang"), environment(.onLoad)) 62} 63 64depListToNamedDepList <- function(dependencies) { 65 if (inherits(dependencies, "html_dependency")) 66 dependencies <- list(dependencies) 67 68 if (is.null(names(dependencies))) { 69 names(dependencies) <- sapply(dependencies, `[[`, "name") 70 } 71 return(dependencies) 72} 73 74#' Resolve a list of dependencies 75#' 76#' Given a list of dependencies, removes any redundant dependencies (based on 77#' name equality). If multiple versions of a dependency are found, the copy with 78#' the latest version number is used. 79#' 80#' @param dependencies A list of [htmlDependency()] objects. 81#' @param resolvePackageDir Whether to resolve the relative path to an absolute 82#' path via [system.file()] when the `package` attribute is 83#' present in a dependency object. 84#' @return dependencies A list of [htmlDependency()] objects with 85#' redundancies removed. 86#' 87#' @export 88resolveDependencies <- function(dependencies, resolvePackageDir = TRUE) { 89 deps <- resolveFunctionalDependencies(dependencies) 90 91 # Get names and numeric versions in vector/list form 92 depnames <- vapply(deps, function(x) x$name, character(1)) 93 depvers <- numeric_version(vapply(deps, function(x) x$version, character(1))) 94 95 # Get latest version of each dependency. `unique` uses the first occurrence of 96 # each dependency name, which is important for inter-dependent libraries. 97 return(lapply(unique(depnames), function(depname) { 98 # Sort by depname equality, then by version. Since na.last=NA, all elements 99 # whose names do not match will not be included in the sorted vector. 100 sorted <- order(ifelse(depnames == depname, TRUE, NA), depvers, 101 na.last = NA, decreasing = TRUE) 102 # The first element in the list is the one with the largest version. 103 dep <- deps[[sorted[[1]]]] 104 if (resolvePackageDir && !is.null(dep$package)) { 105 dir <- dep$src$file 106 if (!is.null(dir)) dep$src$file <- system.file(dir, package = dep$package) 107 dep$package <- NULL 108 } 109 dep 110 })) 111} 112 113# Remove `remove` from `dependencies` if the name matches. 114# dependencies is a named list of dependencies. 115# remove is a named list of dependencies that take priority. 116# If warnOnConflict, then warn when a dependency is being removed because of an 117# older version already being loaded. 118 119#' Subtract dependencies 120#' 121#' Remove a set of dependencies from another list of dependencies. The set of 122#' dependencies to remove can be expressed as either a character vector or a 123#' list; if the latter, a warning can be emitted if the version of the 124#' dependency being removed is later than the version of the dependency object 125#' that is causing the removal. 126#' 127#' @param dependencies A list of [htmlDependency()] objects from which 128#' dependencies should be removed. 129#' @param remove A list of [htmlDependency()] objects indicating which 130#' dependencies should be removed, or a character vector indicating dependency 131#' names. 132#' @param warnOnConflict If `TRUE`, a warning is emitted for each 133#' dependency that is removed if the corresponding dependency in `remove` 134#' has a lower version number. Has no effect if `remove` is provided as a 135#' character vector. 136#' 137#' @return A list of [htmlDependency()] objects that don't intersect 138#' with `remove`. 139#' 140#' @export 141subtractDependencies <- function(dependencies, remove, warnOnConflict = TRUE) { 142 dependencies <- resolveFunctionalDependencies(dependencies) 143 depnames <- vapply(dependencies, function(x) x$name, character(1)) 144 145 if (is.character(remove)) { 146 rmnames <- remove 147 } else { 148 remove <- resolveFunctionalDependencies(remove) 149 rmnames <- vapply(remove, function(x) x$name, character(1)) 150 } 151 152 matches <- depnames %in% rmnames 153 if (warnOnConflict && !is.character(remove)) { 154 for (loser in dependencies[matches]) { 155 winner <- remove[[head(rmnames == loser$name, 1)]] 156 if (compareVersion(loser$version, winner$version) > 0) { 157 warning(sprintf(paste("The dependency %s %s conflicts with", 158 "version %s"), loser$name, loser$version, winner$version 159 )) 160 } 161 } 162 } 163 164 # Return only deps that weren't in remove 165 return(dependencies[!matches]) 166} 167 168 169# Given a vector or list, drop all the NULL items in it 170dropNulls <- function(x) { 171 x[!vapply(x, is.null, FUN.VALUE=logical(1))] 172} 173 174nullOrEmpty <- function(x) { 175 length(x) == 0 176} 177 178# Given a vector or list, drop all the NULL or length-0 items in it 179dropNullsOrEmpty <- function(x) { 180 x[!vapply(x, nullOrEmpty, FUN.VALUE=logical(1))] 181} 182 183isResolvedTag <- function(x) { 184 inherits(x, "shiny.tag") && length(x$.renderHooks) == 0 185} 186 187isTag <- function(x) { 188 inherits(x, "shiny.tag") 189} 190 191#' @rdname print.html 192#' @export 193print.shiny.tag <- function(x, browse = is.browsable(x), ...) { 194 if (browse) 195 html_print(x) 196 else 197 print(HTML(as.character(x)), ...) 198 invisible(x) 199} 200 201# indent can be numeric to indicate an initial indent level, 202# or FALSE to suppress 203#' @export 204format.shiny.tag <- function(x, ..., singletons = character(0), indent = 0) { 205 as.character(renderTags(x, singletons = singletons, indent = indent)$html) 206} 207 208#' @export 209as.character.shiny.tag <- function(x, ...) { 210 as.character(renderTags(x)$html) 211} 212 213#' @export 214as.character.html <- function(x, ...) { 215 as.vector(enc2utf8(x)) 216} 217 218#' @export 219print.shiny.tag.list <- function(x, ...) { 220 if (isTRUE(attr(x, "print.as.list", exact = TRUE))) { 221 attr(x, "print.as.list") <- NULL 222 class(x) <- setdiff(class(x), "shiny.tag.list") 223 return(print(x)) 224 } 225 226 print.shiny.tag(x, ...) 227} 228 229#' @export 230format.shiny.tag.list <- format.shiny.tag 231 232#' @export 233as.character.shiny.tag.list <- as.character.shiny.tag 234 235#' Print method for HTML/tags 236#' 237#' S3 method for printing HTML that prints markup or renders HTML in a web 238#' browser. 239#' 240#' @param x The value to print. 241#' @param browse If `TRUE`, the HTML will be rendered and displayed in a 242#' browser (or possibly another HTML viewer supplied by the environment via 243#' the `viewer` option). If `FALSE` then the HTML object's markup 244#' will be rendered at the console. 245#' @param ... Additional arguments passed to print. 246#' 247#' @export 248print.html <- function(x, ..., browse = is.browsable(x)) { 249 if (browse) 250 html_print(x) 251 else 252 cat(x, "\n", sep = "") 253 invisible(x) 254} 255 256#' @export 257format.html <- function(x, ...) { 258 as.character(x) 259} 260 261normalizeText <- function(text) { 262 if (!is.null(attr(text, "html", TRUE))) 263 text 264 else 265 htmlEscape(text, attribute=FALSE) 266} 267 268#' Create a list of tags 269#' 270#' Create a `list()` of [tag]s with methods for [print()], [as.character()], 271#' etc. 272#' 273#' @param ... A collection of [tag]s. 274#' @export 275#' @examples 276#' tagList( 277#' h1("Title"), 278#' h2("Header text"), 279#' p("Text here") 280#' ) 281tagList <- function(...) { 282 lst <- dots_list(...) 283 class(lst) <- c("shiny.tag.list", "list") 284 return(lst) 285} 286 287#' Tag function 288#' 289#' Create 'lazily' rendered HTML [tags] (and/or [htmlDependencies()]). 290#' 291#' When possible, use [`tagAddRenderHook()`] to provide both a tag 292#' structure and utilize a render function. 293#' 294#' @param func a function with no arguments that returns HTML tags and/or 295#' dependencies. 296#' @seealso [`tagAddRenderHook()`] 297#' @export 298#' @examples 299#' myDivDep <- tagFunction(function() { 300#' if (isTRUE(getOption("useDep", TRUE))) { 301#' htmlDependency( 302#' name = "lazy-dependency", 303#' version = "1.0", src = "" 304#' ) 305#' } 306#' }) 307#' myDiv <- attachDependencies(div(), myDivDep) 308#' renderTags(myDiv) 309#' withr::with_options(list(useDep = FALSE), renderTags(myDiv)) 310#' 311tagFunction <- function(func) { 312 if (!is.function(func) || length(formals(func)) != 0) { 313 stop("`func` must be a function with no arguments") 314 } 315 structure(func, class = "shiny.tag.function") 316} 317 318#' Modify a tag prior to rendering 319#' 320#' Adds a hook to call on a [tag()] object when it is is rendered as HTML (with, 321#' for example, [print()], [renderTags()], [as.tags()], etc). 322#' 323#' The primary motivation for [tagAddRenderHook()] is to create tags that can 324#' change their attributes (e.g., change CSS classes) depending upon the context 325#' in which they're rendered (e.g., use one set of CSS classes in one a page 326#' layout, but a different set in another page layout). In this situation, 327#' [tagAddRenderHook()] is preferable to [tagFunction()] since the latter is more a 328#' "black box" in the sense that you don't know anything about the tag structure 329#' until it's rendered. 330#' 331#' @param tag A [`tag()`] object. 332#' @param func A function (_hook_) to call when the `tag` is rendered. This function 333#' should have at least one argument (the `tag`) and return anything that can 334#' be converted into tags via [as.tags()]. 335#' @param replace If `TRUE`, the previous hooks will be removed. If `FALSE`, 336#' `func` is appended to the previous hooks. 337#' @return A [tag()] object with a `.renderHooks` field containing a list of functions 338#' (e.g. `func`). When the return value is _rendered_ (such as with [`as.tags()`]), 339#' these functions will be called just prior to writing the HTML. 340#' @export 341#' @seealso [tagFunction()] 342#' @examples 343#' # Have a place holder div and return a span instead 344#' obj <- div("example", .renderHook = function(x) { 345#' x$name <- "span" 346#' x 347#' }) 348#' obj$name # "div" 349#' print(obj) # Prints as a `span` 350#' 351#' # Add a class to the tag 352#' # Should print a `span` with class `"extra"` 353#' spanExtra <- tagAddRenderHook(obj, function(x) { 354#' tagAppendAttributes(x, class = "extra") 355#' }) 356#' spanExtra 357#' 358#' # Replace the previous render method 359#' # Should print a `div` with class `"extra"` 360#' divExtra <- tagAddRenderHook(obj, replace = TRUE, function(x) { 361#' tagAppendAttributes(x, class = "extra") 362#' }) 363#' divExtra 364#' 365#' # Add more child tags 366#' spanExtended <- tagAddRenderHook(obj, function(x) { 367#' tagAppendChildren(x, " ", tags$strong("bold text")) 368#' }) 369#' spanExtended 370#' 371#' # Add a new html dependency 372#' newDep <- tagAddRenderHook(obj, function(x) { 373#' fa <- htmlDependency( 374#' "font-awesome", "4.5.0", c(href="shared/font-awesome"), 375#' stylesheet = "css/font-awesome.min.css") 376#' attachDependencies(x, fa, append = TRUE) 377#' }) 378#' # Also add a jqueryui html dependency 379#' htmlDependencies(newDep) <- htmlDependency( 380#' "jqueryui", "1.11.4", c(href="shared/jqueryui"), 381#' script = "jquery-ui.min.js") 382#' # At render time, both dependencies will be found 383#' renderTags(newDep)$dependencies 384#' 385#' # Ignore the original tag and return something completely new. 386#' newObj <- tagAddRenderHook(obj, function(x) { 387#' tags$p("Something else") 388#' }) 389#' newObj 390tagAddRenderHook <- function(tag, func, replace = FALSE) { 391 if (!is.function(func) || length(formals(func)) == 0) { 392 stop("`func` must be a function that accepts at least 1 argument") 393 } 394 395 tag$.renderHooks <- 396 if (isTRUE(replace)) { 397 list(func) 398 } else { 399 append(tag$.renderHooks, list(func)) 400 } 401 402 tag 403} 404 405 406#' Append tag attributes 407#' 408#' Append (`tagAppendAttributes()`), check existence (`tagHasAttribute()`), 409#' and obtain the value (`tagGetAttribute()`) of HTML attribute(s). 410#' 411#' @export 412#' @param tag a [tag] object. 413#' @param ... a collection of attributes. 414#' @param .cssSelector A character string containing a [CSS 415#' selector](https://developer.mozilla.org/en-US/docs/Learn/CSS/Building_blocks/Selectors) 416#' for targeting particular (inner) tags of interest. At the moment, only a 417#' combination of 418#' [type](https://www.w3.org/TR/CSS22/selector.html#type-selectors) (e.g, 419#' `div`), [class](https://www.w3.org/TR/CSS22/selector.html#class-html) 420#' (e.g., `.my-class`), 421#' [id](https://www.w3.org/TR/CSS22/selector.html#id-selectors) (e.g., 422#' `#myID`), and 423#' [universal](https://www.w3.org/TR/CSS22/selector.html#universal-selector) 424#' (`*`) selectors within a given [simple 425#' selector](https://www.w3.org/TR/CSS22/selector.html#selector-syntax) is 426#' supported. Note, if `.cssSelector` is used, the returned tags will have 427#' their `$children` fields flattened to a single `list()` via [`tagQuery()`]. 428#' @seealso [tagAppendChildren()], [tagQuery()] 429#' @examples 430#' html <- div(a()) 431#' tagAppendAttributes(html, class = "foo") 432#' tagAppendAttributes(html, .cssSelector = "a", class = "bar") 433#' 434#' tagHasAttribute(div(foo = "bar"), "foo") 435#' tagGetAttribute(div(foo = "bar"), "foo") 436#' 437tagAppendAttributes <- function(tag, ..., .cssSelector = NULL) { 438 throw_if_tag_function(tag) 439 440 if (!is.null(.cssSelector)) { 441 return( 442 tagQuery(tag)$ 443 find(.cssSelector)$ 444 addAttrs(...)$ 445 allTags() 446 ) 447 } 448 449 newAttribs <- dropNullsOrEmpty(dots_list(...)) 450 if (any(!nzchar(names2(newAttribs)))) { 451 stop( 452 "At least one of the new attribute values did not have a name.\n", 453 "Did you forget to include an attribute name?" 454 ) 455 } 456 tag$attribs <- c(tag$attribs, newAttribs) 457 tag 458} 459 460#' @rdname tagAppendAttributes 461#' @param attr The name of an attribute. 462#' @export 463tagHasAttribute <- function(tag, attr) { 464 throw_if_tag_function(tag) 465 result <- attr %in% names(tag$attribs) 466 result 467} 468 469#' @rdname tagAppendAttributes 470#' @export 471tagGetAttribute <- function(tag, attr) { 472 throw_if_tag_function(tag) 473 # Find out which positions in the attributes list correspond to the given attr 474 attribs <- tag$attribs 475 attrIdx <- which(attr == names(attribs)) 476 477 if (length(attrIdx) == 0) { 478 return (NULL) 479 } 480 481 result <- attribs[attrIdx] 482 # Remove NA values or return a single NA value 483 if (anyNA(result)) { 484 na_idx <- is.na(result) 485 if (all(na_idx)) { 486 return(NA) 487 } 488 result <- result[!na_idx] 489 } 490 491 if (all(vapply(result, is.atomic, logical(1)))) { 492 # Convert all attribs to chars explicitly; prevents us from messing up factors 493 # Separate multiple attributes with the same name 494 vals <- vapply(result, function(val) { 495 val <- as.character(val) 496 # Combine vector values if they exist 497 if (length(val) > 1) { 498 val <- paste0(val, collapse = " ") 499 } 500 val 501 }, character(1)) 502 result <- paste0(vals, collapse = " ") 503 } else { 504 # When retrieving values that are not atomic, return a list of values 505 names(result) <- NULL 506 } 507 508 result 509} 510 511#' Modify tag contents 512#' 513#' Modify the contents (aka children) of a [tag] object. 514#' 515#' @inheritParams tagAppendAttributes 516#' @param child A child element to append to a parent tag. 517#' @export 518#' @seealso [tagAppendAttributes()], [tagQuery()] 519#' @examples 520#' html <- div(a(), h1()) 521#' tagAppendChild(html, span()) 522#' tagAppendChild(html, .cssSelector = "a", span()) 523#' 524#' tagAppendChildren(html, span(), p()) 525#' tagAppendChildren(html, .cssSelector = "a", span(), p()) 526#' 527#' tagSetChildren(html, span(), p()) 528#' 529#' tagInsertChildren(html, after = 1, span(), p()) 530#' 531tagAppendChild <- function(tag, child, .cssSelector = NULL) { 532 throw_if_tag_function(tag) 533 534 if (!is.null(.cssSelector)) { 535 return( 536 tagAppendChildren(tag, child, .cssSelector = .cssSelector) 537 ) 538 } 539 540 tag$children[[length(tag$children)+1]] <- child 541 tag 542} 543 544 545#' @rdname tagAppendChild 546#' @param ... a collection of `child` elements. 547#' @param list Deprecated. Use `!!!` instead to splice into `...`. 548#' @export 549tagAppendChildren <- function(tag, ..., .cssSelector = NULL, list = NULL) { 550 throw_if_tag_function(tag) 551 552 children <- unname(c(dots_list(...), list)) 553 554 if (!is.null(.cssSelector)) { 555 return( 556 tagQuery(tag)$ 557 find(.cssSelector)$ 558 append(!!!children)$ 559 allTags() 560 ) 561 } 562 563 tag$children <- unname(c(tag$children, children)) 564 tag 565} 566 567#' @rdname tagAppendChild 568#' @export 569tagSetChildren <- function(tag, ..., .cssSelector = NULL, list = NULL) { 570 throw_if_tag_function(tag) 571 572 children <- unname(c(dots_list(...), list)) 573 574 if (!is.null(.cssSelector)) { 575 return( 576 tagQuery(tag)$ 577 find(.cssSelector)$ 578 empty()$ 579 append(!!!children)$ 580 allTags() 581 ) 582 } 583 584 tag$children <- children 585 tag 586} 587 588#' @rdname tagAppendChild 589#' @param after an integer value (i.e., subscript) referring to the child position to append after. 590#' @export 591tagInsertChildren <- function(tag, after, ..., .cssSelector = NULL, list = NULL) { 592 throw_if_tag_function(tag) 593 594 children <- unname(c(dots_list(...), list)) 595 596 if (!is.null(.cssSelector)) { 597 return( 598 tagQuery(tag)$ 599 find(.cssSelector)$ 600 each(function(x, i) { 601 tagInsertChildren(x, after = after, !!!children) 602 })$ 603 allTags() 604 ) 605 } 606 607 tag$children <- unname(append(tag$children, children, after)) 608 tag 609} 610 611throw_if_tag_function <- function(tag) { 612 if (is_tag_function(tag)) 613 stop("`tag` can not be a `tagFunction()`") 614} 615 616 617# Use `known_tags` from `known_tags.R` 618# Then remove `known_tags` once done creating tag functions 619#' @include known_tags.R 620names(known_tags) <- known_tags 621 622#' Create HTML tags 623#' 624#' Create an R object that represents an HTML tag. For convenience, common HTML 625#' tags (e.g., `<div>`) can be created by calling for their tag name directly 626#' (e.g., `div()`). To create less common HTML5 (or SVG) tags (e.g., 627#' `<article>`), use the `tags` list collection (e.g., `tags$article()`). To 628#' create other non HTML/SVG tags, use the lower-level `tag()` constructor. 629#' 630#' @name builder 631#' @param ... Tag attributes (named arguments) and children (unnamed arguments). 632#' A named argument with an `NA` value is rendered as a boolean attributes 633#' (see example). Children may include any combination of: 634#' * Other tags objects 635#' * [HTML()] strings 636#' * [htmlDependency()]s 637#' * Single-element atomic vectors 638#' * `list()`s containing any combination of the above 639#' @return A `list()` with a `shiny.tag` class that can be converted into an 640#' HTML string via `as.character()` and saved to a file with `save_html()`. 641#' @seealso [tagList()], [withTags()], [tagAppendAttributes()], [tagQuery()] 642#' @examples 643#' tags$html( 644#' tags$head( 645#' tags$title('My first page') 646#' ), 647#' tags$body( 648#' h1('My first heading'), 649#' p('My first paragraph, with some ', strong('bold'), ' text.'), 650#' div( 651#' id = 'myDiv', class = 'simpleDiv', 652#' 'Here is a div with some attributes.' 653#' ) 654#' ) 655#' ) 656#' 657#' # html5 <audio> with boolean control attribute 658#' # https://www.w3.org/TR/html5/infrastructure.html#sec-boolean-attributes 659#' tags$audio( 660#' controls = NA, 661#' tags$source( 662#' src = "myfile.wav", 663#' type = "audio/wav" 664#' ) 665#' ) 666#' 667#' # suppress the whitespace between tags 668#' tags$span( 669#' tags$strong("I'm strong", .noWS="outside") 670#' ) 671#' 672NULL 673 674#' @rdname builder 675#' @format NULL 676#' @docType NULL 677#' @keywords NULL 678#' @import rlang 679#' @export 680tags <- lapply(known_tags, function(tagname) { 681 # Overwrite the body with the `tagname` value injected into the body 682 new_function( 683 args = exprs(... = , .noWS = NULL, .renderHook = NULL), 684 expr({ 685 validateNoWS(.noWS) 686 contents <- dots_list(...) 687 tag(!!tagname, contents, .noWS = .noWS, .renderHook = .renderHook) 688 }), 689 env = asNamespace("htmltools") 690 ) 691}) 692 693# known_tags is no longer needed, so remove it. 694rm(known_tags) 695 696 697#' @rdname builder 698#' @export 699p <- tags$p 700 701#' @rdname builder 702#' @export 703h1 <- tags$h1 704 705#' @rdname builder 706#' @export 707h2 <- tags$h2 708 709#' @rdname builder 710#' @export 711h3 <- tags$h3 712 713#' @rdname builder 714#' @export 715h4 <- tags$h4 716 717#' @rdname builder 718#' @export 719h5 <- tags$h5 720 721#' @rdname builder 722#' @export 723h6 <- tags$h6 724 725#' @rdname builder 726#' @export 727a <- tags$a 728 729#' @rdname builder 730#' @export 731br <- tags$br 732 733#' @rdname builder 734#' @export 735div <- tags$div 736 737#' @rdname builder 738#' @export 739span <- tags$span 740 741#' @rdname builder 742#' @export 743pre <- tags$pre 744 745#' @rdname builder 746#' @export 747code <- tags$code 748 749#' @rdname builder 750#' @export 751img <- tags$img 752 753#' @rdname builder 754#' @export 755strong <- tags$strong 756 757#' @rdname builder 758#' @export 759em <- tags$em 760 761#' @rdname builder 762#' @export 763hr <- tags$hr 764 765 766#' @rdname builder 767#' @param _tag_name A character string to use for the tag name. 768#' @param varArgs List of tag attributes and children. 769#' @param .noWS Character vector used to omit some of the whitespace that would 770#' normally be written around this tag. Valid options include `before`, 771#' `after`, `outside`, `after-begin`, and `before-end`. 772#' Any number of these options can be specified. 773#' @param .renderHook A function (or list of functions) to call when the `tag` is rendered. This 774#' function should have at least one argument (the `tag`) and return anything 775#' that can be converted into tags via [as.tags()]. Additional hooks may also be 776#' added to a particular `tag` via [tagAddRenderHook()]. 777#' @export 778tag <- function(`_tag_name`, varArgs, .noWS = NULL, .renderHook = NULL) { 779 validateNoWS(.noWS) 780 # Get arg names; if not a named list, use vector of empty strings 781 varArgsNames <- names2(varArgs) 782 783 # Named arguments become attribs, dropping NULL and length-0 values 784 named_idx <- nzchar(varArgsNames) 785 attribs <- dropNullsOrEmpty(varArgs[named_idx]) 786 787 # Unnamed arguments are flattened and added as children. 788 # Use unname() to remove the names attribute from the list, which would 789 # consist of empty strings anyway. 790 children <- unname(varArgs[!named_idx]) 791 792 st <- list(name = `_tag_name`, 793 attribs = attribs, 794 children = children) 795 796 # Conditionally include the `.noWS` field. 797 # We do this to avoid breaking the hashes of existing tags that weren't leveraging .noWS. 798 if (!is.null(.noWS)) { 799 st$.noWS <- .noWS 800 } 801 # Conditionally include the `.renderHooks` field. 802 # We do this to avoid breaking the hashes of existing tags that weren't leveraging .renderHooks. 803 if (!is.null(.renderHook)) { 804 if (!is.list(.renderHook)) { 805 .renderHook <- list(.renderHook) 806 } 807 st$.renderHooks <- .renderHook 808 } 809 810 # Return tag data structure 811 structure(st, class = "shiny.tag") 812} 813 814isTagList <- function(x) { 815 is.list(x) && (inherits(x, "shiny.tag.list") || identical(class(x), "list")) 816} 817 818noWSOptions <- c("before", "after", "after-begin", "before-end", "outside", "inside") 819# Ensure that the provided `.noWS` string contains only valid options 820validateNoWS <- function(.noWS) { 821 if (!all(.noWS %in% noWSOptions)) { 822 stop("Invalid .noWS option(s) '", paste(.noWS, collapse="', '") ,"' specified.") 823 } 824} 825 826#' @include utils.R 827tagWrite <- function(tag, textWriter, indent=0, eol = "\n") { 828 829 if (length(tag) == 0) 830 return (NULL) 831 832 # optionally process a list of tags 833 if (!isTag(tag) && isTagList(tag)) { 834 tag <- dropNullsOrEmpty(flattenTags(tag)) 835 lapply(tag, tagWrite, textWriter, indent) 836 return (NULL) 837 } 838 839 nextIndent <- if (is.numeric(indent)) indent + 1 else indent 840 indent <- if (is.numeric(indent)) indent else 0 841 842 # compute indent text 843 indentText <- paste(rep(" ", indent*2), collapse="") 844 textWriter$writeWS(indentText) 845 846 # Check if it's just text (may either be plain-text or HTML) 847 if (is.character(tag)) { 848 .noWS <- attr(tag, "noWS", exact = TRUE) 849 if ("before" %in% .noWS || "outside" %in% .noWS) { 850 textWriter$eatWS() 851 } 852 textWriter$write(normalizeText(tag)) 853 if ("after" %in% .noWS || "outside" %in% .noWS) { 854 textWriter$eatWS() 855 } 856 textWriter$writeWS(eol) 857 return (NULL) 858 } 859 860 .noWS <- tag$.noWS 861 862 if ("before" %in% .noWS || "outside" %in% .noWS) { 863 textWriter$eatWS() 864 } 865 866 # write tag name 867 textWriter$write(concat8("<", tag$name)) 868 869 # Convert all attribs to chars explicitly; prevents us from messing up factors 870 attribs <- flattenTagAttribs(lapply(tag$attribs, as.character)) 871 attribNames <- names2(attribs) 872 if (any(!nzchar(attribNames))) { 873 # Can not display attrib without a key 874 stop( 875 "A tag's attribute value did not have a name.\n", 876 "Did you forget to name all of your attribute values?" 877 ) 878 } 879 880 # write attributes 881 for (attrib in attribNames) { 882 attribValue <- attribs[[attrib]] 883 if (length(attribValue) > 1) { 884 attribValue <- concat8(attribValue, collapse = " ") 885 } 886 if (!is.na(attribValue)) { 887 if (is.logical(attribValue)) { 888 attribValue <- tolower(attribValue) 889 } 890 text <- htmlEscape(attribValue, attribute=TRUE) 891 textWriter$write(concat8(" ", attrib,"=\"", text, "\"")) 892 } 893 else { 894 textWriter$write(concat8(" ", attrib)) 895 } 896 } 897 898 # write any children 899 children <- dropNullsOrEmpty(flattenTags(tag$children)) 900 if (length(children) > 0) { 901 textWriter$write(">") 902 903 # special case for a single child text node (skip newlines and indentation) 904 if ((length(children) == 1) && is.character(children[[1]]) ) { 905 textWriter$write(concat8(normalizeText(children[[1]]), "</", tag$name, ">")) 906 } 907 else { 908 if ("after-begin" %in% .noWS || "inside" %in% .noWS) { 909 textWriter$eatWS() 910 } 911 textWriter$writeWS("\n") 912 for (child in children) 913 tagWrite(child, textWriter, nextIndent) 914 textWriter$writeWS(indentText) 915 if ("before-end" %in% .noWS || "inside" %in% .noWS) { 916 textWriter$eatWS() 917 } 918 textWriter$write(concat8("</", tag$name, ">")) 919 } 920 } 921 else { 922 # only self-close void elements 923 # (see: http://dev.w3.org/html5/spec/single-page.html#void-elements) 924 if (tag$name %in% c("area", "base", "br", "col", "command", "embed", "hr", 925 "img", "input", "keygen", "link", "meta", "param", 926 "source", "track", "wbr")) { 927 textWriter$write("/>") 928 } 929 else { 930 textWriter$write(concat8("></", tag$name, ">")) 931 } 932 } 933 if ("after" %in% .noWS || "outside" %in% .noWS) { 934 textWriter$eatWS() 935 } 936 textWriter$writeWS(eol) 937} 938 939#' Render tags into HTML 940#' 941#' Renders tags (and objects that can be converted into tags using 942#' [as.tags()]) into HTML. (Generally intended to be called from web 943#' framework libraries, not directly by most users--see 944#' [print.html()] for higher level rendering.) 945#' 946#' @param x Tag object(s) to render 947#' @param singletons A list of [singleton] signatures to consider already 948#' rendered; any matching singletons will be dropped instead of rendered. 949#' (This is useful (only?) for incremental rendering.) 950#' @param indent Initial indent level, or `FALSE` if no indentation should 951#' be used. 952#' 953#' @return `renderTags` returns a list with the following variables: 954#' * `head`: An [HTML()] string that should be included in `<head>`. 955#' * `singletons`: Character vector of singleton signatures that are 956#' known after rendering. 957#' * `dependencies`: A list of [resolved][resolveDependencies] [htmlDependency()] objects. 958#' * `html`: An [HTML()] string that represents the main HTML that was rendered. 959#' 960#' @export 961renderTags <- function(x, singletons = character(0), indent = 0) { 962 x <- tagify(x) 963 # Do singleton and head processing before rendering 964 singletonInfo <- takeSingletons(x, singletons) 965 headInfo <- takeHeads(singletonInfo$ui) 966 deps <- resolveDependencies(findDependencies(singletonInfo$ui, tagify = FALSE)) 967 968 headIndent <- if (is.numeric(indent)) indent + 1 else indent 969 headHtml <- doRenderTags(headInfo$head, indent = headIndent) 970 bodyHtml <- doRenderTags(headInfo$ui, indent = indent) 971 972 return(list(head = headHtml, 973 singletons = singletonInfo$singletons, 974 dependencies = deps, 975 html = bodyHtml)) 976} 977 978#' @details `doRenderTags` is intended for very low-level use; it ignores 979#' render hooks, singletons, head, and dependency handling, and simply renders the given tag 980#' objects as HTML. Please use `renderTags()` if `x` has not already handled its dependencies 981#' and render hooks. 982#' @return `doRenderTags` returns a simple [HTML()] string. 983#' @rdname renderTags 984#' @export 985doRenderTags <- function(x, indent = 0) { 986 assertNotTagEnvLike(x, "doRenderTags") 987 988 textWriter <- WSTextWriter() 989 tagWrite(x, textWriter, indent) 990 # Strip off trailing \n (if present?) 991 textWriter$eatWS() 992 HTML(textWriter$readAll()) 993} 994 995# Walk a tree of tag objects, rewriting objects according to func. 996# preorder=TRUE means preorder tree traversal, that is, an object 997# should be rewritten before its children. 998rewriteTags <- function(ui, func, preorder) { 999 assertNotTagEnvLike(ui, "rewriteTags") 1000 1001 if (preorder) 1002 ui <- func(ui) 1003 1004 if (isTag(ui)) { 1005 ui$children[] <- lapply(ui$children, rewriteTags, func, preorder) 1006 } else if (isTagList(ui)) { 1007 ui[] <- lapply(ui, rewriteTags, func, preorder) 1008 } 1009 1010 if (!preorder) 1011 ui <- func(ui) 1012 1013 return(ui) 1014} 1015 1016#' Singleton manipulation functions 1017#' 1018#' Functions for manipulating [singleton()] objects in tag 1019#' hierarchies. Intended for framework authors. 1020#' 1021#' @rdname singleton_tools 1022#' @name singleton_tools 1023NULL 1024 1025#' @param ui Tag object or lists of tag objects. See [builder] topic. 1026#' @return `surroundSingletons` preprocesses a tag object by changing any 1027#' singleton X into `<!--SHINY.SINGLETON[sig]-->X'<!--/SHINY.SINGLETON[sig]-->` 1028#' where sig is the sha1 of X, and X' is X minus the singleton attribute. 1029#' @rdname singleton_tools 1030#' @export 1031surroundSingletons <- local({ 1032 # In the case of nested singletons, outer singletons are processed 1033 # before inner singletons (otherwise the processing of inner 1034 # singletons would cause the sha1 of the outer singletons to be 1035 # different). 1036 surroundSingleton <- function(uiObj) { 1037 if (is.singleton(uiObj)) { 1038 sig <- digest(uiObj, "sha1") 1039 uiObj <- singleton(uiObj, FALSE) 1040 return(tagList( 1041 HTML(sprintf("<!--SHINY.SINGLETON[%s]-->", sig)), 1042 uiObj, 1043 HTML(sprintf("<!--/SHINY.SINGLETON[%s]-->", sig)) 1044 )) 1045 } else { 1046 uiObj 1047 } 1048 } 1049 1050 function(ui) { 1051 rewriteTags(ui, surroundSingleton, TRUE) 1052 } 1053}) 1054 1055#' @param singletons Character vector of singleton signatures that have already 1056#' been encountered (i.e. returned from previous calls to 1057#' `takeSingletons`). 1058#' @param desingleton Logical value indicating whether singletons that are 1059#' encountered should have the singleton attribute removed. 1060#' @return `takeSingletons` returns a list with the elements `ui` (the 1061#' processed tag objects with any duplicate singleton objects removed) and 1062#' `singletons` (the list of known singleton signatures). 1063#' @rdname singleton_tools 1064#' @export 1065takeSingletons <- function(ui, singletons=character(0), desingleton=TRUE) { 1066 result <- rewriteTags(ui, function(uiObj) { 1067 if (is.singleton(uiObj)) { 1068 sig <- digest(uiObj, "sha1") 1069 if (sig %in% singletons) 1070 return(NULL) 1071 singletons <<- append(singletons, sig) 1072 if (desingleton) 1073 uiObj <- singleton(uiObj, FALSE) 1074 return(uiObj) 1075 } else { 1076 return(uiObj) 1077 } 1078 }, TRUE) 1079 1080 return(list(ui=result, singletons=singletons)) 1081} 1082 1083# Given a tag object, extract out any children of tags$head 1084# and return them separate from the body. 1085takeHeads <- function(ui) { 1086 headItems <- list() 1087 result <- rewriteTags(ui, function(uiObj) { 1088 if (isTag(uiObj) && tolower(uiObj$name) == "head") { 1089 headItems <<- append(headItems, uiObj$children) 1090 return(NULL) 1091 } 1092 return(uiObj) 1093 }, FALSE) 1094 1095 return(list(ui=result, head=headItems)) 1096} 1097 1098#' Collect attached dependencies from HTML tag object 1099#' 1100#' Walks a hierarchy of tags looking for attached dependencies. 1101#' 1102#' @param tags A tag-like object to search for dependencies. 1103#' @param tagify Whether to tagify the input before searching for dependencies. 1104#' 1105#' @return A list of [htmlDependency()] objects. 1106#' 1107#' @export 1108findDependencies <- function(tags, tagify = TRUE) { 1109 if (isTRUE(tagify)) { 1110 tags <- tagify(tags) 1111 } 1112 deps <- resolveFunctionalDependencies(htmlDependencies(tags)) 1113 children <- if (is.list(tags)) { 1114 if (isTag(tags)) { 1115 tags$children 1116 } else { 1117 tags 1118 } 1119 } 1120 childDeps <- unlist(lapply(children, findDependencies, tagify = FALSE), recursive = FALSE, use.names = FALSE) 1121 c(childDeps, deps) 1122} 1123 1124 1125#' Resolves any [tagFunction()]s inside a list of [htmlDependencies()]. To 1126#' resolve [tagFunction()]s _and then_ remove redundant dependencies all at once, 1127#' use [resolveDependencies()] (which calls this function internally). 1128#' @noRd 1129resolveFunctionalDependencies <- function(dependencies) { 1130 if (!length(dependencies)) { 1131 return(dependencies) 1132 } 1133 dependencies <- asDependencies(dependencies) 1134 dependencies <- lapply(dependencies, function(dep) { 1135 if (is_tag_function(dep)) { 1136 dep <- dep() 1137 } 1138 if (isTag(dep) || inherits(dep, "shiny.tag.list")) { 1139 warning( 1140 "It appears attachDependencies() has been used to attach a tagFunction()", 1141 "that returns a shiny.tag/shiny.tag.list, which is considered poor practice", 1142 "since those tags will never actually get rendered", call. = FALSE 1143 ) 1144 return(findDependencies(dep)) 1145 } 1146 asDependencies(dep) 1147 }) 1148 unlist(dependencies, recursive = FALSE, use.names = FALSE) 1149} 1150 1151 1152#' Mark Characters as HTML 1153#' 1154#' Marks the given text as HTML, which means the [tag] functions will know 1155#' not to perform HTML escaping on it. 1156#' 1157#' @param text The text value to mark with HTML 1158#' @param ... Any additional values to be converted to character and 1159#' concatenated together 1160#' @param .noWS Character vector used to omit some of the whitespace that would 1161#' normally be written around this HTML. Valid options include `before`, 1162#' `after`, and `outside` (equivalent to `before` and 1163#' `end`). 1164#' @return The input `text`, but marked as HTML. 1165#' 1166#' @examples 1167#' el <- div(HTML("I like <u>turtles</u>")) 1168#' cat(as.character(el)) 1169#' 1170#' @export 1171HTML <- function(text, ..., .noWS = NULL) { 1172 htmlText <- c(text, as.character(dots_list(...))) 1173 htmlText <- paste8(htmlText, collapse=" ") 1174 attr(htmlText, "html") <- TRUE 1175 attr(htmlText, "noWS") <- .noWS 1176 class(htmlText) <- c("html", "character") 1177 htmlText 1178} 1179 1180#' Evaluate an expression using `tags` 1181#' 1182#' This function makes it simpler to write HTML-generating code. Instead of 1183#' needing to specify `tags` each time a tag function is used, as in 1184#' `tags$div()` and `tags$p()`, code inside `withTags` is 1185#' evaluated with `tags` searched first, so you can simply use 1186#' `div()` and `p()`. 1187#' 1188#' If your code uses an object which happens to have the same name as an 1189#' HTML tag function, such as `source()` or `summary()`, it will call 1190#' the tag function. To call the intended (non-tags function), specify the 1191#' namespace, as in `base::source()` or `base::summary()`. 1192#' 1193#' @param code A set of tags. 1194#' @param .noWS Default whitespace behavior for all tags within this call to 1195#' `withTags()`. Setting `.noWS` on an individual tag fuction inside 1196#' `withTags()` will override the default. See [tag()] for complete options. 1197#' 1198#' @examples 1199#' # Using tags$ each time 1200#' tags$div(class = "myclass", 1201#' tags$h3("header"), 1202#' tags$p("text") 1203#' ) 1204#' 1205#' # Equivalent to above, but using withTags 1206#' withTags( 1207#' div(class = "myclass", 1208#' h3("header"), 1209#' p("text") 1210#' ) 1211#' ) 1212#' 1213#' # Setting .noWS for all tags in withTags() 1214#' withTags( 1215#' div( 1216#' class = "myclass", 1217#' h3("header"), 1218#' p("One", strong(span("two")), "three") 1219#' ), 1220#' .noWS = c("outside", "inside") 1221#' ) 1222#' 1223#' 1224#' @export 1225withTags <- function(code, .noWS = NULL) { 1226 if (!is.null(.noWS)) { 1227 .noWSWithTags <- .noWS 1228 tags <- lapply(tags, function(tag) { 1229 function(..., .noWS = .noWSWithTags) { 1230 tag(..., .noWS = .noWS) 1231 } 1232 }) 1233 } 1234 eval(substitute(code), envir = as.list(tags), enclos = parent.frame()) 1235} 1236 1237# Make sure any objects in the tree that can be converted to tags, have been 1238tagify <- function(x) { 1239 rewriteTags(x, function(uiObj) { 1240 if (isResolvedTag(uiObj) || isTagList(uiObj) || is.character(uiObj)) 1241 return(uiObj) 1242 else 1243 tagify(as.tags(uiObj)) 1244 }, FALSE) 1245} 1246 1247# Given a list of tags, lists, and other items, return a flat list, where the 1248# items from the inner, nested lists are pulled to the top level, recursively. 1249# Be sure to check for tagEnvLike objects and not allow them 1250flattenTags <- function(x) { 1251 assertNotTagEnvLike(x, "flattenTags") 1252 if (isTag(x)) { 1253 # For tags, wrap them into a list (which will be unwrapped by caller) 1254 list(x) 1255 } else if (isTagList(x)) { 1256 if (length(x) == 0) { 1257 # Empty lists are simply returned 1258 x 1259 } else { 1260 # For items that are lists (but not tags), recurse 1261 ret <- unlist(lapply(x, flattenTags), recursive = FALSE) 1262 # Copy over attributes put on the original list (ex: html deps) 1263 mostattributes(ret) <- attributes(x) 1264 ret 1265 } 1266 } else if (is.character(x)){ 1267 # This will preserve attributes if x is a character with attribute, 1268 # like what HTML() produces 1269 list(x) 1270 1271 } else { 1272 # For other items, coerce to character and wrap them into a list (which 1273 # will be unwrapped by caller). Note that this will strip attributes. 1274 flattenTags(as.tags(x)) 1275 } 1276} 1277# This method should be just like `flattenTags()`, except the final `else` will 1278# return `list(x)`, rather than calling `flattenTags(as.tags(x))`. 1279# 1280# By not calling `as.tags(x)`, tagFunctions are not evaluated and other items 1281# are not converted. 1282flattenTagsRaw <- function(x) { 1283 if (isTag(x) || isTagEnv(x)) { 1284 # For tags, wrap them into a list (which will be unwrapped by caller) 1285 list(x) 1286 } else if (isTagList(x)) { 1287 if (length(x) == 0) { 1288 # Empty lists are simply returned 1289 x 1290 } else { 1291 # For items that are lists (but not tags), recurse 1292 ret <- unlist(lapply(x, flattenTagsRaw), recursive = FALSE) 1293 # Copy over attributes put on the original list (ex: html deps) 1294 mostattributes(ret) <- attributes(x) 1295 ret 1296 } 1297 } else { 1298 # This will preserve attributes if x is a character with attribute, 1299 # like what HTML() produces 1300 list(x) 1301 } 1302} 1303 1304 1305combineKeys <- function(x) { 1306 if (anyNA(x)) { 1307 na_idx <- is.na(x) 1308 if (all(na_idx)) { 1309 return(NA) 1310 } 1311 x <- x[!na_idx] 1312 } 1313 unlist(x, recursive = FALSE, use.names = FALSE) 1314} 1315# Do not adjust single values 1316# Only merge keys 1317flattenTagAttribs <- function(attribs) { 1318 1319 attribs <- dropNullsOrEmpty(attribs) 1320 1321 attribNames <- names(attribs) 1322 1323 if (anyDuplicated(attribNames)) { 1324 uniqueAttribNames <- sort(unique(attribNames)) 1325 attribs <- lapply(uniqueAttribNames, function(name) { 1326 obj <- attribs[attribNames == name] 1327 combineKeys(obj) 1328 }) 1329 names(attribs) <- uniqueAttribNames 1330 } 1331 1332 attribs 1333} 1334 1335#' Convert a value to tags 1336#' 1337#' An S3 method for converting arbitrary values to a value that can be used as 1338#' the child of a tag or `tagList`. The default implementation simply calls 1339#' [as.character()]. 1340#' 1341#' @param x Object to be converted. 1342#' @param ... Any additional parameters. 1343#' 1344#' @export 1345as.tags <- function(x, ...) { 1346 UseMethod("as.tags") 1347} 1348 1349#' @export 1350as.tags.default <- function(x, ...) { 1351 # Plain (non-classed) lists will hit as.tags.list(), but lists with a class 1352 # will get here. (tagLists will already have been handled by 1353 # as.tags.shiny.tag.list) 1354 if (is.list(x)) { 1355 tagList(!!!unclass(x)) 1356 } else { 1357 tagList(as.character(x)) 1358 } 1359} 1360 1361#' @export 1362as.tags.html <- function(x, ...) { 1363 x 1364} 1365 1366#' @export 1367as.tags.shiny.tag <- function(x, ...) { 1368 if (isResolvedTag(x)) { 1369 return(x) 1370 } 1371 1372 hook <- x$.renderHooks[[1]] 1373 # remove first hook 1374 x$.renderHooks[[1]] <- NULL 1375 # Recursively call as.tags on the updated object 1376 # (Perform in two lines to avoid lazy arg evaluation issues) 1377 y <- hook(x) 1378 as.tags(y) 1379} 1380 1381#' @export 1382as.tags.shiny.tag.list <- function(x, ...) { 1383 x 1384} 1385 1386#' @export 1387as.tags.shiny.tag.function <- function(x, ...) { 1388 x() 1389} 1390 1391#' @export 1392as.tags.list <- function(x, ...) { 1393 # Only non-classed lists will hit this method 1394 # (classed lists will reach the default method) 1395 tagList(!!!x) 1396} 1397 1398#' @export 1399as.tags.character <- function(x, ...) { 1400 # For printing as.tags("<strong>") directly at console, without dropping any 1401 # attached dependencies 1402 tagList(x) 1403} 1404 1405#' @export 1406as.tags.html_dependency <- function(x, ...) { 1407 attachDependencies(tagList(), x) 1408} 1409 1410#' Preserve HTML regions 1411#' 1412#' Use "magic" HTML comments to protect regions of HTML from being modified by 1413#' text processing tools. 1414#' 1415#' Text processing tools like markdown and pandoc are designed to turn 1416#' human-friendly markup into common output formats like HTML. This works well 1417#' for most prose, but components that generate their own HTML may break if 1418#' their markup is interpreted as the input language. The `htmlPreserve` 1419#' function is used to mark regions of an input document as containing pure HTML 1420#' that must not be modified. This is achieved by substituting each such region 1421#' with a benign but unique string before processing, and undoing those 1422#' substitutions after processing. 1423#' 1424#' @param x A character vector of HTML to be preserved. 1425#' 1426#' @return `htmlPreserve` returns a single-element character vector with 1427#' "magic" HTML comments surrounding the original text (unless the original 1428#' text was empty, in which case an empty string is returned). 1429#' 1430#' @examples 1431#' # htmlPreserve will prevent "<script>alert(10*2*3);</script>" 1432#' # from getting an <em> tag inserted in the middle 1433#' markup <- paste(sep = "\n", 1434#' "This is *emphasized* text in markdown.", 1435#' htmlPreserve("<script>alert(10*2*3);</script>"), 1436#' "Here is some more *emphasized text*." 1437#' ) 1438#' extracted <- extractPreserveChunks(markup) 1439#' markup <- extracted$value 1440#' # Just think of this next line as Markdown processing 1441#' output <- gsub("\\*(.*?)\\*", "<em>\\1</em>", markup) 1442#' output <- restorePreserveChunks(output, extracted$chunks) 1443#' output 1444#' 1445#' @export 1446htmlPreserve <- function(x) { 1447 raw = getOption("htmltools.preserve.raw", FALSE) 1448 x <- paste(x, collapse = "\n") 1449 if (nzchar(x)) 1450 if (raw) { 1451 # use fenced code block if there are embedded newlines 1452 if (grepl("\n", x, fixed = TRUE)) 1453 sprintf("\n```{=html}\n%s\n```\n", x) 1454 # otherwise use inline span 1455 else 1456 sprintf("`%s`{=html}", x) 1457 } 1458 else { 1459 sprintf("<!--html_preserve-->%s<!--/html_preserve-->", x) 1460 } 1461 else 1462 x 1463} 1464 1465# Temporarily set x in env to value, evaluate expr, and 1466# then restore x to its original state 1467withTemporary <- function(env, x, value, expr, unset = FALSE) { 1468 1469 if (exists(x, envir = env, inherits = FALSE)) { 1470 oldValue <- get(x, envir = env, inherits = FALSE) 1471 on.exit( 1472 assign(x, oldValue, envir = env, inherits = FALSE), 1473 add = TRUE) 1474 } else { 1475 on.exit( 1476 rm(list = x, envir = env, inherits = FALSE), 1477 add = TRUE 1478 ) 1479 } 1480 1481 if (!missing(value) && !isTRUE(unset)) 1482 assign(x, value, envir = env, inherits = FALSE) 1483 else { 1484 if (exists(x, envir = env, inherits = FALSE)) 1485 rm(list = x, envir = env, inherits = FALSE) 1486 } 1487 force(expr) 1488} 1489 1490# Evaluate an expression using Shiny's own private stream of 1491# randomness (not affected by set.seed). 1492withPrivateSeed <- local({ 1493 ownSeed <- NULL 1494 function(expr) { 1495 withTemporary(.GlobalEnv, ".Random.seed", 1496 ownSeed, unset=is.null(ownSeed), { 1497 tryCatch({ 1498 expr 1499 }, finally = {ownSeed <<- .Random.seed}) 1500 } 1501 ) 1502 } 1503}) 1504 1505# extract_preserve_chunks looks for regions in strval marked by 1506# <!--html_preserve-->...<!--/html_preserve--> and replaces each such region 1507# with a long unique ID. The return value is a list with $value as the string 1508# with the regions replaced, and $chunks as a named character vector where the 1509# names are the IDs and the values are the regions that were extracted. 1510# 1511# Nested regions are handled appropriately; the outermost region is what's used 1512# and any inner regions simply have their boundaries removed before the values 1513# are stashed in $chunks. 1514 1515#' @return `extractPreserveChunks` returns a list with two named elements: 1516#' `value` is the string with the regions replaced, and `chunks` is 1517#' a named character vector where the names are the IDs and the values are the 1518#' regions that were extracted. 1519#' @rdname htmlPreserve 1520#' @export 1521extractPreserveChunks <- function(strval) { 1522 1523 # Literal start/end marker text. Case sensitive. 1524 startmarker <- "<!--html_preserve-->" 1525 endmarker <- "<!--/html_preserve-->" 1526 # Start and end marker length MUST be different, it's how we tell them apart 1527 startmarker_len <- nchar(startmarker) 1528 endmarker_len <- nchar(endmarker) 1529 # Pattern must match both start and end markers 1530 pattern <- "<!--/?html_preserve-->" 1531 1532 # It simplifies string handling greatly to collapse multiple char elements 1533 if (length(strval) != 1) 1534 strval <- paste(strval, collapse = "\n") 1535 1536 # matches contains the index of all the start and end markers 1537 startmatches <- gregexpr(startmarker, strval, fixed = TRUE)[[1]] 1538 endmatches <- gregexpr(endmarker, strval, fixed = TRUE)[[1]] 1539 matches <- c(startmatches, endmatches) 1540 o <- order(matches) 1541 matches <- matches[o] 1542 lengths <- c( 1543 attr(startmatches, "match.length", TRUE), 1544 attr(endmatches, "match.length", TRUE) 1545 )[o] 1546 1547 # No markers? Just return. 1548 if (unique(matches)[[1]] == -1) 1549 return(list(value = strval, chunks = character(0))) 1550 1551 # If TRUE, it's a start; if FALSE, it's an end 1552 boundary_type <- lengths == startmarker_len 1553 1554 # Positive number means we're inside a region, zero means we just exited to 1555 # the top-level, negative number means error (an end without matching start). 1556 # For example: 1557 # boundary_type - TRUE TRUE FALSE FALSE TRUE FALSE 1558 # preserve_level - 1 2 1 0 1 0 1559 preserve_level <- cumsum(ifelse(boundary_type, 1, -1)) 1560 1561 # Sanity check. 1562 if (any(preserve_level < 0) || tail(preserve_level, 1) != 0) { 1563 stop("Invalid nesting of html_preserve directives") 1564 } 1565 1566 # Identify all the top-level boundary markers. We want to find all of the 1567 # elements of preserve_level whose value is 0 and preceding value is 1, or 1568 # whose value is 1 and preceding value is 0. Since we know that preserve_level 1569 # values can only go up or down by 1, we can simply shift preserve_level by 1570 # one element and add it to preserve_level; in the result, any value of 1 is a 1571 # match. 1572 is_top_level <- 1 == (preserve_level + c(0, preserve_level[-length(preserve_level)])) 1573 1574 preserved <- character(0) 1575 1576 top_level_matches <- matches[is_top_level] 1577 # Iterate backwards so string mutation doesn't screw up positions for future 1578 # iterations 1579 for (i in seq.int(length(top_level_matches) - 1, 1, by = -2)) { 1580 start_outer <- top_level_matches[[i]] 1581 start_inner <- start_outer + startmarker_len 1582 end_inner <- top_level_matches[[i+1]] 1583 end_outer <- end_inner + endmarker_len 1584 1585 id <- withPrivateSeed( 1586 paste("preserve", paste( 1587 format(as.hexmode(sample(256, 8, replace = TRUE)-1), width=2), 1588 collapse = ""), 1589 sep = "") 1590 ) 1591 1592 preserved[id] <- gsub(pattern, "", substr(strval, start_inner, end_inner-1)) 1593 1594 strval <- paste( 1595 substr(strval, 1, start_outer - 1), 1596 id, 1597 substr(strval, end_outer, nchar(strval)), 1598 sep="") 1599 substr(strval, start_outer, end_outer-1) <- id 1600 } 1601 1602 list(value = strval, chunks = preserved) 1603} 1604 1605#' @param strval Input string from which to extract/restore chunks. 1606#' @param chunks The `chunks` element of the return value of 1607#' `extractPreserveChunks`. 1608#' @return `restorePreserveChunks` returns a character vector with the 1609#' chunk IDs replaced with their original values. 1610#' @rdname htmlPreserve 1611#' @export 1612restorePreserveChunks <- function(strval, chunks) { 1613 strval <- enc2utf8(strval) 1614 chunks <- enc2utf8(chunks) 1615 for (id in names(chunks)) 1616 strval <- gsub(id, chunks[[id]], strval, fixed = TRUE, useBytes = TRUE) 1617 Encoding(strval) <- 'UTF-8' 1618 strval 1619} 1620 1621#' Knitr S3 methods 1622#' 1623#' These S3 methods are necessary to allow HTML tags to print themselves in 1624#' knitr/rmarkdown documents. 1625#' 1626#' @name knitr_methods 1627#' @param x Object to knit_print 1628#' @param ... Additional knit_print arguments 1629NULL 1630 1631#' @rdname knitr_methods 1632#' @export 1633knit_print.shiny.tag <- function(x, ...) { 1634 x <- tagify(x) 1635 output <- surroundSingletons(x) 1636 deps <- resolveDependencies(findDependencies(x, tagify = FALSE), resolvePackageDir = FALSE) 1637 content <- takeHeads(output) 1638 head_content <- doRenderTags(tagList(content$head)) 1639 1640 meta <- if (length(head_content) > 1 || head_content != "") { 1641 list(structure(head_content, class = "shiny_head")) 1642 } 1643 meta <- c(meta, deps) 1644 1645 knitr::asis_output( 1646 htmlPreserve(format(content$ui, indent=FALSE)), 1647 meta = meta) 1648} 1649 1650#' @rdname knitr_methods 1651#' @export 1652knit_print.html <- function(x, ...) { 1653 deps <- resolveDependencies(findDependencies(x, tagify = FALSE)) 1654 knitr::asis_output(htmlPreserve(as.character(x)), 1655 meta = if (length(deps)) list(deps)) 1656} 1657 1658#' @rdname knitr_methods 1659#' @export 1660knit_print.shiny.tag.list <- knit_print.shiny.tag 1661 1662 1663#' Include Content From a File 1664#' 1665#' Load HTML, text, or rendered Markdown from a file and turn into HTML. 1666#' 1667#' These functions provide a convenient way to include an extensive amount of 1668#' HTML, textual, Markdown, CSS, or JavaScript content, rather than using a 1669#' large literal R string. 1670#' 1671#' @param path The path of the file to be included. It is highly recommended to 1672#' use a relative path (the base path being the Shiny application directory), 1673#' not an absolute path. 1674#' 1675#' @rdname include 1676#' @name include 1677#' @aliases includeHTML 1678#' @export 1679includeHTML <- function(path) { 1680 lines <- readLines(path, warn=FALSE, encoding='UTF-8') 1681 return(HTML(paste8(lines, collapse='\n'))) 1682} 1683 1684#' @note `includeText` escapes its contents, but does no other processing. 1685#' This means that hard breaks and multiple spaces will be rendered as they 1686#' usually are in HTML: as a single space character. If you are looking for 1687#' preformatted text, wrap the call with [pre()], or consider using 1688#' `includeMarkdown` instead. 1689#' 1690#' @rdname include 1691#' @export 1692includeText <- function(path) { 1693 lines <- readLines(path, warn=FALSE, encoding='UTF-8') 1694 return(paste8(lines, collapse='\n')) 1695} 1696 1697#' @note The `includeMarkdown` function requires the `markdown` 1698#' package. 1699#' @rdname include 1700#' @export 1701includeMarkdown <- function(path) { 1702 html <- markdown::markdownToHTML(path, fragment.only=TRUE) 1703 Encoding(html) <- 'UTF-8' 1704 return(HTML(html)) 1705} 1706 1707#' @param ... Any additional attributes to be applied to the generated tag. 1708#' @rdname include 1709#' @export 1710includeCSS <- function(path, ...) { 1711 lines <- readLines(path, warn=FALSE, encoding='UTF-8') 1712 args <- dots_list(...) 1713 if (is.null(args$type)) 1714 args$type <- 'text/css' 1715 return(do.call(tags$style, 1716 c(list(HTML(paste8(lines, collapse='\n'))), args))) 1717} 1718 1719#' @rdname include 1720#' @export 1721includeScript <- function(path, ...) { 1722 lines <- readLines(path, warn=FALSE, encoding='UTF-8') 1723 return(tags$script(HTML(paste8(lines, collapse='\n')), ...)) 1724} 1725 1726#' Include content only once 1727#' 1728#' Use `singleton` to wrap contents (tag, text, HTML, or lists) that should 1729#' be included in the generated document only once, yet may appear in the 1730#' document-generating code more than once. Only the first appearance of the 1731#' content (in document order) will be used. 1732#' 1733#' @param x A [tag()], text, [HTML()], or list. 1734#' @param value Whether the object should be a singleton. 1735#' 1736#' @export 1737singleton <- function(x, value = TRUE) { 1738 attr(x, "htmltools.singleton") <- if (isTRUE(value)) TRUE else NULL 1739 return(x) 1740} 1741 1742#' @rdname singleton 1743#' @export 1744is.singleton <- function(x) { 1745 isTRUE(attr(x, "htmltools.singleton")) 1746} 1747 1748 1749#' Validate proper CSS formatting of a unit 1750#' 1751#' Checks that the argument is valid for use as a CSS unit of length. 1752#' 1753#' `NULL` and `NA` are returned unchanged. 1754#' 1755#' Single element numeric vectors are returned as a character vector with the 1756#' number plus a suffix of `"px"`. 1757#' 1758#' Single element character vectors must be `"auto"`, `"fit-content"` 1759#' or `"inherit"`, a number, or a length calculated by the `"calc"` 1760#' CSS function. If the number has a suffix, it must be valid: `px`, 1761#' `\%`, `ch`, `em`, `rem`, `pt`, `in`, `cm`, 1762#' `mm`, `ex`, `pc`, `vh`, `vw`, `vmin`, or 1763#' `vmax`. 1764#' If the number has no suffix, the suffix `"px"` is appended. 1765#' 1766#' 1767#' Any other value will cause an error to be thrown. 1768#' 1769#' @param x The unit to validate. Will be treated as a number of pixels if a 1770#' unit is not specified. 1771#' @return A properly formatted CSS unit of length, if possible. Otherwise, will 1772#' throw an error. 1773#' @examples 1774#' validateCssUnit("10%") 1775#' validateCssUnit(400) #treated as '400px' 1776#' @export 1777validateCssUnit <- function(x) { 1778 if (is.null(x) || is.na(x)) 1779 return(x) 1780 1781 if (length(x) > 1 || (!is.character(x) && !is.numeric(x))) 1782 stop('CSS units must be a single-element numeric or character vector') 1783 1784 # if the input is a character vector consisting only of digits (e.g. "960"), 1785 # coerce it to a numeric value 1786 if (is.character(x) && nchar(x) > 0 && gsub("\\d*", "", x) == "") 1787 x <- as.numeric(x) 1788 1789 pattern <- 1790 "^(auto|inherit|fit-content|calc\\(.*\\)|((\\.\\d+)|(\\d+(\\.\\d+)?))(%|in|cm|mm|ch|em|ex|rem|pt|pc|px|vh|vw|vmin|vmax))$" 1791 1792 if (is.character(x) && 1793 !grepl(pattern, x)) { 1794 stop('"', x, '" is not a valid CSS unit (e.g., "100%", "400px", "auto")') 1795 } else if (is.numeric(x)) { 1796 x <- paste(x, "px", sep = "") 1797 } 1798 x 1799} 1800 1801#' CSS string helper 1802#' 1803#' Convenience function for building CSS style declarations (i.e. the string 1804#' that goes into a style attribute, or the parts that go inside curly braces in 1805#' a full stylesheet). 1806#' 1807#' CSS uses `'-'` (minus) as a separator character in property names, but 1808#' this is an inconvenient character to use in an R function argument name. 1809#' Instead, you can use `'.'` (period) and/or `'_'` (underscore) as 1810#' separator characters. For example, `css(font.size = "12px")` yields 1811#' `"font-size:12px;"`. 1812#' 1813#' To mark a property as `!important`, add a `'!'` character to the end 1814#' of the property name. (Since `'!'` is not normally a character that can be 1815#' used in an identifier in R, you'll need to put the name in double quotes or 1816#' backticks.) 1817#' 1818#' Argument values will be converted to strings using 1819#' `paste(collapse = " ")`. Any property with a value of `NULL` or 1820#' `""` (after paste) will be dropped. 1821#' 1822#' @param ... Named style properties, where the name is the property name and 1823#' the argument is the property value. See Details for conversion rules. 1824#' @param collapse_ (Note that the parameter name has a trailing underscore 1825#' character.) Character to use to collapse properties into a single string; 1826#' likely `""` (the default) for style attributes, and either `"\n"` 1827#' or `NULL` for style blocks. 1828#' 1829#' @examples 1830#' padding <- 6 1831#' css( 1832#' font.family = "Helvetica, sans-serif", 1833#' margin = paste0(c(10, 20, 10, 20), "px"), 1834#' "padding!" = if (!is.null(padding)) padding 1835#' ) 1836#' 1837#' @export 1838css <- function(..., collapse_ = "") { 1839 props <- dots_list(...) 1840 if (length(props) == 0) { 1841 return(NULL) 1842 } 1843 1844 if (is.null(names(props)) || any(names(props) == "")) { 1845 stop("cssList expects all arguments to be named") 1846 } 1847 1848 # Necessary to make factors show up as level names, not numbers 1849 props[] <- lapply(props, paste, collapse = " ") 1850 1851 # Drop null args 1852 props <- props[!sapply(props, empty)] 1853 if (length(props) == 0) { 1854 return(NULL) 1855 } 1856 1857 # Replace all '.' and '_' in property names to '-' 1858 names(props) <- gsub("[._]", "-", tolower(gsub("([A-Z])", "-\\1", names(props)))) 1859 1860 # Create "!important" suffix for each property whose name ends with !, then 1861 # remove the ! from the property name 1862 important <- ifelse(grepl("!$", names(props), perl = TRUE), " !important", "") 1863 names(props) <- sub("!$", "", names(props), perl = TRUE) 1864 1865 paste0(names(props), ":", props, important, ";", collapse = collapse_) 1866} 1867 1868empty <- function(x) { 1869 length(x) == 0 || (is.character(x) && !any(nzchar(x))) 1870} 1871