ndwarshuis
/
org-mode
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

initial commit

This commit is contained in:
Eric Schulte 2009-02-05 15:04:09 -08:00
commit a3cf89b5b2
9 changed files with 1713 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
*~

9
README.markdown Normal file
View File

@ -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.

358
existing_tools/RweaveOrg/RweaveOrg.R Normal file
View File

@ -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

19
existing_tools/RweaveOrg/SweaveSyntaxOrg.R Normal file
View File

@ -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"

5
existing_tools/RweaveOrg/export_testing.R Normal file
View File

@ -0,0 +1,5 @@
source("SweaveSyntaxOrg.R")
source("RweaveOrg.R")
Sweave("testing.Rorg", driver=RweaveOrg, syntax=SweaveSyntaxOrg)
Stangle("testing.Rorg", driver=Rtangle(), syntax=SweaveSyntaxOrg)

73
existing_tools/RweaveOrg/testing.Rorg Normal file
View File

@ -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

846
existing_tools/org-R.el Normal file
View File

@ -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)

380
existing_tools/org-exp-blocks.el Normal file
View File

@ -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

22
rorg.org Normal file
View File

@ -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