1#' @import stats 2 3createUniqueId <- function(bytes) { 4 paste(as.hexmode(sample(256, bytes) - 1), collapse = "") 5} 6 7is_windows <- function() { 8 identical(.Platform$OS.type, "windows") 9} 10 11is_osx <- function() { 12 Sys.info()["sysname"] == "Darwin" 13} 14 15# determine the output file for a pandoc conversion 16pandoc_output_file <- function(input, pandoc_options) { 17 to <- pandoc_options$to 18 if (!is.null(pandoc_options$ext)) 19 ext <- pandoc_options$ext 20 else if (to %in% c("latex", "beamer")) 21 ext <- ".pdf" 22 else if (to %in% c("html", "html5", "s5", "slidy", 23 "slideous", "dzslides", "revealjs")) 24 ext <- ".html" 25 else if (grepl("^markdown", to)) { 26 if (!identical(tolower(tools::file_ext(input)), "md")) 27 ext <- ".md" 28 else { 29 ext <- paste(".", strsplit(to, "[\\+\\-]")[[1]][[1]], sep = "") 30 } 31 } 32 else 33 ext <- paste(".", to, sep = "") 34 output <- paste(tools::file_path_sans_ext(input), ext, sep = "") 35 basename(output) 36} 37 38 39rmarkdown_system_file <- function(file) { 40 system.file(file, package = "rmarkdown") 41} 42 43 44#' @rdname rmarkdown_format 45#' @export 46from_rmarkdown <- function(implicit_figures = TRUE, extensions = NULL) { 47 48 # paste extensions together and remove whitespace 49 extensions <- paste0(extensions, collapse = "") 50 extensions <- gsub(" ", "", extensions) 51 52 # exclude implicit figures unless the user has added them back 53 if (!implicit_figures && !grepl("implicit_figures", extensions)) 54 extensions <- paste0("-implicit_figures", extensions) 55 56 rmarkdown_format(extensions) 57} 58 59is_null_or_string <- function(text) { 60 is.null(text) || (is.character(text) && (length(text) == 1)) 61} 62 63read_lines_utf8 <- function(file, encoding) { 64 65 # read the file 66 lines <- readLines(file, warn = FALSE) 67 68 # convert to utf8 69 to_utf8(lines, encoding) 70} 71 72 73to_utf8 <- function(x, encoding) { 74 # normalize encoding to iconv compatible form 75 if (identical(encoding, "native.enc")) 76 encoding <- "" 77 78 # convert to utf8 79 if (!identical(encoding, "UTF-8")) 80 iconv(x, from = encoding, to = "UTF-8") 81 else 82 mark_utf8(x) 83} 84 85# mark the encoding of character vectors as UTF-8 86mark_utf8 <- function(x) { 87 if (is.character(x)) { 88 Encoding(x) <- 'UTF-8' 89 return(x) 90 } 91 if (!is.list(x)) return(x) 92 attrs <- attributes(x) 93 res <- lapply(x, mark_utf8) 94 attributes(res) <- attrs 95 names(res) <- mark_utf8(names(res)) 96 res 97} 98 99# the yaml UTF-8 bug has been fixed https://github.com/viking/r-yaml/issues/6 100# but yaml >= 2.1.14 Win/Mac binaries are not available for R < 3.2.0, so we 101# still need the mark_utf8 trick 102#' @importFrom utils packageVersion 103yaml_load_utf8 <- function(string, ...) { 104 string <- paste(string, collapse = '\n') 105 if (packageVersion('yaml') >= '2.1.14') { 106 yaml::yaml.load(string, ...) 107 } else { 108 mark_utf8(yaml::yaml.load(enc2utf8(string), ...)) 109 } 110} 111 112yaml_load_file_utf8 <- function(input, ...) { 113 yaml_load_utf8(readLines(input, encoding = 'UTF-8'), ...) 114} 115 116file_name_without_shell_chars <- function(file) { 117 name <- gsub(.shell_chars_regex, '_', basename(file)) 118 dir <- dirname(file) 119 if (nzchar(dir) && !identical(dir, ".")) 120 file.path(dir, name) 121 else 122 name 123} 124 125tmpfile_pattern <- "rmarkdown-str" 126 127# return a string as a tempfile 128as_tmpfile <- function(str) { 129 if (length(str) > 0) { 130 str_tmpfile <- tempfile(tmpfile_pattern, fileext = ".html") 131 writeLines(str, str_tmpfile, useBytes = TRUE) 132 str_tmpfile 133 } else { 134 NULL 135 } 136} 137 138# temp files created by as_tmpfile() cannot be immediately removed because they 139# are needed later by the pandoc conversion; we have to clean up the temp files 140# that have the pattern specified in `tmpfile_pattern` when render() exits 141clean_tmpfiles <- function() { 142 unlink(list.files( 143 tempdir(), sprintf("^%s[0-9a-f]+[.]html$", tmpfile_pattern), full.names = TRUE 144 )) 145} 146 147dir_exists <- function(x) { 148 utils::file_test('-d', x) 149} 150 151file_with_ext <- function(file, ext) { 152 paste(tools::file_path_sans_ext(file), ".", ext, sep = "") 153} 154 155 156file_with_meta_ext <- function(file, meta_ext, ext = tools::file_ext(file)) { 157 paste(tools::file_path_sans_ext(file), 158 ".", meta_ext, ".", ext, sep = "") 159} 160 161knitr_files_dir <- function(file) { 162 paste(tools::file_path_sans_ext(file), "_files", sep = "") 163} 164 165knitr_root_cache_dir <- function(file) { 166 paste(tools::file_path_sans_ext(file), "_cache", sep = "") 167} 168 169knitr_cache_dir <- function(file, pandoc_to) { 170 paste(tools::file_path_sans_ext(file), "_cache/", pandoc_to, "/", sep = "") 171} 172 173get_knitr_hook_list <- function(hook_names = NULL) { 174 if (is.null(hook_names)) 175 hook_names <- c("knit_hooks", "opts_chunk", "opts_hooks", "opts_knit") 176 knitr_ns <- asNamespace("knitr") 177 hook_list <- lapply(hook_names, function(hook_name) { 178 hooks <- get(hook_name, envir = knitr_ns, inherits = FALSE) 179 hooks$get() 180 }) 181 names(hook_list) <- hook_names 182 hook_list 183} 184 185set_knitr_hook_list <- function(hook_list) { 186 knitr_ns <- asNamespace("knitr") 187 enumerate(hook_list, function(hook_name, hook_value) { 188 hook <- get(hook_name, envir = knitr_ns, inherits = FALSE) 189 hook$set(hook_value) 190 }) 191} 192 193highlighters <- function() { 194 c("default", 195 "tango", 196 "pygments", 197 "kate", 198 "monochrome", 199 "espresso", 200 "zenburn", 201 "haddock") 202} 203 204merge_lists <- function(base_list, overlay_list, recursive = TRUE) { 205 if (length(base_list) == 0) 206 overlay_list 207 else if (length(overlay_list) == 0) 208 base_list 209 else { 210 merged_list <- base_list 211 for (name in names(overlay_list)) { 212 base <- base_list[[name]] 213 overlay <- overlay_list[[name]] 214 if (is.list(base) && is.list(overlay) && recursive) 215 merged_list[[name]] <- merge_lists(base, overlay) 216 else { 217 merged_list[[name]] <- NULL 218 merged_list <- append(merged_list, 219 overlay_list[which(names(overlay_list) %in% name)]) 220 } 221 } 222 merged_list 223 } 224} 225 226strip_white <- function(x) 227{ 228 if (!length(x)) 229 return(x) 230 while (is_blank(x[1])) { 231 x = x[-1] 232 if (!length(x)) 233 return(x) 234 } 235 while (is_blank(x[(n <- length(x))])) { 236 x = x[-n] 237 if (n < 2) 238 return(x) 239 } 240 x 241} 242 243is_blank <- function(x) 244{ 245 if (length(x)) 246 all(grepl("^\\s*$", x)) 247 else TRUE 248} 249 250trim_trailing_ws <- function(x) { 251 sub("\\s+$", "", x) 252} 253 254 255# Find common base directory, throw error if it doesn't exist 256base_dir <- function(x) { 257 abs <- vapply(x, tools::file_path_as_absolute, character(1)) 258 259 base <- unique(dirname(abs)) 260 if (length(base) > 1) { 261 stop("Input files not all in same directory, please supply explicit wd", 262 call. = FALSE) 263 } 264 265 base 266} 267 268move_dir <- function(from, to) { 269 dir.create(dirname(to), showWarnings = FALSE) 270 file.rename(from, to) 271} 272 273# Check if two paths are the same after being normalized 274same_path <- function(path1, path2, ...) { 275 if (length(path1) * length(path2) != 1) 276 stop('The two paths must be both of length 1') 277 normalize_path(path1, ...) == normalize_path(path2, ...) 278} 279 280# Regular expression representing characters likely to be considered special by 281# the shell (require quoting/escaping) 282.shell_chars_regex <- '[ <>()|\\:&;#?*\']' 283 284# Find a program within the PATH. On OSX we need to explictly call 285# /usr/bin/which with a forwarded PATH since OSX Yosemite strips 286# the PATH from the environment of child processes 287find_program <- function(program) { 288 if (is_osx()) { 289 res <- suppressWarnings({ 290 # Quote the path (so it can contain spaces, etc.) and escape any quotes 291 # and escapes in the path itself 292 sanitized_path <- gsub("\\", "\\\\", Sys.getenv("PATH"), fixed = TRUE) 293 sanitized_path <- gsub("\"", "\\\"", sanitized_path, fixed = TRUE) 294 system(paste0("PATH=\"", sanitized_path, "\" /usr/bin/which ", program), 295 intern = TRUE) 296 }) 297 if (length(res) == 0) 298 "" 299 else 300 res 301 } else { 302 Sys.which(program) 303 } 304} 305 306# given a string, escape the regex metacharacters it contains: 307# regex metas are these, 308# . \ | ( ) [ { ^ $ * + ? 309# as defined here: 310# http://stat.ethz.ch/R-manual/R-devel/library/base/html/regex.html 311escape_regex_metas <- function(in_str) { 312 gsub("([.\\|()[{^$+?])", "\\\\\\1", in_str) 313} 314 315# call latexmk to compile tex to PDF; if not available, use a simple emulation 316latexmk <- function(file, engine, biblatex = FALSE) { 317 if (!grepl('[.]tex$', file)) 318 stop("The input file '", file, "' does not appear to be a LaTeX document") 319 engine <- find_latex_engine(engine) 320 latexmk_path <- find_program('latexmk') 321 if (latexmk_path == '') { 322 # latexmk not found 323 latexmk_emu(file, engine, biblatex) 324 } else if (find_program('perl') != '' && latexmk_installed(latexmk_path)) { 325 system2_quiet(latexmk_path, c( 326 '-pdf -latexoption=-halt-on-error -interaction=batchmode', 327 paste0('-pdflatex=', shQuote(engine)), shQuote(file) 328 ), error = { 329 check_latexmk_version(latexmk_path) 330 show_latex_error(file) 331 }) 332 system2(latexmk_path, '-c', stdout = FALSE) # clean up nonessential files 333 } else { 334 latexmk_emu(file, engine, biblatex) 335 } 336} 337 338# a quick and dirty version of latexmk (should work reasonably well unless the 339# LaTeX document is extremely complicated) 340latexmk_emu <- function(file, engine, biblatex = FALSE) { 341 owd <- setwd(dirname(file)) 342 on.exit(setwd(owd), add = TRUE) 343 # only use basename because bibtex may not work with full path 344 file <- basename(file) 345 346 file_with_same_base <- function(file) { 347 files <- list.files() 348 files <- files[utils::file_test('-f', files)] 349 base <- tools::file_path_sans_ext(file) 350 normalizePath(files[tools::file_path_sans_ext(files) == base]) 351 } 352 # clean up aux files from LaTeX compilation 353 files1 <- file_with_same_base(file) 354 keep_log <- FALSE 355 on.exit(add = TRUE, { 356 files2 <- file_with_same_base(file) 357 files3 <- setdiff(files2, files1) 358 aux <- c( 359 'aux', 'log', 'bbl', 'blg', 'fls', 'out', 'lof', 'lot', 'idx', 'toc', 360 'nav', 'snm', 'vrb', 'ilg', 'ind' 361 ) 362 if (keep_log) aux <- setdiff(aux, 'log') 363 unlink(files3[tools::file_ext(files3) %in% aux]) 364 }) 365 366 fileq <- shQuote(file) 367 run_engine <- function() { 368 system2_quiet(engine, c('-halt-on-error -interaction=batchmode', fileq), error = { 369 keep_log <<- TRUE 370 show_latex_error(file) 371 }) 372 } 373 run_engine() 374 # generate index 375 idx <- sub('[.]tex$', '.idx', file) 376 if (file.exists(idx)) { 377 system2_quiet(find_latex_engine('makeindex'), shQuote(idx), error = { 378 stop("Failed to build the index via makeindex", call. = FALSE) 379 }) 380 } 381 # generate bibliography 382 if (biblatex) { 383 aux_ext <- '.bcf' 384 bib_engine <- 'biber' 385 } else { 386 aux_ext <- '.aux' 387 bib_engine <- 'bibtex' 388 } 389 aux <- sub('[.]tex$', aux_ext, file) 390 if (file.exists(aux)) { 391 if (biblatex || require_bibtex(aux)) 392 system2_quiet(find_latex_engine(bib_engine), shQuote(aux), error = { 393 stop("Failed to build the bibliography via ", bib_engine, call. = FALSE) 394 }) 395 } 396 run_engine() 397 run_engine() 398} 399 400require_bibtex <- function(aux) { 401 x <- readLines(aux) 402 r <- length(grep('^\\\\citation\\{', x)) && length(grep('^\\\\bibdata\\{', x)) && 403 length(grep('^\\\\bibstyle\\{', x)) 404 if (r && is_windows()) tweak_aux(aux, x) 405 r 406} 407 408# remove the .bib extension in \bibdata{} in the .aux file, because bibtex on 409# Windows requires no .bib extension (sigh) 410tweak_aux <- function(aux, x = readLines(aux)) { 411 r <- '^\\\\bibdata\\{.+\\}\\s*$' 412 if (length(i <- grep(r, x)) == 0) return() 413 x[i] = gsub('[.]bib([,}])', '\\1', x[i]) 414 writeLines(x, aux) 415} 416 417system2_quiet <- function(..., error = NULL) { 418 # run the command quietly if possible 419 res <- system2(..., stdout = FALSE, stderr = FALSE) 420 # if failed, use the normal mode 421 if (res != 0) res <- system2(...) 422 # if still fails, run the error callback 423 if (res != 0) error # lazy evaluation 424 invisible(res) 425} 426 427# parse the LaTeX log and show error messages 428show_latex_error <- function(file) { 429 logfile <- file_with_ext(file, 'log') 430 e <- c('Failed to compile ', file, '.') 431 if (!file.exists(logfile)) stop(e, call. = FALSE) 432 x <- readLines(logfile, warn = FALSE) 433 b <- grep('^\\s*$', x) # blank lines 434 m <- NULL 435 for (i in grep('^! ', x)) { 436 # ignore the last error message about the fatal error 437 if (grepl('==> Fatal error occurred', x[i], fixed = TRUE)) next 438 n <- b[b > i] 439 n <- if (length(n) == 0) i else min(n) - 1L 440 m <- c(m, x[i:n], '') 441 } 442 if (length(m)) { 443 message(paste(m, collapse = '\n')) 444 stop(e, ' See ', logfile, ' for more info.', call. = FALSE) 445 } 446} 447 448# check if latexmk was correctly installed; see more info at 449# https://github.com/rstudio/bookdown/issues/121 450latexmk_installed <- function(latexmk_path) { 451 if (system2_quiet(latexmk_path, '-v') == 0) return(TRUE) 452 warning('The LaTeX package latexmk was not correctly installed.', call. = FALSE) 453 if (!is_windows()) return(FALSE) 454 shell('latexmk -v') # hopefully MiKTeX can fix it automatically 455 system2_quiet(latexmk_path, '-v') == 0 456} 457 458# check the version of latexmk 459check_latexmk_version <- function(latexmk_path = find_program('latexmk')) { 460 out <- system2(latexmk_path, '-v', stdout = TRUE) 461 reg <- '^.*Version (\\d+[.]\\d+).*$' 462 out <- grep(reg, out, value = TRUE) 463 if (length(out) == 0) return() 464 ver <- as.numeric_version(gsub(reg, '\\1', out[1])) 465 if (ver >= '4.43') return() 466 system2(latexmk_path, '-v') 467 warning( 468 'Your latexmk version seems to be too low. ', 469 'You may need to update the latexmk package or your LaTeX distribution.', 470 call. = FALSE 471 ) 472} 473 474n_bytes <- function(string) { 475 nchar(string, type = "bytes") 476} 477 478starts_with_bytes <- function(string, bytes) { 479 Encoding(string) <- Encoding(bytes) <- "bytes" 480 if (n_bytes(bytes) > n_bytes(string)) 481 return(FALSE) 482 substring(string, 1, n_bytes(bytes)) == bytes 483} 484 485ends_with_bytes <- function(string, bytes) { 486 Encoding(string) <- Encoding(bytes) <- "bytes" 487 if (n_bytes(bytes) > n_bytes(string)) 488 return(FALSE) 489 substring(string, n_bytes(string) - n_bytes(bytes) + 1, n_bytes(string)) == bytes 490} 491 492base64_encode_object <- function(object) { 493 object <- rapply(object, unclass, how = "list") 494 json <- charToRaw(jsonlite::toJSON(object, auto_unbox = TRUE)) 495 base64enc::base64encode(json) 496} 497 498base64_decode_object <- function(encoded) { 499 json <- rawToChar(base64enc::base64decode(encoded)) 500 jsonlite::fromJSON(json) 501} 502 503read_file <- function(path, binary = FALSE) { 504 n <- file.info(path)$size 505 if (binary) { 506 readBin(path, raw(), n) 507 } else { 508 readChar(path, n, TRUE) 509 } 510} 511 512surround <- function(string, with) { 513 paste(with, string, with, sep = "") 514} 515 516to_html_attributes <- function(data, on_empty = "", prefix = " ") { 517 518 if (inherits(data, "html")) 519 return(data) 520 521 if (!length(data)) 522 return(on_empty) 523 524 # escape attribute contents 525 escaped <- unlist(lapply(data, function(el) { 526 htmltools::htmlEscape(join(as.character(el), collapse = " "), attribute = TRUE) 527 })) 528 529 # generate html attributes as string 530 quoted <- surround(escaped, with = "\"") 531 result <- join(names(data), quoted, sep = "=", collapse = " ") 532 533 # add prefix if necessary 534 if (nzchar(prefix)) 535 result <- join(prefix, result) 536 537 # mark as html and return 538 class(result) <- "html" 539 result 540 541} 542 543to_css <- function(data, on_empty = "", prefix = "") { 544 545 if (inherits(data, "html")) 546 return(data) 547 548 if (!length(data)) 549 return(on_empty) 550 551 # collapse vectors in data list 552 collapsed <- unlist(lapply(data, function(el) { 553 join(el, collapse = " ") 554 })) 555 556 # paste into single string 557 joined <- join(names(data), collapsed, sep = ": ", collapse = "; ") 558 559 # add prefix 560 if (nzchar(prefix)) 561 joined <- join(prefix, joined) 562 563 # return with trailing semi-colon 564 result <- join(joined, ";", sep = "") 565 class(result) <- "html" 566 result 567} 568 569rbind_list <- function(data) { 570 result <- do.call(mapply, c(c, data, USE.NAMES = FALSE, SIMPLIFY = FALSE)) 571 names(result) <- names(data[[1]]) 572 as.data.frame(result, stringsAsFactors = FALSE) 573} 574 575enumerate <- function(data, f, ...) { 576 lapply(seq_along(data), function(i) { 577 f(names(data)[[i]], data[[i]], ...) 578 }) 579} 580 581insert <- function(vector, index, ...) { 582 583 dots <- list(...) 584 mode(dots) <- mode(vector) 585 n <- length(vector) 586 587 result <- if (index == 0) { 588 c(dots, vector) 589 } else if (index == n) { 590 c(vector, dots) 591 } else { 592 c(vector[1:index], dots, vector[(index + 1):n]) 593 } 594 595 result 596} 597 598replace_binding <- function(binding, package, override) { 599 # override in namespace 600 if (!requireNamespace(package, quietly = TRUE)) 601 stop(sprintf("Failed to load namespace for package '%s'", package)) 602 603 namespace <- asNamespace(package) 604 605 # get reference to original binding 606 original <- get(binding, envir = namespace) 607 608 # replace the binding 609 if (is.function(override)) 610 environment(override) <- namespace 611 612 do.call("unlockBinding", list(binding, namespace)) 613 assign(binding, override, envir = namespace) 614 do.call("lockBinding", list(binding, namespace)) 615 616 # if package is attached, override there as well 617 search_name <- paste("package", package, sep = ":") 618 if (search_name %in% search()) { 619 env <- as.environment(search_name) 620 do.call("unlockBinding", list(binding, env)) 621 assign(binding, override, envir = env) 622 do.call("lockBinding", list(binding, env)) 623 } 624 625 # return original 626 original 627} 628 629join <- function(..., sep = "", collapse = "") { 630 paste(..., sep = sep, collapse = collapse) 631} 632 633shell_exec <- function(cmd, intern = FALSE, wait = TRUE, ...) { 634 if (Sys.info()[["sysname"]] == "Windows") 635 shell(cmd, intern = intern, wait = wait, ...) 636 else 637 system(cmd, intern = intern, wait = wait, ...) 638} 639 640# Adjust the graphical device in chunk options: if the device from the output 641# format is png but knitr's global chunk option is not png, respect knitr's 642# option, because (1) users may knitr::opts_chunk$set(dev) (which usually means 643# they know what they are doing) before rmarkdown::render(), and we probably 644# should not override the user's choice; (2) the png device does not work on 645# certain platforms (e.g. headless servers without X11), in which case knitr 646# will set the device to svg instead of png by default in knitr:::set_html_dev, 647# and rmarkdown should also respect this setting, otherwise we will run into 648# issues like https://github.com/rstudio/rmarkdown/issues/1100 649adjust_dev <- function(opts) { 650 dev <- knitr::opts_chunk$get('dev') 651 if (identical(opts$dev, 'png') && length(dev) == 1 && dev != 'png') { 652 opts$dev <- dev 653 } 654 opts 655} 656