R/SweaveCache.R

   1 ######################################################################
   2 ## Copyright (C) 2006, Roger D. Peng <rpeng@jhsph.edu>
   3 ##
   4 ## This program is free software; you can redistribute it and/or modify
   5 ## it under the terms of the GNU General Public License as published by
   6 ## the Free Software Foundation; either version 2 of the License, or
   7 ## (at your option) any later version.
   8 ##
   9 ## This program is distributed in the hope that it will be useful,
  10 ## but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ## GNU General Public License for more details.
  13 ##
  14 ## You should have received a copy of the GNU General Public License
  15 ## along with this program; if not, write to the Free Software
  16 ## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17 ## 02110-1301, USA
  18 #####################################################################
  19
  20 setCacheDir <- function(path) {
  21         assign("cacheDir", path, .cacheEnv)
  22         dir.create(path, showWarnings = FALSE)
  23 }
  24
  25 getCacheDir <- function() {
  26         get("cacheDir", .cacheEnv, inherits = FALSE)
  27 }
  28
  29 ######################################################################
  30 ######################################################################
  31 ## Taken/adapted from Sweave code by Friedrich Leisch, along the lines
  32 ## of 'weaver' from Bioconductor, but more naive and we use 'stashR'
  33 ## databases for the backend.  We also don't check dependencies on
  34 ## previous chunks.
  35
  36 cacheSweaveDriver <- function() {
  37         list(
  38              setup = cacheSweaveSetup,
  39              runcode = cacheSweaveRuncode,
  40              writedoc = utils::RweaveLatexWritedoc,
  41              finish = utils::RweaveLatexFinish,
  42              checkopts = utils::RweaveLatexOptions
  43              )
  44 }
  45
  46
  47 ######################################################################
  48 ## Take a 'filehash' database and insert a bunch of key/value pairs
  49
  50 dumpToDB <- function(db, list = character(0), envir = parent.frame()) {
  51         if(!is(db, "filehash"))
  52                 stop("'db' should be a 'filehash' database")
  53         for(i in seq(along = list))
  54                 dbInsert(db, list[i], get(list[i], envir, inherits = FALSE))
  55         invisible(db)
  56 }
  57
  58 copy2env <- function(keys, fromEnv, toEnv) {
  59         for(key in keys) {
  60                 assign(key, get(key, fromEnv, inherits = FALSE), toEnv)
  61         }
  62 }
  63
  64 ## Take an expression, evaluate it in a local environment and dump the
  65 ## results to a database.  Associate the names of the dumped objects
  66 ## with a digest of the expression.  Return a character vector of keys
  67 ## that were dumped
  68
  69 evalAndDumpToDB <- function(db, expr, exprDigest) {
  70         env <- new.env(parent = globalenv())
  71         keys.global0 <- ls(globalenv())
  72
  73         ## Evaluate the expression
  74         eval(expr, env)
  75
  76         ## If 'source()' was used, there may be new symbols in the global
  77         ## environment, unless 'source(local = TRUE)' was used
  78         keys.global1 <- ls(globalenv())  ## doesn't capture names beginning with '.'
  79         new.global <- setdiff(keys.global1, keys.global0)
  80
  81         copy2env(new.global, globalenv(), env)
  82
  83         ## Get newly assigned object names
  84         keys <- ls(env, all.names = TRUE)
  85
  86         ## Associate the newly created keys with the digest of
  87         ## the expression
  88         dbInsert(db, exprDigest, keys)
  89
  90         ## Dump the values of the keys to the database
  91         dumpToDB(db, list = keys, envir = env)
  92
  93         keys
  94 }
  95
  96 makeChunkDatabaseName <- function(cachedir, options, chunkDigest) {
  97         file.path(cachedir, paste(options$label, chunkDigest, sep = "_"))
  98 }
  99
 100 mangleDigest <- function(x) {
 101         paste(".__", x, "__", sep = "")
 102 }
 103
 104 ################################################################################
 105 ## The major modification is here: Rather than evaluate expressions
 106 ## and leave them in the global environment, we evaluate them in a
 107 ## local environment (that has globalenv() as the parent) and then
 108 ## store the assignments in a 'stashR' database.  If an expression
 109 ## does not give rise to new R objects, then nothing is saved.
 110 ##
 111 ## For each expression ('expr'), we compute a digest and associate
 112 ## with that digest the names of the objects that were created by
 113 ## evaluating the expression.  That way, for a given cached
 114 ## expression, we know which keys to lazy-load from the cache when
 115 ## evaluation is skipped.
 116 ################################################################################
 117
 118 cacheSweaveEvalWithOpt <- function (expr, options) {
 119         chunkDigest <- options$chunkDigest
 120
 121         ## 'expr' is a single expression, so something like 'a <- 1'
 122         res <- NULL
 123
 124         if(!options$eval)
 125                 return(res)
 126         if(options$cache) {
 127                 cachedir <- getCacheDir()
 128
 129                 ## Create database name from chunk label and MD5
 130                 ## digest
 131                 dbName <- makeChunkDatabaseName(cachedir, options, chunkDigest)
 132                 exprDigest <- mangleDigest(digest(expr))
 133
 134                 ## Create 'stashR' database
 135                 db <- new("localDB", dir = dbName, name = basename(dbName))
 136
 137                 ## If the current expression is not cached, then
 138                 ## evaluate the expression and dump the resulting
 139                 ## objects to the database.  Otherwise, just read the
 140                 ## vector of keys from the database
 141
 142                 keys <- if(!dbExists(db, exprDigest))
 143                         try({
 144                                 evalAndDumpToDB(db, expr, exprDigest)
 145                         }, silent = TRUE)
 146                 else
 147                         dbFetch(db, exprDigest)
 148
 149                 ## If there was an error then just return the
 150                 ## condition object and let Sweave deal with it.
 151                 if(inherits(keys, "try-error"))
 152                         return(keys)
 153
 154                 dbLazyLoad(db, globalenv(), keys)
 155         }
 156         else {
 157                 ## If caching is turned off, just evaluate the expression
 158                 ## in the global environment
 159                 res <- try(.Internal(eval.with.vis(expr, .GlobalEnv,
 160                                                    baseenv())),
 161                            silent=TRUE)
 162                 if(inherits(res, "try-error"))
 163                         return(res)
 164                 if(options$print | (options$term & res$visible))
 165                         print(res$value)
 166         }
 167         res
 168 }
 169
 170 ## Need to add the 'cache', 'filename' option to the list
 171 cacheSweaveSetup <- function(file, syntax,
 172                              output=NULL, quiet=FALSE, debug=FALSE, echo=TRUE,
 173                              eval=TRUE, split=FALSE, stylepath=TRUE, pdf=TRUE,
 174                              eps=TRUE, cache = FALSE) {
 175
 176         out <- utils::RweaveLatexSetup(file, syntax, output=NULL, quiet=FALSE,
 177                                        debug=FALSE, echo=TRUE, eval=TRUE,
 178                                        split=FALSE, stylepath=TRUE, pdf=TRUE,
 179                                        eps=TRUE)
 180
 181 ######################################################################
 182         ## Additions here [RDP]
 183         ## Add the (non-standard) options for code chunks with caching
 184         out$options[["cache"]] <- cache
 185
 186         ## We assume that each .Rnw file gets its own map file
 187         out[["mapFile"]] <- makeMapFileName(file)
 188         file.create(out[["mapFile"]])  ## Overwrite an existing file
 189
 190         ## End additions [RDP]
 191 ######################################################################
 192         out
 193 }
 194
 195
 196 makeMapFileName <- function(Rnwfile) {
 197         mapfile <- sub("\\.Rnw$", "\\.map", Rnwfile)
 198
 199         ## Don't clobber
 200         if(identical(mapfile, Rnwfile))
 201                 mapfile <- paste(Rnwfile, "map", sep = ".")
 202         mapfile
 203 }
 204
 205 writeChunkMetadata <- function(object, chunk, options) {
 206         chunkprefix <- utils::RweaveChunkPrefix(options)
 207         chunkexps <- parse(text = chunk)
 208         chunkDigest <- digest(chunkexps)
 209
 210         options$chunkDigest <- chunkDigest
 211
 212         ## If there's a data map file then write the chunk name and the
 213         ## directory of the chunk database to the map file (in DCF format)
 214         dbName <- if(isTRUE(options$cache))
 215                 makeChunkDatabaseName(getCacheDir(), options, chunkDigest)
 216         else
 217                 ""
 218         ## Capture figure filenames; default to PDF, otherwise use EPS.
 219         ## Filenames are <chunkprefix>.<extenstion>, which could change in
 220         ## the future depending on Sweave implementation details
 221         figname <- ""
 222         if(options$fig && options$eval) {
 223                 figname <- if(options$pdf)
 224                         paste(chunkprefix, "pdf", sep = ".")
 225                 else if(options$eps)
 226                         paste(chunkprefix, "eps", sep = ".")
 227                 else
 228                         ""
 229         }
 230         ## Write out map file entry
 231         mapFile <- object[["mapFile"]]
 232         mapEntry <- data.frame(chunk = options$label,
 233                                chunkprefix = chunkprefix,
 234                                fig = figname,
 235                                cacheDB = dbName,
 236                                time = Sys.time())
 237         write.dcf(mapEntry, file = mapFile, append = TRUE, width = 2000)
 238         options
 239 }
 240
 241 ## This function is essentially unchanged from the original Sweave
 242 ## version, except I compute the digest of the entire chunk, write out
 243 ## information to the map file, and use 'cacheSweaveEvalWithOpt'
 244 ## instead.  Note that everything in this function operates at the
 245 ## chunk level.  The code has been copied from R 2.5.0.
 246
 247 cacheSweaveRuncode <- function(object, chunk, options) {
 248         if(!(options$engine %in% c("R", "S"))){
 249                 return(object)
 250         }
 251
 252         if(!object$quiet){
 253                 cat(formatC(options$chunknr, width=2), ":")
 254                 if(options$echo) cat(" echo")
 255                 if(options$keep.source) cat(" keep.source")
 256                 if(options$eval){
 257                         if(options$print) cat(" print")
 258                         if(options$term) cat(" term")
 259                         cat("", options$results)
 260                         if(options$fig){
 261                                 if(options$eps) cat(" eps")
 262                                 if(options$pdf) cat(" pdf")
 263                         }
 264                 }
 265                 if(!is.null(options$label))
 266                         cat(" (label=", options$label, ")", sep="")
 267                 cat("\n")
 268         }
 269
 270         chunkprefix <- RweaveChunkPrefix(options)
 271
 272         if(options$split){
 273                 ## [x][[1]] avoids partial matching of x
 274                 chunkout <- object$chunkout[chunkprefix][[1]]
 275                 if(is.null(chunkout)){
 276                         chunkout <- file(paste(chunkprefix, "tex", sep="."), "w")
 277                         if(!is.null(options$label))
 278                                 object$chunkout[[chunkprefix]] <- chunkout
 279                 }
 280         }
 281         else
 282                 chunkout <- object$output
 283
 284         saveopts <- options(keep.source=options$keep.source)
 285         on.exit(options(saveopts))
 286
 287         SweaveHooks(options, run=TRUE)
 288
 289         ## parse entire chunk block
 290         chunkexps <- try(parse(text=chunk), silent=TRUE)
 291         RweaveTryStop(chunkexps, options)
 292
 293         ## Adding my own stuff here [RDP]
 294         ## Add 'chunkDigest' to 'options'
 295         options <- writeChunkMetadata(object, chunk, options)
 296         ## End adding my own stuff [RDP]
 297
 298         openSinput <- FALSE
 299         openSchunk <- FALSE
 300
 301         if(length(chunkexps)==0)
 302                 return(object)
 303
 304         srclines <- attr(chunk, "srclines")
 305         linesout <- integer(0)
 306         srcline <- srclines[1]
 307
 308         srcrefs <- attr(chunkexps, "srcref")
 309         if (options$expand)
 310                 lastshown <- 0
 311         else
 312                 lastshown <- srcline - 1
 313         thisline <- 0
 314         for(nce in 1:length(chunkexps))
 315         {
 316                 ce <- chunkexps[[nce]]
 317                 if (nce <= length(srcrefs) && !is.null(srcref <- srcrefs[[nce]])) {
 318                         if (options$expand) {
 319                                 srcfile <- attr(srcref, "srcfile")
 320                                 showfrom <- srcref[1]
 321                                 showto <- srcref[3]
 322                         } else {
 323                                 srcfile <- object$srcfile
 324                                 showfrom <- srclines[srcref[1]]
 325                                 showto <- srclines[srcref[3]]
 326                         }
 327                         dce <- getSrcLines(srcfile, lastshown+1, showto)
 328                         leading <- showfrom-lastshown
 329                         lastshown <- showto
 330                         srcline <- srclines[srcref[3]]
 331                         while (length(dce) && length(grep("^[ \\t]*$", dce[1]))) {
 332                                 dce <- dce[-1]
 333                                 leading <- leading - 1
 334                         }
 335                 } else {
 336                         dce <- deparse(ce, width.cutoff=0.75*getOption("width"))
 337                         leading <- 1
 338                 }
 339                 if(object$debug)
 340                         cat("\nRnw> ", paste(dce, collapse="\n+  "),"\n")
 341                 if(options$echo && length(dce)){
 342                         if(!openSinput){
 343                                 if(!openSchunk){
 344                                         cat("\\begin{Schunk}\n",
 345                                             file=chunkout, append=TRUE)
 346                                         linesout[thisline + 1] <- srcline
 347                                         thisline <- thisline + 1
 348                                         openSchunk <- TRUE
 349                                 }
 350                                 cat("\\begin{Sinput}",
 351                                     file=chunkout, append=TRUE)
 352                                 openSinput <- TRUE
 353                         }
 354                         cat("\n", paste(getOption("prompt"), dce[1:leading], sep="", collapse="\n"),
 355                             file=chunkout, append=TRUE, sep="")
 356                         if (length(dce) > leading)
 357                                 cat("\n", paste(getOption("continue"), dce[-(1:leading)], sep="", collapse="\n"),
 358                                     file=chunkout, append=TRUE, sep="")
 359                         linesout[thisline + 1:length(dce)] <- srcline
 360                         thisline <- thisline + length(dce)
 361                 }
 362
 363                 ## tmpcon <- textConnection("output", "w")
 364                 ## avoid the limitations (and overhead) of output text connections
 365                 tmpcon <- file()
 366                 sink(file=tmpcon)
 367                 err <- NULL
 368
 369                 ## [RDP] change this line to use my EvalWithOpt function
 370                 if(options$eval) err <- cacheSweaveEvalWithOpt(ce, options)
 371                 ## [RDP] end change
 372
 373                 cat("\n") # make sure final line is complete
 374                 sink()
 375                 output <- readLines(tmpcon)
 376                 close(tmpcon)
 377                 ## delete empty output
 378                 if(length(output)==1 & output[1]=="") output <- NULL
 379
 380                 RweaveTryStop(err, options)
 381
 382                 if(object$debug)
 383                         cat(paste(output, collapse="\n"))
 384
 385                 if(length(output)>0 & (options$results != "hide")){
 386
 387                         if(openSinput){
 388                                 cat("\n\\end{Sinput}\n", file=chunkout, append=TRUE)
 389                                 linesout[thisline + 1:2] <- srcline
 390                                 thisline <- thisline + 2
 391                                 openSinput <- FALSE
 392                         }
 393                         if(options$results=="verbatim"){
 394                                 if(!openSchunk){
 395                                         cat("\\begin{Schunk}\n",
 396                                             file=chunkout, append=TRUE)
 397                                         linesout[thisline + 1] <- srcline
 398                                         thisline <- thisline + 1
 399                                         openSchunk <- TRUE
 400                                 }
 401                                 cat("\\begin{Soutput}\n",
 402                                     file=chunkout, append=TRUE)
 403                                 linesout[thisline + 1] <- srcline
 404                                 thisline <- thisline + 1
 405                         }
 406
 407                         output <- paste(output,collapse="\n")
 408                         if(options$strip.white %in% c("all", "true")){
 409                                 output <- sub("^[[:space:]]*\n", "", output)
 410                                 output <- sub("\n[[:space:]]*$", "", output)
 411                                 if(options$strip.white=="all")
 412                                         output <- sub("\n[[:space:]]*\n", "\n", output)
 413                         }
 414                         cat(output, file=chunkout, append=TRUE)
 415                         count <- sum(strsplit(output, NULL)[[1]] == "\n")
 416                         if (count > 0) {
 417                                 linesout[thisline + 1:count] <- srcline
 418                                 thisline <- thisline + count
 419                         }
 420
 421                         remove(output)
 422
 423                         if(options$results=="verbatim"){
 424                                 cat("\n\\end{Soutput}\n", file=chunkout, append=TRUE)
 425                                 linesout[thisline + 1:2] <- srcline
 426                                 thisline <- thisline + 2
 427                         }
 428                 }
 429         }
 430
 431         if(openSinput){
 432                 cat("\n\\end{Sinput}\n", file=chunkout, append=TRUE)
 433                 linesout[thisline + 1:2] <- srcline
 434                 thisline <- thisline + 2
 435         }
 436
 437         if(openSchunk){
 438                 cat("\\end{Schunk}\n", file=chunkout, append=TRUE)
 439                 linesout[thisline + 1] <- srcline
 440                 thisline <- thisline + 1
 441         }
 442
 443         if(is.null(options$label) & options$split)
 444                 close(chunkout)
 445
 446         if(options$split & options$include){
 447                 cat("\\input{", chunkprefix, "}\n", sep="",
 448                     file=object$output, append=TRUE)
 449                 linesout[thisline + 1] <- srcline
 450                 thisline <- thisline + 1
 451         }
 452
 453         if(options$fig && options$eval){
 454                 if(options$eps){
 455                         grDevices::postscript(file=paste(chunkprefix, "eps", sep="."),
 456                                               width=options$width, height=options$height,
 457                                               paper="special", horizontal=FALSE)
 458
 459                         err <- try({SweaveHooks(options, run=TRUE)
 460                                     eval(chunkexps, envir=.GlobalEnv)})
 461                         grDevices::dev.off()
 462                         if(inherits(err, "try-error")) stop(err)
 463                 }
 464                 if(options$pdf){
 465                         grDevices::pdf(file=paste(chunkprefix, "pdf", sep="."),
 466                                        width=options$width, height=options$height,
 467                                        version=options$pdf.version,
 468                                        encoding=options$pdf.encoding)
 469
 470                         err <- try({SweaveHooks(options, run=TRUE)
 471                                     eval(chunkexps, envir=.GlobalEnv)})
 472                         grDevices::dev.off()
 473                         if(inherits(err, "try-error")) stop(err)
 474                 }
 475                 if(options$include) {
 476                         cat("\\includegraphics{", chunkprefix, "}\n", sep="",
 477                             file=object$output, append=TRUE)
 478                         linesout[thisline + 1] <- srcline
 479                         thisline <- thisline + 1
 480                 }
 481         }
 482         object$linesout <- c(object$linesout, linesout)
 483         return(object)
 484 }
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516