R/css.R

In highlight: Syntax Highlighter

w3c.colors <- list( 
	aqua    = "#00FFFF" , 
	black   = "#000000" , 
	blue    = "#0000FF" , 
	fuchsia = "#FF00FF" , 
	gray    = "#808080" , 
	green   = "#008000" , 
	lime    = "#00FF00" , 
	maroon  = "#800000" , 
	navy    = "#000080" , 
	olive   = "#808000" , 
	purple  = "#800080" , 
	red     = "#FF0000" , 
	silver  = "#C0C0C0" , 
	teal    = "#008080" , 
	white   = "#FFFFFF" , 
	yellow  = "#FFFF00" 
	)


css.parse.color <- function( txt, default = "#000000" ){
	txt <- gsub( "\\s+", "", casefold( txt ), perl = TRUE )
	
	if( is.hex( txt ) ) return(txt)
	
	# css specs are from 0 to 255
	rgb <- function( ... ){
		grDevices::rgb( ..., maxColorValue = 255 )
	}
	
	# first we try to match against w3c standard colors
	if( !grepl( "[^a-z]", txt) ){
		if( txt %in% names(w3c.colors) ) {
			return( w3c.colors[[txt]] )
		}
	}
	
	# now we try R colors
	if( !grepl( "[^a-z0-9]", txt) ){
		R.colors <- colors()
		res <- R.colors %in% txt
		if( any( res ) ) {
			return( rgb( t(col2rgb( R.colors[res] )) ) )
		}
	}
	
	# next we try an rgb() specification
	if( grepl( "rgb", txt ) ){
		p <- try( parse( text = txt), silent = TRUE )
		if( !inherits( p, "try-error" ) ){
			res <- try( eval( p, envir = environment() ), silent = T )
			if( !inherits( res, "try-error" ) ) return(res)
		}
	}
	
	# fall back on the default color
	default
}

is.hex <- function( x ){
	grepl( "^#[0-9a-f]{6}$", x ) 
}

# this is placeholder at the moment
css.parse.font_weight <- function ( txt ){
	txt
}

css.parse.font_style <- function(txt){
	txt
}

css.parse.text_decoration <- function ( txt ){
	txt
}

#' Minimal CSS parser
#' 
#' @param file file to parse
#' @param lines text lines to parse
#' 
#' @return A list with one element per style class declaration. Each element 
#'         is a list which has one element per CSS setting 
#'         (\samp{color}, \samp{background}, ...)
#'
#' @note
#' 	The parser is very minimal and will only identify CSS declarations like
#' 	the following : 
#' 	
#' \preformatted{
#' .classname{
#' 	setting1 : value ;
#' 	setting2 : value ;
#' } }
#' 
#' 	The line where a declaration occurs must start with a dot, 
#' 	followed by the name of the class and a left brace. The declaration
#' 	ends with the first line that starts with a right brace. The function
#' 	will warn about class names containing numbers as this is likely to 
#' 	cause trouble when the parsed style is translated into another 
#' 	language (e.g. latex commands).
#' 	
#' 	Within the css declaration, the parser identifies setting/value 
#' 	pairs separated by \samp{:} on a single line. Each setting must 
#' 	be on a seperate line.
#' 	
#' 	If the setting is \samp{color} or \samp{background}, the parser then
#' 	tries to map the value to a hex color specification 
#' 	by trying the following options: the value is already a hex
#' 	color, the name of the color is one of the 16 w3c standard colors, the name 
#' 	is an R color (see \code{\link[grDevices]{colors}}), the 
#' 	color is specified as \samp{rgb(r,g,b)}. If all fails, the
#' 	color used is black for the \samp{color} setting and 
#' 	\samp{white} for the \samp{background} setting.
#' 
#' 	Other settings are not further parsed at present.
#' 
#' @export
css.parser <- function( file, lines = readLines( file ) ){
	
	rx <- "^\\.(.*?) *\\{.*$"
	dec.lines <- grep( rx, lines )
	dec.names <- sub( rx, "\\1", lines[dec.lines] ) 
	if( any( grepl( "[0-9]", dec.names) ) ){
		warning( "use of numbers in style names" )
	}
	
	end.rx <- "^[[:space:]]*\\}"
	end.lines <- grep( end.rx, lines )
	
	# find the closing brace of each declaration
	dec.close <- end.lines[ sapply( dec.lines, function( x ) which.min( end.lines < x ) ) ]
	
	pos <- matrix( c(dec.lines, dec.close), ncol = 2 )
	styles <- apply( pos, 1, function( x ) {
	  data <- lines[ (x[1]+1) : (x[2]-1) ]
		settings.rx <- "^\\s*(.*?)\\s*:\\s*(.*?)\\s*;\\s*$"
		settings <- sub( settings.rx, "\\1", data , perl = TRUE)
		contents <- sub( settings.rx, "\\2", data  , perl = TRUE)
		out <- list()
		for( i in 1:length(settings) ){
			setting <- settings[i]
			content <- contents[i]
			out[[ setting ]] <- switch( setting, 
				"color" = css.parse.color( content, "#000000" ), 
				"background" = css.parse.color( content, "#FFFFFF" ),
				"font-weight" = css.parse.font_weight( content ), 
				"font-style" = css.parse.font_style( content ), 
				"text-decoration" = css.parse.text_decoration( content ), 
				content ) 
		}
		out
	} )
	names( styles ) <- dec.names
	styles
}