contrib/babel/lisp/langs/org-babel-R.el

   1 ;;; org-babel-R.el --- org-babel functions for R code evaluation
   2
   3 ;; Copyright (C) 2009 Eric Schulte
   4
   5 ;; Author: Eric Schulte
   6 ;; Keywords: literate programming, reproducible research, R, statistics
   7 ;; Homepage: http://orgmode.org
   8 ;; Version: 0.01
   9
  10 ;;; License:
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16 ;;
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Org-Babel support for evaluating R code
  30
  31 ;;; Code:
  32 (require 'org-babel)
  33
  34 (org-babel-add-interpreter "R")
  35
  36 (add-to-list 'org-babel-tangle-langs '("R" "R" "#!/usr/bin/env Rscript"))
  37
  38 (defun org-babel-execute:R (body params)
  39   "Execute a block of R code with org-babel.  This function is
  40 called by `org-babel-execute-src-block'."
  41   (message "executing R source code block...")
  42   (save-excursion
  43     (let* ((processed-params (org-babel-process-params params))
  44            (result-type (fourth processed-params))
  45            (session (org-babel-R-initiate-session (first processed-params) params))
  46            (vars (mapcar (lambda (i) (cons (car (nth i (second processed-params)))
  47                                            (org-babel-reassemble-table
  48                                             (cdr (nth i (second processed-params)))
  49                                             (cdr (nth i (fifth processed-params)))
  50                                             (cdr (nth i (sixth processed-params))))))
  51                          (number-sequence 0 (1- (length (second processed-params))))))
  52            (colnames-p (and (cdr (assoc :colnames params))
  53                                 (string= "yes" (cdr (assoc :colnames params)))))
  54            (rownames-p (and (cdr (assoc :rownames params))
  55                                 (string= "yes" (cdr (assoc :rownames params)))))
  56            (out-file (cdr (assoc :file params)))
  57            (augmented-body
  58             (concat
  59              (if out-file (concat (org-babel-R-construct-graphics-device-call out-file params) "\n") "")
  60              (mapconcat ;; define any variables
  61               (lambda (pair) (org-babel-R-assign-elisp (car pair) (cdr pair) colnames-p rownames-p)) vars "\n")
  62              "\n" body "\n" (if out-file "dev.off()\n" "")))
  63            (result (org-babel-R-evaluate session augmented-body result-type colnames-p rownames-p)))
  64       (or out-file result))))
  65
  66 (defun org-babel-prep-session:R (session params)
  67   "Prepare SESSION according to the header arguments specified in PARAMS."
  68   (let* ((session (org-babel-R-initiate-session session params))
  69          (vars (org-babel-ref-variables params))
  70          (var-lines
  71           (mapcar
  72            (lambda (pair) (org-babel-R-assign-elisp
  73                            (car pair) (cdr pair)
  74                            (equal (cdr (assoc :colnames params)) "yes")
  75                            (equal (cdr (assoc :rownames params)) "yes")))
  76            vars)))
  77     (org-babel-comint-in-buffer session
  78       (mapc (lambda (var)
  79               (move-end-of-line 1) (insert var) (comint-send-input nil t)
  80               (org-babel-comint-wait-for-output session)) var-lines))
  81     session))
  82
  83 (defun org-babel-load-session:R (session body params)
  84   "Load BODY into SESSION."
  85   (save-window-excursion
  86     (let ((buffer (org-babel-prep-session:R session params)))
  87       (with-current-buffer buffer
  88         (goto-char (process-mark (get-buffer-process (current-buffer))))
  89         (insert (org-babel-chomp body)))
  90       buffer)))
  91
  92 ;; helper functions
  93
  94 (defun org-babel-R-quote-tsv-field (s)
  95   "Quote field S for export to R."
  96   (if (stringp s)
  97       (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"")
  98     (format "%S" s)))
  99
 100 (defun org-babel-R-assign-elisp (name value colnames-p rownames-p)
 101   "Construct R code assigning the elisp VALUE to a variable named NAME."
 102   (if (listp value)
 103       (let ((transition-file (make-temp-file "org-babel-R-import")))
 104         ;; ensure VALUE has an orgtbl structure (depth of at least 2)
 105         (unless (listp (car value)) (setq value (list value)))
 106         (with-temp-file (org-babel-maybe-remote-file transition-file)
 107           (insert (orgtbl-to-tsv value '(:fmt org-babel-R-quote-tsv-field)))
 108           (insert "\n"))
 109         (format "%s <- read.table(\"%s\", header=%s, row.names=%s, sep=\"\\t\", as.is=TRUE)"
 110                 name transition-file
 111                 (if (and (eq (second value) 'hline) colnames-p) "TRUE" "FALSE")
 112                 (if rownames-p "1" "NULL")))
 113     (format "%s <- %s" name (org-babel-R-quote-tsv-field value))))
 114
 115 (defun org-babel-R-initiate-session (session params)
 116   "If there is not a current R process then create one."
 117   (unless (string= session "none")
 118     (let ((session (or session "*R*"))
 119           (ess-ask-for-ess-directory (not (cdr (assoc :dir params)))))
 120       (if (org-babel-comint-buffer-livep session)
 121           session
 122         (save-window-excursion
 123           (R)
 124           (rename-buffer (if (bufferp session) (buffer-name session)
 125                            (if (stringp session) session (buffer-name)))) (current-buffer))))))
 126
 127 (defun org-babel-R-construct-graphics-device-call (out-file params)
 128   "Construct the call to the graphics device"
 129   (let ((devices
 130          '((:bmp . "bmp")
 131            (:jpg . "jpeg")
 132            (:jpeg . "jpeg")
 133            (:tiff . "tiff")
 134            (:png . "png")
 135            (:svg . "svg")
 136            (:pdf . "pdf")
 137            (:ps . "postscript")
 138            (:postscript . "postscript")))
 139         (allowed-args '(:width :height :bg :units :pointsize
 140                                :antialias :quality :compression :res :type
 141                                :family :title :fonts :version :paper :encoding
 142                                :pagecentre :colormodel :useDingbats :horizontal))
 143         (device (and (string-match ".+\\.\\([^.]+\\)" out-file) (match-string 1 out-file)))
 144         (extra-args (cdr (assq :R-dev-args params))) filearg args)
 145     (setq device (or (and device (cdr (assq (intern (concat ":" device)) devices))) "png"))
 146     (setq filearg (if (member device '("pdf" "postscript" "svg")) "file" "filename"))
 147     (setq args (mapconcat (lambda (pair)
 148                             (if (member (car pair) allowed-args)
 149                                 (format ",%s=%s" (substring (symbol-name (car pair)) 1) (cdr pair)) ""))
 150                           params ""))
 151     (format "%s(%s=\"%s\"%s%s%s)\n" device filearg out-file args (if extra-args "," "") (or extra-args ""))))
 152
 153 (defvar org-babel-R-eoe-indicator "'org_babel_R_eoe'")
 154 (defvar org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"")
 155 (defvar org-babel-R-wrapper-method "main <- function ()\n{\n%s\n}
 156 write.table(main(), file=\"%s\", sep=\"\\t\", na=\"nil\",row.names=%s, col.names=%s, quote=FALSE)")
 157
 158 (defun org-babel-R-evaluate (session body result-type column-names-p row-names-p)
 159   "Pass BODY to the R process in SESSION.  If RESULT-TYPE equals
 160 'output then return a list of the outputs of the statements in
 161 BODY, if RESULT-TYPE equals 'value then return the value of the
 162 last statement in BODY, as elisp."
 163   (if (not session)
 164       ;; external process evaluation
 165       (case result-type
 166         (output
 167          (with-temp-buffer
 168            (insert body)
 169            (org-babel-shell-command-on-region (point-min) (point-max) "R --slave --no-save" 'current-buffer 'replace)
 170            (buffer-string)))
 171         (value
 172          (let* ((tmp-file (make-temp-file "R-out-functional-results")) exit-code
 173                 (stderr
 174                  (with-temp-buffer
 175                    (insert (format org-babel-R-wrapper-method
 176                                    body tmp-file (if row-names-p "TRUE" "FALSE") (if column-names-p (if row-names-p "NA" "TRUE") "FALSE")))
 177                    (setq exit-code (org-babel-shell-command-on-region
 178                                     (point-min) (point-max) "R --no-save" nil 'replace (current-buffer)))
 179                    (buffer-string))))
 180            (if (> exit-code 0) (org-babel-error-notify exit-code stderr))
 181            (org-babel-R-process-value-result
 182             (org-babel-import-elisp-from-file (org-babel-maybe-remote-file tmp-file))
 183             column-names-p))))
 184     ;; comint session evaluation
 185     (org-babel-comint-in-buffer session
 186       (let* ((tmp-file (make-temp-file "org-babel-R"))
 187              (full-body
 188               (case result-type
 189                 (value
 190                  (mapconcat #'org-babel-chomp (list body
 191                                                     (format "write.table(.Last.value, file=\"%s\", sep=\"\\t\", na=\"nil\",row.names=%s, col.names=%s, quote=FALSE)" tmp-file (if row-names-p "TRUE" "FALSE") (if column-names-p  (if row-names-p "NA" "TRUE") "FALSE"))
 192                                                     org-babel-R-eoe-indicator) "\n"))
 193                 (output
 194                  (mapconcat #'org-babel-chomp (list body org-babel-R-eoe-indicator) "\n"))))
 195              (raw (org-babel-comint-with-output session org-babel-R-eoe-output nil
 196                     (insert full-body) (inferior-ess-send-input)))
 197              (comint-prompt-regexp
 198               (concat "^\\("
 199                       inferior-ess-primary-prompt
 200                       "\\|"
 201                       inferior-ess-secondary-prompt
 202                       "\\)*"))
 203              broke results)
 204         (case result-type
 205           (value (org-babel-R-process-value-result
 206                   (org-babel-import-elisp-from-file
 207                    (org-babel-maybe-remote-file tmp-file))
 208                   column-names-p))
 209           (output
 210            (flet ((extractor
 211                    (el)
 212                    (if (or broke
 213                            (and (string-match (regexp-quote org-babel-R-eoe-output) el)
 214                                 (setq broke t)))
 215                        nil
 216                      (if (= (length el) 0)
 217                          nil
 218                        (if (string-match comint-prompt-regexp el)
 219                            (substring el (match-end 0))
 220                          el)))))
 221              (mapconcat
 222               #'identity
 223               (delete nil (mapcar #'extractor (mapcar #'org-babel-chomp raw))) "\n"))))))))
 224
 225 (defun org-babel-R-process-value-result (result column-names-p)
 226   "R-specific processing of return value prior to return to org-babel.
 227
 228 Currently, insert hline if column names in output have been requested."
 229   (if column-names-p
 230       (cons (car result) (cons 'hline (cdr result)))
 231     result))
 232
 233
 234 (provide 'org-babel-R)
 235 ;;; org-babel-R.el ends here