1"RweaveHTML" <- function() 2{ 3 list(setup = RweaveHTMLSetup, 4 runcode = RweaveHTMLRuncode, 5 writedoc = RweaveHTMLWritedoc, 6 finish = RweaveHTMLFinish, 7 checkopts = RweaveHTMLOptions) 8} 9 10"RweaveHTMLSetup" <- 11 function(file, syntax, 12 output=NULL, quiet=FALSE, debug=FALSE, echo=TRUE, 13 eval=TRUE, split=FALSE, cssfile="R2HTML.css",havecss=FALSE,width=500,height=500,border=1,png=TRUE) 14{ 15 # This driver requires R2HTML package to work... 16 #if(!require(R2HTML)) stop("R2HTML package is required.") 17 if(is.null(output)){ 18 prefix.string <- basename(sub(syntax$extension, "", file)) 19 output <- paste(prefix.string, "html", sep=".") 20 } 21 else{ 22 prefix.string <- basename(sub("\\.html$", "", output)) 23 } 24 if(!quiet) cat("Writing to file ", output, "\n", 25 "Processing code chunks ...\n", sep="") 26 output <- file(output, open="w+") 27 options <- list(prefix=TRUE, prefix.string=prefix.string, 28 engine="R", print=FALSE, eval=eval, 29 fig=FALSE, png=png,width=width, height=height, term=TRUE, 30 echo=echo, results="Robj", split=split, 31 strip.white=TRUE, include=TRUE,align="center",caption=NULL,bg="white",pointsize=12) 32 list(output=output, debug=debug, quiet=quiet, syntax = syntax, 33 options=options, chunkout=list(),cssfile=cssfile,havecss=havecss) 34} 35 36"RweaveHTMLRuncode" <- function(object, chunk, options) 37{ 38 if(!(options$engine %in% c("R", "S"))) return(object) 39 if(!object$quiet){ 40 cat(formatC(options$chunknr, width=2), ":") 41 if(options$echo) cat(" echo") 42 if(options$eval){ 43 if(options$print) cat(" print") 44 if(options$term) cat(" term") 45 cat("", options$results) 46 if(options$fig){ 47 if(options$png) cat(" png") 48 } 49 } 50 if(!is.null(options$label)) 51 cat(" (label=", options$label, ")", sep="") 52 cat("\n") 53 } 54 55 56 #chunkprefix <- utils:::RweaveChunkPrefix(options) 57 chunkprefix <- RweaveChunkPrefix(options) 58 59 if(options$split){ 60 chunkout <- object$chunkout[[chunkprefix]] 61 if(is.null(chunkout)){ 62 chunkout <- file(paste(chunkprefix, "html", sep="."), "w") 63 if(!is.null(options$label)) 64 object$chunkout[[chunkprefix]] <- chunkout 65 } 66 } 67 else 68 chunkout <- object$output 69 70 assign(".HTML.file",chunkout,pos=.HTMLEnv, immediate=TRUE) 71 #utils:::SweaveHooks(options, run=TRUE) 72 SweaveHooks(options, run=TRUE) 73 74 chunkexps <- try(parse(text=chunk), silent=TRUE) 75 #utils:::RweaveTryStop(chunkexps, options) 76 RweaveTryStop(chunkexps, options) 77 openSinput <- FALSE 78 openSchunk <- FALSE 79 80 if(length(chunkexps)==0) 81 return(object) 82 83 for(nce in 1:length(chunkexps)) 84 { 85 ce <- chunkexps[[nce]] 86 #dce <- deparse(ce, width.cutoff=0.75*getOption("width")) 87 if(object$debug) 88 cat("\nRnw> ", paste(ce, collapse="\n+ "),"\n") 89 if(options$echo){ 90 if(!openSinput){ 91 if(!openSchunk){ 92 cat("<!-- begin{Schunk} !-->\n", 93 file=chunkout, append=TRUE) 94 openSchunk <- TRUE 95 } 96 cat("<!-- begin{Sinput} !-->", 97 file=chunkout, append=TRUE) 98 openSinput <- TRUE 99 } 100 cat("\n", paste(HTMLCommand(deparse(ce)), 101 collapse=paste("\n", getOption("continue"), sep="")), 102 file=chunkout, append=TRUE, sep="") 103 } 104 105 # tmpcon <- textConnection("output", "w") 106 # avoid the limitations (and overhead) of output text connections 107 tmpcon <- file() 108 sink(file=tmpcon) 109 err <- NULL 110 #if(options$eval) err <- utils:::RweaveEvalWithOpt(ce, options) 111 if(options$eval) err <- RweaveEvalWithOpt(ce, options) 112 cat("\n") # make sure final line is complete 113 sink() 114 output <- readLines(tmpcon) 115 close(tmpcon) 116 # delete empty output 117 if(length(output)==1 & output[1]=="") output <- NULL 118 119 #utils:::RweaveTryStop(err, options) #### !!! err$value peut etre exporte via HTML(err.value) 120 RweaveTryStop(err, options) #### !!! err$value peut etre exporte via HTML(err.value) 121 122 if(object$debug) 123 cat(paste(output, collapse="\n")) 124 125 if(length(output)>0 & (options$results!="hide")){ 126 if(!openSchunk){ 127 cat("<!-- begin{Schunk} !--> \n", 128 file=chunkout, append=TRUE) 129 openSchunk <- TRUE 130 } 131 if(openSinput){ 132 cat("\n<!-- end{Sinput} !-->\n", file=chunkout, append=TRUE) 133 openSinput <- FALSE 134 } 135 if (options$results=="Robj") HTML(err$value, file=chunkout, append=TRUE) 136 if (options$results=="html") cat(err$value, file=chunkout, append=TRUE) 137 remove(output) 138 139 } 140 } 141 if(openSinput){ 142 cat("\n<!--\\end{Sinput}!-->\n", file=chunkout, append=TRUE) 143 } 144 if(openSchunk){ 145 cat("\n<!--\\end{Schunk}!-->\n", file=chunkout, append=TRUE) 146 } 147 148 if(is.null(options$label) & options$split) 149 close(chunkout) 150 151 if(options$fig && options$eval){ 152 if(options$png){ 153 png(filename=paste(chunkprefix, "png", sep="."),width=options$width,height=options$height,bg=options$bg,pointsize=options$pointsize) 154 155 #err <- try({utils:::SweaveHooks(options, run=TRUE); 156 err <- try({SweaveHooks(options, run=TRUE); 157 eval(chunkexps, envir=.GlobalEnv)}) 158 dev.off() 159 if(inherits(err, "try-error")) stop(err) 160 } 161 if(options$include) 162 cat("<p align='",options$align,"'><img height=",options$HTMLheight, " width=",options$HTMLwidth," src='", chunkprefix, ".png'",if (!is.null(options$border)) paste("border=",options$border,sep=""),">",if(!is.null(options$caption)) paste("<br><font class='caption='>",options$caption,"</font>",sep=""),"</p>", sep="", 163 file=object$output, append=TRUE) 164 } 165 return(object) 166} 167 168"RweaveHTMLWritedoc" <- function(object, chunk) 169{ 170 # Very temporary and ugly fix: importing function definition from 171 # latest R source code (r45768) 172 InternalSweaveParseOptions <- function(text, defaults=list(), check=NULL) 173 { 174 x <- sub("^[[:space:]]*(.*)", "\\1", text) 175 x <- sub("(.*[^[:space:]])[[:space:]]*$", "\\1", x) 176 x <- unlist(strsplit(x, "[[:space:]]*,[[:space:]]*")) 177 x <- strsplit(x, "[[:space:]]*=[[:space:]]*") 178 179 ## only the first option may have no name: the chunk label 180 if(length(x)>0){ 181 if(length(x[[1]])==1){ 182 x[[1]] <- c("label", x[[1]]) 183 } 184 } 185 else 186 return(defaults) 187 188 if(any(sapply(x, length)!=2)) 189 stop(gettextf("parse error or empty option in\n%s", text), domain = NA) 190 191 options <- defaults 192 193 for(k in 1:length(x)) 194 options[[ x[[k]][1] ]] <- x[[k]][2] 195 196 if(!is.null(options[["label"]]) && !is.null(options[["engine"]])) 197 options[["label"]] <- sub(paste("\\.", options[["engine"]], "$", 198 sep=""), 199 "", options[["label"]]) 200 201 if(!is.null(check)) 202 options <- check(options) 203 204 options 205 } 206 207 208 209 if(any(grep("text/css", chunk))) 210 object$havecss <- TRUE 211 212 if(!object$havecss){ 213 if(any(grep("<body>", chunk, ignore.case = TRUE))) chunk <- gsub("<body>",paste("\n<link rel=stylesheet type=text/css href=",object$cssfile,"><body>",sep="") ,chunk,ignore.case=TRUE) 214 else { 215 if(any(grep("</head>", chunk, ignore.case = TRUE))) chunk <- gsub("</head>",paste("\n<link rel=stylesheet type=text/css href=",object$cssfile,"></head>",sep="") ,chunk,ignore.case=TRUE) 216 else chunk <- gsub("<html>",paste("<html>","\n<link rel=stylesheet type=text/css href=",object$cssfile,">",sep="") ,chunk,ignore.case=TRUE) 217 } 218 object$havecss <- TRUE 219 } 220 while(any(pos <- grep(object$syntax$docexpr, chunk))) 221 { 222 cmdloc <- regexpr(object$syntax$docexpr, chunk[pos[1]]) 223 cmd <- substr(chunk[pos[1]], cmdloc, 224 cmdloc+attr(cmdloc, "match.length")-1) 225 cmd <- sub(object$syntax$docexpr, "\\1", cmd) 226 if(object$options$eval) 227 val <- as.character(eval(parse(text=cmd), envir=.GlobalEnv)) 228 else 229 val <- paste("<font class='Rcmd'>", cmd, "</font>", sep="") 230 231 chunk[pos[1]] <- sub(object$syntax$docexpr, val, chunk[pos[1]]) 232 } 233 while(any(pos <- grep(object$syntax$docopt, chunk))) 234 { 235 opts <- sub(paste(".*", object$syntax$docopt, ".*", sep=""), 236 "\\1", chunk[pos[1]]) 237 object$options <- InternalSweaveParseOptions(opts, object$options, RweaveHTMLOptions) 238 chunk[pos[1]] <- sub(object$syntax$docopt, "", chunk[pos[1]]) 239 } 240 cat(chunk, sep="\n", file=object$output, append=TRUE) 241 return(object) 242} 243 244"RweaveHTMLFinish" <- function(object, error=FALSE) 245{ 246 if(!object$quiet && !error) 247 cat(paste("file ",summary(object$output)$description),"is completed", "\n") 248 close(object$output) 249 if(length(object$chunkout)>0){ 250 for(con in object$chunkout) close(con) 251 } 252} 253 254"RweaveHTMLOptions" <- function(options) 255{ 256 ## convert a character string to logical 257 c2l <- function(x){ 258 if(is.null(x)) return(FALSE) 259 else return(as.logical(toupper(as.character(x)))) 260 } 261 NUMOPTS <- c("width", "height") 262 NOLOGOPTS <- c(NUMOPTS, "results", "prefix.string", 263 "engine", "label","align","caption","border","height","width","HTMLheight","HTMLwidth","bg","pointsize") 264 for(opt in names(options)){ 265 if(! (opt %in% NOLOGOPTS)){ 266 oldval <- options[[opt]] 267 if(!is.logical(options[[opt]])){ 268 options[[opt]] <- c2l(options[[opt]]) 269 } 270 if(is.na(options[[opt]])) 271 stop(paste("invalid value for", opt, ":", oldval)) 272 } 273 else if(opt %in% NUMOPTS){ 274 options[[opt]] <- as.numeric(options[[opt]]) 275 } 276 } 277 options$results <- match.arg(options$results,c("Robj","html", "hide")) 278 options 279} 280 281#----------------------------------------------------------------------------------------------------# 282 283SweaveSyntaxHTML <- SweaveSyntaxNoweb 284SweaveSyntaxHTML$docexpr <- "<[/]?Sexpr([^>]*)>" 285SweaveSyntaxHTML$syntaxname <- "<[/]?SweaveSyntax([^>]*)>" 286SweaveSyntaxHTML$trans$docexpr <- "<[/]?Sexpr\\1>" 287SweaveSyntaxHTML$trans$syntaxname <- "<!--SweaveSyntax{SweaveSyntaxHTML}!-->" 288