R/SweaveLatexDriver.R

In highlight: Syntax Highlighter

latex_color <- function( name = col, col  = "white"){
	sprintf( "\\definecolor{%s}{rgb}{%s}", name, paste(as.vector(col2rgb(col))/255, collapse = "," ) )
}

should_use_external_highlight <- function(options){
	any( c("lang", "file" ) %in% names(options) )	
}

HighlightWeaveLatexCheckOps <- function(options){
	if( should_use_external_highlight(options) ){
		options
	} else {
		if( "size" %in% names(options) ) {
			append( RweaveLatexOptions( options[ - which( names(options) == "size" ) ] ), list( size = options$size ) ) 
		} else RweaveLatexOptions( options )
	}
}

# {{{ HighlightWeaveLatex: driver
#' Sweave driver performing syntax highlighting
#' 
#' Sweave driver using the highlight latex renderer to perform syntax 
#' highlighting of input R code in sweave chunks.
#' 
#' This sweave driver is very similar to standard driver that is 
#' included in \samp{utils}. The difference is that input R code and 
#' verbatim output is rendered using \code{highlight} enabling 
#' syntax highlighting of R code. 
#' 
#' Instead of using \samp{Sinput} and \samp{Soutput} commands, this 
#' driver uses \samp{Hinput} and \samp{Houtput} and defines these commands
#' at the very beginning of the document, letting the user the option 
#' to overwrite them as necessary. 
#' 
#' Latex boxes defined by the latex renderer (\code{\link{renderer_latex}})
#' and style definitions needed are also written at the beginning 
#' of the document.
#' 
#' Because highlight does not use verbatim environments, the user
#' of this driver can freely redefine the \samp{Hinput}, \samp{Houtput}
#' and \samp{Hchunk} environments to achieve greater control
#' of the output latex document than with the standard driver.
#' 
#' @param boxes if \code{TRUE}, code blocks are wrapped in boxes.
#' @param bg background color for code boxes.
#' @param border color to use for the border of code boxes.
#' @param highlight.options Can be used instead of the other arguments to 
#'        set the \code{boxes}, \code{bg} and \code{border} settings.
#' 
#' @return A sweave driver, suitable for the \samp{driver} argument of
#' \code{\link[utils]{Sweave}} 
#' @examples
#' \dontrun{
#' # using the driver on the grid vignette
#' require( grid )
#' v <- vignette( "grid", package = "grid" )$file
#' file.copy( v, "grid.Snw" )
#' Sweave( "grid.Snw", driver= HighlightWeaveLatex() )
#' }
#' @export
HighlightWeaveLatex <- function(boxes=FALSE, bg = rgb( 0.95,0.95,0.95, maxColorValue = 1 ), border = "black", 
	highlight.options = list( boxes = boxes, bg = bg, border = border )
) {
	list(setup      = RweaveLatexSetup,
         runcode    = makeHighlightWeaveLatexCodeRunner( 
         	evalFunc=RweaveEvalWithOpt, highlight.options = options 
         ) ,
         writedoc   = makeHighlightWeaveLatex_WriteDoc(
         	highlight.options = highlight.options
         ),
         finish     = RweaveLatexFinish,
         checkopts  = HighlightWeaveLatexCheckOps )
}
# }}}

