1 2# Write an index.htm file for an Rmd deployment if necessary (returns the 3# files written so they can be removed after deployment) 4writeRmdIndex <- function(appName, appDir) { 5 6 # files written 7 files <- NULL 8 9 # no index required for Shiny, or for directories with an index.Rmd 10 if (!file.exists(file.path(appDir, "ui.R")) && 11 !file.exists(file.path(appDir, "server.R")) && 12 !file.exists(file.path(appDir, "index.htm")) && 13 !file.exists(file.path(appDir, "index.Rmd"))) 14 { 15 # otherwise enumerate the Rmd files as the basis for the index 16 appFiles <- list.files(path = appDir, pattern = "\\.(rmd|html)$", 17 recursive = FALSE, ignore.case = TRUE) 18 19 if (length(appFiles) == 1) 20 indexPage <- redirectWebPage(appFiles[1]) 21 else 22 indexPage <- listingWebPage(appName, appFiles) 23 24 indexFile <- file.path(appDir, "index.htm") 25 files <- c(files, indexFile) 26 writeLines(indexPage, indexFile, useBytes = TRUE) 27 } 28 29 files 30} 31 32redirectWebPage <- function(appFile) { 33 meta <- paste('<meta http-equiv="refresh" content="0;', 34 htmlEscape(appFile), '">', sep = "") 35 webPage(meta, NULL) 36} 37 38listingWebPage <- function(appDir, appFiles) { 39 40 head <- c("<style type='text/css'>", 41 "body { padding-left: 20px; }", 42 ".rmd { margin-bottom: 20px; }", 43 ".rmdlink { font-size: 1.5em; text-decoration: none; }", 44 ".rmdlink:hover { text-decoration: underline; }", 45 "</style>") 46 47 appDir <- htmlEscape(appDir) 48 appFiles <- htmlEscape(appFiles) 49 50 body <- paste("<h1>", basename(appDir), "</h1>", sep = "") 51 body <- c(body, paste("<div class = 'rmd'>", 52 "<a href='", appFiles, "' class = 'rmdlink'>", 53 appFiles, 54 "</a></div>", sep = "")) 55 56 webPage(head, body) 57} 58 59webPage <- function(head, body) { 60 61 if (is.null(head)) 62 head <- c() 63 64 if (is.null(body)) 65 body <- c() 66 67 enc2utf8(c( 68 '<!DOCTYPE HTML>', 69 '<html>', 70 '<head>', 71 '<meta charset="UTF-8">', 72 head, 73 '</head>', 74 '<body>', 75 body, 76 '</body>', 77 '</html>') 78 ) 79} 80 81htmlEscape <- local({ 82 83 .htmlSpecials <- list( 84 `&` = '&', 85 `<` = '<', 86 `>` = '>' 87 ) 88 .htmlSpecialsPattern <- paste(names(.htmlSpecials), collapse='|') 89 .htmlSpecialsAttrib <- c( 90 .htmlSpecials, 91 `'` = ''', 92 `"` = '"', 93 `\r` = ' ', 94 `\n` = ' ' 95 ) 96 .htmlSpecialsPatternAttrib <- paste(names(.htmlSpecialsAttrib), collapse='|') 97 98 function(text, attribute=FALSE) { 99 pattern <- if(attribute) 100 .htmlSpecialsPatternAttrib 101 else 102 .htmlSpecialsPattern 103 104 # Short circuit in the common case that there's nothing to escape 105 if (!any(grepl(pattern, text))) 106 return(text) 107 108 specials <- if(attribute) 109 .htmlSpecialsAttrib 110 else 111 .htmlSpecials 112 113 for (chr in names(specials)) { 114 text <- gsub(chr, specials[[chr]], text, fixed=TRUE) 115 } 116 117 return(text) 118 } 119}) 120 121