| # File src/library/utils/R/SweaveDrivers.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2016 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| RweaveLatex <- function() |
| { |
| list(setup = RweaveLatexSetup, |
| runcode = RweaveLatexRuncode, |
| writedoc = RweaveLatexWritedoc, |
| finish = RweaveLatexFinish, |
| checkopts = RweaveLatexOptions) |
| } |
| |
| ## We definitely do not want '.' in here, to avoid misidentification |
| ## of file extensions. Note that - is used literally here. |
| .SweaveValidFilenameRegexp <- "^[[:alnum:]/#+_-]+$" |
| |
| RweaveLatexSetup <- |
| function(file, syntax, output = NULL, quiet = FALSE, debug = FALSE, |
| stylepath, ...) |
| { |
| dots <- list(...) |
| if (is.null(output)) { |
| prefix.string <- basename(sub(syntax$extension, "", file)) |
| output <- paste0(prefix.string, ".tex") |
| } else prefix.string <- basename(sub("\\.tex$", "", output)) |
| |
| if (!quiet) cat("Writing to file ", output, "\n", |
| "Processing code chunks with options ...\n", sep = "") |
| encoding <- attr(file, "encoding") |
| if (encoding %in% c("ASCII", "bytes")) encoding <- "" |
| output <- file(output, open = "w", encoding = encoding) |
| |
| if (missing(stylepath)) { |
| p <- Sys.getenv("SWEAVE_STYLEPATH_DEFAULT") |
| stylepath <- |
| if (length(p) >= 1L && nzchar(p[1L])) identical(p, "TRUE") else FALSE |
| } |
| if (stylepath) { |
| styfile <- file.path(R.home("share"), "texmf", "tex", "latex", "Sweave") |
| if (.Platform$OS.type == "windows") |
| styfile <- chartr("\\", "/", styfile) |
| if (length(grep(" ", styfile))) |
| warning(gettextf("path to %s contains spaces,\n", sQuote(styfile)), |
| gettext("this may cause problems when running LaTeX"), |
| domain = NA) |
| } else styfile <- "Sweave" |
| |
| options <- list(prefix = TRUE, prefix.string = prefix.string, |
| engine = "R", print = FALSE, eval = TRUE, fig = FALSE, |
| pdf = TRUE, eps = FALSE, png = FALSE, jpeg = FALSE, |
| grdevice = "", width = 6, height = 6, resolution = 300, |
| term = TRUE, echo = TRUE, keep.source = TRUE, |
| results = "verbatim", |
| split = FALSE, strip.white = "true", include = TRUE, |
| pdf.version = grDevices::pdf.options()$version, |
| pdf.encoding = grDevices::pdf.options()$encoding, |
| pdf.compress = grDevices::pdf.options()$compress, |
| expand = TRUE, # unused by us, for 'highlight' |
| concordance = FALSE, figs.only = TRUE) |
| options$.defaults <- options |
| options[names(dots)] <- dots |
| |
| ## to be on the safe side: see if defaults pass the check |
| options <- RweaveLatexOptions(options) |
| |
| list(output = output, styfile = styfile, havesty = FALSE, |
| haveconcordance = FALSE, debug = debug, quiet = quiet, |
| syntax = syntax, options = options, |
| chunkout = list(), # a list of open connections |
| srclines = integer()) |
| } |
| |
| makeRweaveLatexCodeRunner <- function(evalFunc = RweaveEvalWithOpt) |
| { |
| ## Return a function suitable as the 'runcode' element |
| ## of an Sweave driver. evalFunc will be used for the |
| ## actual evaluation of chunk code. |
| ## FIXME: well, actually not for the figures. |
| ## If there were just one figure option set, we could eval the chunk |
| ## only once. |
| function(object, chunk, options) { |
| pdf.Swd <- function(name, width, height, ...) |
| grDevices::pdf(file = paste0(chunkprefix, ".pdf"), |
| width = width, height = height, |
| version = options$pdf.version, |
| encoding = options$pdf.encoding, |
| compress = options$pdf.compress) |
| eps.Swd <- function(name, width, height, ...) |
| grDevices::postscript(file = paste0(name, ".eps"), |
| width = width, height = height, |
| paper = "special", horizontal = FALSE) |
| png.Swd <- function(name, width, height, options, ...) |
| grDevices::png(filename = paste0(chunkprefix, ".png"), |
| width = width, height = height, |
| res = options$resolution, units = "in") |
| jpeg.Swd <- function(name, width, height, options, ...) |
| grDevices::jpeg(filename = paste0(chunkprefix, ".jpeg"), |
| width = width, height = height, |
| res = options$resolution, units = "in") |
| |
| if (!(options$engine %in% c("R", "S"))) return(object) |
| |
| devs <- devoffs <- list() |
| if (options$fig && options$eval) { |
| if (options$pdf) { |
| devs <- c(devs, list(pdf.Swd)) |
| devoffs <- c(devoffs, list(grDevices::dev.off)) |
| } |
| if (options$eps) { |
| devs <- c(devs, list(eps.Swd)) |
| devoffs <- c(devoffs, list(grDevices::dev.off)) |
| } |
| if (options$png) { |
| devs <- c(devs, list(png.Swd)) |
| devoffs <- c(devoffs, list(grDevices::dev.off)) |
| } |
| if (options$jpeg) { |
| devs <- c(devs, list(jpeg.Swd)) |
| devoffs <- c(devoffs, list(grDevices::dev.off)) |
| } |
| if(nzchar(grd <- options$grdevice)) { |
| grdo <- paste0(grd, ".off") |
| if(grepl("::", grd, fixed = TRUE)) { |
| devs <- c(devs, eval(parse(text = grd))) |
| devoffs <- |
| c(devoffs, |
| if(!inherits(grdo <- |
| tryCatch(eval(parse(text = grdo)), |
| error = identity), |
| "error")) |
| list(grdo) |
| else |
| list(grDevices::dev.off)) |
| } else { |
| devs <- c(devs, list(get(grd, envir = .GlobalEnv))) |
| devoffs <- |
| c(devoffs, |
| if(exists(grdo, envir = .GlobalEnv)) |
| list(get(grdo, envir = .GlobalEnv)) |
| else |
| list(grDevices::dev.off)) |
| } |
| } |
| } |
| if (!object$quiet) { |
| cat(formatC(options$chunknr, width = 2), ":") |
| if (options$echo) cat(" echo") |
| if (options$keep.source) cat(" keep.source") |
| if (options$eval) { |
| if (options$print) cat(" print") |
| if (options$term) cat(" term") |
| cat("", options$results) |
| if (options$fig) { |
| if (options$eps) cat(" eps") |
| if (options$pdf) cat(" pdf") |
| if (options$png) cat(" png") |
| if (options$jpeg) cat(" jpeg") |
| if (!is.null(options$grdevice)) cat("", options$grdevice) |
| } |
| } |
| cat(" (") |
| if (!is.null(options$label)) |
| cat("label = ", options$label, ", ", sep = "") |
| filenum <- attr(chunk, "srcFilenum")[1] |
| filename <- attr(chunk, "srcFilenames")[filenum] |
| cat(basename(filename), ":", attr(chunk, "srclines")[1], ")", sep = "") |
| cat("\n") |
| } |
| |
| chunkprefix <- RweaveChunkPrefix(options) |
| |
| if (options$split) { |
| ## [x][[1L]] avoids partial matching of x |
| chunkout <- object$chunkout[chunkprefix][[1L]] |
| if (is.null(chunkout)) { |
| chunkout <- file(paste0(chunkprefix, ".tex"), "w") |
| if (!is.null(options$label)) |
| object$chunkout[[chunkprefix]] <- chunkout |
| if(!grepl(.SweaveValidFilenameRegexp, chunkout)) |
| warning("file stem ", sQuote(chunkout), " is not portable", |
| call. = FALSE, domain = NA) |
| } |
| } else chunkout <- object$output |
| |
| srcfile <- srcfilecopy(object$filename, chunk, isFile = TRUE) |
| |
| ## Note that we edit the error message below, so change both |
| ## if you change this line: |
| chunkexps <- try(parse(text = chunk, srcfile = srcfile), silent = TRUE) |
| if (inherits(chunkexps, "try-error")) |
| chunkexps[1L] <- sub(" parse(text = chunk, srcfile = srcfile) : \n ", |
| "", chunkexps[1L], fixed = TRUE) |
| |
| RweaveTryStop(chunkexps, options) |
| |
| ## Some worker functions used below... |
| putSinput <- function(dce, leading) { |
| if (!openSinput) { |
| if (!openSchunk) { |
| cat("\\begin{Schunk}\n", file = chunkout) |
| linesout[thisline + 1L] <<- srcline |
| filenumout[thisline + 1L] <<- srcfilenum |
| thisline <<- thisline + 1L |
| openSchunk <<- TRUE |
| } |
| cat("\\begin{Sinput}", file = chunkout) |
| openSinput <<- TRUE |
| } |
| leading <- max(leading, 1L) # safety check |
| cat("\n", paste0(getOption("prompt"), dce[seq_len(leading)], |
| collapse = "\n"), |
| file = chunkout, sep = "") |
| if (length(dce) > leading) |
| cat("\n", paste0(getOption("continue"), dce[-seq_len(leading)], |
| collapse = "\n"), |
| file = chunkout, sep = "") |
| linesout[thisline + seq_along(dce)] <<- srcline |
| filenumout[thisline + seq_along(dce)] <<- srcfilenum |
| thisline <<- thisline + length(dce) |
| } |
| |
| trySrcLines <- function(srcfile, showfrom, showto, ce) { |
| tryCatch(suppressWarnings(getSrcLines(srcfile, showfrom, showto)), |
| error = function(e) { |
| if (is.null(ce)) character() |
| else deparse(ce, width.cutoff = 0.75*getOption("width")) |
| }) |
| } |
| |
| echoComments <- function(showto) { |
| if (options$echo && !is.na(lastshown) && lastshown < showto) { |
| dce <- trySrcLines(srcfile, lastshown + 1L, showto, NULL) |
| linedirs <- startsWith(dce, "#line ") |
| dce <- dce[!linedirs] |
| if (length(dce)) |
| putSinput(dce, length(dce)) # These are all trailing comments |
| lastshown <<- showto |
| } |
| } |
| |
| openSinput <- FALSE |
| openSchunk <- FALSE |
| |
| srclines <- attr(chunk, "srclines") |
| srcfilenums <- attr(chunk, "srcFilenum") |
| linesout <- integer() # maintains concordance |
| filenumout <- integer() # ditto |
| srcline <- srclines[1L] # current input line |
| srcfilenum <- srcfilenums[1L] # from this file |
| thisline <- 0L # current output line |
| lastshown <- 0L # last line already displayed; |
| |
| ## refline <- NA # line containing the current named chunk ref |
| leading <- 1L # How many lines get the user prompt |
| |
| srcrefs <- attr(chunkexps, "srcref") |
| |
| if (length(devs)) { |
| if(!grepl(.SweaveValidFilenameRegexp, chunkprefix)) |
| warning("file stem ", sQuote(chunkprefix), " is not portable", |
| call. = FALSE, domain = NA) |
| if (options$figs.only) |
| devs[[1L]](name = chunkprefix, |
| width = options$width, height = options$height, |
| options) |
| } |
| SweaveHooks(options, run = TRUE) |
| |
| for (nce in seq_along(chunkexps)) { |
| ce <- chunkexps[[nce]] |
| if (options$keep.source && nce <= length(srcrefs) && |
| !is.null(srcref <- srcrefs[[nce]])) { |
| showfrom <- srcref[7L] |
| showto <- srcref[8L] |
| |
| dce <- trySrcLines(srcfile, lastshown+1L, showto, ce) |
| leading <- showfrom - lastshown |
| |
| lastshown <- showto |
| srcline <- srcref[3L] |
| |
| linedirs <- startsWith(dce, "#line ") |
| dce <- dce[!linedirs] |
| # Need to reduce leading lines if some were just removed |
| leading <- leading - sum(linedirs[seq_len(leading)]) |
| |
| while (length(dce) && length(grep("^[[:blank:]]*$", dce[1L]))) { |
| dce <- dce[-1L] |
| leading <- leading - 1L |
| } |
| } else { |
| dce <- deparse(ce, width.cutoff = 0.75*getOption("width")) |
| leading <- 1L |
| } |
| if (object$debug) |
| cat("\nRnw> ", paste(dce, collapse = "\n+ "),"\n") |
| |
| if (options$echo && length(dce)) putSinput(dce, leading) |
| |
| ## avoid the limitations (and overhead) of output text connections |
| if (options$eval) { |
| tmpcon <- file() |
| sink(file = tmpcon) |
| err <- tryCatch(evalFunc(ce, options), finally = { |
| cat("\n") # make sure final line is complete |
| sink() |
| }) |
| output <- readLines(tmpcon) |
| close(tmpcon) |
| ## delete empty output |
| if (length(output) == 1L && !nzchar(output[1L])) output <- NULL |
| RweaveTryStop(err, options) |
| } else output <- NULL |
| |
| ## or writeLines(output) |
| if (length(output) && object$debug) |
| cat(paste(output, collapse = "\n")) |
| |
| if (length(output) && (options$results != "hide")) { |
| if (openSinput) { |
| cat("\n\\end{Sinput}\n", file = chunkout) |
| linesout[thisline + 1L:2L] <- srcline |
| filenumout[thisline + 1L:2L] <- srcfilenum |
| thisline <- thisline + 2L |
| openSinput <- FALSE |
| } |
| if (options$results == "verbatim") { |
| if (!openSchunk) { |
| cat("\\begin{Schunk}\n", file = chunkout) |
| linesout[thisline + 1L] <- srcline |
| filenumout[thisline + 1L] <- srcfilenum |
| thisline <- thisline + 1L |
| openSchunk <- TRUE |
| } |
| cat("\\begin{Soutput}\n", file = chunkout) |
| linesout[thisline + 1L] <- srcline |
| filenumout[thisline + 1L] <- srcfilenum |
| thisline <- thisline + 1L |
| } |
| |
| output <- paste(output, collapse = "\n") |
| if (options$strip.white %in% c("all", "true")) { |
| output <- sub("^[[:space:]]*\n", "", output) |
| output <- sub("\n[[:space:]]*$", "", output) |
| if (options$strip.white == "all") |
| output <- sub("\n[[:space:]]*\n", "\n", output) |
| } |
| cat(output, file = chunkout) |
| count <- sum(strsplit(output, NULL)[[1L]] == "\n") |
| if (count > 0L) { |
| linesout[thisline + 1L:count] <- srcline |
| filenumout[thisline + 1L:count] <- srcfilenum |
| thisline <- thisline + count |
| } |
| |
| remove(output) |
| |
| if (options$results == "verbatim") { |
| cat("\n\\end{Soutput}\n", file = chunkout) |
| linesout[thisline + 1L:2L] <- srcline |
| filenumout[thisline + 1L:2L] <- srcfilenum |
| thisline <- thisline + 2L |
| } |
| } |
| } # end of loop over chunkexps. |
| |
| ## Echo remaining comments if necessary |
| if (options$keep.source) echoComments(length(srcfile$lines)) |
| |
| if (openSinput) { |
| cat("\n\\end{Sinput}\n", file = chunkout) |
| linesout[thisline + 1L:2L] <- srcline |
| filenumout[thisline + 1L:2L] <- srcfilenum |
| thisline <- thisline + 2L |
| } |
| |
| if (openSchunk) { |
| cat("\\end{Schunk}\n", file = chunkout) |
| linesout[thisline + 1L] <- srcline |
| filenumout[thisline + 1L] <- srcfilenum |
| thisline <- thisline + 1L |
| } |
| |
| if (is.null(options$label) && options$split) close(chunkout) |
| |
| if (options$split && options$include) { |
| cat("\\input{", chunkprefix, "}\n", sep = "", file = object$output) |
| linesout[thisline + 1L] <- srcline |
| filenumout[thisline + 1L] <- srcfilenum |
| thisline <- thisline + 1L |
| } |
| |
| if (length(devs)) { |
| if (options$figs.only) devoffs[[1L]]() |
| for (i in seq_along(devs)) { |
| if (options$figs.only && i == 1) next |
| devs[[i]](name = chunkprefix, width = options$width, |
| height = options$height, options) |
| err <- tryCatch({ |
| SweaveHooks(options, run = TRUE) |
| eval(chunkexps, envir = .GlobalEnv) |
| }, error = function(e) { |
| devoffs[[i]]() |
| stop(conditionMessage(e), call. = FALSE, domain = NA) |
| }) |
| devoffs[[i]]() |
| } |
| |
| if (options$include) { |
| cat("\\includegraphics{", chunkprefix, "}\n", sep = "", |
| file = object$output) |
| linesout[thisline + 1L] <- srcline |
| filenumout[thisline + 1L] <- srcfilenum |
| thisline <- thisline + 1L |
| } |
| } |
| object$linesout <- c(object$linesout, linesout) |
| object$filenumout <- c(object$filenumout, filenumout) |
| object |
| } |
| } |
| |
| RweaveLatexRuncode <- makeRweaveLatexCodeRunner() |
| |
| RweaveLatexWritedoc <- function(object, chunk) |
| { |
| linesout <- attr(chunk, "srclines") |
| filenumout <- attr(chunk, "srcFilenum") |
| |
| if (length(grep("\\usepackage[^\\}]*Sweave.*\\}", chunk))) |
| object$havesty <- TRUE |
| |
| if (!object$havesty) { |
| begindoc <- "^[[:space:]]*\\\\begin\\{document\\}" |
| which <- grep(begindoc, chunk) |
| if (length(which)) { |
| chunk[which] <- sub(begindoc, |
| paste0("\\\\usepackage{", |
| object$styfile, |
| "}\n\\\\begin{document}"), |
| chunk[which]) |
| idx <- c(1L:which, which, seq.int(from = which+1L, |
| length.out = length(linesout)-which)) |
| linesout <- linesout[idx] |
| filenumout <- filenumout[idx] |
| object$havesty <- TRUE |
| } |
| } |
| |
| while(length(pos <- grep(object$syntax$docexpr, chunk))) |
| { |
| cmdloc <- regexpr(object$syntax$docexpr, chunk[pos[1L]]) |
| cmd <- substr(chunk[pos[1L]], cmdloc, |
| cmdloc + attr(cmdloc, "match.length") - 1L) |
| cmd <- sub(object$syntax$docexpr, "\\1", cmd) |
| if (object$options$eval) { |
| val <- tryCatch(as.character(eval(parse(text = cmd), envir = .GlobalEnv)), |
| error = function(e) { |
| filenum <- attr(chunk, "srcFilenum")[pos[1L]] |
| filename <- attr(chunk, "srcFilenames")[filenum] |
| location <- paste0(basename(filename), ":", attr(chunk, "srclines")[pos[1L]]) |
| stop("at ",location, ", ", conditionMessage(e), domain = NA, call. = FALSE) |
| }) |
| ## protect against character(), because sub() will fail |
| if (length(val) == 0L) val <- "" |
| } |
| else val <- paste0("\\\\verb#<<", cmd, ">>#") |
| ## it's always debatable what \verb delim-character to use; |
| ## originally had '{' but that really can mess up LaTeX |
| |
| chunk[pos[1L]] <- sub(object$syntax$docexpr, val, chunk[pos[1L]]) |
| } |
| |
| ## Process \SweaveOpts{} or similar |
| ## Since they are only supposed to affect code chunks, it is OK |
| ## to process all such in a doc chunk at once. |
| while(length(pos <- grep(object$syntax$docopt, chunk))) |
| { |
| opts <- sub(paste0(".*", object$syntax$docopt, ".*"), |
| "\\1", chunk[pos[1L]]) |
| object$options <- SweaveParseOptions(opts, object$options, |
| RweaveLatexOptions) |
| |
| if (isTRUE(object$options$concordance) |
| && !object$haveconcordance) { |
| savelabel <- object$options$label |
| object$options$label <- "concordance" |
| prefix <- RweaveChunkPrefix(object$options) |
| object$options$label <- savelabel |
| object$concordfile <- paste0(prefix, ".tex") |
| chunk[pos[1L]] <- sub(object$syntax$docopt, |
| paste0("\\\\input{", prefix, "}"), |
| chunk[pos[1L]]) |
| object$haveconcordance <- TRUE |
| } else |
| chunk[pos[1L]] <- sub(object$syntax$docopt, "", chunk[pos[1L]]) |
| } |
| |
| cat(chunk, sep = "\n", file = object$output) |
| object$linesout <- c(object$linesout, linesout) |
| object$filenumout <- c(object$filenumout, filenumout) |
| |
| object |
| } |
| |
| RweaveLatexFinish <- function(object, error = FALSE) |
| { |
| outputname <- summary(object$output)$description |
| if (!object$quiet && !error) { |
| if(!file.exists(outputname)) |
| stop(gettextf("the output file '%s' has disappeared", outputname)) |
| cat("\n", |
| sprintf("You can now run (pdf)latex on %s", sQuote(outputname)), |
| "\n", sep = "") |
| } |
| close(object$output) |
| if (length(object$chunkout)) |
| for (con in object$chunkout) close(con) |
| if (object$haveconcordance) { |
| ## This output format is subject to change. Currently it contains |
| ## three or four parts, separated by colons: |
| ## 1. The output .tex filename |
| ## 2. The input .Rnw filename |
| ## 3. Optionally, the starting line number of the output coded as "ofs nn", |
| ## where nn is the offset to the first output line. This is omitted if nn is 0. |
| ## 4. The input line numbers corresponding to each output line. |
| ## This are compressed using the following simple scheme: |
| ## The first line number, followed by |
| ## a run-length encoded diff of the rest of the line numbers. |
| linesout <- object$linesout |
| filenumout <- object$filenumout |
| filenames <- object$srcFilenames[filenumout] |
| if (!is.null(filenames)) { # Might be NULL if an error occurred |
| filegps <- rle(filenames) |
| offset <- 0L |
| for (i in seq_along(filegps$lengths)) { |
| len <- filegps$lengths[i] |
| inputname <- filegps$values[i] |
| vals <- rle(diff(linesout[offset + seq_len(len)])) |
| vals <- c(linesout[offset + 1L], as.numeric(rbind(vals$lengths, vals$values))) |
| concordance <- paste(strwrap(paste(vals, collapse = " ")), collapse = " %\n") |
| special <- paste0("\\Sconcordance{concordance:", outputname, ":", |
| inputname, ":", |
| if (offset) paste0("ofs ", offset, ":") else "", |
| "%\n", |
| concordance,"}\n") |
| cat(special, file = object$concordfile, append=offset > 0L) |
| offset <- offset + len |
| } |
| } |
| } |
| invisible(outputname) |
| } |
| |
| ## This is the check function for both RweaveLatex and Rtangle drivers |
| RweaveLatexOptions <- function(options) |
| { |
| defaults <- options[[".defaults"]] |
| |
| ## convert a character string to logical |
| c2l <- function(x) |
| if (is.null(x)) FALSE else suppressWarnings(as.logical(x)) |
| |
| ## numeric |
| NUMOPTS <- c("width", "height", "resolution") |
| |
| ## character: largely for safety, but 'label' matters as there |
| ## is no default (and someone uses "F") |
| CHAROPTS <- c("results", "prefix.string", "engine", "label", |
| "strip.white", "pdf.version", "pdf.encoding", "grdevice") |
| |
| |
| for (opt in names(options)) { |
| if(opt == ".defaults") next |
| oldval <- options[[opt]] |
| defval <- defaults[[opt]] |
| if(opt %in% CHAROPTS || is.character(defval)) { |
| } else if(is.logical(defval)) |
| options[[opt]] <- c2l(oldval) |
| else if(opt %in% NUMOPTS || is.numeric(defval)) |
| options[[opt]] <- as.numeric(oldval) |
| else if(!is.na(newval <- c2l(oldval))) |
| options[[opt]] <- newval |
| else if(!is.na(newval <- suppressWarnings(as.numeric(oldval)))) |
| options[[opt]] <- newval |
| if (is.na(options[[opt]])) |
| stop(gettextf("invalid value for %s : %s", sQuote(opt), oldval), |
| domain = NA) |
| } |
| |
| if (!is.null(options$results)) { |
| res <- as.character(options$results) |
| if(tolower(res) != res) # documented as lower-case |
| warning("value of 'results' option should be lowercase", |
| call. = FALSE) |
| options$results <- tolower(res) |
| } |
| options$results <- match.arg(options$results, c("verbatim", "tex", "hide")) |
| |
| if (!is.null(options$strip.white)) { |
| res <- as.character(options$strip.white) |
| if(tolower(res) != res) |
| warning("value of 'strip.white' option should be lowercase", |
| call. = FALSE) |
| options$strip.white <- tolower(res) |
| } |
| options$strip.white <- |
| match.arg(options$strip.white, c("true", "false", "all")) |
| options |
| } |
| |
| |
| RweaveChunkPrefix <- function(options) |
| { |
| if (!is.null(options$label)) { |
| if (options$prefix) |
| paste0(options$prefix.string, "-", options$label) |
| else |
| options$label |
| } else |
| paste0(options$prefix.string, "-", |
| formatC(options$chunknr, flag = "0", width = 3)) |
| } |
| |
| RweaveEvalWithOpt <- function (expr, options) |
| { |
| if (options$eval) { |
| ## Note: try() as opposed to tryCatch() for back compatibility; |
| ## and RweaveTryStop() will work with it |
| res <- try(withVisible(eval(expr, .GlobalEnv)), silent = TRUE) |
| if (inherits(res, "try-error")) return(res) |
| if (options$print || (options$term && res$visible)) { |
| if (.isMethodsDispatchOn() && isS4(res$value)) |
| methods::show(res$value) else print(res$value) |
| } |
| } |
| res |
| } |
| |
| RweaveTryStop <- function(err, options) |
| { |
| if (inherits(err, "try-error")) { ## from RweaveEvalWithOpt() |
| cat("\n") |
| msg <- paste(" chunk", options$chunknr) |
| if (!is.null(options$label)) |
| msg <- paste0(msg, " (label = ", options$label, ")") |
| msg <- paste(msg, "\n") |
| stop(msg, err, call. = FALSE) |
| } |
| } |
| |
| ###------------------------------------------------------------------------ |
| |
| Rtangle <- function() |
| { |
| list(setup = RtangleSetup, |
| runcode = RtangleRuncode, |
| writedoc = RtangleWritedoc, |
| finish = RtangleFinish, |
| checkopts = RweaveLatexOptions) |
| } |
| |
| |
| RtangleSetup <- |
| function(file, syntax, output = NULL, annotate = TRUE, split = FALSE, |
| quiet = FALSE, drop.evalFALSE = FALSE, ...) |
| { |
| dots <- list(...) |
| if (is.null(output)) { |
| prefix.string <- basename(sub(syntax$extension, "", file)) |
| ## This is odd, since for split = TRUE it uses the engine name. |
| output <- paste0(prefix.string, ".R") |
| } else |
| prefix.string <- basename(sub("\\.[rsRS]$", "", output)) |
| |
| if (!split) { |
| if (identical(output, "stdout")) output <- stdout() |
| else if (identical(output, "stderr")) output <- stderr() |
| else { |
| if (!quiet) cat("Writing to file", output, "\n") |
| ## We could at some future point try to write the file in |
| ## 'encoding'. |
| output <- file(output, open = "w") |
| } |
| lines <- c(sprintf("R code from vignette source '%s'", file), |
| if(attr(file, "encoding") != "ASCII") |
| sprintf("Encoding: %s", localeToCharset()[1L]) |
| ) |
| lines <- c(paste("###", lines), "") |
| writeLines(lines, output) |
| } else { |
| if (!quiet) cat("Writing chunks to files ...\n") |
| output <- NULL |
| } |
| |
| options <- list(split = split, prefix = TRUE, |
| prefix.string = prefix.string, |
| engine = "R", eval = TRUE, |
| show.line.nos = FALSE) |
| options$.defaults <- options |
| options[names(dots)] <- dots |
| |
| ## to be on the safe side: see if defaults pass the check |
| options <- RweaveLatexOptions(options) |
| |
| list(output = output, annotate = annotate, options = options, |
| chunkout = list(), quiet = quiet, syntax = syntax, |
| drop.evalFALSE = drop.evalFALSE) |
| } |
| |
| .RtangleCodeLabel <- function(chunk) { |
| if(length(lnos <- grep("^#line ", chunk, value = TRUE))) { |
| srclines <- attr(chunk, "srclines") |
| ## srcfilenum <- attr(chunk, "srcFilenum") |
| ## this currently includes the chunk header |
| lno <- if (length(srclines)) |
| paste(min(srclines), max(srclines), sep = "-") |
| else srclines |
| fn <- sub('[^"]*"([^"]+).*', "\\1", lnos[1L]) |
| paste(fn, lno, sep = ":") |
| } else |
| "(missing #line/file info)" |
| } |
| |
| RtangleRuncode <- function(object, chunk, options) |
| { |
| if (!(options$engine %in% c("R", "S"))) return(object) |
| |
| chunkprefix <- RweaveChunkPrefix(options) |
| |
| if (options$split) { |
| if(!grepl(.SweaveValidFilenameRegexp, chunkprefix)) |
| warning("file stem ", sQuote(chunkprefix), " is not portable", |
| call. = FALSE, domain = NA) |
| outfile <- paste(chunkprefix, options$engine, sep = ".") |
| if (!object$quiet) cat(options$chunknr, ":", outfile,"\n") |
| ## [x][[1L]] avoids partial matching of x |
| chunkout <- object$chunkout[chunkprefix][[1L]] |
| if (is.null(chunkout)) { |
| chunkout <- file(outfile, "w") |
| if (!is.null(options$label)) |
| object$chunkout[[chunkprefix]] <- chunkout |
| } |
| } else |
| chunkout <- object$output |
| |
| showOut <- options$eval || !object$drop.evalFALSE |
| if(showOut) { |
| annotate <- object$annotate |
| if (is.logical(annotate) && annotate) { |
| cat("###################################################\n", |
| "### code chunk number ", options$chunknr, ": ", |
| if(!is.null(ol <- options$label)) ol else .RtangleCodeLabel(chunk), |
| if(!options$eval) " (eval = FALSE)", "\n", |
| "###################################################\n", |
| file = chunkout, sep = "") |
| } else if(is.function(annotate)) |
| annotate(options, chunk = chunk, output = chunkout) |
| } |
| |
| ## The next returns a character vector of the logical options |
| ## which are true and have hooks set. |
| hooks <- SweaveHooks(options, run = FALSE) |
| for (k in hooks) |
| cat("getOption(\"SweaveHooks\")[[\"", k, "\"]]()\n", |
| file = chunkout, sep = "") |
| |
| if(showOut) { |
| if (!options$show.line.nos) # drop "#line ...." lines |
| chunk <- grep("^#line ", chunk, value = TRUE, invert = TRUE) |
| if (!options$eval) chunk <- paste("##", chunk) |
| cat(chunk, "\n", file = chunkout, sep = "\n") |
| } |
| if (is.null(options$label) && options$split) close(chunkout) |
| object |
| } |
| |
| RtangleWritedoc <- function(object, chunk) |
| { |
| while(length(pos <- grep(object$syntax$docopt, chunk))) { |
| opts <- sub(paste0(".*", object$syntax$docopt, ".*"), |
| "\\1", chunk[pos[1L]]) |
| object$options <- SweaveParseOptions(opts, object$options, |
| RweaveLatexOptions) |
| chunk[pos[1L]] <- sub(object$syntax$docopt, "", chunk[pos[1L]]) |
| } |
| object |
| } |
| |
| |
| RtangleFinish <- function(object, error = FALSE) |
| { |
| ## might be stdout() or stderr() |
| if (!is.null(object$output) && object$output >= 3) |
| close(object$output) |
| |
| if (length(object$chunkout)) |
| for (con in object$chunkout) close(con) |
| } |
