initial commit
This commit is contained in:
Eric Schulte
commit
a3cf89b5b2
|
|
@ -0,0 +1 @@
|
||||||
|
*~
|
||||||
|
|
@ -0,0 +1,9 @@
|
||||||
|
rorg --- R and org-mode
|
||||||
|
======================
|
||||||
|
|
||||||
|
* for information on R see the [R website](http://www.r-project.org/)
|
||||||
|
* for information on org see the [Org-Mode website](http://org-mode.org)
|
||||||
|
|
||||||
|
Probably would be good to place the main objectives here, once they
|
||||||
|
are ironed out.
|
||||||
|
|
||||||
|
|
@ -0,0 +1,358 @@
|
||||||
|
require(utils)
|
||||||
|
|
||||||
|
RweaveOrg = function () {
|
||||||
|
list(setup = RweaveOrgSetup, runcode = RweaveOrgRuncode,
|
||||||
|
writedoc = RweaveOrgWritedoc, finish = RweaveOrgFinish,
|
||||||
|
checkopts = RweaveOrgOptions)
|
||||||
|
}
|
||||||
|
|
||||||
|
RweaveOrgSetup <-
|
||||||
|
function (file, syntax, output = NULL, quiet = FALSE, debug = FALSE,
|
||||||
|
echo = TRUE, eval = TRUE, keep.source = FALSE, split = FALSE,
|
||||||
|
stylepath, pdf = TRUE, eps = TRUE) {
|
||||||
|
if (is.null(output)) {
|
||||||
|
prefix.string <- basename(sub(syntax$extension, "", file))
|
||||||
|
output <- paste(prefix.string, "org", sep = ".")
|
||||||
|
}
|
||||||
|
else prefix.string <- basename(sub("\\.org$", "", output))
|
||||||
|
if (!quiet)
|
||||||
|
cat("Writing to file ", output, "\n", "Processing code chunks ...\n",
|
||||||
|
sep = "")
|
||||||
|
output <- file(output, open = "w+")
|
||||||
|
if (missing(stylepath)) {
|
||||||
|
p <- as.vector(Sys.getenv("SWEAVE_STYLEPATH_DEFAULT"))
|
||||||
|
stylepath <- if (length(p) >= 1 && nzchar(p[1]))
|
||||||
|
identical(p, "TRUE")
|
||||||
|
else TRUE
|
||||||
|
}
|
||||||
|
if (stylepath) {
|
||||||
|
styfile <- file.path(R.home("share"), "texmf", "Sweave")
|
||||||
|
if (.Platform$OS.type == "windows")
|
||||||
|
styfile <- gsub("\\\\", "/", styfile)
|
||||||
|
if (length(grep(" ", styfile)))
|
||||||
|
warning(gettextf("path to '%s' contains spaces,\n",
|
||||||
|
styfile), gettext("this may cause problems when running LaTeX"),
|
||||||
|
domain = NA)
|
||||||
|
}
|
||||||
|
else styfile <- "Sweave"
|
||||||
|
options <- list(prefix = TRUE, prefix.string = prefix.string,
|
||||||
|
engine = "R", print = FALSE, eval = eval, fig = FALSE,
|
||||||
|
pdf = pdf, eps = eps, width = 6, height = 6, term = TRUE,
|
||||||
|
echo = echo, keep.source = keep.source, results = "verbatim",
|
||||||
|
split = split, strip.white = "true", include = TRUE,
|
||||||
|
pdf.version = "1.1", pdf.encoding = "default", concordance = FALSE,
|
||||||
|
expand = TRUE)
|
||||||
|
options <- RweaveOrgOptions(options)
|
||||||
|
list(output = output, styfile = styfile, havesty = FALSE,
|
||||||
|
haveconcordance = FALSE, debug = debug, quiet = quiet,
|
||||||
|
syntax = syntax, options = options, chunkout = list(),
|
||||||
|
srclines = integer(0), srcfile = srcfile(file))
|
||||||
|
}
|
||||||
|
|
||||||
|
makeRweaveOrgCodeRunner <-
|
||||||
|
function (evalFunc = RweaveEvalWithOpt)
|
||||||
|
{
|
||||||
|
RweaveOrgRuncode <- function(object, chunk, options) {
|
||||||
|
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) {
|
||||||
|
chunkout <- object$chunkout[chunkprefix][[1]]
|
||||||
|
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), silent = TRUE)
|
||||||
|
RweaveTryStop(chunkexps, options)
|
||||||
|
openSinput <- FALSE
|
||||||
|
openSchunk <- FALSE
|
||||||
|
if (length(chunkexps) == 0)
|
||||||
|
return(object)
|
||||||
|
srclines <- attr(chunk, "srclines")
|
||||||
|
linesout <- integer(0)
|
||||||
|
srcline <- srclines[1]
|
||||||
|
srcrefs <- attr(chunkexps, "srcref")
|
||||||
|
if (options$expand)
|
||||||
|
lastshown <- 0
|
||||||
|
else lastshown <- srcline - 1
|
||||||
|
thisline <- 0
|
||||||
|
for (nce in 1:length(chunkexps)) {
|
||||||
|
ce <- chunkexps[[nce]]
|
||||||
|
if (nce <= length(srcrefs) && !is.null(srcref <- srcrefs[[nce]])) {
|
||||||
|
if (options$expand) {
|
||||||
|
srcfile <- attr(srcref, "srcfile")
|
||||||
|
showfrom <- srcref[1]
|
||||||
|
showto <- srcref[3]
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
srcfile <- object$srcfile
|
||||||
|
showfrom <- srclines[srcref[1]]
|
||||||
|
showto <- srclines[srcref[3]]
|
||||||
|
}
|
||||||
|
dce <- getSrcLines(srcfile, lastshown + 1, showto)
|
||||||
|
leading <- showfrom - lastshown
|
||||||
|
lastshown <- showto
|
||||||
|
srcline <- srclines[srcref[3]]
|
||||||
|
while (length(dce) && length(grep("^[[:blank:]]*$",
|
||||||
|
dce[1]))) {
|
||||||
|
dce <- dce[-1]
|
||||||
|
leading <- leading - 1
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
dce <- deparse(ce, width.cutoff = 0.75 * getOption("width"))
|
||||||
|
leading <- 1
|
||||||
|
}
|
||||||
|
if (object$debug)
|
||||||
|
cat("\nRnw> ", paste(dce, collapse = "\n+ "),
|
||||||
|
"\n")
|
||||||
|
if (options$echo && length(dce)) {
|
||||||
|
if (!openSinput) {
|
||||||
|
if (!openSchunk) {
|
||||||
|
cat("#+BEGIN_LaTeX\n", file = chunkout, append = TRUE)
|
||||||
|
cat("\\begin{Schunk}\n", file = chunkout, append = TRUE)
|
||||||
|
linesout[thisline + 1:2] <- srcline
|
||||||
|
thisline <- thisline + 2
|
||||||
|
openSchunk <- TRUE
|
||||||
|
}
|
||||||
|
cat("\\begin{Sinput}", file = chunkout, append = TRUE)
|
||||||
|
openSinput <- TRUE
|
||||||
|
}
|
||||||
|
cat("\n", paste(getOption("prompt"), dce[1:leading],
|
||||||
|
sep = "", collapse = "\n"), file = chunkout,
|
||||||
|
append = TRUE, sep = "")
|
||||||
|
if (length(dce) > leading)
|
||||||
|
cat("\n", paste(getOption("continue"), dce[-(1:leading)],
|
||||||
|
sep = "", collapse = "\n"), file = chunkout,
|
||||||
|
append = TRUE, sep = "")
|
||||||
|
linesout[thisline + 1:length(dce)] <- srcline
|
||||||
|
thisline <- thisline + length(dce)
|
||||||
|
}
|
||||||
|
tmpcon <- file()
|
||||||
|
sink(file = tmpcon)
|
||||||
|
err <- NULL
|
||||||
|
if (options$eval)
|
||||||
|
err <- evalFunc(ce, options)
|
||||||
|
cat("\n")
|
||||||
|
sink()
|
||||||
|
output <- readLines(tmpcon)
|
||||||
|
close(tmpcon)
|
||||||
|
if (length(output) == 1 & output[1] == "")
|
||||||
|
output <- NULL
|
||||||
|
RweaveTryStop(err, options)
|
||||||
|
if (object$debug)
|
||||||
|
cat(paste(output, collapse = "\n"))
|
||||||
|
if (length(output) > 0 & (options$results != "hide")) {
|
||||||
|
if (openSinput) {
|
||||||
|
cat("\n\\end{Sinput}\n", file = chunkout, append = TRUE)
|
||||||
|
linesout[thisline + 1:2] <- srcline
|
||||||
|
thisline <- thisline + 2
|
||||||
|
openSinput <- FALSE
|
||||||
|
}
|
||||||
|
if (options$results == "verbatim") {
|
||||||
|
if (!openSchunk) {
|
||||||
|
cat("#+BEGIN_LaTeX\n", file = chunkout, append = TRUE)
|
||||||
|
cat("\\begin{Schunk}\n", file = chunkout,
|
||||||
|
append = TRUE)
|
||||||
|
linesout[thisline + 1:2] <- srcline
|
||||||
|
thisline <- thisline + 2
|
||||||
|
openSchunk <- TRUE
|
||||||
|
}
|
||||||
|
cat("\\begin{Soutput}\n", file = chunkout,
|
||||||
|
append = TRUE)
|
||||||
|
linesout[thisline + 1] <- srcline
|
||||||
|
thisline <- thisline + 1
|
||||||
|
}
|
||||||
|
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)
|
||||||
|
}
|
||||||
|
cat(output, file = chunkout, append = TRUE)
|
||||||
|
count <- sum(strsplit(output, NULL)[[1]] == "\n")
|
||||||
|
if (count > 0) {
|
||||||
|
linesout[thisline + 1:count] <- srcline
|
||||||
|
thisline <- thisline + count
|
||||||
|
}
|
||||||
|
remove(output)
|
||||||
|
if (options$results == "verbatim") {
|
||||||
|
cat("\n\\end{Soutput}\n", file = chunkout,
|
||||||
|
append = TRUE)
|
||||||
|
linesout[thisline + 1:2] <- srcline
|
||||||
|
thisline <- thisline + 2
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if (openSinput) {
|
||||||
|
cat("\n\\end{Sinput}\n", file = chunkout, append = TRUE)
|
||||||
|
linesout[thisline + 1:2] <- srcline
|
||||||
|
thisline <- thisline + 2
|
||||||
|
}
|
||||||
|
if (openSchunk) {
|
||||||
|
cat("\\end{Schunk}\n", file = chunkout, append = TRUE)
|
||||||
|
cat("#+END_LaTeX\n", file = chunkout, append = TRUE)
|
||||||
|
linesout[thisline + 1:2] <- srcline
|
||||||
|
thisline <- thisline + 2
|
||||||
|
}
|
||||||
|
if (is.null(options$label) & options$split)
|
||||||
|
close(chunkout)
|
||||||
|
if (options$split & options$include) {
|
||||||
|
cat("#+LaTeX: \\input{", chunkprefix, "}\n", sep = "", file = object$output,
|
||||||
|
append = TRUE)
|
||||||
|
linesout[thisline + 1] <- srcline
|
||||||
|
thisline <- thisline + 1
|
||||||
|
}
|
||||||
|
if (options$fig && options$eval) {
|
||||||
|
if (options$eps) {
|
||||||
|
grDevices::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)
|
||||||
|
})
|
||||||
|
grDevices::dev.off()
|
||||||
|
if (inherits(err, "try-error"))
|
||||||
|
stop(err)
|
||||||
|
}
|
||||||
|
if (options$pdf) {
|
||||||
|
grDevices::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)
|
||||||
|
})
|
||||||
|
grDevices::dev.off()
|
||||||
|
if (inherits(err, "try-error"))
|
||||||
|
stop(err)
|
||||||
|
}
|
||||||
|
if (options$include) {
|
||||||
|
chunksuffix <- ifelse(options$eps, "eps", "pdf")
|
||||||
|
cat("[[./", paste(chunkprefix, chunksuffix, sep = "."), "]]\n",
|
||||||
|
sep = "", file = object$output, append = TRUE)
|
||||||
|
linesout[thisline + 1] <- srcline
|
||||||
|
thisline <- thisline + 1
|
||||||
|
}
|
||||||
|
}
|
||||||
|
object$linesout <- c(object$linesout, linesout)
|
||||||
|
return(object)
|
||||||
|
}
|
||||||
|
RweaveOrgRuncode
|
||||||
|
}
|
||||||
|
|
||||||
|
RweaveOrgRuncode <- makeRweaveOrgCodeRunner()
|
||||||
|
|
||||||
|
RweaveOrgWritedoc <-
|
||||||
|
function (object, chunk) {
|
||||||
|
linesout <- attr(chunk, "srclines")
|
||||||
|
## This part of the function adds the appropriate \usepackage
|
||||||
|
## directive and begins the document. Skip this for now, but
|
||||||
|
## eventually add in detection for #+LATEX_PREAMBLE
|
||||||
|
### if (length(grep("\\usepackage[^\\}]*Sweave.*\\}", chunk)))
|
||||||
|
### object$havesty <- TRUE
|
||||||
|
### if (!object$havesty) {
|
||||||
|
### begindoc <- "^[[:space:]]*\\\\begin\\{document\\}"
|
||||||
|
### which <- grep(begindoc, chunk)
|
||||||
|
### if (length(which)) {
|
||||||
|
### chunk[which] <- sub(begindoc, paste("\\\\usepackage{",
|
||||||
|
### object$styfile, "}\n\\\\begin{document}", sep = ""),
|
||||||
|
### chunk[which])
|
||||||
|
### linesout <- linesout[c(1:which, which, seq(from = which +
|
||||||
|
### 1, length.out = length(linesout) - which))]
|
||||||
|
### object$havesty <- TRUE
|
||||||
|
### }
|
||||||
|
### }
|
||||||
|
while (length(pos <- grep(object$syntax$docexpr, chunk))) {
|
||||||
|
cmdloc <- regexpr(object$syntax$docexpr, chunk[pos[1]])
|
||||||
|
cmd <- substr(chunk[pos[1]], cmdloc, cmdloc + attr(cmdloc,
|
||||||
|
"match.length") - 1)
|
||||||
|
cmd <- sub(object$syntax$docexpr, "\\1", cmd)
|
||||||
|
if (object$options$eval) {
|
||||||
|
val <- as.character(eval(parse(text = cmd), envir = .GlobalEnv))
|
||||||
|
if (length(val) == 0)
|
||||||
|
val <- ""
|
||||||
|
}
|
||||||
|
else val <- paste("\\\\verb{<<", cmd, ">>{", sep = "")
|
||||||
|
chunk[pos[1]] <- sub(object$syntax$docexpr, val, chunk[pos[1]])
|
||||||
|
}
|
||||||
|
while (length(pos <- grep(object$syntax$docopt, chunk))) {
|
||||||
|
opts <- sub(paste(".*", object$syntax$docopt, ".*", sep = ""),
|
||||||
|
"\\1", chunk[pos[1]])
|
||||||
|
object$options <- SweaveParseOptions(opts, object$options,
|
||||||
|
RweaveOrgOptions)
|
||||||
|
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, "org", sep = ".")
|
||||||
|
chunk[pos[1]] <- sub(object$syntax$docopt, paste("\\\\input{",
|
||||||
|
prefix, "}", sep = ""), chunk[pos[1]])
|
||||||
|
object$haveconcordance <- TRUE
|
||||||
|
}
|
||||||
|
else chunk[pos[1]] <- sub(object$syntax$docopt, "", chunk[pos[1]])
|
||||||
|
}
|
||||||
|
cat(chunk, sep = "\n", file = object$output, append = TRUE)
|
||||||
|
object$linesout <- c(object$linesout, linesout)
|
||||||
|
return(object)
|
||||||
|
}
|
||||||
|
|
||||||
|
RweaveOrgFinish <-
|
||||||
|
function (object, error = FALSE) {
|
||||||
|
outputname <- summary(object$output)$description
|
||||||
|
inputname <- object$srcfile$filename
|
||||||
|
if (!object$quiet && !error)
|
||||||
|
cat("\n", gettextf("You can now run org-export-as-latex on '%s'", outputname),
|
||||||
|
"\n", sep = "")
|
||||||
|
close(object$output)
|
||||||
|
if (length(object$chunkout) > 0)
|
||||||
|
for (con in object$chunkout) close(con)
|
||||||
|
if (object$haveconcordance) {
|
||||||
|
linesout <- object$linesout
|
||||||
|
vals <- rle(diff(linesout))
|
||||||
|
vals <- c(linesout[1], as.numeric(rbind(vals$lengths,
|
||||||
|
vals$values)))
|
||||||
|
concordance <- paste(strwrap(paste(vals, collapse = " ")),
|
||||||
|
collapse = " %\n")
|
||||||
|
special <- paste("\\special{concordance:", outputname,
|
||||||
|
":", inputname, ":%\n", concordance, "}\n", sep = "")
|
||||||
|
cat(special, file = object$concordfile)
|
||||||
|
}
|
||||||
|
invisible(outputname)
|
||||||
|
}
|
||||||
|
|
||||||
|
RweaveOrgOptions <- RweaveLatexOptions
|
||||||
|
|
@ -0,0 +1,19 @@
|
||||||
|
SweaveSyntaxOrg <- list()
|
||||||
|
SweaveSyntaxOrg$doc <- "^#\\+END_[SR]"
|
||||||
|
SweaveSyntaxOrg$code <- "^#\\+BEGIN_[SR]:?[[:space:]]*(.*)$"
|
||||||
|
SweaveSyntaxOrg$coderef <- "^#\\+[SR]_CODEREF:?[[:space:]]*(.*)$"
|
||||||
|
SweaveSyntaxOrg$docopt <- "^#\\+[SR]_OPTS:?[[:space:]]*(.*)$"
|
||||||
|
SweaveSyntaxOrg$docexpr <- "\\\\[SR]\\{([^\\}]*)\\}"
|
||||||
|
SweaveSyntaxOrg$extension <- "\\.[SRsr]org$"
|
||||||
|
SweaveSyntaxOrg$syntaxname <- "^#\\+[SR]WEAVE_SYNTAX:?[[:space:]]*(.*)$"
|
||||||
|
SweaveSyntaxOrg$input <- "^#\\+[SR]_FILE:?[[:space:]]*(.*)$"
|
||||||
|
SweaveSyntaxOrg$trans <- list()
|
||||||
|
SweaveSyntaxOrg$trans$doc <- "\\\\end{Scode}"
|
||||||
|
SweaveSyntaxOrg$trans$code <- "\\\\begin{Scode}{\\1}"
|
||||||
|
SweaveSyntaxOrg$trans$coderef <- "\\\\Scoderef{\\1}"
|
||||||
|
SweaveSyntaxOrg$trans$docopt <- "\\\\SweaveOpts{\\1}"
|
||||||
|
SweaveSyntaxOrg$trans$docexpr <- "\\\\Sexpr{\\1}"
|
||||||
|
SweaveSyntaxOrg$trans$extension <- ".[SR]org"
|
||||||
|
SweaveSyntaxOrg$trans$syntaxname <- "\\\\SweaveSyntax{SweaveSyntaxLatex}"
|
||||||
|
SweaveSyntaxOrg$trans$input <- "\\\\SweaveInput{\\1}"
|
||||||
|
attr(SweaveSyntaxOrg, "class") <- "SweaveSyntax"
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
source("SweaveSyntaxOrg.R")
|
||||||
|
source("RweaveOrg.R")
|
||||||
|
|
||||||
|
Sweave("testing.Rorg", driver=RweaveOrg, syntax=SweaveSyntaxOrg)
|
||||||
|
Stangle("testing.Rorg", driver=Rtangle(), syntax=SweaveSyntaxOrg)
|
||||||
|
|
@ -0,0 +1,73 @@
|
||||||
|
# -*- mode: org -*-
|
||||||
|
#+OPTIONS: LaTeX:t
|
||||||
|
|
||||||
|
* Sweave and org-mode
|
||||||
|
If you're reading a PDF version of this document, you should also
|
||||||
|
look at [[file:testing.Rorg][testing.Rorg]] (the source file) and [[file:testing.org][testing.org]] (the output
|
||||||
|
of the Sweave process).
|
||||||
|
|
||||||
|
Keep in mind that one of the advantages of a block-based approach is
|
||||||
|
using \texttt{C-'} to edit code in its native mode.
|
||||||
|
|
||||||
|
** Use the Sweave package for latex formatting
|
||||||
|
Org allows us to issue commands to be included in \{LaTeX} export.
|
||||||
|
#+LATEX_HEADER: \usepackage{Sweave}
|
||||||
|
|
||||||
|
** R blocks
|
||||||
|
The first argument to an R block when using Sweave is the label for
|
||||||
|
that block.
|
||||||
|
|
||||||
|
Not all R blocks are printed. Sweave options allow the printing of
|
||||||
|
the evaluated code, the output of the code, both, or neither.
|
||||||
|
|
||||||
|
*** R code that is not printed
|
||||||
|
#+BEGIN_R: hidden_block, echo=FALSE, results=HIDE
|
||||||
|
a <- 3
|
||||||
|
b <- 6
|
||||||
|
#+END_R
|
||||||
|
|
||||||
|
*** R code that is printed
|
||||||
|
#+BEGIN_R: visible_block
|
||||||
|
c <- 4
|
||||||
|
#+END_R
|
||||||
|
|
||||||
|
We can use block labels to embed blocks by reference (even if they
|
||||||
|
weren't printed before).
|
||||||
|
*** R code that references other blocks
|
||||||
|
#+BEGIN_R: combined_block
|
||||||
|
#+R_CODEREF: hidden_block
|
||||||
|
#+R_CODEREF: visible_block
|
||||||
|
a + b +c
|
||||||
|
#+END_R
|
||||||
|
|
||||||
|
** Inline references to R data
|
||||||
|
We can evaluate R code inline.
|
||||||
|
*** Used in text
|
||||||
|
The value of =a= is \R{a}.
|
||||||
|
|
||||||
|
*** Used in a table
|
||||||
|
| a | b | c | TOTAL |
|
||||||
|
|-------+-------+-------+---------------|
|
||||||
|
| \R{a} | \R{b} | \R{c} | \R{a + b + c} |
|
||||||
|
|
||||||
|
** Single-line R commands
|
||||||
|
If we want a line of R code to be evaluated but not printed,
|
||||||
|
there's a convenient shorthand. This only works for single lines
|
||||||
|
of R code, but you can have more than one in a row.
|
||||||
|
#+R: library(lattice)
|
||||||
|
#+R: data(cars)
|
||||||
|
|
||||||
|
** Graphics
|
||||||
|
We use values defined elsewhere in the buffer to produce this
|
||||||
|
graph. The new CAPTION and LABEL arguments work just fine.
|
||||||
|
|
||||||
|
#+CAPTION: speed by distance
|
||||||
|
#+LABEL: fig:speed_by_distance
|
||||||
|
#+BEGIN_R fig=TRUE, eps=FALSE, pdf=TRUE
|
||||||
|
print(xyplot(speed ~ dist, cars,
|
||||||
|
panel = function (x, y, ...) {
|
||||||
|
panel.xyplot(x, y, ...)
|
||||||
|
panel.abline(h=a)
|
||||||
|
panel.abline(v=b)
|
||||||
|
}))
|
||||||
|
#+END_R
|
||||||
|
|
@ -0,0 +1,846 @@
|
||||||
|
;;; org-R.el --- Numerical computation and data visualisation for org-mode using R
|
||||||
|
|
||||||
|
;; Copyright (C) 2009
|
||||||
|
;; Free Software Foundation, Inc.
|
||||||
|
|
||||||
|
;; Author: Dan Davison <davison@stats.ox.ac.uk>
|
||||||
|
;; Keywords: org, R, ESS, tables, graphics
|
||||||
|
;; Homepage: http://www.stats.ox.ac.uk/~davison/software/org-R
|
||||||
|
;; Version: 0.05 2009-02-05
|
||||||
|
;;
|
||||||
|
;; This file is not part of GNU Emacs.
|
||||||
|
;;
|
||||||
|
;; This file is free software; you can redistribute it and/or modify
|
||||||
|
;; it under the terms of the GNU General Public License as published by
|
||||||
|
;; the Free Software Foundation; either version 3, or (at your option)
|
||||||
|
;; any later version.
|
||||||
|
|
||||||
|
;; This file is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;; GNU General Public License for more details.
|
||||||
|
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;;
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; This file allows R (http://www.r-project.org) code to be applied to
|
||||||
|
;; emacs org-mode (http://orgmode.org) tables. When the
|
||||||
|
;; result of the analysis is a vector or matrix, it is output back
|
||||||
|
;; into the org-mode buffer as a new org table. Alternatively the R
|
||||||
|
;; code may be used to plot the data in the org table. It requires R to be
|
||||||
|
;; running in an inferior-ess-mode buffer (install Emacs Speaks
|
||||||
|
;; Statistics http://ess.r-project.org and issue M-x R).
|
||||||
|
;;
|
||||||
|
;;
|
||||||
|
;; The user interface is via two different options lines in the org
|
||||||
|
;; buffer. As is conventional in org-mode, these are lines starting
|
||||||
|
;; with `#+'. Lines starting with #+R: specify options in the
|
||||||
|
;; standard org style (option:value) and are used to specify certain
|
||||||
|
;; off-the-shelf transformations and plots of the table data. The
|
||||||
|
;; #+R: line is also used to specify the data to be analysed
|
||||||
|
;; (either an org table or a csv file), and to restrict the analysis
|
||||||
|
;; to certain columns etc. In lines starting #+RR: you can supply
|
||||||
|
;; literal R code, giving you full control over what you do with the
|
||||||
|
;; table. With point in the first #+R line, M-x org-R-apply
|
||||||
|
;; makes happen whatever has been specified in those lines.
|
||||||
|
|
||||||
|
;; The best documentation is currently the Worg tutorial:
|
||||||
|
;;
|
||||||
|
;; http://orgmode.org/worg/org-tutorials/org-R/org-R.php
|
||||||
|
|
||||||
|
|
||||||
|
(defconst org-R-skeleton-funcall-1-arg
|
||||||
|
"%s(x[%s]%s)"
|
||||||
|
"Skeleton of a call to an R function.
|
||||||
|
E.g. barplot(x[,3:5], names.arg=rownames(x))")
|
||||||
|
|
||||||
|
(defconst org-R-skeleton-funcall-2-args
|
||||||
|
"%s(x[,%s], x[,%s]%s)"
|
||||||
|
"Skeleton of a call to an R function which can take x and y
|
||||||
|
args.")
|
||||||
|
|
||||||
|
(defconst org-R-write-org-table-def
|
||||||
|
"write.org.table <- function (x, write.rownames = TRUE)
|
||||||
|
{
|
||||||
|
if(!is.null(dim(x)) && length(dim(x)) > 2)
|
||||||
|
stop(\"Object must be 1- or 2-dimensional\") ;
|
||||||
|
if(is.vector(x) || is.table(x) || is.factor(x) || is.array(x))
|
||||||
|
x <- as.matrix(x) ;
|
||||||
|
if(!(is.matrix(x) || inherits(x, c('matrix', 'data.frame')))) {
|
||||||
|
invisible() ;
|
||||||
|
print(x) ;
|
||||||
|
stop(\"Object not recognised as 1- or 2-dimensional\") ;
|
||||||
|
} ;
|
||||||
|
if(is.null(colnames(x)))
|
||||||
|
colnames(x) <- rep('', ncol(x)) ;
|
||||||
|
if(write.rownames)
|
||||||
|
x <- cbind(rownames(x), x) ;
|
||||||
|
cat('|', paste(colnames(x), collapse = ' | '), '|\\n') ;
|
||||||
|
cat('|', paste(rep('----', ncol(x)), collapse = '+'), '|\\n', sep = '') ;
|
||||||
|
invisible(apply(x, 1, function(row) cat('|', paste(row, collapse = ' | '), '|\\n'))) ;
|
||||||
|
}"
|
||||||
|
"Definition of R function to write org table representation of R objects.
|
||||||
|
To see a more human-readable version of this, look at the code,
|
||||||
|
or type dput(write.org.table) RET at the R (inferior-ess-mode
|
||||||
|
buffer) prompt.")
|
||||||
|
|
||||||
|
|
||||||
|
(defun org-R-apply ()
|
||||||
|
"Construct and evaluate an R function call.
|
||||||
|
Construct an R function corresponding to the #+R: and #+RR:
|
||||||
|
lines. R must be currently running in an inferior-ess-mode
|
||||||
|
buffer. The function evaluates any user-supplied R code in the
|
||||||
|
#+RR: line before the off-the-shelf actions specified in the #+R:
|
||||||
|
line. The user-supplied R code can operate on a variable called x
|
||||||
|
that is the org table represented as a data frame in R. Text
|
||||||
|
output from the R process may be inserted into the org buffer, as
|
||||||
|
an org table where appropriate."
|
||||||
|
(interactive)
|
||||||
|
(require 'ess)
|
||||||
|
(save-excursion
|
||||||
|
(beginning-of-line)
|
||||||
|
(unless (looking-at "#\\+RR?:") (error "Point must be in a #+R or #+RR line"))
|
||||||
|
(while (looking-at "#\\+RR?:") (forward-line -1))
|
||||||
|
(forward-line)
|
||||||
|
;; For the rest of the code in this file we are based at the
|
||||||
|
;; beginning of the first #+R line
|
||||||
|
|
||||||
|
;; FIXME: if point is at the beginning of the #+RR? lines when
|
||||||
|
;; this function is called, then tabular output gets inserted,
|
||||||
|
;; leaving point up at the top of the tabular output.
|
||||||
|
|
||||||
|
(let* ((options (org-R-get-options))
|
||||||
|
(code (org-R-construct-code options))
|
||||||
|
(infile (plist-get options :infile))
|
||||||
|
(ext (if infile (file-name-extension infile)))
|
||||||
|
csv-file)
|
||||||
|
|
||||||
|
(if (string-equal ext "csv")
|
||||||
|
(setq csv-file infile)
|
||||||
|
(setq csv-file
|
||||||
|
(org-R-export-to-csv
|
||||||
|
(make-temp-file "org-R-tmp" nil ".csv") options)))
|
||||||
|
|
||||||
|
(org-R-eval code csv-file options)
|
||||||
|
|
||||||
|
(delete-other-windows) ;; FIXME
|
||||||
|
(if (plist-get options :showcode) (org-R-showcode code)))))
|
||||||
|
|
||||||
|
(defun org-R-apply-to-subtree ()
|
||||||
|
"Call org-R-apply in every org-R block in current subtree."
|
||||||
|
;; This currently relies on re-search-forward leaving point after
|
||||||
|
;; the #+RR?: If point were at the beginning of the line, then
|
||||||
|
;; tabular input would get inserted leaving point above the #+RR?:,
|
||||||
|
;; and this would loop infinitely. Same for org-R-apply-to-buffer.
|
||||||
|
(interactive)
|
||||||
|
(save-excursion
|
||||||
|
(org-back-to-heading)
|
||||||
|
(while (re-search-forward
|
||||||
|
"^#\\+RR?:"
|
||||||
|
(save-excursion (org-end-of-subtree)) t)
|
||||||
|
(org-R-apply)
|
||||||
|
(forward-line)
|
||||||
|
(while (looking-at "#\\+RR?")
|
||||||
|
(forward-line)))))
|
||||||
|
|
||||||
|
(defun org-R-apply-to-buffer ()
|
||||||
|
"Call org-R-apply in every org-R block in the buffer."
|
||||||
|
(interactive)
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (point-min))
|
||||||
|
(while (re-search-forward "^#\\+RR?:" nil t)
|
||||||
|
(org-R-apply)
|
||||||
|
(forward-line)
|
||||||
|
(while (looking-at "#\\+RR?")
|
||||||
|
(forward-line)))))
|
||||||
|
|
||||||
|
(defun org-R-construct-code (options)
|
||||||
|
"Construct the R function that implements the requested
|
||||||
|
behaviour. The body of this function derives from two sources:
|
||||||
|
|
||||||
|
1. Explicit R code which is read from lines starting with
|
||||||
|
#+RR: by org-R-get-user-code, and
|
||||||
|
|
||||||
|
2. Off-the-shelf code corresponding to options specified in the
|
||||||
|
#+R: line. This code is constructed by
|
||||||
|
org-R-off-the-shelf-code."
|
||||||
|
(let ((user-code (org-R-get-user-code))
|
||||||
|
(action (plist-get options :action)))
|
||||||
|
|
||||||
|
(if (or (eq action 'tabulate) (eq action 'transpose))
|
||||||
|
(setq options (plist-put options :output-to-buffer t)))
|
||||||
|
(format "function(x){%sx}"
|
||||||
|
(concat
|
||||||
|
(when user-code (concat user-code ";"))
|
||||||
|
(when action (concat (org-R-off-the-shelf-code options) ";"))))))
|
||||||
|
|
||||||
|
(defun org-R-get-user-code (&optional R)
|
||||||
|
"Read user-supplied R code from #+RR: lines"
|
||||||
|
(let ((case-fold-search t))
|
||||||
|
(save-excursion
|
||||||
|
(while (looking-at "^#\\+\\(RR?:\\) *\\(.*\\)")
|
||||||
|
(if (string= "RR:" (match-string 1))
|
||||||
|
(setq R (concat R (when R ";") (match-string 2))))
|
||||||
|
(forward-line))))
|
||||||
|
R)
|
||||||
|
|
||||||
|
(defun org-R-off-the-shelf-code (options)
|
||||||
|
"Return R code implementing the actions requested in the
|
||||||
|
#+R: lines."
|
||||||
|
|
||||||
|
;; This is a somewhat long function as it deals with several
|
||||||
|
;; different cases, corresponding to all the off-the-shelf actions
|
||||||
|
;; that have been implemented.
|
||||||
|
|
||||||
|
(let* ((action (plist-get options :action))
|
||||||
|
(cols (plist-get options :columns))
|
||||||
|
(ncols (org-R-number-of-columns cols))
|
||||||
|
(nxcols (nth 0 ncols))
|
||||||
|
(nycols (nth 1 ncols))
|
||||||
|
(cols-R (org-R-make-index-vectors cols))
|
||||||
|
(xcols-R (nth 0 cols-R))
|
||||||
|
(ycols-R (nth 1 cols-R))
|
||||||
|
seq args largs extra-code title colour matrix-index)
|
||||||
|
|
||||||
|
;; I want this to affect options outside this function. Will it
|
||||||
|
;; necessarily do so? (not if plist-put adds to head of the
|
||||||
|
;; plist?)
|
||||||
|
(setq options (plist-put options :nxcols nxcols))
|
||||||
|
|
||||||
|
(cond ((eq action 'points)
|
||||||
|
(setq action 'plot)
|
||||||
|
(setq options (plist-put options :lines nil)))
|
||||||
|
((eq action 'lines)
|
||||||
|
(setq action 'plot)
|
||||||
|
(setq options (plist-put options :lines t))))
|
||||||
|
|
||||||
|
(if (and (setq title (plist-get options :title)) (symbolp title))
|
||||||
|
(setq title symbol-name title))
|
||||||
|
|
||||||
|
(setq args (plist-put args :main (concat "\"" title "\"")))
|
||||||
|
|
||||||
|
(if (setq colour (or (plist-get options :colour)
|
||||||
|
(plist-get options :color)
|
||||||
|
(plist-get options :col)))
|
||||||
|
(setq args
|
||||||
|
(plist-put args :col
|
||||||
|
(concat "\"" (if (symbolp colour) (symbol-name colour) colour) "\""))))
|
||||||
|
|
||||||
|
(setq largs
|
||||||
|
(if (setq legend (plist-get options :legend))
|
||||||
|
(plist-put largs :x
|
||||||
|
(concat "\"" (if (symbolp legend) (symbol-name legend) legend) "\""))
|
||||||
|
(plist-put largs :x "\"topright\"")))
|
||||||
|
|
||||||
|
(cond
|
||||||
|
((null ycols-R)
|
||||||
|
;; single set of columns; implicit x values
|
||||||
|
(if (null xcols-R)
|
||||||
|
(setq xcols-R "" matrix-index "")
|
||||||
|
(setq matrix-index (concat "," xcols-R)))
|
||||||
|
(cond
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
((eq action 'barplot)
|
||||||
|
(if (eq nxcols 1)
|
||||||
|
(progn
|
||||||
|
(setq args (plist-put args :names.arg "rownames(x)"))
|
||||||
|
(setq args (org-R-set-user-supplied-args args (plist-get options :args)))
|
||||||
|
(format org-R-skeleton-funcall-1-arg
|
||||||
|
"barplot" xcols-R
|
||||||
|
(concat ", " (org-R-plist-to-R-args args))))
|
||||||
|
|
||||||
|
(setq args (plist-put args :names.arg "colnames(x)"))
|
||||||
|
(setq args (plist-put args :col "seq(nrow(x))"))
|
||||||
|
(setq args (plist-put args :beside "TRUE"))
|
||||||
|
|
||||||
|
(setq largs (plist-put largs :bty "\"n\""))
|
||||||
|
;; (setq largs (plist-put largs :lwd 10))
|
||||||
|
(setq largs (plist-put largs :col "seq(nrow(x))"))
|
||||||
|
(setq largs (plist-put largs :legend "rownames(x)"))
|
||||||
|
|
||||||
|
(setq args (org-R-set-user-supplied-args args (plist-get options :args)))
|
||||||
|
|
||||||
|
(concat (format org-R-skeleton-funcall-1-arg
|
||||||
|
"barplot(as.matrix" matrix-index
|
||||||
|
(concat "), " (org-R-plist-to-R-args args)))
|
||||||
|
"; legend(" (org-R-plist-to-R-args largs) ")")))
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
((eq action 'density)
|
||||||
|
(if (and nxcols (> nxcols 1))
|
||||||
|
(error "Multiple columns not implemented for action:%s" action))
|
||||||
|
|
||||||
|
(setq args (plist-put args :xlab (concat "colnames(x)["xcols-R"]")))
|
||||||
|
(setq args (org-R-set-user-supplied-args args (plist-get options :args)))
|
||||||
|
|
||||||
|
(format org-R-skeleton-funcall-1-arg
|
||||||
|
"plot(density" matrix-index
|
||||||
|
(concat "), " (org-R-plist-to-R-args args))))
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
((eq action 'hist)
|
||||||
|
(if (and nxcols (> nxcols 1))
|
||||||
|
(error "Multiple columns not implemented for action:%s" action))
|
||||||
|
(setq args (plist-put args :xlab (concat "colnames(x)["xcols-R"]")))
|
||||||
|
(setq args (org-R-set-user-supplied-args args (plist-get options :args)))
|
||||||
|
(setq args (concat ", " (org-R-plist-to-R-args args)))
|
||||||
|
(format org-R-skeleton-funcall-1-arg "hist" matrix-index args))
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
((eq action 'image)
|
||||||
|
(format org-R-skeleton-funcall-1-arg "image(as.matrix" matrix-index ")"))
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
((eq action 'plot)
|
||||||
|
(setq seq (concat "seq_along("xcols-R")"))
|
||||||
|
|
||||||
|
(setq args (plist-put args :type (if (plist-get options :lines) "\"l\"" "\"p\"")))
|
||||||
|
(setq args (plist-put args :ylab (concat "colnames(x)["xcols-R"]")))
|
||||||
|
(setq args (concat ", " (org-R-plist-to-R-args args)))
|
||||||
|
|
||||||
|
(concat (format org-R-skeleton-funcall-1-arg
|
||||||
|
(if (eq nxcols 1) "plot" "matplot") matrix-index args)
|
||||||
|
extra-code))
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
((eq action 'tabulate)
|
||||||
|
(concat
|
||||||
|
(if (plist-get options :sort)
|
||||||
|
(format org-R-skeleton-funcall-1-arg
|
||||||
|
"x <- sort(table" xcols-R "), decreasing=TRUE")
|
||||||
|
(format org-R-skeleton-funcall-1-arg "x <- table" matrix-index ""))
|
||||||
|
(if (eq nxcols 1) "; x <- data.frame(value=names(x), count=x[])")))
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
((eq action 'transpose)
|
||||||
|
(format org-R-skeleton-funcall-1-arg "x <- t" matrix-index ""))
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
;; Don't recognise action: option, try applying it as the name of an R function.
|
||||||
|
|
||||||
|
(t (format org-R-skeleton-funcall-1-arg
|
||||||
|
(concat "x <- " (symbol-name action)) matrix-index ""))))
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
(ycols-R
|
||||||
|
;; x and y columns specified
|
||||||
|
(cond
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
((eq action 'plot)
|
||||||
|
(unless (eq nxcols 1) (error "Multiple x-columns not implemented for action:plot"))
|
||||||
|
|
||||||
|
(setq args
|
||||||
|
(plist-put
|
||||||
|
args :ylab
|
||||||
|
(concat "if(length("ycols-R") == 1) colnames(x)["ycols-R"] else ''")))
|
||||||
|
(setq args (plist-put args :xlab (concat "colnames(x)["xcols-R"]")))
|
||||||
|
|
||||||
|
(setq args (plist-put args :type (if (plist-get options :lines) "\"l\"" "\"p\"")))
|
||||||
|
|
||||||
|
(setq args (concat ", " (org-R-plist-to-R-args args)))
|
||||||
|
(setq seq (concat "seq_along("ycols-R")"))
|
||||||
|
|
||||||
|
(setq largs (plist-put largs :col seq))
|
||||||
|
(setq largs (plist-put largs :lty seq))
|
||||||
|
(setq largs (plist-put largs :bty "\"n\""))
|
||||||
|
(setq largs (plist-put largs :legend (concat "colnames(x)["ycols-R"]")))
|
||||||
|
|
||||||
|
(setq extra-code
|
||||||
|
(concat "; "
|
||||||
|
"if(length("ycols-R") > 1) "
|
||||||
|
"legend(" (org-R-plist-to-R-args largs) ")"))
|
||||||
|
|
||||||
|
(concat (format org-R-skeleton-funcall-2-args
|
||||||
|
(if (and (eq nxcols 1) (eq nycols 1)) "plot" "matplot")
|
||||||
|
xcols-R ycols-R args)
|
||||||
|
extra-code))
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
|
||||||
|
(t (error "action:%s requires a single set of columns" (symbol-name action))))))))
|
||||||
|
|
||||||
|
(defun org-R-set-user-supplied-args (args user-args)
|
||||||
|
"Set user-supplied values in arguments plist."
|
||||||
|
(while (setq prop (pop user-args))
|
||||||
|
(setq args (plist-put args prop (pop user-args))))
|
||||||
|
args)
|
||||||
|
|
||||||
|
(defun org-R-plist-to-R-args (plist)
|
||||||
|
"Convert a plist into a string of R arguments."
|
||||||
|
(let (arg-string arg)
|
||||||
|
(while (setq arg (pop plist))
|
||||||
|
(string-match ":\\(\.*\\)" (symbol-name arg))
|
||||||
|
(setq arg (match-string 1 (symbol-name arg)))
|
||||||
|
(setq arg-string
|
||||||
|
(concat
|
||||||
|
(if arg-string (concat arg-string ", "))
|
||||||
|
(format "%s=%s" arg (pop plist)))))
|
||||||
|
arg-string))
|
||||||
|
|
||||||
|
(defun org-R-alist-to-R-args (alist)
|
||||||
|
"Convert an alist of (argument . val) pairs into a string of R arguments.
|
||||||
|
The alist is something like
|
||||||
|
'((arg1 . 1)
|
||||||
|
(arg2 . a))
|
||||||
|
This isn't used, but it seems much nicer than
|
||||||
|
my plist equivalent. Is there a better way to write the plist
|
||||||
|
version?
|
||||||
|
"
|
||||||
|
(mapconcat
|
||||||
|
'identity
|
||||||
|
(mapcar (lambda(pair) (format "%s = %s" (car pair) (cdr pair))) alist)
|
||||||
|
", "))
|
||||||
|
|
||||||
|
(defun org-R-make-index-vectors (cols)
|
||||||
|
"COLS is the lisp form given by the `columns:' option. It may
|
||||||
|
take the following forms:
|
||||||
|
|
||||||
|
1. integer atom - the number of the column
|
||||||
|
2. symbol/string atom - the name of the column
|
||||||
|
3. list of length 1 - same as 1 or 2 above
|
||||||
|
4. list of length > 1 - specification of multiple columns as 1 or 2 above, unless it is
|
||||||
|
5. list of 2 lists - each list specifies (possibly multiple) columns
|
||||||
|
|
||||||
|
In cases 1-4 this function returns a list of length 1, containing
|
||||||
|
the R index vector as a string. In case 5 this function returns a
|
||||||
|
list of two such index vectors.
|
||||||
|
|
||||||
|
In cases 1 - 4, when a bivariate plot is requested such as by
|
||||||
|
`action:lines', the x values are implicit, i.e
|
||||||
|
1,2,...,number-of-rows.
|
||||||
|
|
||||||
|
In case 4, an attempt is made to do something sensible with the
|
||||||
|
multiple columns, e.g. for `action:lines' they will be plotted
|
||||||
|
together on the same graph against the implicit x values, and for
|
||||||
|
`action:barplot' the bars corresponding to a single row will be
|
||||||
|
stacked on top of each other, or placed side by side, depending
|
||||||
|
on the value of the `beside' option.
|
||||||
|
|
||||||
|
For `action:tabulate', if 2 columns are selected, a
|
||||||
|
two-dimensional table is created. If more than 2, then the
|
||||||
|
appropriately dimensioned table is computed and inserted using
|
||||||
|
the standard text representation of multi-dimensional arrays used
|
||||||
|
by R (as org does not currently have tables of dimension > 2).
|
||||||
|
|
||||||
|
The straightforward case of case 5 is that both lists are of
|
||||||
|
length 1. For `action:plot' and `action:lines' these specify the
|
||||||
|
y and x coordinates of the points to be plotted or joined by
|
||||||
|
lines.
|
||||||
|
|
||||||
|
The intention is that `org-R-apply' does something
|
||||||
|
corresponding to what would happen if you did the following in R:
|
||||||
|
|
||||||
|
fun(x=tab[,xcols], y=tab[,ycols])
|
||||||
|
|
||||||
|
where fun is the R function implementing the desired
|
||||||
|
action (plotting/computation), tab is the org table, xcols are
|
||||||
|
the columns specified in cases 1-4 above, and ycols are the
|
||||||
|
second set of columns which might have been specified under case
|
||||||
|
5 above. For relevant R documentation see the help page
|
||||||
|
associated with the function xy.coords, e.g. by typing ?xy.coords
|
||||||
|
at the R prompt.
|
||||||
|
|
||||||
|
The following won't work with case 5: `tabulate'
|
||||||
|
"
|
||||||
|
(defun org-R-make-index-vector (cols)
|
||||||
|
"Return the R indexing vector (as a string) corresponding to
|
||||||
|
the lisp form COLS. In this function, COLS is a either a list of
|
||||||
|
atoms, or an atom, i.e. in the form of cases 1-4"
|
||||||
|
(when cols
|
||||||
|
(let (to-stringf)
|
||||||
|
(unless (listp cols) (setq cols (list cols)))
|
||||||
|
(setq to-stringf
|
||||||
|
(cond ((car (mapcar 'symbolp cols))
|
||||||
|
(lambda (symbol) (concat "\"" (symbol-name symbol) "\"")))
|
||||||
|
((car (mapcar 'integerp cols))
|
||||||
|
'int-to-string)
|
||||||
|
((car (mapcar 'stringp cols))
|
||||||
|
(lambda (string) (concat "\"" string "\"")))
|
||||||
|
(t (error "Column selection should be symbol, integer or string: %S" cols))))
|
||||||
|
(concat (when (> (length cols) 1) "c(")
|
||||||
|
(mapconcat to-stringf cols ",")
|
||||||
|
(when (> (length cols) 1) ")")))))
|
||||||
|
|
||||||
|
(if (and (listp cols) (listp (car cols)))
|
||||||
|
(mapcar 'org-R-make-index-vector cols) ;; case 5
|
||||||
|
(list (org-R-make-index-vector cols)))) ;; other cases
|
||||||
|
|
||||||
|
(defun org-R-number-of-columns (cols)
|
||||||
|
(defun f (c) (if (listp c) (length c) 1))
|
||||||
|
(if (and (listp cols) (listp (car cols)))
|
||||||
|
(mapcar 'f cols)
|
||||||
|
(list (f cols))))
|
||||||
|
|
||||||
|
(defun org-R-eval (R-function csv-file options)
|
||||||
|
"Apply an R function to tabular data and receive output as an org table.
|
||||||
|
|
||||||
|
R-FUNCTION is a string; it may be simply the name of an
|
||||||
|
appropriate R function (e.g. \"summary\", \"plot\"), or a
|
||||||
|
user-defined anonymous function of the form
|
||||||
|
\"(function(data.frame) {...})\". It will receive as its first
|
||||||
|
argument the org table as an R 'data frame' -- a table-like
|
||||||
|
structure which can have columns containing different types of
|
||||||
|
data -- numeric, character etc.
|
||||||
|
|
||||||
|
The R function may produce graphical and/or text output. If it
|
||||||
|
produces text output, and the replace:t is specified, and if
|
||||||
|
there is a table immediately above the #+R lines, then it is
|
||||||
|
replaced by the text output. Otherwise the text output is
|
||||||
|
inserted above the #+R lines.
|
||||||
|
"
|
||||||
|
(let ((transit-buffer "org-R-transit")
|
||||||
|
(infile (plist-get options :infile))
|
||||||
|
(output-file (plist-get options :outfile))
|
||||||
|
(title (plist-get options :title))
|
||||||
|
output-format graphics-output-file width height)
|
||||||
|
|
||||||
|
(unless (not output-file)
|
||||||
|
;; We are writing output to file. Determine file format and
|
||||||
|
;; location, and open graphics device if necessary.
|
||||||
|
(if (string-match
|
||||||
|
"\\(.*\.\\)?\\(org\\|png\\|jpg\\|jpeg\\|pdf\\|ps\\|bmp\\|tiff\\)$"
|
||||||
|
output-file)
|
||||||
|
(setq output-format (match-string 2 output-file))
|
||||||
|
(error "Did not recognise file name suffix %s as available output format"
|
||||||
|
(match-string 2 output-file)))
|
||||||
|
(unless (match-string 1 output-file)
|
||||||
|
;; only suffix provided: store in org-attach dir
|
||||||
|
(require 'org-attach)
|
||||||
|
(let ((temporary-file-directory (org-attach-dir t)))
|
||||||
|
(setq output-file
|
||||||
|
(make-temp-file
|
||||||
|
"org-R-output-" nil (concat "." output-format)))))
|
||||||
|
(if (eq output-format "jpg") (setq output-format "jpeg"))
|
||||||
|
(setq graphics-output-file (not (string-equal output-format "org")))
|
||||||
|
(if graphics-output-file ;; open the graphics device
|
||||||
|
(ess-execute
|
||||||
|
(concat output-format "(file=\"" output-file "\""
|
||||||
|
(if (setq width (plist-get options :width))
|
||||||
|
(format ", width=%d" width))
|
||||||
|
(if (setq height (plist-get options :height))
|
||||||
|
(format ", height=%d" height)) ")"))))
|
||||||
|
|
||||||
|
;; Apply R code to table (which is now stored as a csv file)
|
||||||
|
;; does it matter whether this uses ess-command or ess-execute?
|
||||||
|
|
||||||
|
;; First evaluate function definition for R -> org table conversion
|
||||||
|
(ess-execute (replace-regexp-in-string "\n" " " org-R-write-org-table-def)
|
||||||
|
nil transit-buffer)
|
||||||
|
|
||||||
|
;; FIXME: why not eval the function def together with the function call
|
||||||
|
;; as in the commented out line below (it didn't work for some reason)
|
||||||
|
(ess-execute
|
||||||
|
(concat
|
||||||
|
;; (replace-regexp-in-string "\n" " " org-R-write-org-table-def) ";"
|
||||||
|
(org-R-make-expr R-function csv-file options)) nil transit-buffer)
|
||||||
|
|
||||||
|
(save-excursion
|
||||||
|
(set-buffer (concat "*" transit-buffer "*"))
|
||||||
|
(unless (or (looking-at "$")
|
||||||
|
(string-equal (buffer-substring-no-properties 1 2) "|"))
|
||||||
|
(error "Error in R evaluation:\n%s" (buffer-string))))
|
||||||
|
|
||||||
|
|
||||||
|
(if csv-file
|
||||||
|
(unless (and infile
|
||||||
|
(string-equal (file-name-extension infile) "csv"))
|
||||||
|
(delete-file csv-file)))
|
||||||
|
|
||||||
|
(if graphics-output-file (ess-execute "dev.off()")) ;; Close graphics device
|
||||||
|
|
||||||
|
(unless (or graphics-output-file
|
||||||
|
(not (plist-get options :output-to-buffer)))
|
||||||
|
;; Send tabular output to a org buffer as new org
|
||||||
|
;; table. Recall that we are currently at the beginning of the
|
||||||
|
;; first #+R line
|
||||||
|
(if (and output-file graphics-output-file)
|
||||||
|
(error "output-to-buffer and graphics-output-file both t"))
|
||||||
|
|
||||||
|
(save-excursion
|
||||||
|
(if output-file
|
||||||
|
(progn (set-buffer (find-file-noselect output-file))
|
||||||
|
(delete-region (point-min) (point-max)))
|
||||||
|
(if (plist-get options :replace)
|
||||||
|
(progn ;; kill a table iff in one or one ends on the previous line
|
||||||
|
(delete-region (org-table-begin) (org-table-end))
|
||||||
|
(save-excursion
|
||||||
|
(forward-line -1)
|
||||||
|
(if (looking-at "#\\+TBLNAME")
|
||||||
|
(delete-region (point) (1+ (point-at-eol))))))))
|
||||||
|
(if title (insert "#+TBLNAME:" title "\n"))
|
||||||
|
(insert-buffer-substring (concat "*" transit-buffer "*"))
|
||||||
|
(org-table-align)
|
||||||
|
(if output-file (save-buffer))))
|
||||||
|
|
||||||
|
;; We might be linking to graphical output, or to org output in
|
||||||
|
;; another file. Either way, point is still at the beginning of
|
||||||
|
;; the first #+R line.
|
||||||
|
(unless (not output-file)
|
||||||
|
(save-excursion
|
||||||
|
(forward-line -1)
|
||||||
|
(if (looking-at "\\[\\[file:")
|
||||||
|
(delete-region (point) (1+ (point-at-eol)))))
|
||||||
|
(insert (org-make-link-string
|
||||||
|
(concat "file:" output-file)
|
||||||
|
(unless (plist-get options :inline)
|
||||||
|
(or title (concat output-format " output")))) "\n"))
|
||||||
|
|
||||||
|
(kill-buffer (concat "*" transit-buffer "*"))))
|
||||||
|
|
||||||
|
|
||||||
|
(defun org-R-export-to-csv (csv-file options)
|
||||||
|
"Find and export org table to csv.
|
||||||
|
|
||||||
|
If the intable: option has not been supplied, then the table must
|
||||||
|
end on the line immediately above the #+R lines. Otherwise,
|
||||||
|
the remote table referenced by the intable: option is found using
|
||||||
|
org-R-find-table. If options:infile has been set then this is the
|
||||||
|
org file containing the table. See the docstring of
|
||||||
|
org-R-find-table for details."
|
||||||
|
(let ((tbl-name-or-id (plist-get options :intable))
|
||||||
|
(org-file (plist-get options :infile)) tbl-marker)
|
||||||
|
|
||||||
|
(if (and org-file
|
||||||
|
(not (string-equal (file-name-extension org-file) "org")))
|
||||||
|
(error "File %s extension is not .csv so should be .org"))
|
||||||
|
|
||||||
|
(save-excursion
|
||||||
|
(if tbl-name-or-id
|
||||||
|
;; a remote table has been specified -- move into it
|
||||||
|
(progn
|
||||||
|
(if org-file (set-buffer (find-file-noselect org-file)))
|
||||||
|
(setq tbl-marker (org-R-find-table tbl-name-or-id 'marker))
|
||||||
|
(set-buffer (marker-buffer tbl-marker))
|
||||||
|
(goto-char (marker-position tbl-marker)))
|
||||||
|
(forward-line -1)) ;; move into table above
|
||||||
|
(if (looking-at "[ \t]*|")
|
||||||
|
(progn (org-table-export csv-file "orgtbl-to-csv") csv-file)
|
||||||
|
nil))))
|
||||||
|
|
||||||
|
(defun org-R-find-table (name-or-id &optional markerp)
|
||||||
|
"Return location of a table.
|
||||||
|
|
||||||
|
NAME-OR-ID may be the name of a
|
||||||
|
table in the current file as set by a \"#+TBLNAME:\" directive.
|
||||||
|
The first table following this line will then be used.
|
||||||
|
Alternatively, it may be an ID referring to any entry, perhaps in
|
||||||
|
a different file. In this case, the first table in that entry
|
||||||
|
will be referenced. The location is returned as a marker pointing
|
||||||
|
to the beginning of the first line of the table.
|
||||||
|
|
||||||
|
This is taken from the first part of org-table-get-remote-range
|
||||||
|
in org-table.el.
|
||||||
|
"
|
||||||
|
(cond
|
||||||
|
((symbolp name-or-id) (setq name-or-id (symbol-name name-or-id)))
|
||||||
|
((numberp name-or-id) (setq name-or-id (number-to-string name-or-id))))
|
||||||
|
(save-match-data
|
||||||
|
(let ((id-loc nil) (case-fold-search t) buffer loc)
|
||||||
|
(save-excursion
|
||||||
|
(save-restriction
|
||||||
|
(widen)
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (point-min))
|
||||||
|
(if (re-search-forward
|
||||||
|
(concat "^#\\+TBLNAME:[ \t]*" (regexp-quote name-or-id) "[ \t]*$")
|
||||||
|
nil t)
|
||||||
|
;; OK, we've found a matching table name in this buffer.
|
||||||
|
(setq buffer (current-buffer) loc (match-beginning 0))
|
||||||
|
;; It's not a table name in this buffer. It must be an entry id.
|
||||||
|
;; obtain a marker pointing to it.
|
||||||
|
(setq id-loc (org-id-find name-or-id 'marker)
|
||||||
|
buffer (marker-buffer id-loc)
|
||||||
|
loc (marker-position id-loc))
|
||||||
|
(move-marker id-loc nil))) ;; disable the marker
|
||||||
|
;; (switch-to-buffer buffer)
|
||||||
|
(set-buffer buffer)
|
||||||
|
;; OK, so now we're in the right buffer, and loc is either
|
||||||
|
;; the beginning of the #+TBLNAME line, or the location of the entry
|
||||||
|
;; either way we need to search forward to get to the beginning of the table
|
||||||
|
(save-excursion
|
||||||
|
(save-restriction
|
||||||
|
(widen)
|
||||||
|
(goto-char loc)
|
||||||
|
(forward-char 1)
|
||||||
|
;; The following regexp search finds the beginning of
|
||||||
|
;; the next table in this entry. If it gets to the next
|
||||||
|
;; entry before the next table, then it signals failure.
|
||||||
|
(unless (and (re-search-forward "^\\(\\*+ \\)\\|[ \t]*|" nil t)
|
||||||
|
(not (match-beginning 1)))
|
||||||
|
(error "Cannot find a table at NAME or ID %s" name-or-id))
|
||||||
|
(if markerp
|
||||||
|
(move-marker (make-marker) (point-at-bol) (current-buffer))
|
||||||
|
(error "Option to return cons cell not implemented.
|
||||||
|
It should return (file-name . position) to be
|
||||||
|
consistent with functions in org-id.el")))))))))
|
||||||
|
|
||||||
|
(defun org-R-make-expr (R-function csv-file options)
|
||||||
|
"Construct R code to read data, analyse it and write output."
|
||||||
|
|
||||||
|
(let ((rownames (plist-get options :rownames))
|
||||||
|
(colnames (plist-get options :colnames))
|
||||||
|
(action (plist-get options :action))
|
||||||
|
(replace (plist-get options :replace)))
|
||||||
|
|
||||||
|
(if (and csv-file (symbolp csv-file))
|
||||||
|
(setq csv-file (symbol-name csv-file)))
|
||||||
|
|
||||||
|
(format "write.org.table((%s)(%s), write.rownames=%s)"
|
||||||
|
R-function
|
||||||
|
(if csv-file
|
||||||
|
(format
|
||||||
|
"read.csv(\"%s\", header=%s, row.names=%s)"
|
||||||
|
csv-file
|
||||||
|
|
||||||
|
;; Do we treat first row as colnames? Yes by default
|
||||||
|
;; FIXME: should really check for hline
|
||||||
|
(if colnames "TRUE" "FALSE")
|
||||||
|
|
||||||
|
;; Do we use a column as rownames? Not unless rownames: is specified
|
||||||
|
(if rownames "1" "NULL"))
|
||||||
|
"NULL")
|
||||||
|
|
||||||
|
;; Do we write rownames into org table?
|
||||||
|
(cond ((eq action 'tabulate)
|
||||||
|
(if (eq (plist-get options :nxcols) 1) "FALSE" "TRUE"))
|
||||||
|
((eq action 'transpose) (if colnames "TRUE" "FALSE"))
|
||||||
|
(rownames "TRUE")
|
||||||
|
(t "TRUE")))))
|
||||||
|
|
||||||
|
(defun org-R-get-options ()
|
||||||
|
"Parse the #+R: lines and return the options and values as a p-list."
|
||||||
|
(let ((opts '(
|
||||||
|
(:infile . "infile")
|
||||||
|
(:intable . "intable")
|
||||||
|
(:rownames . "rownames")
|
||||||
|
(:colnames . "colnames")
|
||||||
|
(:columns . "columns")
|
||||||
|
|
||||||
|
(:action . "action")
|
||||||
|
(:args . "args")
|
||||||
|
|
||||||
|
(:outfile . "outfile")
|
||||||
|
(:replace . "replace")
|
||||||
|
(:title . "title")
|
||||||
|
(:legend . "legend")
|
||||||
|
(:colour . "colour")
|
||||||
|
(:color . "color")
|
||||||
|
(:col . "col")
|
||||||
|
(:height . "height")
|
||||||
|
(:width . "width")
|
||||||
|
(:lines . "lines")
|
||||||
|
(:sort . "sort")
|
||||||
|
(:inline . "inline")
|
||||||
|
|
||||||
|
(:output-to-buffer . "output-to-buffer")
|
||||||
|
|
||||||
|
(:showcode . "showcode")))
|
||||||
|
(regexp ":\\(\"[^\"]*\"\\|(([^)]*) *([^)]*))\\|([^)]*)\\|[^ \t\n\r;,.]*\\)")
|
||||||
|
(case-fold-search t) p)
|
||||||
|
|
||||||
|
;; FIXME: set default options properly
|
||||||
|
(setq p (plist-put p :output-to-buffer t)) ;; FIXME: hack: null options plist is bad news
|
||||||
|
(setq p (plist-put p :replace t))
|
||||||
|
(setq p (plist-put p :rownames nil))
|
||||||
|
(setq p (plist-put p :colnames t))
|
||||||
|
(setq p (plist-put p :inline nil))
|
||||||
|
|
||||||
|
(save-excursion
|
||||||
|
(while (looking-at "^#\\+\\(RR?:+\\) *\\(.*\\)")
|
||||||
|
(if (string= "R:" (match-string 1))
|
||||||
|
(setq p (org-R-add-options-to-plist p (match-string 2) opts regexp)))
|
||||||
|
(forward-line)))
|
||||||
|
p))
|
||||||
|
|
||||||
|
(defun org-R-add-options-to-plist (p opt-string op regexp)
|
||||||
|
"Parse a #+R: line and set values in the property list
|
||||||
|
p. This function is adapted from similar functions in org-exp.el
|
||||||
|
and org-plot.el. It might be a good idea to have a single
|
||||||
|
function serving these three files' needs."
|
||||||
|
;; Adapted from org-exp.el and org-plot.el
|
||||||
|
(let (o)
|
||||||
|
(when opt-string
|
||||||
|
(while (setq o (pop op))
|
||||||
|
(if (string-match
|
||||||
|
(concat (regexp-quote (cdr o)) regexp)
|
||||||
|
opt-string)
|
||||||
|
(setq p (plist-put p (car o)
|
||||||
|
(car (read-from-string
|
||||||
|
(match-string 1 opt-string)))))))))
|
||||||
|
p)
|
||||||
|
|
||||||
|
|
||||||
|
(defun org-R-sanitise-options (options)
|
||||||
|
(error "not used yet")
|
||||||
|
(let (should-be-strings '(title legend colour color col csv)))
|
||||||
|
)
|
||||||
|
(defun org-R-showcode (R)
|
||||||
|
"Display R function constructed by org-R in a new R-mode
|
||||||
|
buffer"
|
||||||
|
(split-window-vertically)
|
||||||
|
(switch-to-buffer "*org-table.R*")
|
||||||
|
(kill-region (point-min) (point-max))
|
||||||
|
(R-mode)
|
||||||
|
(insert (replace-regexp-in-string
|
||||||
|
";" "\n" (replace-regexp-in-string "\\([{}]\\)" "\n\\1\n" R)))
|
||||||
|
;; (mark-whole-buffer)
|
||||||
|
;; (indent-region)
|
||||||
|
;; why doesn't that do what I hoped?
|
||||||
|
)
|
||||||
|
|
||||||
|
(defun org-R-get-remote-range (name-or-id form)
|
||||||
|
"This is a refactoring of Carsten's original version. I have
|
||||||
|
extracted the first bit of his function and named it
|
||||||
|
org-R-find-table (which would presumably be called
|
||||||
|
something like org-table-find-table or org-id-find-table if this
|
||||||
|
were accepted).
|
||||||
|
|
||||||
|
Get a field value or a list of values in a range from table at ID.
|
||||||
|
|
||||||
|
NAME-OR-ID may be the name of a table in the current file as set by
|
||||||
|
a \"#+TBLNAME:\" directive. The first table following this line
|
||||||
|
will then be used. Alternatively, it may be an ID referring to
|
||||||
|
any entry, possibly in a different file. In this case, the first table
|
||||||
|
in that entry will be referenced.
|
||||||
|
FORM is a field or range descriptor like \"@2$3\" or or \"B3\" or
|
||||||
|
\"@I$2..@II$2\". All the references must be absolute, not relative.
|
||||||
|
|
||||||
|
The return value is either a single string for a single field, or a
|
||||||
|
list of the fields in the rectangle."
|
||||||
|
|
||||||
|
(let ((tbl-marker (org-R-find-table name-or-id 'marker))
|
||||||
|
org-table-column-names org-table-column-name-regexp
|
||||||
|
org-table-local-parameters org-table-named-field-locations
|
||||||
|
org-table-current-line-types org-table-current-begin-line
|
||||||
|
org-table-current-begin-pos org-table-dlines
|
||||||
|
org-table-hlines org-table-last-alignment
|
||||||
|
org-table-last-column-widths org-table-last-alignment
|
||||||
|
org-table-last-column-widths tbeg)
|
||||||
|
|
||||||
|
(save-excursion
|
||||||
|
(set-buffer (marker-buffer tbl-marker))
|
||||||
|
(goto-char (marker-position tbl-marker))
|
||||||
|
(org-table-get-specials)
|
||||||
|
(setq form (org-table-formula-substitute-names form))
|
||||||
|
(if (and (string-match org-table-range-regexp form)
|
||||||
|
(> (length (match-string 0 form)) 1))
|
||||||
|
(save-match-data
|
||||||
|
(org-table-get-range (match-string 0 form) (point) 1))
|
||||||
|
form))))
|
||||||
|
|
||||||
|
(provide 'org-R)
|
||||||
|
|
@ -0,0 +1,380 @@
|
||||||
|
;;; org-exp-blocks.el --- pre-process blocks when exporting org files
|
||||||
|
|
||||||
|
;; Copyright (C) 2008 Eric Schulte
|
||||||
|
|
||||||
|
;; Author: Eric Schulte
|
||||||
|
|
||||||
|
;; This file is not currently part of GNU Emacs.
|
||||||
|
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or (at
|
||||||
|
;; your option) any later version.
|
||||||
|
|
||||||
|
;; This program is distributed in the hope that it will be useful, but
|
||||||
|
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this program ; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||||
|
;; Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;;
|
||||||
|
;; This is a utility for pre-processing blocks in org files before
|
||||||
|
;; export using the `org-export-preprocess-hook'. It can be used for
|
||||||
|
;; exporting new types of blocks from org-mode files and also for
|
||||||
|
;; changing the default export behavior of existing org-mode blocks.
|
||||||
|
;; The `org-export-blocks' and `org-export-interblocks' alist can be
|
||||||
|
;; used to control how blocks and the spaces between blocks
|
||||||
|
;; respectively are processed upon export.
|
||||||
|
;;
|
||||||
|
;; The type of a block is defined as the string following =#+begin_=,
|
||||||
|
;; so for example the following block would be of type ditaa. Note
|
||||||
|
;; that both upper or lower case are allowed in =#+BEGIN_= and
|
||||||
|
;; =#+END_=.
|
||||||
|
;;
|
||||||
|
;; #+begin_ditaa blue.png -r -S
|
||||||
|
;; +---------+
|
||||||
|
;; | cBLU |
|
||||||
|
;; | |
|
||||||
|
;; | +----+
|
||||||
|
;; | |cPNK|
|
||||||
|
;; | | |
|
||||||
|
;; +----+----+
|
||||||
|
;; #+end_ditaa
|
||||||
|
;;
|
||||||
|
;;; Currently Implemented Block Types
|
||||||
|
;;
|
||||||
|
;; ditaa :: Convert ascii pictures to actual images using ditaa
|
||||||
|
;; http://ditaa.sourceforge.net/. To use this set
|
||||||
|
;; `org-ditaa-jar-path' to the path to ditaa.jar on your
|
||||||
|
;; system (should be set automatically in most cases) .
|
||||||
|
;;
|
||||||
|
;; dot :: Convert graphs defined using the dot graphing language to
|
||||||
|
;; images using the dot utility. For information on dot see
|
||||||
|
;; http://www.graphviz.org/
|
||||||
|
;;
|
||||||
|
;; comment :: Wrap comments with titles and author information, in
|
||||||
|
;; their own divs with author-specific ids allowing for css
|
||||||
|
;; coloring of comments based on the author.
|
||||||
|
;;
|
||||||
|
;; R :: Implements Sweave type exporting, evaluates blocks of R code,
|
||||||
|
;; and also replaces \R{} chunks in the file with their result
|
||||||
|
;; when passed to R. This require the `R' command which is
|
||||||
|
;; provided by ESS (Emacs Speaks Statistics).
|
||||||
|
|
||||||
|
(defcustom org-export-blocks
|
||||||
|
'((comment org-export-blocks-format-comment)
|
||||||
|
(ditaa org-export-blocks-format-ditaa)
|
||||||
|
(dot org-export-blocks-format-dot)
|
||||||
|
(r org-export-blocks-format-R)
|
||||||
|
(R org-export-blocks-format-R))
|
||||||
|
"Use this a-list to associate block types with block exporting
|
||||||
|
functions. The type of a block is determined by the text
|
||||||
|
immediately following the '#+BEGIN_' portion of the block header.
|
||||||
|
Each block export function should accept three argumets..."
|
||||||
|
:group 'org-export-general
|
||||||
|
:type 'alist)
|
||||||
|
|
||||||
|
(defcustom org-export-interblocks
|
||||||
|
'((r org-export-interblocks-format-R)
|
||||||
|
(R org-export-interblocks-format-R))
|
||||||
|
"Use this a-list to associate block types with block exporting
|
||||||
|
functions. The type of a block is determined by the text
|
||||||
|
immediately following the '#+BEGIN_' portion of the block header.
|
||||||
|
Each block export function should accept three argumets..."
|
||||||
|
:group 'org-export-general
|
||||||
|
:type 'alist)
|
||||||
|
|
||||||
|
(defcustom org-export-blocks-witheld
|
||||||
|
'(hidden)
|
||||||
|
"List of block types (see `org-export-blocks') which should not
|
||||||
|
be exported."
|
||||||
|
:group 'org-export-general
|
||||||
|
:type 'list)
|
||||||
|
|
||||||
|
(defvar org-export-blocks-postblock-hooks nil "")
|
||||||
|
|
||||||
|
(defun org-export-blocks-html-quote (body &optional open close)
|
||||||
|
"Protext BODY from org html export. The optional OPEN and
|
||||||
|
CLOSE tags will be inserted around BODY."
|
||||||
|
(concat
|
||||||
|
"\n#+BEGIN_HTML\n"
|
||||||
|
(or open "")
|
||||||
|
body (if (string-match "\n$" body) "" "\n")
|
||||||
|
(or close "")
|
||||||
|
"#+END_HTML\n"))
|
||||||
|
|
||||||
|
(defun org-export-blocks-latex-quote (body &optional open close)
|
||||||
|
"Protext BODY from org latex export. The optional OPEN and
|
||||||
|
CLOSE tags will be inserted around BODY."
|
||||||
|
(concat
|
||||||
|
"\n#+BEGIN_LaTeX\n"
|
||||||
|
(or open "")
|
||||||
|
body (if (string-match "\n$" body) "" "\n")
|
||||||
|
(or close "")
|
||||||
|
"#+END_LaTeX\n"))
|
||||||
|
|
||||||
|
(defun org-export-blocks-preprocess ()
|
||||||
|
"Export all blocks acording to the `org-export-blocks' block
|
||||||
|
exportation alist. Does not export block types specified in
|
||||||
|
specified in BLOCKS which default to the value of
|
||||||
|
`org-export-blocks-witheld'."
|
||||||
|
(interactive)
|
||||||
|
(save-window-excursion
|
||||||
|
(let ((count 0)
|
||||||
|
(blocks org-export-blocks-witheld)
|
||||||
|
(case-fold-search t)
|
||||||
|
(types '())
|
||||||
|
type func start end)
|
||||||
|
(flet ((interblock (start end type)
|
||||||
|
(save-match-data
|
||||||
|
(when (setf func (cadr (assoc type org-export-interblocks)))
|
||||||
|
(funcall func start end)))))
|
||||||
|
(goto-char (point-min))
|
||||||
|
(setf start (point))
|
||||||
|
(while (re-search-forward
|
||||||
|
"^#\\+begin_\\(\\S-+\\)[ \t]*\\(.*\\)?[\r\n]\\([^\000]*?\\)#\\+end_\\S-*[\r\n]" nil t)
|
||||||
|
(save-match-data (setf type (intern (match-string 1))))
|
||||||
|
(unless (memq type types) (setf types (cons type types)))
|
||||||
|
(setf end (save-match-data (match-beginning 0)))
|
||||||
|
(interblock start end type)
|
||||||
|
(if (setf func (cadr (assoc type org-export-blocks)))
|
||||||
|
(replace-match (save-match-data
|
||||||
|
(if (memq type blocks)
|
||||||
|
""
|
||||||
|
(apply func (match-string 3) (split-string (match-string 2) " ")))) t t))
|
||||||
|
(setf start (save-match-data (match-end 0))))
|
||||||
|
(mapcar (lambda (type)
|
||||||
|
(interblock start (point-max) type))
|
||||||
|
types)))))
|
||||||
|
|
||||||
|
(add-hook 'org-export-preprocess-hook 'org-export-blocks-preprocess)
|
||||||
|
|
||||||
|
;;================================================================================
|
||||||
|
;; type specific functions
|
||||||
|
|
||||||
|
;;--------------------------------------------------------------------------------
|
||||||
|
;; ditaa: create images from ASCII art using the ditaa utility
|
||||||
|
(defvar org-ditaa-jar-path (expand-file-name
|
||||||
|
"ditaa.jar"
|
||||||
|
(file-name-as-directory
|
||||||
|
(expand-file-name
|
||||||
|
"scripts"
|
||||||
|
(file-name-as-directory
|
||||||
|
(expand-file-name
|
||||||
|
".."
|
||||||
|
(file-name-directory (or load-file-name buffer-file-name)))))))
|
||||||
|
"Path to the ditaa jar executable")
|
||||||
|
|
||||||
|
(defun org-export-blocks-format-ditaa (body &rest headers)
|
||||||
|
"Pass block BODY to the ditaa utility creating an image.
|
||||||
|
Specify the path at which the image should be saved as the first
|
||||||
|
element of headers, any additional elements of headers will be
|
||||||
|
passed to the ditaa utility as command line arguments."
|
||||||
|
(message "ditaa-formatting...")
|
||||||
|
(let ((out-file (if headers (car headers)))
|
||||||
|
(args (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))
|
||||||
|
(data-file (make-temp-file "org-ditaa")))
|
||||||
|
(unless (file-exists-p org-ditaa-jar-path)
|
||||||
|
(error (format "Could not find ditaa.jar at %s" org-ditaa-jar-path)))
|
||||||
|
(setq body (if (string-match "^\\([^:\\|:[^ ]\\)" body)
|
||||||
|
body
|
||||||
|
(mapconcat (lambda (x) (substring x (if (> (length x) 1) 2 1)))
|
||||||
|
(org-split-string body "\n")
|
||||||
|
"\n")))
|
||||||
|
(cond
|
||||||
|
((or htmlp latexp)
|
||||||
|
(with-temp-file data-file (insert body))
|
||||||
|
(message (concat "java -jar " org-ditaa-jar-path " " args " " data-file " " out-file))
|
||||||
|
(shell-command (concat "java -jar " org-ditaa-jar-path " " args " " data-file " " out-file))
|
||||||
|
(format "\n[[file:%s]]\n" out-file))
|
||||||
|
(t (concat
|
||||||
|
"\n#+BEGIN_EXAMPLE\n"
|
||||||
|
body (if (string-match "\n$" body) "" "\n")
|
||||||
|
"#+END_EXAMPLE\n")))))
|
||||||
|
|
||||||
|
;;--------------------------------------------------------------------------------
|
||||||
|
;; dot: create graphs using the dot graphing language
|
||||||
|
;; (require the dot executable to be in your path)
|
||||||
|
(defun org-export-blocks-format-dot (body &rest headers)
|
||||||
|
"Pass block BODY to the dot graphing utility creating an image.
|
||||||
|
Specify the path at which the image should be saved as the first
|
||||||
|
element of headers, any additional elements of headers will be
|
||||||
|
passed to the dot utility as command line arguments. Don't
|
||||||
|
forget to specify the output type for the dot command, so if you
|
||||||
|
are exporting to a file with a name like 'image.png' you should
|
||||||
|
include a '-Tpng' argument, and your block should look like the
|
||||||
|
following.
|
||||||
|
|
||||||
|
#+begin_dot models.png -Tpng
|
||||||
|
digraph data_relationships {
|
||||||
|
\"data_requirement\" [shape=Mrecord, label=\"{DataRequirement|description\lformat\l}\"]
|
||||||
|
\"data_product\" [shape=Mrecord, label=\"{DataProduct|name\lversion\lpoc\lformat\l}\"]
|
||||||
|
\"data_requirement\" -> \"data_product\"
|
||||||
|
}
|
||||||
|
#+end_dot"
|
||||||
|
(message "dot-formatting...")
|
||||||
|
(let ((out-file (if headers (car headers)))
|
||||||
|
(args (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))
|
||||||
|
(data-file (make-temp-file "org-ditaa")))
|
||||||
|
(cond
|
||||||
|
((or htmlp latexp)
|
||||||
|
(with-temp-file data-file (insert body))
|
||||||
|
(message (concat "dot " data-file " " args " -o " out-file))
|
||||||
|
(shell-command (concat "dot " data-file " " args " -o " out-file))
|
||||||
|
(format "\n[[file:%s]]\n" out-file))
|
||||||
|
(t (concat
|
||||||
|
"\n#+BEGIN_EXAMPLE\n"
|
||||||
|
body (if (string-match "\n$" body) "" "\n")
|
||||||
|
"#+END_EXAMPLE\n")))))
|
||||||
|
|
||||||
|
;;--------------------------------------------------------------------------------
|
||||||
|
;; comment: export comments in author-specific css-stylable divs
|
||||||
|
(defun org-export-blocks-format-comment (body &rest headers)
|
||||||
|
"Format comment BODY by OWNER and return it formatted for export.
|
||||||
|
Currently, this only does something for HTML export, for all
|
||||||
|
other backends, it converts the comment into an EXAMPLE segment."
|
||||||
|
(let ((owner (if headers (car headers)))
|
||||||
|
(title (if (cdr headers) (mapconcat 'identity (cdr headers) " "))))
|
||||||
|
(cond
|
||||||
|
(htmlp ;; We are exporting to HTML
|
||||||
|
(concat "#+BEGIN_HTML\n"
|
||||||
|
"<div class=\"org-comment\""
|
||||||
|
(if owner (format " id=\"org-comment-%s\" " owner))
|
||||||
|
">\n"
|
||||||
|
(if owner (concat "<b>" owner "</b> ") "")
|
||||||
|
(if (and title (> (length title) 0)) (concat " -- " title "</br>\n") "</br>\n")
|
||||||
|
"<p>\n"
|
||||||
|
"#+END_HTML\n"
|
||||||
|
body
|
||||||
|
"#+BEGIN_HTML\n"
|
||||||
|
"</p>\n"
|
||||||
|
"</div>\n"
|
||||||
|
"#+END_HTML\n"))
|
||||||
|
(t ;; This is not HTML, so just make it an example.
|
||||||
|
(concat "#+BEGIN_EXAMPLE\n"
|
||||||
|
(if title (concat "Title:" title "\n") "")
|
||||||
|
(if owner (concat "By:" owner "\n") "")
|
||||||
|
body
|
||||||
|
(if (string-match "\n\\'" body) "" "\n")
|
||||||
|
"#+END_EXAMPLE\n")))))
|
||||||
|
|
||||||
|
;;--------------------------------------------------------------------------------
|
||||||
|
;; R: Sweave-type functionality
|
||||||
|
(defvar interblock-R-buffer nil
|
||||||
|
"Holds the buffer for the current R process")
|
||||||
|
|
||||||
|
(defun org-export-blocks-format-R (body &rest headers)
|
||||||
|
"Process R blocks and replace \R{} forms outside the blocks
|
||||||
|
with their values as determined by R."
|
||||||
|
(interactive)
|
||||||
|
(message "R processing...")
|
||||||
|
(let ((image-path (or (and (car headers)
|
||||||
|
(string-match "\\(.?\\)\.\\(EPS\\|eps\\)" (car headers))
|
||||||
|
(match-string 1 (car headers)))
|
||||||
|
(and (> (length (car headers)) 0)
|
||||||
|
(car headers))
|
||||||
|
;; create the default filename
|
||||||
|
(format "Rplot-%03d" count)))
|
||||||
|
(plot (string-match "plot" body))
|
||||||
|
R-proc)
|
||||||
|
(setf count (+ count 1))
|
||||||
|
(interblock-initiate-R-buffer)
|
||||||
|
(setf R-proc (get-buffer-process interblock-R-buffer))
|
||||||
|
;; send strings to the ESS process using `comint-send-string'
|
||||||
|
(setf body (mapconcat (lambda (line)
|
||||||
|
(interblock-R-input-command line) (concat "> " line))
|
||||||
|
(butlast (split-string body "[\r\n]"))
|
||||||
|
"\n"))
|
||||||
|
;; if there is a plot command, then create the images
|
||||||
|
(when plot
|
||||||
|
(interblock-R-input-command (format "dev.copy2eps(file=\"%s.eps\")" image-path)))
|
||||||
|
(concat (cond
|
||||||
|
(htmlp (org-export-blocks-html-quote body
|
||||||
|
(format "<div id=\"R-%d\">\n<pre>\n" count)
|
||||||
|
"</pre>\n</div>\n"))
|
||||||
|
(latexp (org-export-blocks-latex-quote body
|
||||||
|
"\\begin{Schunk}\n\\begin{Sinput}\n"
|
||||||
|
"\\end{Sinput}\n\\end{Schunk}\n"))
|
||||||
|
(t (insert ;; default export
|
||||||
|
"#+begin_R " (mapconcat 'identity headers " ") "\n"
|
||||||
|
body (if (string-match "\n$" body) "" "\n")
|
||||||
|
"#+end_R\n")))
|
||||||
|
(if plot
|
||||||
|
(format "[[file:%s.eps]]\n" image-path)
|
||||||
|
""))))
|
||||||
|
|
||||||
|
(defun org-export-interblocks-format-R (start end)
|
||||||
|
"This is run over parts of the org-file which are between R
|
||||||
|
blocks. It's main use is to expand the \R{stuff} chunks for
|
||||||
|
export."
|
||||||
|
(save-excursion
|
||||||
|
(goto-char start)
|
||||||
|
(interblock-initiate-R-buffer)
|
||||||
|
(let (code replacement)
|
||||||
|
(while (and (< (point) end) (re-search-forward "\\\\R{\\(.*\\)}" end t))
|
||||||
|
(save-match-data (setf code (match-string 1)))
|
||||||
|
(setf replacement (interblock-R-command-to-string code))
|
||||||
|
(setf replacement (cond
|
||||||
|
(htmlp replacement)
|
||||||
|
(latexp replacement)
|
||||||
|
(t replacement)))
|
||||||
|
(setf end (+ end (- (length replacement) (length code))))
|
||||||
|
(replace-match replacement t t)))))
|
||||||
|
|
||||||
|
(defun interblock-initiate-R-buffer ()
|
||||||
|
"If there is not a current R process then create one."
|
||||||
|
(unless (and (buffer-live-p interblock-R-buffer) (get-buffer interblock-R-buffer))
|
||||||
|
(save-excursion
|
||||||
|
(R)
|
||||||
|
(setf interblock-R-buffer (current-buffer))
|
||||||
|
(interblock-R-wait-for-output)
|
||||||
|
(interblock-R-input-command ""))))
|
||||||
|
|
||||||
|
(defun interblock-R-command-to-string (command)
|
||||||
|
"Send a command to R, and return the results as a string."
|
||||||
|
(interblock-R-input-command command)
|
||||||
|
(interblock-R-last-output))
|
||||||
|
|
||||||
|
(defun interblock-R-input-command (command)
|
||||||
|
"Pass COMMAND to the R process running in `interblock-R-buffer'."
|
||||||
|
(save-excursion
|
||||||
|
(save-match-data
|
||||||
|
(set-buffer interblock-R-buffer)
|
||||||
|
(goto-char (process-mark (get-buffer-process (current-buffer))))
|
||||||
|
(insert command)
|
||||||
|
(comint-send-input)
|
||||||
|
(interblock-R-wait-for-output))))
|
||||||
|
|
||||||
|
(defun interblock-R-wait-for-output ()
|
||||||
|
"Wait until output arrives"
|
||||||
|
(save-excursion
|
||||||
|
(save-match-data
|
||||||
|
(set-buffer interblock-R-buffer)
|
||||||
|
(while (progn
|
||||||
|
(goto-char comint-last-input-end)
|
||||||
|
(not (re-search-forward comint-prompt-regexp nil t)))
|
||||||
|
(accept-process-output (get-buffer-process (current-buffer)))))))
|
||||||
|
|
||||||
|
(defun interblock-R-last-output ()
|
||||||
|
"Return the last R output as a string"
|
||||||
|
(save-excursion
|
||||||
|
(save-match-data
|
||||||
|
(set-buffer interblock-R-buffer)
|
||||||
|
(goto-char (process-mark (get-buffer-process (current-buffer))))
|
||||||
|
(forward-line 0)
|
||||||
|
(let ((raw (buffer-substring comint-last-input-end (- (point) 1))))
|
||||||
|
(if (string-match "\n" raw)
|
||||||
|
raw
|
||||||
|
(and (string-match "\\[[[:digit:]+]\\] *\\(.*\\)$" raw)
|
||||||
|
(message raw)
|
||||||
|
(message (match-string 1 raw))
|
||||||
|
(match-string 1 raw)))))))
|
||||||
|
|
||||||
|
(provide 'org-exp-blocks)
|
||||||
|
|
||||||
|
;;; org-exp-blocks.el ends here
|
||||||
|
|
@ -0,0 +1,22 @@
|
||||||
|
#+TITLE: rorg --- R and org-mode
|
||||||
|
|
||||||
|
Please feel free to change the layout of this file, I'm just putting
|
||||||
|
this here to get things started.
|
||||||
|
|
||||||
|
* objectives
|
||||||
|
What are these?
|
||||||
|
|
||||||
|
I'll pre-populate with a quick list from the email to get started
|
||||||
|
|
||||||
|
Just to get this out there, there seem to be four kinds of
|
||||||
|
functionality we're trying to get here:
|
||||||
|
1. import data into R from org
|
||||||
|
2. easy editing of R code using r-mode from an org buffer
|
||||||
|
3. evaluate R code and make the output available for processing in an
|
||||||
|
org buffer
|
||||||
|
4. evaluate R code and format the output for export
|
||||||
|
|
||||||
|
|
||||||
|
* tasks
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in New Issue