contrib/lisp/org-R.el

   1 ;;; org-R.el --- Computing and data visualisation in Org-mode using R
   2
   3 ;; Copyright (C) 2009
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: Dan Davison <davison@stats.ox.ac.uk>
   7 ;; Keywords: org, R, ESS, tables, graphics
   8 ;; Homepage: http://www.stats.ox.ac.uk/~davison/software/org-R
   9 ;; Version: 0.06 2009-04-15
  10 ;;
  11 ;; This file is not part of GNU Emacs.
  12 ;;
  13 ;; This file is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17
  18 ;; This file is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;;
  27 ;;; Commentary:
  28
  29 ;; This file allows R (http://www.r-project.org) code to be applied to
  30 ;; emacs org-mode (http://orgmode.org) tables. When the result of the
  31 ;; analysis is a vector or matrix, it is output back into the org-mode
  32 ;; buffer as a new org table. Alternatively the R code may be used to
  33 ;; plot the data in the org table. It requires R to be running in an
  34 ;; inferior-ess-mode buffer (install Emacs Speaks Statistics
  35 ;; http://ess.r-project.org and issue M-x R).
  36 ;;
  37 ;;
  38 ;; The user interface is via two different options lines in the org
  39 ;; buffer. As is conventional in org-mode, these are lines starting
  40 ;; with `#+'. Lines starting with #+R: specify options in the
  41 ;; standard org style (option:value) and are used to specify certain
  42 ;; off-the-shelf transformations and plots of the table data. The
  43 ;; #+R: line is also used to specify the data to be analysed
  44 ;; (either an org table or a csv file), and to restrict the analysis
  45 ;; to certain columns etc. In lines starting #+RR: you can supply
  46 ;; literal R code, giving you full control over what you do with the
  47 ;; table. With point in the first #+R line, M-x org-R-apply
  48 ;; makes happen whatever has been specified in those lines.
  49
  50 ;; The documentation is currently the Worg tutorial:
  51 ;;
  52 ;; http://orgmode.org/worg/org-tutorials/org-R/org-R.php
  53 ;;
  54 ;; changelog:
  55 ;; 2009-04-05 two bug fixes in org-R-eval contributed by David Moffat
  56 ;; 2009-05-15 added lwd argument to matplot because it doesn't respect global par settings
  57 ;; 2009-05-15 uncommented set-buffer to transit buffer in org-eval (why was it commented?)
  58
  59 (defconst org-R-skeleton-funcall-1-arg
  60   "%s(x[%s]%s)"
  61   "Skeleton of a call to an R function.
  62 E.g. barplot(x[,3:5], names.arg=rownames(x))")
  63
  64 (defconst org-R-skeleton-funcall-2-args
  65   "%s(x[,%s], x[,%s]%s)"
  66   "Skeleton of a call to an R function which can take x and y
  67   args.")
  68
  69 (defconst org-R-write-org-table-def
  70   "write.org.table <- function (x, write.rownames = TRUE)
  71 {
  72     if(!is.null(dim(x)) && length(dim(x)) > 2)
  73         stop(\"Object must be 1- or 2-dimensional\") ;
  74     if(is.vector(x) || is.table(x) || is.factor(x) || is.array(x))
  75         x <- as.matrix(x) ;
  76     if(!(is.matrix(x) || inherits(x, c('matrix', 'data.frame')))) {
  77        invisible() ;
  78        print(x) ;
  79        stop(\"Object not recognised as 1- or 2-dimensional\") ;
  80     } ;
  81     if(is.null(colnames(x)))
  82         colnames(x) <- rep('', ncol(x)) ;
  83     if(write.rownames)
  84         x <- cbind(rownames(x), x) ;
  85     cat('|', paste(colnames(x), collapse = ' | '), '|\\n') ;
  86     cat('|', paste(rep('----', ncol(x)), collapse = '+'), '|\\n', sep = '') ;
  87     invisible(apply(x, 1, function(row) cat('|', paste(row, collapse = ' | '), '|\\n'))) ;
  88 }"
  89   "Definition of R function to write org table representation of R objects.
  90 To see a more human-readable version of this, look at the code,
  91 or type dput(write.org.table) RET at the R (inferior-ess-mode
  92 buffer) prompt.")
  93
  94 (defun org-R-apply-maybe ()
  95   (if (save-excursion
  96         (beginning-of-line 1)
  97         (looking-at "#\\+RR?:"))
  98       (progn (call-interactively 'org-R-apply)
  99              t) ;; to signal that we took action
 100     nil)) ;; to signal that we did not
 101
 102 (add-hook 'org-ctrl-c-ctrl-c-hook 'org-R-apply-maybe)
 103
 104
 105 (defun org-R-apply ()
 106   "Construct and evaluate an R function call.
 107 Construct an R function corresponding to the #+R: and #+RR:
 108 lines. R must be currently running in an inferior-ess-mode
 109 buffer. The function evaluates any user-supplied R code in the
 110 #+RR: line before the off-the-shelf actions specified in the #+R:
 111 line. The user-supplied R code can operate on a variable called x
 112 that is the org table represented as a data frame in R. Text
 113 output from the R process may be inserted into the org buffer, as
 114 an org table where appropriate."
 115   (interactive)
 116   (require 'ess)
 117   (save-excursion
 118     (beginning-of-line)
 119     (unless (looking-at "#\\+RR?:") (error "Point must be in a #+R or #+RR line"))
 120     (while (looking-at "#\\+RR?:") (forward-line -1))
 121     (forward-line)
 122     ;; For the rest of the code in this file we are based at the
 123     ;; beginning of the first #+R line
 124
 125     ;; FIXME: if point is at the beginning of the #+RR? lines when
 126     ;; this function is called, then tabular output gets inserted,
 127     ;; leaving point up at the top of the tabular output.
 128
 129     (let* ((options (org-R-get-options))
 130            (code (org-R-construct-code options))
 131            (infile (plist-get options :infile))
 132            (ext (if infile (file-name-extension infile)))
 133            csv-file)
 134
 135       (if (string-equal ext "csv")
 136           (setq csv-file infile)
 137         (setq csv-file
 138               (org-R-export-to-csv
 139                (make-temp-file "org-R-tmp" nil ".csv") options)))
 140
 141       (org-R-eval code csv-file options)
 142
 143       (delete-other-windows) ;; FIXME
 144       (if (plist-get options :showcode) (org-R-showcode code)))))
 145
 146 (defun org-R-apply-throughout-subtree ()
 147   "Call org-R-apply in every org-R block in current subtree."
 148   ;; This currently relies on re-search-forward leaving point after
 149   ;; the #+RR?: If point were at the beginning of the line, then
 150   ;; tabular input would get inserted leaving point above the #+RR?:,
 151   ;; and this would loop infinitely. Same for org-R-apply-to-buffer.
 152   (interactive)
 153   (save-excursion
 154     (org-back-to-heading)
 155     (while (re-search-forward
 156             "^#\\+RR?:"
 157             (save-excursion (org-end-of-subtree)) t)
 158       (org-R-apply)
 159       (forward-line)
 160       (while (looking-at "#\\+RR?")
 161         (forward-line)))))
 162
 163 (defun org-R-apply-throughout-buffer ()
 164   "Call org-R-apply in every org-R block in the buffer."
 165   (interactive)
 166   (save-excursion
 167     (goto-char (point-min))
 168     (while (re-search-forward "^#\\+RR?:" nil t)
 169       (org-R-apply)
 170       (forward-line)
 171       (while (looking-at "#\\+RR?")
 172         (forward-line)))))
 173
 174 (defun org-R-construct-code (options)
 175   "Construct the R function that implements the requested
 176 behaviour.
 177 The body of this function derives from two sources:
 178
 179 1. Explicit R code which is read from lines starting with
 180 #+RR: by org-R-get-user-code, and
 181
 182 2. Off-the-shelf code corresponding to options specified in the
 183 #+R: line. This code is constructed by
 184 org-R-off-the-shelf-code."
 185   (let ((user-code (org-R-get-user-code))
 186         (action (plist-get options :action)))
 187
 188     (if (or (eq action 'tabulate) (eq action 'transpose))
 189         (setq options (plist-put options :output-to-buffer t)))
 190     (format "function(x){%sx}"
 191             (concat
 192              (when user-code (concat user-code ";"))
 193              (when action (concat (org-R-off-the-shelf-code options) ";"))))))
 194
 195 (defun org-R-get-user-code (&optional R)
 196   "Read user-supplied R code from #+RR: lines."
 197   (let ((case-fold-search t))
 198     (save-excursion
 199       (while (looking-at "^#\\+\\(RR?:\\) *\\(.*\\)")
 200         (if (string= "RR:" (match-string 1))
 201             (setq R (concat R (when R ";") (match-string 2))))
 202         (forward-line))))
 203   R)
 204
 205 (defun org-R-off-the-shelf-code (options)
 206   "Return R code implementing the actions requested in the
 207 #+R: lines."
 208
 209   ;; This is a somewhat long function as it deals with several
 210   ;; different cases, corresponding to all the off-the-shelf actions
 211   ;; that have been implemented.
 212
 213   (let* ((action (plist-get options :action))
 214          (cols (plist-get options :columns))
 215          (ncols (org-R-number-of-columns cols))
 216          (nxcols (nth 0 ncols))
 217          (nycols (nth 1 ncols))
 218          (cols-R (org-R-make-index-vectors cols))
 219          (xcols-R (nth 0 cols-R))
 220          (ycols-R (nth 1 cols-R))
 221          seq args largs extra-code title colour matrix-index)
 222
 223     ;; I want this to affect options outside this function.  Will it
 224     ;; necessarily do so? (not if plist-put adds to head of the
 225     ;; plist?)
 226     (setq options (plist-put options :nxcols nxcols))
 227
 228     (cond ((eq action 'points)
 229            (setq action 'plot)
 230            (setq options (plist-put options :lines nil)))
 231           ((eq action 'lines)
 232            (setq action 'plot)
 233            (setq options (plist-put options :lines t))))
 234
 235     (if (and (setq title (plist-get options :title)) (symbolp title))
 236         (setq title symbol-name title))
 237
 238     (setq args (plist-put args :main (concat "\"" title "\"")))
 239
 240     (if (setq colour (or (plist-get options :colour)
 241                          (plist-get options :color)
 242                          (plist-get options :col)))
 243         (setq args
 244               (plist-put args :col
 245                          (concat "\"" (if (symbolp colour) (symbol-name colour) colour) "\""))))
 246
 247     (setq largs
 248           (if (setq legend (plist-get options :legend))
 249               (plist-put largs :x
 250                          (concat "\"" (if (symbolp legend) (symbol-name legend) legend) "\""))
 251             (plist-put largs :x "\"topright\"")))
 252
 253     (cond
 254      ((null ycols-R)
 255       ;; single set of columns; implicit x values
 256       (if (null xcols-R)
 257           (setq xcols-R "" matrix-index "")
 258         (setq matrix-index (concat "," xcols-R)))
 259       (cond
 260
 261        ;;----------------------------------------------------------------------
 262
 263        ((eq action 'barplot)
 264         (if (eq nxcols 1)
 265             (progn
 266               (setq args (plist-put args :names.arg "rownames(x)"))
 267               (setq args (org-R-set-user-supplied-args args (plist-get options :args)))
 268               (format org-R-skeleton-funcall-1-arg
 269                       "barplot" xcols-R
 270                       (concat ", " (org-R-plist-to-R-args args))))
 271
 272           (setq args (plist-put args :names.arg "colnames(x)"))
 273           (setq args (plist-put args :col "seq(nrow(x))"))
 274           (setq args (plist-put args :beside "TRUE"))
 275
 276           (setq largs (plist-put largs :bty "\"n\""))
 277           ;; (setq largs (plist-put largs :lwd 10))
 278           (setq largs (plist-put largs :col "seq(nrow(x))"))
 279           (setq largs (plist-put largs :legend "rownames(x)"))
 280
 281           (setq args (org-R-set-user-supplied-args args (plist-get options :args)))
 282
 283           (concat (format org-R-skeleton-funcall-1-arg
 284                           "barplot(as.matrix" matrix-index
 285                           (concat "), " (org-R-plist-to-R-args args)))
 286                   "; legend(" (org-R-plist-to-R-args largs) ")")))
 287
 288        ;;----------------------------------------------------------------------
 289
 290        ((eq action 'density)
 291         (if (and nxcols (> nxcols 1))
 292           (error "Multiple columns not implemented for action:%s" action))
 293
 294         (setq args (plist-put args :xlab (concat "colnames(x)["xcols-R"]")))
 295         (setq args (org-R-set-user-supplied-args args (plist-get options :args)))
 296
 297         (format org-R-skeleton-funcall-1-arg
 298                 "plot(density" matrix-index
 299                 (concat "), " (org-R-plist-to-R-args args))))
 300
 301        ;;----------------------------------------------------------------------
 302
 303        ((eq action 'hist)
 304         (if (and nxcols (> nxcols 1))
 305           (error "Multiple columns not implemented for action:%s" action))
 306         (setq args (plist-put args :xlab (concat "colnames(x)["xcols-R"]")))
 307         (setq args (org-R-set-user-supplied-args args (plist-get options :args)))
 308         (setq args (concat ", " (org-R-plist-to-R-args args)))
 309         (format org-R-skeleton-funcall-1-arg "hist" matrix-index args))
 310
 311        ;;----------------------------------------------------------------------
 312
 313        ((eq action 'image)
 314         (format org-R-skeleton-funcall-1-arg "image(as.matrix" matrix-index ")"))
 315
 316        ;;----------------------------------------------------------------------
 317
 318        ((eq action 'plot)
 319         (setq R-fun (if (eq nxcols 1) "plot" "matplot"))
 320         (setq seq (concat "seq_along("xcols-R")"))
 321
 322         (setq args (plist-put args :type (if (plist-get options :lines) "\"l\"" "\"p\"")))
 323         (setq args (plist-put args :ylab (concat "colnames(x)["xcols-R"]")))
 324         (if (string-equal R-fun "matplot")
 325             (setq args (plist-put args :lwd "par(\"lwd\")")))
 326         (setq args (concat ", " (org-R-plist-to-R-args args)))
 327
 328         (concat
 329          (format org-R-skeleton-funcall-1-arg R-fun matrix-index args)
 330          extra-code))
 331
 332        ;;----------------------------------------------------------------------
 333
 334        ((eq action 'tabulate)
 335         (concat
 336          (if (plist-get options :sort)
 337              (format org-R-skeleton-funcall-1-arg
 338                      "x <- sort(table" xcols-R "), decreasing=TRUE")
 339            (format org-R-skeleton-funcall-1-arg "x <- table" matrix-index ""))
 340          (if (eq nxcols 1) "; x <- data.frame(value=names(x), count=x[])")))
 341
 342        ;;----------------------------------------------------------------------
 343
 344        ((eq action 'transpose)
 345         (format org-R-skeleton-funcall-1-arg "x <- t" matrix-index ""))
 346
 347        ;;----------------------------------------------------------------------
 348
 349        ;; Don't recognise action: option, try applying it as the name of an R function.
 350
 351        (t (format org-R-skeleton-funcall-1-arg
 352                   (concat "x <- " (symbol-name action)) matrix-index ""))))
 353
 354      ;;----------------------------------------------------------------------
 355
 356      (ycols-R
 357       ;; x and y columns specified
 358       (cond
 359
 360        ;;----------------------------------------------------------------------
 361
 362        ((eq action 'plot)
 363         (unless (eq nxcols 1) (error "Multiple x-columns not implemented for action:plot"))
 364         (setq R-fun (if (and (eq nxcols 1) (eq nycols 1)) "plot" "matplot"))
 365
 366         (setq args
 367               (plist-put
 368                args :ylab
 369                (concat "if(length("ycols-R") == 1) colnames(x)["ycols-R"] else ''")))
 370         (setq args (plist-put args :xlab (concat "colnames(x)["xcols-R"]")))
 371         (if (string-equal R-fun "matplot") ;; matplot doesn't respect par()$lwd
 372             (setq args (plist-put args :lwd "par(\"lwd\")")))
 373         (setq args (plist-put args :type (if (plist-get options :lines) "\"l\"" "\"p\"")))
 374
 375         (setq args (concat ", " (org-R-plist-to-R-args args)))
 376         (setq seq (concat "seq_along("ycols-R")"))
 377
 378         (setq largs (plist-put largs :col seq))
 379         (setq largs (plist-put largs :lty seq))
 380         (setq largs (plist-put largs :bty "\"n\""))
 381         (setq largs (plist-put largs :legend (concat "colnames(x)["ycols-R"]")))
 382
 383         (setq extra-code
 384               (concat "; "
 385                       "if(length("ycols-R") > 1) "
 386                       "legend(" (org-R-plist-to-R-args largs) ")"))
 387
 388         (concat
 389          (format org-R-skeleton-funcall-2-args R-fun xcols-R ycols-R args)
 390          extra-code))
 391
 392        ;;----------------------------------------------------------------------
 393
 394        (t (error "action:%s requires a single set of columns" (symbol-name action))))))))
 395
 396 (defun org-R-set-user-supplied-args (args user-args)
 397   "Set user-supplied values in arguments plist."
 398   (while (setq prop (pop user-args))
 399     (setq args (plist-put args prop (pop user-args))))
 400   args)
 401
 402 (defun org-R-plist-to-R-args (plist)
 403   "Convert a plist into a string of R arguments."
 404   (let (arg-string arg)
 405     (while (setq arg (pop plist))
 406       (string-match ":\\(\.*\\)" (symbol-name arg))
 407       (setq arg (match-string 1 (symbol-name arg)))
 408       (setq arg-string
 409             (concat
 410              (if arg-string (concat arg-string ", "))
 411              (format "%s=%s" arg (pop plist)))))
 412     arg-string))
 413
 414 (defun org-R-alist-to-R-args (alist)
 415   "Convert an alist of (argument . val) pairs into a string of R arguments.
 416 The alist is something like
 417       '((arg1 . 1)
 418         (arg2 . a))
 419 This isn't used, but it seems much nicer than
 420 my plist equivalent. Is there a better way to write the plist
 421 version?
 422 "
 423   (mapconcat
 424    'identity
 425    (mapcar (lambda(pair) (format "%s = %s" (car pair) (cdr pair))) alist)
 426    ", "))
 427
 428 (defun org-R-make-index-vectors (cols)
 429   "Construct R indexing vectors as strings from lisp form.
 430
 431 COLS is the lisp form given by the `columns:' option. It may
 432 take the following forms:
 433
 434 1. integer atom        - the number of the column
 435 2. symbol/string atom  - the name of the column
 436 3. list of length 1    - same as 1 or 2 above
 437 4. list of length > 1  - specification of multiple columns as 1 or 2 above, unless it is
 438 5. list of 2 lists     - each list specifies (possibly multiple) columns
 439
 440 In cases 1-4 this function returns a list of length 1, containing
 441 the R index vector as a string. In case 5 this function returns a
 442 list of two such index vectors.
 443
 444 In cases 1 - 4, when a bivariate plot is requested such as by
 445 `action:lines', the x values are implicit, i.e
 446 1,2,...,number-of-rows.
 447
 448 In case 4, an attempt is made to do something sensible with the
 449 multiple columns, e.g. for `action:lines' they will be plotted
 450 together on the same graph against the implicit x values, and for
 451 `action:barplot' the bars corresponding to a single row will be
 452 stacked on top of each other, or placed side by side, depending
 453 on the value of the `beside' option.
 454
 455 For `action:tabulate', if 2 columns are selected, a
 456 two-dimensional table is created. If more than 2, then the
 457 appropriately dimensioned table is computed and inserted using
 458 the standard text representation of multi-dimensional arrays used
 459 by R (as org does not currently have tables of dimension > 2).
 460
 461 The straightforward case of case 5 is that both lists are of
 462 length 1. For `action:plot' and `action:lines' these specify the
 463 y and x coordinates of the points to be plotted or joined by
 464 lines.
 465
 466 The intention is that `org-R-apply' does something
 467 corresponding to what would happen if you did the following in R:
 468
 469 fun(x=tab[,xcols], y=tab[,ycols])
 470
 471 where fun is the R function implementing the desired
 472 action (plotting/computation), tab is the org table, xcols are
 473 the columns specified in cases 1-4 above, and ycols are the
 474 second set of columns which might have been specified under case
 475 5 above. For relevant R documentation see the help page
 476 associated with the function xy.coords, e.g. by typing ?xy.coords
 477 at the R prompt.
 478
 479 The following won't work with case 5: `tabulate'
 480 "
 481   (defun org-R-make-index-vector (cols)
 482     "Return the R indexing vector (as a string) corresponding to
 483 the lisp form COLS. In this function, COLS is a either a list of
 484 atoms, or an atom, i.e. in the form of cases 1-4"
 485     (when cols
 486       (let (to-stringf)
 487         (unless (listp cols) (setq cols (list cols)))
 488         (setq to-stringf
 489               (cond ((car (mapcar 'symbolp cols))
 490                      (lambda (symbol) (concat "\"" (symbol-name symbol) "\"")))
 491                     ((car (mapcar 'integerp cols))
 492                      'int-to-string)
 493                     ((car (mapcar 'stringp cols))
 494                      (lambda (string) (concat "\"" string "\"")))
 495                     (t (error "Column selection should be symbol, integer or string: %S" cols))))
 496         (concat (when (> (length cols) 1) "c(")
 497                 (mapconcat to-stringf cols ",")
 498                 (when (> (length cols) 1) ")")))))
 499
 500   (if (and (listp cols) (listp (car cols)))
 501       (mapcar 'org-R-make-index-vector cols) ;; case 5
 502     (list (org-R-make-index-vector cols))))  ;; other cases
 503
 504 (defun org-R-number-of-columns (cols)
 505   (defun f (c) (if (listp c) (length c) 1))
 506   (if (and (listp cols) (listp (car cols)))
 507       (mapcar 'f cols)
 508     (list (f cols))))
 509
 510
 511 (defun org-R-eval (R-function csv-file options)
 512   "Apply an R function to tabular data and receive output as an org table.
 513
 514 R-FUNCTION is a string; it may be simply the name of an
 515 appropriate R function (e.g. \"summary\", \"plot\"), or a
 516 user-defined anonymous function of the form
 517 \"(function(data.frame) {...})\". It will receive as its first
 518 argument the org table as an R 'data frame' -- a table-like
 519 structure which can have columns containing different types of
 520 data -- numeric, character etc.
 521
 522 The R function may produce graphical and/or text output. If it
 523 produces text output, and the replace:t is specified, and if
 524 there is a table immediately above the #+R lines, then it is
 525 replaced by the text output. Otherwise the text output is
 526 inserted above the #+R lines.
 527 "
 528   (let ((transit-buffer "org-R-transit")
 529         (infile (plist-get options :infile))
 530         (output-file (plist-get options :outfile))
 531         (title (plist-get options :title))
 532         output-format graphics-output-file width height)
 533
 534     (unless (not output-file)
 535       ;; We are writing output to file. Determine file format and
 536       ;; location, and open graphics device if necessary.
 537       (if (string-match
 538            "\\(.*\.\\)?\\(org\\|png\\|jpg\\|jpeg\\|pdf\\|ps\\|bmp\\|tiff\\)$"
 539            output-file)
 540           (setq output-format (match-string 2 output-file))
 541         (error "Did not recognise file name suffix %s as available output format"
 542                (match-string 2 output-file)))
 543       (unless (match-string 1 output-file)
 544         ;; only suffix provided: store in org-attach dir
 545         (require 'org-attach)
 546         (let ((temporary-file-directory (org-attach-dir t)))
 547           (setq output-file
 548                 (make-temp-file
 549                  "org-R-output-" nil (concat "." output-format)))))
 550       ;;; MdQ bug fix.
 551       ;;; If a filename is given, make sure it's absolute,
 552       ;;; as ess-execute needs that later.
 553       (if (match-string 1 output-file)
 554           (setq output-file (expand-file-name output-file)) )
 555
 556       (if (eq output-format "jpg") (setq output-format "jpeg"))
 557       (setq graphics-output-file (not (string-equal output-format "org")))
 558       (if graphics-output-file ;; open the graphics device
 559           (ess-execute
 560            (concat output-format "(file=\"" output-file "\""
 561                    (if (setq width (plist-get options :width))
 562                        (format ", width=%d" width))
 563                    (if (setq height (plist-get options :height))
 564                        (format ", height=%d" height)) ")"))))
 565
 566     ;; Apply R code to table (which is now stored as a csv file)
 567     ;; does it matter whether this uses ess-command or ess-execute?
 568
 569     ;; First evaluate function definition for R -> org table conversion
 570     ;;; MdQ bug fix.
 571     ;;; The following save-excursion has been brought up to here
 572     ;;; so that the two ess-execute commands are now within it.
 573     ;;; This is because they have the side effect of changing current
 574     ;;; buffer to the transit-buffer, which causes error of deleting
 575     ;;; the wrong table there, instead of in the org buffer.
 576     (save-excursion
 577       (ess-execute (replace-regexp-in-string "\n" " " org-R-write-org-table-def)
 578                    nil transit-buffer)
 579
 580       ;; FIXME: why not eval the function def together with the function call
 581       ;; as in the commented out line below (it didn't work for some reason)
 582       (ess-execute
 583        (concat
 584         ;; (replace-regexp-in-string "\n" " " org-R-write-org-table-def) ";"
 585         (org-R-make-expr R-function csv-file options)) nil transit-buffer)
 586
 587       (set-buffer (concat "*" transit-buffer "*"))
 588       (unless (or (looking-at "$")
 589                   (string-equal (buffer-substring-no-properties 1 2) "|"))
 590         (error "Error in R evaluation:\n%s" (buffer-string))))
 591
 592
 593     (if csv-file
 594         (unless (and infile
 595                      (string-equal (file-name-extension infile) "csv"))
 596           (delete-file csv-file)))
 597
 598     (if graphics-output-file (ess-execute "dev.off()")) ;; Close graphics device
 599
 600     (unless (or graphics-output-file
 601                 (not (plist-get options :output-to-buffer)))
 602       ;; Send tabular output to a org buffer as new org
 603       ;; table. Recall that we are currently at the beginning of the
 604       ;; first #+R line
 605       (if (and output-file graphics-output-file)
 606           (error "output-to-buffer and graphics-output-file both t"))
 607
 608       (save-excursion
 609         (if output-file
 610             (progn (set-buffer (find-file-noselect output-file))
 611                    (delete-region (point-min) (point-max)))
 612           (if (plist-get options :replace)
 613               (progn ;; kill a table iff in one or one ends on the previous line
 614                 (delete-region (org-table-begin) (org-table-end))
 615                 (save-excursion
 616                   (forward-line -1)
 617                   (if (looking-at "#\\+TBLNAME")
 618                       (delete-region (point) (1+ (point-at-eol))))))))
 619         (if title (insert "#+TBLNAME:" title "\n"))
 620         (insert-buffer-substring (concat "*" transit-buffer "*"))
 621         (org-table-align)
 622         (if output-file (save-buffer))))
 623
 624     ;; We might be linking to graphical output, or to org output in
 625     ;; another file. Either way, point is still at the beginning of
 626     ;; the first #+R line.
 627     (unless (not output-file)
 628       (save-excursion
 629         (forward-line -1)
 630         (if (looking-at "\\[\\[file:")
 631             (delete-region (point) (1+ (point-at-eol)))))
 632       (insert (org-make-link-string
 633                (concat "file:" output-file)
 634                (unless (plist-get options :inline)
 635                  (or title (concat output-format " output")))) "\n"))
 636
 637     (kill-buffer (concat "*" transit-buffer "*"))))
 638
 639
 640 (defun org-R-export-to-csv (csv-file options)
 641   "Find and export org table to csv.
 642
 643 If the intable: option has not been supplied, then the table must
 644 end on the line immediately above the #+R lines. Otherwise,
 645 the remote table referenced by the intable: option is found using
 646 org-R-find-table. If options:infile has been set then this is the
 647 org file containing the table. See the docstring of
 648 org-R-find-table for details."
 649   (let ((tbl-name-or-id (plist-get options :intable))
 650         (org-file (plist-get options :infile)) tbl-marker)
 651
 652     (if (and org-file
 653              (not (string-equal (file-name-extension org-file) "org")))
 654         (error "File %s extension is not .csv so should be .org"))
 655
 656     (save-excursion
 657       (if tbl-name-or-id
 658           ;; a remote table has been specified -- move into it
 659           (progn
 660             (if org-file (set-buffer (find-file-noselect org-file)))
 661             (setq tbl-marker (org-R-find-table tbl-name-or-id 'marker))
 662             (set-buffer (marker-buffer tbl-marker))
 663             (goto-char (marker-position tbl-marker)))
 664         (forward-line -1)) ;; move into table above
 665       (if (looking-at "[ \t]*|")
 666           (progn (org-table-export csv-file "orgtbl-to-csv") csv-file)
 667         nil))))
 668
 669 (defun org-R-find-table (name-or-id &optional markerp)
 670   "Return location of a table.
 671
 672 NAME-OR-ID may be the name of a
 673 table in the current file as set by a \"#+TBLNAME:\" directive.
 674 The first table following this line will then be used.
 675 Alternatively, it may be an ID referring to any entry, perhaps in
 676 a different file.  In this case, the first table in that entry
 677 will be referenced. The location is returned as a marker pointing
 678 to the beginning of the first line of the table.
 679
 680 This is taken from the first part of org-table-get-remote-range
 681 in org-table.el.
 682 "
 683   (cond
 684    ((symbolp name-or-id) (setq name-or-id (symbol-name name-or-id)))
 685    ((numberp name-or-id) (setq name-or-id (number-to-string name-or-id))))
 686   (save-match-data
 687     (let ((id-loc nil) (case-fold-search t) buffer loc)
 688       (save-excursion
 689         (save-restriction
 690           (widen)
 691           (save-excursion
 692             (goto-char (point-min))
 693             (if (re-search-forward
 694                  (concat "^#\\+TBLNAME:[ \t]*" (regexp-quote name-or-id) "[ \t]*$")
 695                  nil t)
 696                 ;; OK, we've found a matching table name in this buffer.
 697                 (setq buffer (current-buffer) loc (match-beginning 0))
 698               ;; It's not a table name in this buffer. It must be an entry id.
 699               ;; obtain a marker pointing to it.
 700               (setq id-loc (org-id-find name-or-id 'marker)
 701                     buffer (marker-buffer id-loc)
 702                     loc (marker-position id-loc))
 703               (move-marker id-loc nil))) ;; disable the marker
 704           ;; (switch-to-buffer buffer)
 705           (set-buffer buffer)
 706           ;; OK, so now we're in the right buffer, and loc is either
 707           ;; the beginning of the #+TBLNAME line, or the location of the entry
 708           ;; either way we need to search forward to get to the beginning of the table
 709           (save-excursion
 710             (save-restriction
 711               (widen)
 712               (goto-char loc)
 713               (forward-char 1)
 714               ;; The following regexp search finds the beginning of
 715               ;; the next table in this entry. If it gets to the next
 716               ;; entry before the next table, then it signals failure.
 717               (unless (and (re-search-forward "^\\(\\*+ \\)\\|[ \t]*|" nil t)
 718                            (not (match-beginning 1)))
 719                 (error "Cannot find a table at NAME or ID %s" name-or-id))
 720               (if markerp
 721                   (move-marker (make-marker) (point-at-bol) (current-buffer))
 722                 (error "Option to return cons cell not implemented.
 723                         It should return (file-name . position) to be
 724                         consistent with functions in org-id.el")))))))))
 725
 726 (defun org-R-make-expr (R-function csv-file options)
 727   "Construct R code to read data, analyse it and write output."
 728
 729   (let ((rownames (plist-get options :rownames))
 730         (colnames (plist-get options :colnames))
 731         (action (plist-get options :action))
 732         (replace (plist-get options :replace)))
 733
 734     (if (and csv-file (symbolp csv-file))
 735         (setq csv-file (symbol-name csv-file)))
 736
 737     (format "write.org.table((%s)(%s), write.rownames=%s)"
 738             R-function
 739             (if csv-file
 740                 (format
 741                  "read.csv(\"%s\", header=%s, row.names=%s)"
 742                  csv-file
 743
 744                  ;; Do we treat first row as colnames? Yes by default
 745                  ;; FIXME: should really check for hline
 746                  (if colnames "TRUE" "FALSE")
 747
 748                  ;; Do we use a column as rownames? Not unless rownames: is specified
 749                  (if rownames "1" "NULL"))
 750               "NULL")
 751
 752             ;; Do we write rownames into org table?
 753             (cond ((eq action 'tabulate)
 754                    (if (eq (plist-get options :nxcols) 1) "FALSE" "TRUE"))
 755                   ((eq action 'transpose) (if colnames "TRUE" "FALSE"))
 756                   (rownames "TRUE")
 757                   (t "TRUE")))))
 758
 759 (defun org-R-get-options ()
 760   "Parse the #+R: lines and return the options and values as a p-list."
 761   (let ((opts '(
 762                 (:infile . "infile")
 763                 (:intable . "intable")
 764                 (:rownames . "rownames")
 765                 (:colnames . "colnames")
 766                 (:columns . "columns")
 767
 768                 (:action . "action")
 769                 (:args . "args")
 770
 771                 (:outfile . "outfile")
 772                 (:replace . "replace")
 773                 (:title . "title")
 774                 (:legend . "legend")
 775                 (:colour . "colour")
 776                 (:color . "color")
 777                 (:col . "col")
 778                 (:height . "height")
 779                 (:width . "width")
 780                 (:lines . "lines")
 781                 (:sort . "sort")
 782                 (:inline . "inline")
 783
 784                 (:output-to-buffer . "output-to-buffer")
 785
 786                 (:showcode . "showcode")))
 787         (regexp ":\\(\"[^\"]*\"\\|(([^)]*) *([^)]*))\\|([^)]*)\\|[^ \t\n\r;,.]*\\)")
 788         (case-fold-search t) p)
 789
 790     ;; FIXME: set default options properly
 791     (setq p (plist-put p :output-to-buffer t)) ;; FIXME: hack: null options plist is bad news
 792     (setq p (plist-put p :replace t))
 793     (setq p (plist-put p :rownames nil))
 794     (setq p (plist-put p :colnames t))
 795     (setq p (plist-put p :inline nil))
 796
 797     (save-excursion
 798       (while (looking-at "^#\\+\\(RR?:+\\) *\\(.*\\)")
 799         (if (string= "R:" (match-string 1))
 800             (setq p (org-R-add-options-to-plist p (match-string 2) opts regexp)))
 801         (forward-line)))
 802     p))
 803
 804 (defun org-R-add-options-to-plist (p opt-string op regexp)
 805   "Parse a #+R: line and set values in the property list p.
 806 This function is adapted from similar functions in org-exp.el
 807 and org-plot.el. It might be a good idea to have a single
 808 function serving these three files' needs."
 809   ;; Adapted from org-exp.el and org-plot.el
 810   (let (o)
 811     (when opt-string
 812       (while (setq o (pop op))
 813         (if (string-match
 814              (concat (regexp-quote (cdr o)) regexp)
 815              opt-string)
 816             (setq p (plist-put p (car o)
 817                                (car (read-from-string
 818                                      (match-string 1 opt-string)))))))))
 819   p)
 820
 821
 822 (defun org-R-sanitise-options (options)
 823   (error "not used yet")
 824   (let (should-be-strings '(title legend colour color col csv)))
 825   )
 826 (defun org-R-showcode (R)
 827   "Display R function constructed by org-R in a new R-mode
 828 buffer."
 829   (split-window-vertically)
 830   (switch-to-buffer "*org-table.R*")
 831   (kill-region (point-min) (point-max))
 832   (R-mode)
 833   (insert (replace-regexp-in-string
 834            ";" "\n" (replace-regexp-in-string "\\([{}]\\)" "\n\\1\n" R)))
 835   ;; (mark-whole-buffer)
 836   ;; (indent-region)
 837   ;; why doesn't that do what I hoped?
 838   )
 839
 840 (defun org-R-get-remote-range (name-or-id form)
 841   "Get a field value or a list of values in a range from table at ID.
 842
 843 This is a refactoring of Carsten's original version. I have
 844 extracted the first bit of his function and named it
 845 org-R-find-table (which would presumably be called something like
 846 org-table-find-table or org-id-find-table if this were accepted).
 847
 848 ---
 849
 850 Get a field value or a list of values in a range from table at ID.
 851
 852 NAME-OR-ID may be the name of a table in the current file as set by
 853 a \"#+TBLNAME:\" directive.  The first table following this line
 854 will then be used.  Alternatively, it may be an ID referring to
 855 any entry, possibly in a different file.  In this case, the first table
 856 in that entry will be referenced.
 857 FORM is a field or range descriptor like \"@2$3\" or or \"B3\" or
 858 \"@I$2..@II$2\".  All the references must be absolute, not relative.
 859
 860 The return value is either a single string for a single field, or a
 861 list of the fields in the rectangle."
 862
 863   (let ((tbl-marker (org-R-find-table name-or-id 'marker))
 864         org-table-column-names org-table-column-name-regexp
 865         org-table-local-parameters org-table-named-field-locations
 866         org-table-current-line-types org-table-current-begin-line
 867         org-table-current-begin-pos org-table-dlines
 868         org-table-hlines org-table-last-alignment
 869         org-table-last-column-widths org-table-last-alignment
 870         org-table-last-column-widths tbeg)
 871
 872     (save-excursion
 873       (set-buffer (marker-buffer tbl-marker))
 874       (goto-char (marker-position tbl-marker))
 875       (org-table-get-specials)
 876       (setq form (org-table-formula-substitute-names form))
 877       (if (and (string-match org-table-range-regexp form)
 878                (> (length (match-string 0 form)) 1))
 879           (save-match-data
 880             (org-table-get-range (match-string 0 form) (point) 1))
 881         form))))
 882
 883 (provide 'org-R)