# {{{ makeHighlightWeaveLatexCodeRunner
makeHighlightWeaveLatexCodeRunner <- function(evalFunc=RweaveEvalWithOpt, highlight.options) {
	
    ## Return a function suitable as the 'runcode' element
    ## of an Sweave driver.  evalFunc will be used for the
    ## actual evaluation of chunk code.
    HighlightWeaveLatexRuncode <- function(object, chunk, options) {
      	 if( grepl( "#line [0-9]", chunk[1L] ) ){
      	  	   chunk <- chunk[-1L]
      	  	   attr(chunk, "srclines" ) <- attr(chunk, "srclines" )[-1L]
      	  }
      	  if( should_use_external_highlight(options) ){
      	  	  if( "file" %in% names(options) ){
      	  	  	  chunkfile <- options[["file"]]
      	  	  } else {
      	  	  	  chunkfile <- sprintf( "%s.%s", tempfile(), options[["lang"]] )
      	  	  	  writeLines( chunk, chunkfile )   
      	  	  }
      	  	 tex <- external_highlight( chunkfile, outfile = NULL, 
      	  	 	type = "LATEX", doc = FALSE )
      	  	 
      	  	 size <- if( "size" %in% names(options) ) LATEX_SIZES[ pmatch( options$size, LATEX_SIZES) ] else "normalsize"
      	  	 tex <- gsub( "hlbox", sprintf( "hl%sbox", size ), tex, fixed = TRUE ) 
      	  	 
			 tex <- c(
			 		sprintf( "\\begin{%s}", size ), 
			 		"\\begin{Hchunk}" , 
			 		tex ,
			 		"\\end{Hchunk}", 
			 		sprintf( "\\end{%s}", size )
			 	)
             writeLines( tex, object$output )
             return(object)
      	  } else { 
      	  
	          if(!(options$engine %in% c("R", "S"))){
	              return(object)
	          }
	
	          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(!is.null(options$label))
	                cat(" (label=", options$label, ")", 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(paste(chunkprefix, "tex", sep="."), "w")
	                  if(!is.null(options$label))
	                    object$chunkout[[chunkprefix]] <- chunkout
	              }
	          }
	          else
	            chunkout <- object$output
	
		  saveopts <- options(keep.source=options$keep.source)
		  on.exit(options(saveopts))
	
	          SweaveHooks(options, run=TRUE)
	
	          chunkexps <- try(parse(text=chunk, keep.source = TRUE), silent=TRUE)
			  RweaveTryStop(chunkexps, options)
	          parse.output <- try( parse(text = chunk, keep.source = TRUE ), silent = TRUE )
			  
			  styles <- simple_detective( parse.output )
			  renderer <- renderer_latex( document = FALSE )
			  
	          openSinput <- FALSE
	          openSchunk <- FALSE
	
	          if(length(chunkexps) == 0L)
	            return(object)
	
	          srclines <- attr(chunk, "srclines")
	          linesout <- integer(0L)
	          srcline <- srclines[1L]
	
		  srcrefs <- attr(chunkexps, "srcref")
		  if (options$expand)
		    lastshown <- 0L
		  else
		    lastshown <- srcline - 1L
		  thisline <- 0
		  
		  if( options$echo ) {
		  	  cat("\\begin{Hchunk}\n",file=chunkout, append=TRUE)
		  	  size <- if( "size" %in% names(options) ) LATEX_SIZES[ pmatch( options$size, LATEX_SIZES) ] else "normalsize"
      	  	  cat( sprintf( "\\begin{%s}\n", size ), file = chunkout, append = TRUE )		
		  }
	                 
	          for(nce in 1L:length(chunkexps)) {
				     ce <- chunkexps[[nce]]
	                if (nce <= length(srcrefs) && !is.null(srcref <- srcrefs[[nce]])) {
	            	        if (options$expand) {
	      			          	srcfile <- attr(srcref, "srcfile")
	      			          	showfrom <- srcref[1L]
	      			          	showto <- srcref[3L]
	            	        } else {
	            	        	srcfile <- object$srcfile
	            	        	showfrom <- srclines[srcref[1L]]
	            	        	showto <- srclines[srcref[3L]]
	            	        }
	            	        dce <- getSrcLines(srcfile, lastshown+1, showto)
		    		    leading <- showfrom - lastshown
		    		    lastshown <- showto
	            	   srcline <- srclines[srcref[3L]]
	            	   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){ 
						 if(!openSinput){
	                        if(!openSchunk){
	                            linesout[thisline + 1] <- srcline
	                            thisline <- thisline + 1
	                            openSchunk <- TRUE
	                        }
							openSinput <- TRUE
						 }
						
						cat("\\begin{Hinput}", file=chunkout, append=TRUE)
						cat("\n", file = chunkout, append = TRUE )
						showPrompts <- options$prompt
						size <- if( "size" %in% names(options) ) options$size else "normalsize"
						highlight( output = chunkout, 
		 					parse.output = parse.output, 
		 					styles = styles, 
		 					expr = nce, 
		 					renderer = renderer, 
							final.newline = FALSE, 
							showPrompts = if( !is.null(showPrompts) ) isTRUE(showPrompts) else TRUE , 
							initial.spaces = FALSE, 
							size = size, 
							show_line_numbers = options$show_line_numbers
							)
						cat("\\end{Hinput}\n\n", file=chunkout, append=TRUE)
	                   
						linesout[thisline + 1L:length(dce)] <- srcline
						thisline <- thisline + length(dce)
	                }
	
	                tmpcon <- file()
	                sink(file=tmpcon)
	                err <- NULL
	                if(options$eval) err <- evalFunc(ce, options)
	                cat("\n") # make sure final line is complete
	                sink()
	                output <- readLines(tmpcon)
	                close(tmpcon)
	                ## delete empty output
	                if(length(output) == 1L & output[1L] == "") output <- NULL
	
	                RweaveTryStop(err, options)
	
	                if(object$debug)
	                  cat(paste(output, collapse="\n"))
	
	                if(length(output) & (options$results != "hide")){
	
	                    if(openSinput){
						    linesout[thisline + 1L:2L] <- srcline
	                        thisline <- thisline + 2L
	                        openSinput <- FALSE
	                    }
	                    if(options$results=="verbatim"){
	                        if(!openSchunk){
	                        #    cat("\\begin{Hchunk}\n",
	                        #        file=chunkout, append=TRUE)
	                            linesout[thisline + 1L] <- srcline
	                            thisline <- thisline + 1L
	                            openSchunk <- TRUE
	                        }
	                        cat("\\begin{Houtput}\n",
	                            file=chunkout, append=TRUE)
	                        linesout[thisline + 1L] <- srcline
	                        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)
	                    }
	                    
						if( options$results == "verbatim" ){
							cat( paste( renderer$header(), collapse = "\n" ), file = chunkout, append = TRUE)
							output. <- strsplit( output, "\n" )[[1]]
							size <- if( "size" %in% names(options) ) LATEX_SIZES[ pmatch( options$size, LATEX_SIZES) ] else "normalsize"
      	  	  				tex <- paste( renderer$translator(output., size = size), renderer$newline(), sep = "")
      	  	  				tex[ length(tex ) ] <- sub( "\\\\\\\\\n\\\\hlstd", "\\\\hlstd", tex[length(tex)] )
      	  	  				cat( paste(tex, collapse="") , file=chunkout, append=TRUE )
							remove( output.) 
							cat( paste( renderer$footer(), collapse = "\n" ), file = chunkout, append = TRUE )
						 } else{
							cat( output, file=chunkout, append=TRUE)
						}
						 count <- sum(strsplit(output, NULL)[[1L]] == "\n")
	                    if (count > 0L) {
	                    	linesout[thisline + 1L:count] <- srcline
	                    	thisline <- thisline + count
	                    }
	
	                    remove(output)
	
	                    if(options$results=="verbatim"){
	                        cat("\\end{Houtput}\n", file=chunkout, append=TRUE)
	                        linesout[thisline + 1L:2] <- srcline
	                        thisline <- thisline + 2L
	                    }
	                } 
					if( options$echo ) cat("\n", file = chunkout, append = TRUE)
	            }
	
	            if( options$echo ){
	            	size <- if( "size" %in% names(options) ) LATEX_SIZES[ pmatch( options$size, LATEX_SIZES) ] else "normalsize"
	            	cat( sprintf( "\\end{%s}\n", size ), file = chunkout, append = TRUE )
	            	cat("\\end{Hchunk}\n\n", file=chunkout, append=TRUE)
	            }
	          
	#          if(openSinput){
	#			  cat("\n\\end{Hinput}\n", file=chunkout, append=TRUE)
	#              linesout[thisline + 1L:2L] <- srcline
	#              thisline <- thisline + 2L
	#          }
	
	          
			  if(openSchunk){
	              linesout[thisline + 1L] <- srcline
	              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, append=TRUE)
	              linesout[thisline + 1L] <- srcline
	              thisline <- thisline + 1L
	          }
	
	          if(options$fig && options$eval){
	              if(options$eps){
	                  postscript(file=paste(chunkprefix, "eps", sep="."),
	                                        width=options$width, height=options$height,
	                                        paper="special", horizontal=FALSE)
	
	                  err <- try({SweaveHooks(options, run=TRUE)
	                              eval(chunkexps, envir=.GlobalEnv)})
	                  dev.off()
	                  if(inherits(err, "try-error")) stop(err)
	              }
	              if(options$pdf){
	                  pdf(file=paste(chunkprefix, "pdf", sep="."),
	                                 width=options$width, height=options$height,
	                                 version=options$pdf.version,
	                                 encoding=options$pdf.encoding)
	
	                  err <- try({SweaveHooks(options, run=TRUE)
	                              eval(chunkexps, envir=.GlobalEnv)})
	                  dev.off()
	                  if(inherits(err, "try-error")) stop(err)
	              }
	              if(options$include) {
	                  cat("\\includegraphics{", chunkprefix, "}\n", sep="",
	                      file=object$output, append=TRUE)
	                  linesout[thisline + 1L] <- srcline
	                  thisline <- thisline + 1L
	              }
	          }
	          object$linesout <- c(object$linesout, linesout)
	          return(object)
	    }
      }
    HighlightWeaveLatexRuncode
}
# }}} 

