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