1# File src/library/utils/R/SweaveDrivers.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2016 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19RweaveLatex <- function() 20{ 21 list(setup = RweaveLatexSetup, 22 runcode = RweaveLatexRuncode, 23 writedoc = RweaveLatexWritedoc, 24 finish = RweaveLatexFinish, 25 checkopts = RweaveLatexOptions) 26} 27 28## We definitely do not want '.' in here, to avoid misidentification 29## of file extensions. Note that - is used literally here. 30.SweaveValidFilenameRegexp <- "^[[:alnum:]/#+_-]+$" 31 32RweaveLatexSetup <- 33 function(file, syntax, output = NULL, quiet = FALSE, debug = FALSE, 34 stylepath, ...) 35{ 36 dots <- list(...) 37 if (is.null(output)) { 38 prefix.string <- basename(sub(syntax$extension, "", file)) 39 output <- paste0(prefix.string, ".tex") 40 } else prefix.string <- basename(sub("\\.tex$", "", output)) 41 42 if (!quiet) cat("Writing to file ", output, "\n", 43 "Processing code chunks with options ...\n", sep = "") 44 encoding <- attr(file, "encoding") 45 if (encoding %in% c("ASCII", "bytes")) encoding <- "" 46 output <- file(output, open = "w", encoding = encoding) 47 48 if (missing(stylepath)) { 49 p <- Sys.getenv("SWEAVE_STYLEPATH_DEFAULT") 50 stylepath <- 51 if (length(p) >= 1L && nzchar(p[1L])) identical(p, "TRUE") else FALSE 52 } 53 if (stylepath) { 54 styfile <- file.path(R.home("share"), "texmf", "tex", "latex", "Sweave") 55 if (.Platform$OS.type == "windows") 56 styfile <- chartr("\\", "/", styfile) 57 if (length(grep(" ", styfile))) 58 warning(gettextf("path to %s contains spaces,\n", sQuote(styfile)), 59 gettext("this may cause problems when running LaTeX"), 60 domain = NA) 61 } else styfile <- "Sweave" 62 63 options <- list(prefix = TRUE, prefix.string = prefix.string, 64 engine = "R", print = FALSE, eval = TRUE, fig = FALSE, 65 pdf = TRUE, eps = FALSE, png = FALSE, jpeg = FALSE, 66 grdevice = "", width = 6, height = 6, resolution = 300, 67 term = TRUE, echo = TRUE, keep.source = TRUE, 68 results = "verbatim", 69 split = FALSE, strip.white = "true", include = TRUE, 70 pdf.version = grDevices::pdf.options()$version, 71 pdf.encoding = grDevices::pdf.options()$encoding, 72 pdf.compress = grDevices::pdf.options()$compress, 73 expand = TRUE, # unused by us, for 'highlight' 74 concordance = FALSE, figs.only = TRUE) 75 options$.defaults <- options 76 options[names(dots)] <- dots 77 78 ## to be on the safe side: see if defaults pass the check 79 options <- RweaveLatexOptions(options) 80 81 list(output = output, styfile = styfile, havesty = FALSE, 82 haveconcordance = FALSE, debug = debug, quiet = quiet, 83 syntax = syntax, options = options, 84 chunkout = list(), # a list of open connections 85 srclines = integer()) 86} 87 88makeRweaveLatexCodeRunner <- function(evalFunc = RweaveEvalWithOpt) 89{ 90 ## Return a function suitable as the 'runcode' element 91 ## of an Sweave driver. evalFunc will be used for the 92 ## actual evaluation of chunk code. 93 ## FIXME: well, actually not for the figures. 94 ## If there were just one figure option set, we could eval the chunk 95 ## only once. 96 function(object, chunk, options) { 97 pdf.Swd <- function(name, width, height, ...) 98 grDevices::pdf(file = paste0(chunkprefix, ".pdf"), 99 width = width, height = height, 100 version = options$pdf.version, 101 encoding = options$pdf.encoding, 102 compress = options$pdf.compress) 103 eps.Swd <- function(name, width, height, ...) 104 grDevices::postscript(file = paste0(name, ".eps"), 105 width = width, height = height, 106 paper = "special", horizontal = FALSE) 107 png.Swd <- function(name, width, height, options, ...) 108 grDevices::png(filename = paste0(chunkprefix, ".png"), 109 width = width, height = height, 110 res = options$resolution, units = "in") 111 jpeg.Swd <- function(name, width, height, options, ...) 112 grDevices::jpeg(filename = paste0(chunkprefix, ".jpeg"), 113 width = width, height = height, 114 res = options$resolution, units = "in") 115 116 if (!(options$engine %in% c("R", "S"))) return(object) 117 118 devs <- devoffs <- list() 119 if (options$fig && options$eval) { 120 if (options$pdf) { 121 devs <- c(devs, list(pdf.Swd)) 122 devoffs <- c(devoffs, list(grDevices::dev.off)) 123 } 124 if (options$eps) { 125 devs <- c(devs, list(eps.Swd)) 126 devoffs <- c(devoffs, list(grDevices::dev.off)) 127 } 128 if (options$png) { 129 devs <- c(devs, list(png.Swd)) 130 devoffs <- c(devoffs, list(grDevices::dev.off)) 131 } 132 if (options$jpeg) { 133 devs <- c(devs, list(jpeg.Swd)) 134 devoffs <- c(devoffs, list(grDevices::dev.off)) 135 } 136 if(nzchar(grd <- options$grdevice)) { 137 grdo <- paste0(grd, ".off") 138 if(grepl("::", grd, fixed = TRUE)) { 139 devs <- c(devs, eval(str2expression(grd))) 140 devoffs <- 141 c(devoffs, 142 if(!inherits(grdo <- tryCatch(eval(str2expression(grdo)), error = identity), 143 "error")) 144 list(grdo) 145 else 146 list(grDevices::dev.off)) 147 } else { 148 devs <- c(devs, list(get(grd, envir = .GlobalEnv))) 149 devoffs <- 150 c(devoffs, 151 if(exists(grdo, envir = .GlobalEnv)) 152 list(get(grdo, envir = .GlobalEnv)) 153 else 154 list(grDevices::dev.off)) 155 } 156 } 157 } 158 if (!object$quiet) { 159 cat(formatC(options$chunknr, width = 2), ":") 160 if (options$echo) cat(" echo") 161 if (options$keep.source) cat(" keep.source") 162 if (options$eval) { 163 if (options$print) cat(" print") 164 if (options$term) cat(" term") 165 cat("", options$results) 166 if (options$fig) { 167 if (options$eps) cat(" eps") 168 if (options$pdf) cat(" pdf") 169 if (options$png) cat(" png") 170 if (options$jpeg) cat(" jpeg") 171 if (!is.null(options$grdevice)) cat("", options$grdevice) 172 } 173 } 174 cat(" (") 175 if (!is.null(options$label)) 176 cat("label = ", options$label, ", ", sep = "") 177 filenum <- attr(chunk, "srcFilenum")[1] 178 filename <- attr(chunk, "srcFilenames")[filenum] 179 cat(basename(filename), ":", attr(chunk, "srclines")[1], ")", sep = "") 180 cat("\n") 181 } 182 183 chunkprefix <- RweaveChunkPrefix(options) 184 185 if (options$split) { 186 ## [x][[1L]] avoids partial matching of x 187 chunkout <- object$chunkout[chunkprefix][[1L]] 188 if (is.null(chunkout)) { 189 chunkout <- file(paste0(chunkprefix, ".tex"), "w") 190 if (!is.null(options$label)) 191 object$chunkout[[chunkprefix]] <- chunkout 192 if(!grepl(.SweaveValidFilenameRegexp, chunkout)) 193 warning("file stem ", sQuote(chunkout), " is not portable", 194 call. = FALSE, domain = NA) 195 } 196 } else chunkout <- object$output 197 198 srcfile <- srcfilecopy(object$filename, chunk, isFile = TRUE) 199 200 ## Note that we edit the error message below, so change both 201 ## if you change this line: 202 chunkexps <- try(parse(text = chunk, srcfile = srcfile), silent = TRUE) 203 if (inherits(chunkexps, "try-error")) 204 chunkexps[1L] <- sub(" parse(text = chunk, srcfile = srcfile) : \n ", 205 "", chunkexps[1L], fixed = TRUE) 206 207 RweaveTryStop(chunkexps, options) 208 209 ## Some worker functions used below... 210 putSinput <- function(dce, leading) { 211 if (!openSinput) { 212 if (!openSchunk) { 213 cat("\\begin{Schunk}\n", file = chunkout) 214 linesout[thisline + 1L] <<- srcline 215 filenumout[thisline + 1L] <<- srcfilenum 216 thisline <<- thisline + 1L 217 openSchunk <<- TRUE 218 } 219 cat("\\begin{Sinput}", file = chunkout) 220 openSinput <<- TRUE 221 } 222 leading <- max(leading, 1L) # safety check 223 cat("\n", paste0(getOption("prompt"), dce[seq_len(leading)], 224 collapse = "\n"), 225 file = chunkout, sep = "") 226 if (length(dce) > leading) 227 cat("\n", paste0(getOption("continue"), dce[-seq_len(leading)], 228 collapse = "\n"), 229 file = chunkout, sep = "") 230 linesout[thisline + seq_along(dce)] <<- srcline 231 filenumout[thisline + seq_along(dce)] <<- srcfilenum 232 thisline <<- thisline + length(dce) 233 } 234 235 trySrcLines <- function(srcfile, showfrom, showto, ce) { 236 tryCatch(suppressWarnings(getSrcLines(srcfile, showfrom, showto)), 237 error = function(e) { 238 if (is.null(ce)) character() 239 else deparse(ce, width.cutoff = 0.75*getOption("width")) 240 }) 241 } 242 243 echoComments <- function(showto) { 244 if (options$echo && !is.na(lastshown) && lastshown < showto) { 245 dce <- trySrcLines(srcfile, lastshown + 1L, showto, NULL) 246 linedirs <- startsWith(dce, "#line ") 247 dce <- dce[!linedirs] 248 if (length(dce)) 249 putSinput(dce, length(dce)) # These are all trailing comments 250 lastshown <<- showto 251 } 252 } 253 254 openSinput <- FALSE 255 openSchunk <- FALSE 256 257 srclines <- attr(chunk, "srclines") 258 srcfilenums <- attr(chunk, "srcFilenum") 259 linesout <- integer() # maintains concordance 260 filenumout <- integer() # ditto 261 srcline <- srclines[1L] # current input line 262 srcfilenum <- srcfilenums[1L] # from this file 263 thisline <- 0L # current output line 264 lastshown <- 0L # last line already displayed; 265 266## refline <- NA # line containing the current named chunk ref 267 leading <- 1L # How many lines get the user prompt 268 269 srcrefs <- attr(chunkexps, "srcref") 270 271 if (length(devs)) { 272 if(!grepl(.SweaveValidFilenameRegexp, chunkprefix)) 273 warning("file stem ", sQuote(chunkprefix), " is not portable", 274 call. = FALSE, domain = NA) 275 if (options$figs.only) 276 devs[[1L]](name = chunkprefix, 277 width = options$width, height = options$height, 278 options) 279 } 280 SweaveHooks(options, run = TRUE) 281 282 for (nce in seq_along(chunkexps)) { 283 ce <- chunkexps[[nce]] 284 if (options$keep.source && nce <= length(srcrefs) && 285 !is.null(srcref <- srcrefs[[nce]])) { 286 showfrom <- srcref[7L] 287 showto <- srcref[8L] 288 289 dce <- trySrcLines(srcfile, lastshown+1L, showto, ce) 290 leading <- showfrom - lastshown 291 292 lastshown <- showto 293 srcline <- srcref[3L] 294 295 linedirs <- startsWith(dce, "#line ") 296 dce <- dce[!linedirs] 297 # Need to reduce leading lines if some were just removed 298 leading <- leading - sum(linedirs[seq_len(leading)]) 299 300 while (length(dce) && length(grep("^[[:blank:]]*$", dce[1L]))) { 301 dce <- dce[-1L] 302 leading <- leading - 1L 303 } 304 } else { 305 dce <- deparse(ce, width.cutoff = 0.75*getOption("width")) 306 leading <- 1L 307 } 308 if (object$debug) 309 cat("\nRnw> ", paste(dce, collapse = "\n+ "),"\n") 310 311 if (options$echo && length(dce)) putSinput(dce, leading) 312 313 ## avoid the limitations (and overhead) of output text connections 314 if (options$eval) { 315 tmpcon <- file() 316 sink(file = tmpcon) 317 err <- tryCatch(evalFunc(ce, options), finally = { 318 cat("\n") # make sure final line is complete 319 sink() 320 }) 321 output <- readLines(tmpcon) 322 close(tmpcon) 323 ## delete empty output 324 if (length(output) == 1L && !nzchar(output[1L])) output <- NULL 325 RweaveTryStop(err, options) 326 } else output <- NULL 327 328 ## or writeLines(output) 329 if (length(output) && object$debug) 330 cat(paste(output, collapse = "\n")) 331 332 if (length(output) && (options$results != "hide")) { 333 if (openSinput) { 334 cat("\n\\end{Sinput}\n", file = chunkout) 335 linesout[thisline + 1L:2L] <- srcline 336 filenumout[thisline + 1L:2L] <- srcfilenum 337 thisline <- thisline + 2L 338 openSinput <- FALSE 339 } 340 if (options$results == "verbatim") { 341 if (!openSchunk) { 342 cat("\\begin{Schunk}\n", file = chunkout) 343 linesout[thisline + 1L] <- srcline 344 filenumout[thisline + 1L] <- srcfilenum 345 thisline <- thisline + 1L 346 openSchunk <- TRUE 347 } 348 cat("\\begin{Soutput}\n", file = chunkout) 349 linesout[thisline + 1L] <- srcline 350 filenumout[thisline + 1L] <- srcfilenum 351 thisline <- thisline + 1L 352 } 353 354 output <- paste(output, collapse = "\n") 355 if (options$strip.white %in% c("all", "true")) { 356 output <- sub("^[[:space:]]*\n", "", output) 357 output <- sub("\n[[:space:]]*$", "", output) 358 if (options$strip.white == "all") 359 output <- sub("\n[[:space:]]*\n", "\n", output) 360 } 361 cat(output, file = chunkout) 362 count <- sum(strsplit(output, NULL)[[1L]] == "\n") 363 if (count > 0L) { 364 linesout[thisline + 1L:count] <- srcline 365 filenumout[thisline + 1L:count] <- srcfilenum 366 thisline <- thisline + count 367 } 368 369 remove(output) 370 371 if (options$results == "verbatim") { 372 cat("\n\\end{Soutput}\n", file = chunkout) 373 linesout[thisline + 1L:2L] <- srcline 374 filenumout[thisline + 1L:2L] <- srcfilenum 375 thisline <- thisline + 2L 376 } 377 } 378 } # end of loop over chunkexps. 379 380 ## Echo remaining comments if necessary 381 if (options$keep.source) echoComments(length(srcfile$lines)) 382 383 if (openSinput) { 384 cat("\n\\end{Sinput}\n", file = chunkout) 385 linesout[thisline + 1L:2L] <- srcline 386 filenumout[thisline + 1L:2L] <- srcfilenum 387 thisline <- thisline + 2L 388 } 389 390 if (openSchunk) { 391 cat("\\end{Schunk}\n", file = chunkout) 392 linesout[thisline + 1L] <- srcline 393 filenumout[thisline + 1L] <- srcfilenum 394 thisline <- thisline + 1L 395 } 396 397 if (is.null(options$label) && options$split) close(chunkout) 398 399 if (options$split && options$include) { 400 cat("\\input{", chunkprefix, "}\n", sep = "", file = object$output) 401 linesout[thisline + 1L] <- srcline 402 filenumout[thisline + 1L] <- srcfilenum 403 thisline <- thisline + 1L 404 } 405 406 if (length(devs)) { 407 if (options$figs.only) devoffs[[1L]]() 408 for (i in seq_along(devs)) { 409 if (options$figs.only && i == 1) next 410 devs[[i]](name = chunkprefix, width = options$width, 411 height = options$height, options) 412 err <- tryCatch({ 413 SweaveHooks(options, run = TRUE) 414 eval(chunkexps, envir = .GlobalEnv) 415 }, error = function(e) { 416 devoffs[[i]]() 417 stop(conditionMessage(e), call. = FALSE, domain = NA) 418 }) 419 devoffs[[i]]() 420 } 421 422 if (options$include) { 423 cat("\\includegraphics{", chunkprefix, "}\n", sep = "", 424 file = object$output) 425 linesout[thisline + 1L] <- srcline 426 filenumout[thisline + 1L] <- srcfilenum 427 thisline <- thisline + 1L 428 } 429 } 430 object$linesout <- c(object$linesout, linesout) 431 object$filenumout <- c(object$filenumout, filenumout) 432 object 433 } 434} 435 436RweaveLatexRuncode <- makeRweaveLatexCodeRunner() 437 438RweaveLatexWritedoc <- function(object, chunk) 439{ 440 linesout <- attr(chunk, "srclines") 441 filenumout <- attr(chunk, "srcFilenum") 442 443 if (length(grep("\\usepackage[^\\}]*Sweave.*\\}", chunk))) 444 object$havesty <- TRUE 445 446 if (!object$havesty) { 447 begindoc <- "^[[:space:]]*\\\\begin\\{document\\}" 448 which <- grep(begindoc, chunk) 449 if (length(which)) { 450 chunk[which] <- sub(begindoc, 451 paste0("\\\\usepackage{", 452 object$styfile, 453 "}\n\\\\begin{document}"), 454 chunk[which]) 455 idx <- c(1L:which, which, seq.int(from = which+1L, 456 length.out = length(linesout)-which)) 457 linesout <- linesout[idx] 458 filenumout <- filenumout[idx] 459 object$havesty <- TRUE 460 } 461 } 462 463 while(length(pos <- grep(object$syntax$docexpr, chunk))) 464 { 465 cmdloc <- regexpr(object$syntax$docexpr, chunk[pos[1L]]) 466 cmd <- substr(chunk[pos[1L]], cmdloc, 467 cmdloc + attr(cmdloc, "match.length") - 1L) 468 cmd <- sub(object$syntax$docexpr, "\\1", cmd) 469 if (object$options$eval) { 470 val <- tryCatch(as.character(eval(str2expression(cmd), envir = .GlobalEnv)), 471 error = function(e) { 472 filenum <- attr(chunk, "srcFilenum")[pos[1L]] 473 filename <- attr(chunk, "srcFilenames")[filenum] 474 location <- paste0(basename(filename), ":", attr(chunk, "srclines")[pos[1L]]) 475 stop("at ",location, ", ", conditionMessage(e), domain = NA, call. = FALSE) 476 }) 477 ## protect against character(), because sub() will fail 478 if (length(val) == 0L) val <- "" 479 } 480 else val <- paste0("\\\\verb#<<", cmd, ">>#") 481 ## it's always debatable what \verb delim-character to use; 482 ## originally had '{' but that really can mess up LaTeX 483 484 chunk[pos[1L]] <- sub(object$syntax$docexpr, val, chunk[pos[1L]]) 485 } 486 487 ## Process \SweaveOpts{} or similar 488 ## Since they are only supposed to affect code chunks, it is OK 489 ## to process all such in a doc chunk at once. 490 while(length(pos <- grep(object$syntax$docopt, chunk))) 491 { 492 opts <- sub(paste0(".*", object$syntax$docopt, ".*"), 493 "\\1", chunk[pos[1L]]) 494 object$options <- SweaveParseOptions(opts, object$options, 495 RweaveLatexOptions) 496 497 if (isTRUE(object$options$concordance) 498 && !object$haveconcordance) { 499 savelabel <- object$options$label 500 object$options$label <- "concordance" 501 prefix <- RweaveChunkPrefix(object$options) 502 object$options$label <- savelabel 503 object$concordfile <- paste0(prefix, ".tex") 504 chunk[pos[1L]] <- sub(object$syntax$docopt, 505 paste0("\\\\input{", prefix, "}"), 506 chunk[pos[1L]]) 507 object$haveconcordance <- TRUE 508 } else 509 chunk[pos[1L]] <- sub(object$syntax$docopt, "", chunk[pos[1L]]) 510 } 511 512 cat(chunk, sep = "\n", file = object$output) 513 object$linesout <- c(object$linesout, linesout) 514 object$filenumout <- c(object$filenumout, filenumout) 515 516 object 517} 518 519RweaveLatexFinish <- function(object, error = FALSE) 520{ 521 outputname <- summary(object$output)$description 522 if (!object$quiet && !error) { 523 if(!file.exists(outputname)) 524 stop(gettextf("the output file '%s' has disappeared", outputname)) 525 cat("\n", 526 sprintf("You can now run (pdf)latex on %s", sQuote(outputname)), 527 "\n", sep = "") 528 } 529 close(object$output) 530 if (length(object$chunkout)) 531 for (con in object$chunkout) close(con) 532 if (object$haveconcordance) { 533 ## This output format is subject to change. Currently it contains 534 ## three or four parts, separated by colons: 535 ## 1. The output .tex filename 536 ## 2. The input .Rnw filename 537 ## 3. Optionally, the starting line number of the output coded as "ofs nn", 538 ## where nn is the offset to the first output line. This is omitted if nn is 0. 539 ## 4. The input line numbers corresponding to each output line. 540 ## This are compressed using the following simple scheme: 541 ## The first line number, followed by 542 ## a run-length encoded diff of the rest of the line numbers. 543 linesout <- object$linesout 544 filenumout <- object$filenumout 545 filenames <- object$srcFilenames[filenumout] 546 if (!is.null(filenames)) { # Might be NULL if an error occurred 547 filegps <- rle(filenames) 548 offset <- 0L 549 for (i in seq_along(filegps$lengths)) { 550 len <- filegps$lengths[i] 551 inputname <- filegps$values[i] 552 vals <- rle(diff(linesout[offset + seq_len(len)])) 553 vals <- c(linesout[offset + 1L], as.numeric(rbind(vals$lengths, vals$values))) 554 concordance <- paste(strwrap(paste(vals, collapse = " ")), collapse = " %\n") 555 special <- paste0("\\Sconcordance{concordance:", outputname, ":", 556 inputname, ":", 557 if (offset) paste0("ofs ", offset, ":") else "", 558 "%\n", 559 concordance,"}\n") 560 cat(special, file = object$concordfile, append=offset > 0L) 561 offset <- offset + len 562 } 563 } 564 } 565 invisible(outputname) 566} 567 568## This is the check function for both RweaveLatex and Rtangle drivers 569RweaveLatexOptions <- function(options) 570{ 571 defaults <- options[[".defaults"]] 572 573 ## convert a character string to logical 574 c2l <- function(x) 575 if (is.null(x)) FALSE else suppressWarnings(as.logical(x)) 576 577 ## numeric 578 NUMOPTS <- c("width", "height", "resolution") 579 580 ## character: largely for safety, but 'label' matters as there 581 ## is no default (and someone uses "F") 582 CHAROPTS <- c("results", "prefix.string", "engine", "label", 583 "strip.white", "pdf.version", "pdf.encoding", "grdevice") 584 585 586 for (opt in names(options)) { 587 if(opt == ".defaults") next 588 oldval <- options[[opt]] 589 defval <- defaults[[opt]] 590 if(opt %in% CHAROPTS || is.character(defval)) { 591 } else if(is.logical(defval)) 592 options[[opt]] <- c2l(oldval) 593 else if(opt %in% NUMOPTS || is.numeric(defval)) 594 options[[opt]] <- as.numeric(oldval) 595 else if(!is.na(newval <- c2l(oldval))) 596 options[[opt]] <- newval 597 else if(!is.na(newval <- suppressWarnings(as.numeric(oldval)))) 598 options[[opt]] <- newval 599 if (is.na(options[[opt]])) 600 stop(gettextf("invalid value for %s : %s", sQuote(opt), oldval), 601 domain = NA) 602 } 603 604 if (!is.null(options$results)) { 605 res <- as.character(options$results) 606 if(tolower(res) != res) # documented as lower-case 607 warning("value of 'results' option should be lowercase", 608 call. = FALSE) 609 options$results <- tolower(res) 610 } 611 options$results <- match.arg(options$results, c("verbatim", "tex", "hide")) 612 613 if (!is.null(options$strip.white)) { 614 res <- as.character(options$strip.white) 615 if(tolower(res) != res) 616 warning("value of 'strip.white' option should be lowercase", 617 call. = FALSE) 618 options$strip.white <- tolower(res) 619 } 620 options$strip.white <- 621 match.arg(options$strip.white, c("true", "false", "all")) 622 options 623} 624 625 626RweaveChunkPrefix <- function(options) 627{ 628 if (!is.null(options$label)) { 629 if (options$prefix) 630 paste0(options$prefix.string, "-", options$label) 631 else 632 options$label 633 } else 634 paste0(options$prefix.string, "-", 635 formatC(options$chunknr, flag = "0", width = 3)) 636} 637 638RweaveEvalWithOpt <- function (expr, options) 639{ 640 if (options$eval) { 641 ## Note: try() as opposed to tryCatch() for back compatibility; 642 ## and RweaveTryStop() will work with it 643 res <- try(withVisible(eval(expr, .GlobalEnv)), silent = TRUE) 644 if (inherits(res, "try-error")) return(res) 645 if (options$print || (options$term && res$visible)) { 646 if (.isMethodsDispatchOn() && isS4(res$value)) 647 methods::show(res$value) else print(res$value) 648 } 649 } 650 res 651} 652 653RweaveTryStop <- function(err, options) 654{ 655 if (inherits(err, "try-error")) { ## from RweaveEvalWithOpt() 656 cat("\n") 657 msg <- paste(" chunk", options$chunknr) 658 if (!is.null(options$label)) 659 msg <- paste0(msg, " (label = ", options$label, ")") 660 msg <- paste(msg, "\n") 661 stop(msg, err, call. = FALSE) 662 } 663} 664 665###------------------------------------------------------------------------ 666 667Rtangle <- function() 668{ 669 list(setup = RtangleSetup, 670 runcode = RtangleRuncode, 671 writedoc = RtangleWritedoc, 672 finish = RtangleFinish, 673 checkopts = RweaveLatexOptions) 674} 675 676 677RtangleSetup <- 678 function(file, syntax, output = NULL, annotate = TRUE, split = FALSE, 679 quiet = FALSE, drop.evalFALSE = FALSE, ...) 680{ 681 dots <- list(...) 682 if (is.null(output)) { 683 prefix.string <- basename(sub(syntax$extension, "", file)) 684 ## This is odd, since for split = TRUE it uses the engine name. 685 output <- paste0(prefix.string, ".R") 686 } else 687 prefix.string <- basename(sub("\\.[rsRS]$", "", output)) 688 689 if (!split) { 690 if (identical(output, "stdout")) output <- stdout() 691 else if (identical(output, "stderr")) output <- stderr() 692 else { 693 if (!quiet) cat("Writing to file", output, "\n") 694 encoding <- attr(file, "encoding") 695 if (encoding %in% c("ASCII", "bytes")) encoding <- "" 696 output <- file(output, open = "w", encoding = encoding) 697 } 698 lines <- c(paste("###", 699 sprintf("R code from vignette source '%s'", 700 file)), 701 "") 702 writeLines(lines, output) 703 } else { 704 if (!quiet) cat("Writing chunks to files ...\n") 705 output <- NULL 706 } 707 708 options <- list(split = split, prefix = TRUE, 709 prefix.string = prefix.string, 710 engine = "R", eval = TRUE, 711 show.line.nos = FALSE) 712 options$.defaults <- options 713 options[names(dots)] <- dots 714 715 ## to be on the safe side: see if defaults pass the check 716 options <- RweaveLatexOptions(options) 717 718 list(output = output, annotate = annotate, options = options, 719 chunkout = list(), quiet = quiet, syntax = syntax, 720 drop.evalFALSE = drop.evalFALSE) 721} 722 723.RtangleCodeLabel <- function(chunk) { 724 if(length(lnos <- grep("^#line ", chunk, value = TRUE))) { 725 srclines <- attr(chunk, "srclines") 726 ## srcfilenum <- attr(chunk, "srcFilenum") 727 ## this currently includes the chunk header 728 lno <- if (length(srclines)) 729 paste(min(srclines), max(srclines), sep = "-") 730 else srclines 731 fn <- sub('[^"]*"([^"]+).*', "\\1", lnos[1L]) 732 paste(fn, lno, sep = ":") 733 } else 734 "(missing #line/file info)" 735} 736 737RtangleRuncode <- function(object, chunk, options) 738{ 739 if (!(options$engine %in% c("R", "S"))) return(object) 740 741 chunkprefix <- RweaveChunkPrefix(options) 742 743 if (options$split) { 744 if(!grepl(.SweaveValidFilenameRegexp, chunkprefix)) 745 warning("file stem ", sQuote(chunkprefix), " is not portable", 746 call. = FALSE, domain = NA) 747 outfile <- paste(chunkprefix, options$engine, sep = ".") 748 if (!object$quiet) cat(options$chunknr, ":", outfile,"\n") 749 ## [x][[1L]] avoids partial matching of x 750 chunkout <- object$chunkout[chunkprefix][[1L]] 751 if (is.null(chunkout)) { 752 chunkout <- file(outfile, "w") 753 if (!is.null(options$label)) 754 object$chunkout[[chunkprefix]] <- chunkout 755 } 756 } else 757 chunkout <- object$output 758 759 showOut <- options$eval || !object$drop.evalFALSE 760 if(showOut) { 761 annotate <- object$annotate 762 if (is.logical(annotate) && annotate) { 763 cat("###################################################\n", 764 "### code chunk number ", options$chunknr, ": ", 765 if(!is.null(ol <- options$label)) ol else .RtangleCodeLabel(chunk), 766 if(!options$eval) " (eval = FALSE)", "\n", 767 "###################################################\n", 768 file = chunkout, sep = "") 769 } else if(is.function(annotate)) 770 annotate(options, chunk = chunk, output = chunkout) 771 } 772 773 ## The next returns a character vector of the logical options 774 ## which are true and have hooks set. 775 hooks <- SweaveHooks(options, run = FALSE) 776 for (k in hooks) 777 cat("getOption(\"SweaveHooks\")[[\"", k, "\"]]()\n", 778 file = chunkout, sep = "") 779 780 if(showOut) { 781 if (!options$show.line.nos) # drop "#line ...." lines 782 chunk <- grep("^#line ", chunk, value = TRUE, invert = TRUE) 783 if (!options$eval) chunk <- paste("##", chunk) 784 cat(chunk, "\n", file = chunkout, sep = "\n") 785 } 786 if (is.null(options$label) && options$split) close(chunkout) 787 object 788} 789 790RtangleWritedoc <- function(object, chunk) 791{ 792 while(length(pos <- grep(object$syntax$docopt, chunk))) { 793 opts <- sub(paste0(".*", object$syntax$docopt, ".*"), 794 "\\1", chunk[pos[1L]]) 795 object$options <- SweaveParseOptions(opts, object$options, 796 RweaveLatexOptions) 797 chunk[pos[1L]] <- sub(object$syntax$docopt, "", chunk[pos[1L]]) 798 } 799 object 800} 801 802 803RtangleFinish <- function(object, error = FALSE) 804{ 805 ## might be stdout() or stderr() 806 if (!is.null(object$output) && object$output >= 3) 807 close(object$output) 808 809 if (length(object$chunkout)) 810 for (con in object$chunkout) close(con) 811} 812