# {{{ HighlightWeaveLatexWritedoc
makeHighlightWeaveLatex_WriteDoc <- function( highlight.options ){
	
HighlightWeaveLatexWritedoc <- function(object, chunk) {
	
	linesout <- attr(chunk, "srclines")
	renderer <- renderer_latex( )

    if(length(grep("\\usepackage[^\\}]*Sweave.*\\}", chunk))){
        object$havesty <- TRUE
	}

    if(!object$havesty){
 		sweave <- paste( "\\usepackage{", object$styfile , "}" )
    } else{
		where.sweave <- grep("\\usepackage[^\\}]*Sweave.*\\}", chunk)[1]
		sweave <- chunk[ where.sweave ]
		chunk[ where.sweave ] <- paste( "" )
	}
	
	environments <- if( highlight.options[["boxes"]] ){                                     
sprintf( 
'
\\usepackage{color}%%
%s
%s
\\newenvironment{Hinput}%%
{}%%
{}%%
\\newenvironment{Houtput}%%
{}%%
{}%%
\\newsavebox{\\highlightbox}%%
\\newenvironment{Hchunk}%%
{%%
\\vspace{0.5em}\\noindent\\begin{lrbox}{\\highlightbox}%%
\\begin{minipage}[b]{.9\\textwidth}%%
}%%
{%%
\\end{minipage}%%
\\end{lrbox}%%
\\fcolorbox{highlightBorder}{highlightBg}{\\usebox{\\highlightbox}}%%
\\vspace{0.5em}}%%
', 
latex_color("highlightBg", highlight.options$bg ), 
latex_color("highlightBorder", highlight.options$border )
)
	} else {
'\\newenvironment{Hinput}%
{}%
{}%
\\newenvironment{Houtput}%
{}%
{}%
\\newenvironment{Hchunk}%
{\\vspace{0.5em}\\par\\begin{flushleft}}%
{\\end{flushleft}}%'
	}

	documentclass <- "^[[:space:]]*\\\\documentclass.*$"
 	which <- grep( documentclass, chunk )
	
	if( length( which ) ){
		replacement <- paste(
				chunk[which], 
				sweave , 
				environments, 
				paste( renderer$boxes , collapse = "\n"),  
				paste( renderer$styles, collapse = "\n"), 
				sep = "\n" )
		chunk[which] <- replacement
	}
	
	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 <- as.character(eval(parse(text=cmd, keep.source = TRUE), envir=.GlobalEnv))
            ## protect against character(0L), because sub() will fail
            if(length(val) == 0L) val <- ""
        }
        else
            val <- paste("\\\\verb{<<", cmd, ">>{", sep="")

        chunk[pos[1L]] <- sub(object$syntax$docexpr, val, chunk[pos[1L]])
    }
	
    while(length(pos <- grep(object$syntax$docopt, chunk))){
        opts <- sub(paste(".*", object$syntax$docopt, ".*", sep=""),
                    "\\1", chunk[pos[1L]])
        object$options <- SweaveParseOptions(opts, object$options,
                                             HighlightWeaveLatexCheckOps )
        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 <- paste(prefix, "tex", sep=".")
            chunk[pos[1L]] <- sub(object$syntax$docopt,
                                 paste("\\\\input{", prefix, "}", sep=""),
                                 chunk[pos[1L]])
            object$haveconcordance <- TRUE
        } else
            chunk[pos[1L]] <- sub(object$syntax$docopt, "", chunk[pos[1L]])
    }

    cat(chunk, sep="\n", file=object$output, append=TRUE)
    object$linesout <- c(object$linesout, linesout)

    return(object)
}
HighlightWeaveLatexWritedoc
}
# }}}

