Commit | Line | Data |
---|---|---|
86fbb8ca CD |
1 | ;;; ob-R.el --- org-babel functions for R code evaluation |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2009-2014 Free Software Foundation, Inc. |
86fbb8ca | 4 | |
c7557a0f GM |
5 | ;; Author: Eric Schulte |
6 | ;; Dan Davison | |
86fbb8ca CD |
7 | ;; Keywords: literate programming, reproducible research, R, statistics |
8 | ;; Homepage: http://orgmode.org | |
86fbb8ca CD |
9 | |
10 | ;; This file is part of GNU Emacs. | |
11 | ||
12 | ;; GNU Emacs 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 of the License, or | |
15 | ;; (at your option) any later version. | |
16 | ||
17 | ;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. | |
24 | ||
25 | ;;; Commentary: | |
26 | ||
27 | ;; Org-Babel support for evaluating R code | |
28 | ||
29 | ;;; Code: | |
30 | (require 'ob) | |
86fbb8ca CD |
31 | (eval-when-compile (require 'cl)) |
32 | ||
f1eee0b6 | 33 | (declare-function orgtbl-to-tsv "org-table" (table params)) |
86fbb8ca CD |
34 | (declare-function R "ext:essd-r" (&optional start-args)) |
35 | (declare-function inferior-ess-send-input "ext:ess-inf" ()) | |
afe98dfa CD |
36 | (declare-function ess-make-buffer-current "ext:ess-inf" ()) |
37 | (declare-function ess-eval-buffer "ext:ess-inf" (vis)) | |
38 | (declare-function org-number-sequence "org-compat" (from &optional to inc)) | |
8223b1d2 | 39 | (declare-function org-remove-if-not "org" (predicate seq)) |
86fbb8ca | 40 | |
8223b1d2 BG |
41 | (defconst org-babel-header-args:R |
42 | '((width . :any) | |
43 | (height . :any) | |
44 | (bg . :any) | |
45 | (units . :any) | |
46 | (pointsize . :any) | |
47 | (antialias . :any) | |
48 | (quality . :any) | |
49 | (compression . :any) | |
50 | (res . :any) | |
51 | (type . :any) | |
52 | (family . :any) | |
53 | (title . :any) | |
54 | (fonts . :any) | |
55 | (version . :any) | |
56 | (paper . :any) | |
57 | (encoding . :any) | |
58 | (pagecentre . :any) | |
59 | (colormodel . :any) | |
60 | (useDingbats . :any) | |
61 | (horizontal . :any) | |
62 | (results . ((file list vector table scalar verbatim) | |
63 | (raw org html latex code pp wrap) | |
64 | (replace silent append prepend) | |
65 | (output value graphics)))) | |
86fbb8ca CD |
66 | "R-specific header arguments.") |
67 | ||
68 | (defvar org-babel-default-header-args:R '()) | |
69 | ||
8223b1d2 BG |
70 | (defcustom org-babel-R-command "R --slave --no-save" |
71 | "Name of command to use for executing R code." | |
72 | :group 'org-babel | |
73 | :version "24.1" | |
74 | :type 'string) | |
86fbb8ca | 75 | |
8223b1d2 | 76 | (defvar ess-local-process-name) ; dynamically scoped |
3ab2c837 BG |
77 | (defun org-babel-edit-prep:R (info) |
78 | (let ((session (cdr (assoc :session (nth 2 info))))) | |
79 | (when (and session (string-match "^\\*\\(.+?\\)\\*$" session)) | |
8223b1d2 | 80 | (save-match-data (org-babel-R-initiate-session session nil))))) |
3ab2c837 BG |
81 | |
82 | (defun org-babel-expand-body:R (body params &optional graphics-file) | |
86fbb8ca | 83 | "Expand BODY according to PARAMS, return the expanded body." |
3ab2c837 BG |
84 | (let ((graphics-file |
85 | (or graphics-file (org-babel-R-graphical-output-file params)))) | |
afe98dfa CD |
86 | (mapconcat |
87 | #'identity | |
666ffc7e SM |
88 | (let ((inside |
89 | (append | |
90 | (when (cdr (assoc :prologue params)) | |
91 | (list (cdr (assoc :prologue params)))) | |
92 | (org-babel-variable-assignments:R params) | |
93 | (list body) | |
94 | (when (cdr (assoc :epilogue params)) | |
95 | (list (cdr (assoc :epilogue params))))))) | |
96 | (if graphics-file | |
97 | (append | |
98 | (list (org-babel-R-construct-graphics-device-call | |
99 | graphics-file params)) | |
100 | inside | |
101 | (list "dev.off()")) | |
102 | inside)) | |
103 | "\n"))) | |
86fbb8ca CD |
104 | |
105 | (defun org-babel-execute:R (body params) | |
106 | "Execute a block of R code. | |
107 | This function is called by `org-babel-execute-src-block'." | |
108 | (save-excursion | |
e66ba1df BG |
109 | (let* ((result-params (cdr (assoc :result-params params))) |
110 | (result-type (cdr (assoc :result-type params))) | |
86fbb8ca | 111 | (session (org-babel-R-initiate-session |
afe98dfa | 112 | (cdr (assoc :session params)) params)) |
86fbb8ca CD |
113 | (colnames-p (cdr (assoc :colnames params))) |
114 | (rownames-p (cdr (assoc :rownames params))) | |
3ab2c837 BG |
115 | (graphics-file (org-babel-R-graphical-output-file params)) |
116 | (full-body (org-babel-expand-body:R body params graphics-file)) | |
86fbb8ca CD |
117 | (result |
118 | (org-babel-R-evaluate | |
e66ba1df | 119 | session full-body result-type result-params |
86fbb8ca | 120 | (or (equal "yes" colnames-p) |
afe98dfa CD |
121 | (org-babel-pick-name |
122 | (cdr (assoc :colname-names params)) colnames-p)) | |
86fbb8ca | 123 | (or (equal "yes" rownames-p) |
afe98dfa CD |
124 | (org-babel-pick-name |
125 | (cdr (assoc :rowname-names params)) rownames-p))))) | |
3ab2c837 | 126 | (if graphics-file nil result)))) |
86fbb8ca CD |
127 | |
128 | (defun org-babel-prep-session:R (session params) | |
129 | "Prepare SESSION according to the header arguments specified in PARAMS." | |
130 | (let* ((session (org-babel-R-initiate-session session params)) | |
afe98dfa | 131 | (var-lines (org-babel-variable-assignments:R params))) |
86fbb8ca CD |
132 | (org-babel-comint-in-buffer session |
133 | (mapc (lambda (var) | |
134 | (end-of-line 1) (insert var) (comint-send-input nil t) | |
135 | (org-babel-comint-wait-for-output session)) var-lines)) | |
136 | session)) | |
137 | ||
138 | (defun org-babel-load-session:R (session body params) | |
139 | "Load BODY into SESSION." | |
140 | (save-window-excursion | |
141 | (let ((buffer (org-babel-prep-session:R session params))) | |
142 | (with-current-buffer buffer | |
143 | (goto-char (process-mark (get-buffer-process (current-buffer)))) | |
144 | (insert (org-babel-chomp body))) | |
145 | buffer))) | |
146 | ||
147 | ;; helper functions | |
148 | ||
afe98dfa | 149 | (defun org-babel-variable-assignments:R (params) |
8223b1d2 | 150 | "Return list of R statements assigning the block's variables." |
afe98dfa CD |
151 | (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) |
152 | (mapcar | |
153 | (lambda (pair) | |
154 | (org-babel-R-assign-elisp | |
155 | (car pair) (cdr pair) | |
156 | (equal "yes" (cdr (assoc :colnames params))) | |
157 | (equal "yes" (cdr (assoc :rownames params))))) | |
158 | (mapcar | |
159 | (lambda (i) | |
160 | (cons (car (nth i vars)) | |
161 | (org-babel-reassemble-table | |
162 | (cdr (nth i vars)) | |
163 | (cdr (nth i (cdr (assoc :colname-names params)))) | |
164 | (cdr (nth i (cdr (assoc :rowname-names params))))))) | |
165 | (org-number-sequence 0 (1- (length vars))))))) | |
166 | ||
86fbb8ca CD |
167 | (defun org-babel-R-quote-tsv-field (s) |
168 | "Quote field S for export to R." | |
169 | (if (stringp s) | |
170 | (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"") | |
171 | (format "%S" s))) | |
172 | ||
173 | (defun org-babel-R-assign-elisp (name value colnames-p rownames-p) | |
174 | "Construct R code assigning the elisp VALUE to a variable named NAME." | |
175 | (if (listp value) | |
8223b1d2 BG |
176 | (let ((max (apply #'max (mapcar #'length (org-remove-if-not |
177 | #'sequencep value)))) | |
178 | (min (apply #'min (mapcar #'length (org-remove-if-not | |
179 | #'sequencep value)))) | |
180 | (transition-file (org-babel-temp-file "R-import-"))) | |
86fbb8ca CD |
181 | ;; ensure VALUE has an orgtbl structure (depth of at least 2) |
182 | (unless (listp (car value)) (setq value (list value))) | |
afe98dfa | 183 | (with-temp-file transition-file |
8223b1d2 BG |
184 | (insert |
185 | (orgtbl-to-tsv value '(:fmt org-babel-R-quote-tsv-field)) | |
186 | "\n")) | |
187 | (let ((file (org-babel-process-file-name transition-file 'noquote)) | |
188 | (header (if (or (eq (nth 1 value) 'hline) colnames-p) | |
189 | "TRUE" "FALSE")) | |
190 | (row-names (if rownames-p "1" "NULL"))) | |
191 | (if (= max min) | |
192 | (format "%s <- read.table(\"%s\", | |
193 | header=%s, | |
194 | row.names=%s, | |
195 | sep=\"\\t\", | |
196 | as.is=TRUE)" name file header row-names) | |
197 | (format "%s <- read.table(\"%s\", | |
198 | header=%s, | |
199 | row.names=%s, | |
200 | sep=\"\\t\", | |
201 | as.is=TRUE, | |
202 | fill=TRUE, | |
203 | col.names = paste(\"V\", seq_len(%d), sep =\"\"))" | |
204 | name file header row-names max)))) | |
86fbb8ca CD |
205 | (format "%s <- %s" name (org-babel-R-quote-tsv-field value)))) |
206 | ||
8223b1d2 | 207 | (defvar ess-ask-for-ess-directory) ; dynamically scoped |
86fbb8ca CD |
208 | (defun org-babel-R-initiate-session (session params) |
209 | "If there is not a current R process then create one." | |
210 | (unless (string= session "none") | |
211 | (let ((session (or session "*R*")) | |
afe98dfa | 212 | (ess-ask-for-ess-directory |
8223b1d2 BG |
213 | (and (and (boundp 'ess-ask-for-ess-directory) ess-ask-for-ess-directory) |
214 | (not (cdr (assoc :dir params)))))) | |
86fbb8ca CD |
215 | (if (org-babel-comint-buffer-livep session) |
216 | session | |
217 | (save-window-excursion | |
271672fa BG |
218 | (when (get-buffer session) |
219 | ;; Session buffer exists, but with dead process | |
220 | (set-buffer session)) | |
86fbb8ca CD |
221 | (require 'ess) (R) |
222 | (rename-buffer | |
223 | (if (bufferp session) | |
224 | (buffer-name session) | |
225 | (if (stringp session) | |
226 | session | |
227 | (buffer-name)))) | |
228 | (current-buffer)))))) | |
229 | ||
afe98dfa CD |
230 | (defun org-babel-R-associate-session (session) |
231 | "Associate R code buffer with an R session. | |
232 | Make SESSION be the inferior ESS process associated with the | |
233 | current code buffer." | |
234 | (setq ess-local-process-name | |
235 | (process-name (get-buffer-process session))) | |
236 | (ess-make-buffer-current)) | |
237 | ||
3ab2c837 BG |
238 | (defun org-babel-R-graphical-output-file (params) |
239 | "Name of file to which R should send graphical output." | |
240 | (and (member "graphics" (cdr (assq :result-params params))) | |
241 | (cdr (assq :file params)))) | |
242 | ||
271672fa BG |
243 | (defvar org-babel-R-graphics-devices |
244 | '((:bmp "bmp" "filename") | |
245 | (:jpg "jpeg" "filename") | |
246 | (:jpeg "jpeg" "filename") | |
247 | (:tikz "tikz" "file") | |
248 | (:tiff "tiff" "filename") | |
249 | (:png "png" "filename") | |
250 | (:svg "svg" "file") | |
251 | (:pdf "pdf" "file") | |
252 | (:ps "postscript" "file") | |
253 | (:postscript "postscript" "file")) | |
254 | "An alist mapping graphics file types to R functions. | |
255 | ||
256 | Each member of this list is a list with three members: | |
257 | 1. the file extension of the graphics file, as an elisp :keyword | |
258 | 2. the R graphics device function to call to generate such a file | |
259 | 3. the name of the argument to this function which specifies the | |
260 | file to write to (typically \"file\" or \"filename\")") | |
261 | ||
86fbb8ca CD |
262 | (defun org-babel-R-construct-graphics-device-call (out-file params) |
263 | "Construct the call to the graphics device." | |
271672fa BG |
264 | (let* ((allowed-args '(:width :height :bg :units :pointsize |
265 | :antialias :quality :compression :res | |
266 | :type :family :title :fonts :version | |
267 | :paper :encoding :pagecentre :colormodel | |
268 | :useDingbats :horizontal)) | |
269 | (device (and (string-match ".+\\.\\([^.]+\\)" out-file) | |
270 | (match-string 1 out-file))) | |
271 | (device-info (or (assq (intern (concat ":" device)) | |
272 | org-babel-R-graphics-devices) | |
273 | (assq :png org-babel-R-graphics-devices))) | |
274 | (extra-args (cdr (assq :R-dev-args params))) filearg args) | |
275 | (setq device (nth 1 device-info)) | |
276 | (setq filearg (nth 2 device-info)) | |
86fbb8ca CD |
277 | (setq args (mapconcat |
278 | (lambda (pair) | |
279 | (if (member (car pair) allowed-args) | |
8223b1d2 | 280 | (format ",%s=%S" |
86fbb8ca CD |
281 | (substring (symbol-name (car pair)) 1) |
282 | (cdr pair)) "")) | |
283 | params "")) | |
284 | (format "%s(%s=\"%s\"%s%s%s)" | |
285 | device filearg out-file args | |
286 | (if extra-args "," "") (or extra-args "")))) | |
287 | ||
288 | (defvar org-babel-R-eoe-indicator "'org_babel_R_eoe'") | |
289 | (defvar org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"") | |
3ab2c837 BG |
290 | |
291 | (defvar org-babel-R-write-object-command "{function(object,transfer.file){object;invisible(if(inherits(try({tfile<-tempfile();write.table(object,file=tfile,sep=\"\\t\",na=\"nil\",row.names=%s,col.names=%s,quote=FALSE);file.rename(tfile,transfer.file)},silent=TRUE),\"try-error\")){if(!file.exists(transfer.file))file.create(transfer.file)})}}(object=%s,transfer.file=\"%s\")") | |
86fbb8ca CD |
292 | |
293 | (defun org-babel-R-evaluate | |
e66ba1df | 294 | (session body result-type result-params column-names-p row-names-p) |
afe98dfa CD |
295 | "Evaluate R code in BODY." |
296 | (if session | |
297 | (org-babel-R-evaluate-session | |
e66ba1df | 298 | session body result-type result-params column-names-p row-names-p) |
afe98dfa | 299 | (org-babel-R-evaluate-external-process |
e66ba1df | 300 | body result-type result-params column-names-p row-names-p))) |
afe98dfa CD |
301 | |
302 | (defun org-babel-R-evaluate-external-process | |
e66ba1df | 303 | (body result-type result-params column-names-p row-names-p) |
afe98dfa CD |
304 | "Evaluate BODY in external R process. |
305 | If RESULT-TYPE equals 'output then return standard output as a | |
8223b1d2 | 306 | string. If RESULT-TYPE equals 'value then return the value of the |
afe98dfa CD |
307 | last statement in BODY, as elisp." |
308 | (case result-type | |
309 | (value | |
310 | (let ((tmp-file (org-babel-temp-file "R-"))) | |
311 | (org-babel-eval org-babel-R-command | |
312 | (format org-babel-R-write-object-command | |
313 | (if row-names-p "TRUE" "FALSE") | |
314 | (if column-names-p | |
315 | (if row-names-p "NA" "TRUE") | |
316 | "FALSE") | |
317 | (format "{function ()\n{\n%s\n}}()" body) | |
318 | (org-babel-process-file-name tmp-file 'noquote))) | |
319 | (org-babel-R-process-value-result | |
271672fa BG |
320 | (org-babel-result-cond result-params |
321 | (with-temp-buffer | |
322 | (insert-file-contents tmp-file) | |
323 | (buffer-string)) | |
e66ba1df BG |
324 | (org-babel-import-elisp-from-file tmp-file '(16))) |
325 | column-names-p))) | |
afe98dfa CD |
326 | (output (org-babel-eval org-babel-R-command body)))) |
327 | ||
666ffc7e SM |
328 | (defvar ess-eval-visibly-p) |
329 | ||
afe98dfa | 330 | (defun org-babel-R-evaluate-session |
e66ba1df | 331 | (session body result-type result-params column-names-p row-names-p) |
afe98dfa CD |
332 | "Evaluate BODY in SESSION. |
333 | If RESULT-TYPE equals 'output then return standard output as a | |
8223b1d2 | 334 | string. If RESULT-TYPE equals 'value then return the value of the |
afe98dfa CD |
335 | last statement in BODY, as elisp." |
336 | (case result-type | |
337 | (value | |
338 | (with-temp-buffer | |
339 | (insert (org-babel-chomp body)) | |
340 | (let ((ess-local-process-name | |
153ae947 BG |
341 | (process-name (get-buffer-process session))) |
342 | (ess-eval-visibly-p nil)) | |
afe98dfa CD |
343 | (ess-eval-buffer nil))) |
344 | (let ((tmp-file (org-babel-temp-file "R-"))) | |
345 | (org-babel-comint-eval-invisibly-and-wait-for-file | |
346 | session tmp-file | |
347 | (format org-babel-R-write-object-command | |
348 | (if row-names-p "TRUE" "FALSE") | |
349 | (if column-names-p | |
350 | (if row-names-p "NA" "TRUE") | |
351 | "FALSE") | |
352 | ".Last.value" (org-babel-process-file-name tmp-file 'noquote))) | |
353 | (org-babel-R-process-value-result | |
271672fa BG |
354 | (org-babel-result-cond result-params |
355 | (with-temp-buffer | |
356 | (insert-file-contents tmp-file) | |
357 | (buffer-string)) | |
e66ba1df BG |
358 | (org-babel-import-elisp-from-file tmp-file '(16))) |
359 | column-names-p))) | |
afe98dfa CD |
360 | (output |
361 | (mapconcat | |
362 | #'org-babel-chomp | |
363 | (butlast | |
364 | (delq nil | |
365 | (mapcar | |
acedf35c CD |
366 | (lambda (line) (when (> (length line) 0) line)) |
367 | (mapcar | |
368 | (lambda (line) ;; cleanup extra prompts left in output | |
369 | (if (string-match | |
e66ba1df | 370 | "^\\([ ]*[>+\\.][ ]?\\)+\\([[0-9]+\\|[ ]\\)" line) |
acedf35c CD |
371 | (substring line (match-end 1)) |
372 | line)) | |
373 | (org-babel-comint-with-output (session org-babel-R-eoe-output) | |
374 | (insert (mapconcat #'org-babel-chomp | |
375 | (list body org-babel-R-eoe-indicator) | |
376 | "\n")) | |
377 | (inferior-ess-send-input)))))) "\n")))) | |
86fbb8ca CD |
378 | |
379 | (defun org-babel-R-process-value-result (result column-names-p) | |
380 | "R-specific processing of return value. | |
381 | Insert hline if column names in output have been requested." | |
382 | (if column-names-p | |
383 | (cons (car result) (cons 'hline (cdr result))) | |
384 | result)) | |
385 | ||
386 | (provide 'ob-R) | |
387 | ||
5b409b39 | 388 | |
86fbb8ca CD |
389 | |
390 | ;;; ob-R.el ends here |