syntax highlighter for R 2.16.0

README.md

This has been incorporated into the highr package: https://github.com/yihui/highr

highr.r

stopifnot(getRversion() >= '3.0.0')

.keywords = c('FUNCTION', 'IF', 'ELSE', 'WHILE', 'FOR', 'IN', 'BREAK', 'REPEAT', 'NEXT')

.cmd.list = c(
  NUM_CONST            = 'number',
  SYMBOL_FUNCTION_CALL = 'functioncall',
  STR_CONST            = 'string',
  setNames(rep('keyword', length(.keywords)), .keywords),
  SYMBOL_FORMALS       = 'argument',
  COMMENT              = 'comment',
  SYMBOL_SUB           = 'formalargs',
  EQ_SUB               = 'eqformalargs',
  LEFT_ASSIGN          = 'assignment',
  EQ_ASSIGN            = 'assignment',
  RIGHT_ASSIGN         = 'assignment',
  SLOT                 = 'slot',
  SYMBOL               = 'symbol'
)

cmd_latex = data.frame(
  cmd1 = paste('\\hl', .cmd.list, '{', sep = ''),
  cmd2 = '}',
  stringsAsFactors = FALSE,
  row.names = names(.cmd.list)
)

cmd_html = data.frame(
  cmd1 = paste('<span class="', .cmd.list, '">', sep = ''),
  cmd2 = '</span>',
  stringsAsFactors = FALSE,
  row.names = names(.cmd.list)
)

## an important missing part: must put white spaces back!
## a minor missing part: escape special characters (see knitr:::escape_latex)
hilight = function(x, format = c('latex', 'html')) {
  format = match.arg(format)
  p = parse(text = x)
  if (length(p) == 0L) return(x)
  z = getParseData(p)
  if (NROW(z) == 0L || !any(z$terminal)) return(x)
  z = z[z$terminal, ]
  res = (if (format == 'latex') cmd_latex else cmd_html)[z$token, ]
  res = cbind(z, res)
  res = within(res, {cmd1[is.na(cmd1)] = ''; cmd2[is.na(cmd2)] = ''})
  with(res, tapply(paste(cmd1, text, cmd2, sep = ''), line1, paste, collapse = ''))  
}

hi_latex = function(x) hilight(x, 'latex')
hi_html = function(x) hilight(x, 'html')

# examples
txt = c('a<-1 # something', 'c(z="hello")', 'b=function(x=2){while(FALSE) NA}',
        'for(i in 1:10) {if (i < 5) print(i) else break}', 'z@child # S4 slot')
hi_latex(txt)
hi_html(txt)