# {{{ Hweave
HweaveSyntaxNoweb <- SweaveSyntaxNoweb
HweaveSyntaxNoweb$extension <- "\\.[hHrsRS]?nw$"

#' Weaving and Tangling with syntax highlighting
#' 
#' \code{Hweave} and \code{Htangle} are similar to \code{Sweave} 
#' and \code{Stangle}, but they take advantage of the
#' custom driver shipped with this package 
#'
#'    These functions exist for the purpose of the 
#'    \code{\\VignetteEngine} option in vignette introduced in R 3.0.0
#'    
#'    \code{highlight} loads the \code{highlight} vignette engine 
#'    at load time. Client packages must declare to use it
#'    with the \code{VignetteBuilder} field in their \code{DESCRIPTION}
#'    file
#'    
#'    The vignette engine looks for files matching the 
#'    pattern \code{"[.][hHrRsS]nw$"} although in order to distinguish 
#'    vignettes using this engine and the default
#'    Sweave engine, the recommandation is to use vignette with the \code{".Hnw"}
#'    extension. 
#' 
#' @param file Path to Sweave source file
#' @param driver  The actual workhorse, see the Details section in \code{\link[utils]{Sweave}}
#' @param syntax \code{NULL} or an object of class \code{SweaveSyntax}
#'      or a character string with its name. See the section \code{Syntax Definition}
#'      in \code{\link[utils]{Sweave}}
#' @param encoding  The default encoding to assume for \code{file}
#' @param \dots Further arguments passed to the driver's setup function.
#' 
#' @rdname Hweave
#' @export
Hweave <- function (file, driver = HighlightWeaveLatex(), syntax = HweaveSyntaxNoweb, encoding = "", ...){
    Sweave( file, driver = driver, syntax = syntax, encoding = encoding, ... )
}

HighlightTangle <- function(){
	driver <- Rtangle()
	runcode <- driver$runcode
	driver$runcode <- function (object, chunk, options){
		if( "lang" %in% names(options) && ! options$lang %in% c("r", "R" ) ){ 
			object
		} else {	
			runcode(object, chunk, options)
		}
	}
	driver
}

#' @rdname Hweave
#' @export
Htangle <- function (file, driver = HighlightTangle(), syntax = HweaveSyntaxNoweb, encoding = "", ...){
	Sweave(file = file, driver = driver, encoding = encoding, ...)
}
# }}}

# :tabSize=4:indentSize=4:noTabs=false:folding=explicit:collapseFolds=1: