| commit | author | age | ||
| 76bbd0 | 1 | ;;; ob-R.el --- Babel Functions for R -*- lexical-binding: t; -*- |
| C | 2 | |
| 3 | ;; Copyright (C) 2009-2018 Free Software Foundation, Inc. | |
| 4 | ||
| 5 | ;; Author: Eric Schulte | |
| 6 | ;; Dan Davison | |
| 7 | ;; Keywords: literate programming, reproducible research, R, statistics | |
| 8 | ;; Homepage: https://orgmode.org | |
| 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 <https://www.gnu.org/licenses/>. | |
| 24 | ||
| 25 | ;;; Commentary: | |
| 26 | ||
| 27 | ;; Org-Babel support for evaluating R code | |
| 28 | ||
| 29 | ;;; Code: | |
| 30 | ||
| 31 | (require 'cl-lib) | |
| 32 | (require 'ob) | |
| 33 | ||
| 34 | (declare-function orgtbl-to-tsv "org-table" (table params)) | |
| 35 | (declare-function R "ext:essd-r" (&optional start-args)) | |
| 36 | (declare-function inferior-ess-send-input "ext:ess-inf" ()) | |
| 37 | (declare-function ess-make-buffer-current "ext:ess-inf" ()) | |
| 38 | (declare-function ess-eval-buffer "ext:ess-inf" (vis)) | |
| 39 | (declare-function ess-wait-for-process "ext:ess-inf" | |
| 40 | (&optional proc sec-prompt wait force-redisplay)) | |
| 41 | ||
| 42 | (defconst org-babel-header-args:R | |
| 43 | '((width . :any) | |
| 44 | (height . :any) | |
| 45 | (bg . :any) | |
| 46 | (units . :any) | |
| 47 | (pointsize . :any) | |
| 48 | (antialias . :any) | |
| 49 | (quality . :any) | |
| 50 | (compression . :any) | |
| 51 | (res . :any) | |
| 52 | (type . :any) | |
| 53 | (family . :any) | |
| 54 | (title . :any) | |
| 55 | (fonts . :any) | |
| 56 | (version . :any) | |
| 57 | (paper . :any) | |
| 58 | (encoding . :any) | |
| 59 | (pagecentre . :any) | |
| 60 | (colormodel . :any) | |
| 61 | (useDingbats . :any) | |
| 62 | (horizontal . :any) | |
| 63 | (results . ((file list vector table scalar verbatim) | |
| 64 | (raw html latex org code pp drawer) | |
| 65 | (replace silent none append prepend) | |
| 66 | (output value graphics)))) | |
| 67 | "R-specific header arguments.") | |
| 68 | ||
| 69 | (defconst ob-R-safe-header-args | |
| 70 | (append org-babel-safe-header-args | |
| 71 | '(:width :height :bg :units :pointsize :antialias :quality | |
| 72 | :compression :res :type :family :title :fonts | |
| 73 | :version :paper :encoding :pagecentre :colormodel | |
| 74 | :useDingbats :horizontal)) | |
| 75 | "Header args which are safe for R babel blocks. | |
| 76 | ||
| 77 | See `org-babel-safe-header-args' for documentation of the format of | |
| 78 | this variable.") | |
| 79 | ||
| 80 | (defvar org-babel-default-header-args:R '()) | |
| 81 | (put 'org-babel-default-header-args:R 'safe-local-variable | |
| 82 | (org-babel-header-args-safe-fn ob-R-safe-header-args)) | |
| 83 | ||
| 84 | (defcustom org-babel-R-command "R --slave --no-save" | |
| 85 | "Name of command to use for executing R code." | |
| 86 | :group 'org-babel | |
| 87 | :version "24.1" | |
| 88 | :type 'string) | |
| 89 | ||
| 90 | (defvar ess-current-process-name) ; dynamically scoped | |
| 91 | (defvar ess-local-process-name) ; dynamically scoped | |
| 92 | (defun org-babel-edit-prep:R (info) | |
| 93 | (let ((session (cdr (assq :session (nth 2 info))))) | |
| 94 | (when (and session | |
| 95 | (string-prefix-p "*" session) | |
| 96 | (string-suffix-p "*" session)) | |
| 97 | (org-babel-R-initiate-session session nil)))) | |
| 98 | ||
| 99 | ;; The usage of utils::read.table() ensures that the command | |
| 100 | ;; read.table() can be found even in circumstances when the utils | |
| 101 | ;; package is not in the search path from R. | |
| 102 | (defconst ob-R-transfer-variable-table-with-header | |
| 103 | "%s <- local({ | |
| 104 | con <- textConnection( | |
| 105 | %S | |
| 106 | ) | |
| 107 | res <- utils::read.table( | |
| 108 | con, | |
| 109 | header = %s, | |
| 110 | row.names = %s, | |
| 111 | sep = \"\\t\", | |
| 112 | as.is = TRUE | |
| 113 | ) | |
| 114 | close(con) | |
| 115 | res | |
| 116 | })" | |
| 117 | "R code used to transfer a table defined as a variable from org to R. | |
| 118 | ||
| 119 | This function is used when the table contains a header.") | |
| 120 | ||
| 121 | (defconst ob-R-transfer-variable-table-without-header | |
| 122 | "%s <- local({ | |
| 123 | con <- textConnection( | |
| 124 | %S | |
| 125 | ) | |
| 126 | res <- utils::read.table( | |
| 127 | con, | |
| 128 | header = %s, | |
| 129 | row.names = %s, | |
| 130 | sep = \"\\t\", | |
| 131 | as.is = TRUE, | |
| 132 | fill = TRUE, | |
| 133 | col.names = paste(\"V\", seq_len(%d), sep =\"\") | |
| 134 | ) | |
| 135 | close(con) | |
| 136 | res | |
| 137 | })" | |
| 138 | "R code used to transfer a table defined as a variable from org to R. | |
| 139 | ||
| 140 | This function is used when the table does not contain a header.") | |
| 141 | ||
| 142 | (defun org-babel-expand-body:R (body params &optional _graphics-file) | |
| 143 | "Expand BODY according to PARAMS, return the expanded body." | |
| 144 | (mapconcat 'identity | |
| 145 | (append | |
| 146 | (when (cdr (assq :prologue params)) | |
| 147 | (list (cdr (assq :prologue params)))) | |
| 148 | (org-babel-variable-assignments:R params) | |
| 149 | (list body) | |
| 150 | (when (cdr (assq :epilogue params)) | |
| 151 | (list (cdr (assq :epilogue params))))) | |
| 152 | "\n")) | |
| 153 | ||
| 154 | (defun org-babel-execute:R (body params) | |
| 155 | "Execute a block of R code. | |
| 156 | This function is called by `org-babel-execute-src-block'." | |
| 157 | (save-excursion | |
| 158 | (let* ((result-params (cdr (assq :result-params params))) | |
| 159 | (result-type (cdr (assq :result-type params))) | |
| 160 | (session (org-babel-R-initiate-session | |
| 161 | (cdr (assq :session params)) params)) | |
| 162 | (graphics-file (and (member "graphics" (assq :result-params params)) | |
| 163 | (org-babel-graphical-output-file params))) | |
| 164 | (colnames-p (unless graphics-file (cdr (assq :colnames params)))) | |
| 165 | (rownames-p (unless graphics-file (cdr (assq :rownames params)))) | |
| 166 | (full-body | |
| 167 | (let ((inside | |
| 168 | (list (org-babel-expand-body:R body params graphics-file)))) | |
| 169 | (mapconcat 'identity | |
| 170 | (if graphics-file | |
| 171 | (append | |
| 172 | (list (org-babel-R-construct-graphics-device-call | |
| 173 | graphics-file params)) | |
| 174 | inside | |
| 175 | (list "},error=function(e){plot(x=-1:1, y=-1:1, type='n', xlab='', ylab='', axes=FALSE); text(x=0, y=0, labels=e$message, col='red'); paste('ERROR', e$message, sep=' : ')}); dev.off()")) | |
| 176 | inside) | |
| 177 | "\n"))) | |
| 178 | (result | |
| 179 | (org-babel-R-evaluate | |
| 180 | session full-body result-type result-params | |
| 181 | (or (equal "yes" colnames-p) | |
| 182 | (org-babel-pick-name | |
| 183 | (cdr (assq :colname-names params)) colnames-p)) | |
| 184 | (or (equal "yes" rownames-p) | |
| 185 | (org-babel-pick-name | |
| 186 | (cdr (assq :rowname-names params)) rownames-p))))) | |
| 187 | (if graphics-file nil result)))) | |
| 188 | ||
| 189 | (defun org-babel-prep-session:R (session params) | |
| 190 | "Prepare SESSION according to the header arguments specified in PARAMS." | |
| 191 | (let* ((session (org-babel-R-initiate-session session params)) | |
| 192 | (var-lines (org-babel-variable-assignments:R params))) | |
| 193 | (org-babel-comint-in-buffer session | |
| 194 | (mapc (lambda (var) | |
| 195 | (end-of-line 1) (insert var) (comint-send-input nil t) | |
| 196 | (org-babel-comint-wait-for-output session)) var-lines)) | |
| 197 | session)) | |
| 198 | ||
| 199 | (defun org-babel-load-session:R (session body params) | |
| 200 | "Load BODY into SESSION." | |
| 201 | (save-window-excursion | |
| 202 | (let ((buffer (org-babel-prep-session:R session params))) | |
| 203 | (with-current-buffer buffer | |
| 204 | (goto-char (process-mark (get-buffer-process (current-buffer)))) | |
| 205 | (insert (org-babel-chomp body))) | |
| 206 | buffer))) | |
| 207 | ||
| 208 | ;; helper functions | |
| 209 | ||
| 210 | (defun org-babel-variable-assignments:R (params) | |
| 211 | "Return list of R statements assigning the block's variables." | |
| 212 | (let ((vars (org-babel--get-vars params))) | |
| 213 | (mapcar | |
| 214 | (lambda (pair) | |
| 215 | (org-babel-R-assign-elisp | |
| 216 | (car pair) (cdr pair) | |
| 217 | (equal "yes" (cdr (assq :colnames params))) | |
| 218 | (equal "yes" (cdr (assq :rownames params))))) | |
| 219 | (mapcar | |
| 220 | (lambda (i) | |
| 221 | (cons (car (nth i vars)) | |
| 222 | (org-babel-reassemble-table | |
| 223 | (cdr (nth i vars)) | |
| 224 | (cdr (nth i (cdr (assq :colname-names params)))) | |
| 225 | (cdr (nth i (cdr (assq :rowname-names params))))))) | |
| 226 | (number-sequence 0 (1- (length vars))))))) | |
| 227 | ||
| 228 | (defun org-babel-R-quote-tsv-field (s) | |
| 229 | "Quote field S for export to R." | |
| 230 | (if (stringp s) | |
| 231 | (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"") | |
| 232 | (format "%S" s))) | |
| 233 | ||
| 234 | (defun org-babel-R-assign-elisp (name value colnames-p rownames-p) | |
| 235 | "Construct R code assigning the elisp VALUE to a variable named NAME." | |
| 236 | (if (listp value) | |
| 237 | (let* ((lengths (mapcar 'length (cl-remove-if-not 'sequencep value))) | |
| 238 | (max (if lengths (apply 'max lengths) 0)) | |
| 239 | (min (if lengths (apply 'min lengths) 0))) | |
| 240 | ;; Ensure VALUE has an orgtbl structure (depth of at least 2). | |
| 241 | (unless (listp (car value)) (setq value (list value))) | |
| 242 | (let ((file (orgtbl-to-tsv value '(:fmt org-babel-R-quote-tsv-field))) | |
| 243 | (header (if (or (eq (nth 1 value) 'hline) colnames-p) | |
| 244 | "TRUE" "FALSE")) | |
| 245 | (row-names (if rownames-p "1" "NULL"))) | |
| 246 | (if (= max min) | |
| 247 | (format ob-R-transfer-variable-table-with-header | |
| 248 | name file header row-names) | |
| 249 | (format ob-R-transfer-variable-table-without-header | |
| 250 | name file header row-names max)))) | |
| 251 | (cond ((integerp value) (format "%s <- %s" name (concat (number-to-string value) "L"))) | |
| 252 | ((floatp value) (format "%s <- %s" name value)) | |
| 253 | ((stringp value) (format "%s <- %S" name (org-no-properties value))) | |
| 254 | (t (format "%s <- %S" name (prin1-to-string value)))))) | |
| 255 | ||
| 256 | ||
| 257 | (defvar ess-ask-for-ess-directory) ; dynamically scoped | |
| 258 | (defun org-babel-R-initiate-session (session params) | |
| 259 | "If there is not a current R process then create one." | |
| 260 | (unless (string= session "none") | |
| 261 | (let ((session (or session "*R*")) | |
| 262 | (ess-ask-for-ess-directory | |
| 263 | (and (boundp 'ess-ask-for-ess-directory) | |
| 264 | ess-ask-for-ess-directory | |
| 265 | (not (cdr (assq :dir params)))))) | |
| 266 | (if (org-babel-comint-buffer-livep session) | |
| 267 | session | |
| 268 | (save-window-excursion | |
| 269 | (when (get-buffer session) | |
| 270 | ;; Session buffer exists, but with dead process | |
| 271 | (set-buffer session)) | |
| 272 | (require 'ess) (R) | |
| 273 | (let ((R-proc (get-process (or ess-local-process-name | |
| 274 | ess-current-process-name)))) | |
| 275 | (while (process-get R-proc 'callbacks) | |
| 276 | (ess-wait-for-process R-proc))) | |
| 277 | (rename-buffer | |
| 278 | (if (bufferp session) | |
| 279 | (buffer-name session) | |
| 280 | (if (stringp session) | |
| 281 | session | |
| 282 | (buffer-name)))) | |
| 283 | (current-buffer)))))) | |
| 284 | ||
| 285 | (defun org-babel-R-associate-session (session) | |
| 286 | "Associate R code buffer with an R session. | |
| 287 | Make SESSION be the inferior ESS process associated with the | |
| 288 | current code buffer." | |
| 289 | (setq ess-local-process-name | |
| 290 | (process-name (get-buffer-process session))) | |
| 291 | (ess-make-buffer-current)) | |
| 292 | ||
| 293 | (defvar org-babel-R-graphics-devices | |
| 294 | '((:bmp "bmp" "filename") | |
| 295 | (:jpg "jpeg" "filename") | |
| 296 | (:jpeg "jpeg" "filename") | |
| 297 | (:tikz "tikz" "file") | |
| 298 | (:tiff "tiff" "filename") | |
| 299 | (:png "png" "filename") | |
| 300 | (:svg "svg" "file") | |
| 301 | (:pdf "pdf" "file") | |
| 302 | (:ps "postscript" "file") | |
| 303 | (:postscript "postscript" "file")) | |
| 304 | "An alist mapping graphics file types to R functions. | |
| 305 | ||
| 306 | Each member of this list is a list with three members: | |
| 307 | 1. the file extension of the graphics file, as an elisp :keyword | |
| 308 | 2. the R graphics device function to call to generate such a file | |
| 309 | 3. the name of the argument to this function which specifies the | |
| 310 | file to write to (typically \"file\" or \"filename\")") | |
| 311 | ||
| 312 | (defun org-babel-R-construct-graphics-device-call (out-file params) | |
| 313 | "Construct the call to the graphics device." | |
| 314 | (let* ((allowed-args '(:width :height :bg :units :pointsize | |
| 315 | :antialias :quality :compression :res | |
| 316 | :type :family :title :fonts :version | |
| 317 | :paper :encoding :pagecentre :colormodel | |
| 318 | :useDingbats :horizontal)) | |
| 319 | (device (file-name-extension out-file)) | |
| 320 | (device-info (or (assq (intern (concat ":" device)) | |
| 321 | org-babel-R-graphics-devices) | |
| 322 | (assq :png org-babel-R-graphics-devices))) | |
| 323 | (extra-args (cdr (assq :R-dev-args params))) filearg args) | |
| 324 | (setq device (nth 1 device-info)) | |
| 325 | (setq filearg (nth 2 device-info)) | |
| 326 | (setq args (mapconcat | |
| 327 | (lambda (pair) | |
| 328 | (if (member (car pair) allowed-args) | |
| 329 | (format ",%s=%S" | |
| 330 | (substring (symbol-name (car pair)) 1) | |
| 331 | (cdr pair)) "")) | |
| 332 | params "")) | |
| 333 | (format "%s(%s=\"%s\"%s%s%s); tryCatch({" | |
| 334 | device filearg out-file args | |
| 335 | (if extra-args "," "") (or extra-args "")))) | |
| 336 | ||
| 337 | (defconst org-babel-R-eoe-indicator "'org_babel_R_eoe'") | |
| 338 | (defconst org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"") | |
| 339 | ||
| 340 | (defconst org-babel-R-write-object-command "{ | |
| 341 | function(object,transfer.file) { | |
| 342 | object | |
| 343 | invisible( | |
| 344 | if ( | |
| 345 | inherits( | |
| 346 | try( | |
| 347 | { | |
| 348 | tfile<-tempfile() | |
| 349 | write.table(object, file=tfile, sep=\"\\t\", | |
| 350 | na=\"nil\",row.names=%s,col.names=%s, | |
| 351 | quote=FALSE) | |
| 352 | file.rename(tfile,transfer.file) | |
| 353 | }, | |
| 354 | silent=TRUE), | |
| 355 | \"try-error\")) | |
| 356 | { | |
| 357 | if(!file.exists(transfer.file)) | |
| 358 | file.create(transfer.file) | |
| 359 | } | |
| 360 | ) | |
| 361 | } | |
| 362 | }(object=%s,transfer.file=\"%s\")" | |
| 363 | "A template for an R command to evaluate a block of code and write the result to a file. | |
| 364 | ||
| 365 | Has four %s escapes to be filled in: | |
| 366 | 1. Row names, \"TRUE\" or \"FALSE\" | |
| 367 | 2. Column names, \"TRUE\" or \"FALSE\" | |
| 368 | 3. The code to be run (must be an expression, not a statement) | |
| 369 | 4. The name of the file to write to") | |
| 370 | ||
| 371 | (defun org-babel-R-evaluate | |
| 372 | (session body result-type result-params column-names-p row-names-p) | |
| 373 | "Evaluate R code in BODY." | |
| 374 | (if session | |
| 375 | (org-babel-R-evaluate-session | |
| 376 | session body result-type result-params column-names-p row-names-p) | |
| 377 | (org-babel-R-evaluate-external-process | |
| 378 | body result-type result-params column-names-p row-names-p))) | |
| 379 | ||
| 380 | (defun org-babel-R-evaluate-external-process | |
| 381 | (body result-type result-params column-names-p row-names-p) | |
| 382 | "Evaluate BODY in external R process. | |
| 383 | If RESULT-TYPE equals `output' then return standard output as a | |
| 384 | string. If RESULT-TYPE equals `value' then return the value of the | |
| 385 | last statement in BODY, as elisp." | |
| 386 | (cl-case result-type | |
| 387 | (value | |
| 388 | (let ((tmp-file (org-babel-temp-file "R-"))) | |
| 389 | (org-babel-eval org-babel-R-command | |
| 390 | (format org-babel-R-write-object-command | |
| 391 | (if row-names-p "TRUE" "FALSE") | |
| 392 | (if column-names-p | |
| 393 | (if row-names-p "NA" "TRUE") | |
| 394 | "FALSE") | |
| 395 | (format "{function ()\n{\n%s\n}}()" body) | |
| 396 | (org-babel-process-file-name tmp-file 'noquote))) | |
| 397 | (org-babel-R-process-value-result | |
| 398 | (org-babel-result-cond result-params | |
| 399 | (with-temp-buffer | |
| 400 | (insert-file-contents tmp-file) | |
| 401 | (org-babel-chomp (buffer-string) "\n")) | |
| 402 | (org-babel-import-elisp-from-file tmp-file '(16))) | |
| 403 | column-names-p))) | |
| 404 | (output (org-babel-eval org-babel-R-command body)))) | |
| 405 | ||
| 406 | (defvar ess-eval-visibly-p) | |
| 407 | ||
| 408 | (defun org-babel-R-evaluate-session | |
| 409 | (session body result-type result-params column-names-p row-names-p) | |
| 410 | "Evaluate BODY in SESSION. | |
| 411 | If RESULT-TYPE equals `output' then return standard output as a | |
| 412 | string. If RESULT-TYPE equals `value' then return the value of the | |
| 413 | last statement in BODY, as elisp." | |
| 414 | (cl-case result-type | |
| 415 | (value | |
| 416 | (with-temp-buffer | |
| 417 | (insert (org-babel-chomp body)) | |
| 418 | (let ((ess-local-process-name | |
| 419 | (process-name (get-buffer-process session))) | |
| 420 | (ess-eval-visibly-p nil)) | |
| 421 | (ess-eval-buffer nil))) | |
| 422 | (let ((tmp-file (org-babel-temp-file "R-"))) | |
| 423 | (org-babel-comint-eval-invisibly-and-wait-for-file | |
| 424 | session tmp-file | |
| 425 | (format org-babel-R-write-object-command | |
| 426 | (if row-names-p "TRUE" "FALSE") | |
| 427 | (if column-names-p | |
| 428 | (if row-names-p "NA" "TRUE") | |
| 429 | "FALSE") | |
| 430 | ".Last.value" (org-babel-process-file-name tmp-file 'noquote))) | |
| 431 | (org-babel-R-process-value-result | |
| 432 | (org-babel-result-cond result-params | |
| 433 | (with-temp-buffer | |
| 434 | (insert-file-contents tmp-file) | |
| 435 | (org-babel-chomp (buffer-string) "\n")) | |
| 436 | (org-babel-import-elisp-from-file tmp-file '(16))) | |
| 437 | column-names-p))) | |
| 438 | (output | |
| 439 | (mapconcat | |
| 440 | 'org-babel-chomp | |
| 441 | (butlast | |
| 442 | (delq nil | |
| 443 | (mapcar | |
| 444 | (lambda (line) (when (> (length line) 0) line)) | |
| 445 | (mapcar | |
| 446 | (lambda (line) ;; cleanup extra prompts left in output | |
| 447 | (if (string-match | |
| 448 | "^\\([>+.]\\([ ][>.+]\\)*[ ]\\)" | |
| 449 | (car (split-string line "\n"))) | |
| 450 | (substring line (match-end 1)) | |
| 451 | line)) | |
| 452 | (org-babel-comint-with-output (session org-babel-R-eoe-output) | |
| 453 | (insert (mapconcat 'org-babel-chomp | |
| 454 | (list body org-babel-R-eoe-indicator) | |
| 455 | "\n")) | |
| 456 | (inferior-ess-send-input)))))) "\n")))) | |
| 457 | ||
| 458 | (defun org-babel-R-process-value-result (result column-names-p) | |
| 459 | "R-specific processing of return value. | |
| 460 | Insert hline if column names in output have been requested." | |
| 461 | (if column-names-p | |
| 462 | (cons (car result) (cons 'hline (cdr result))) | |
| 463 | result)) | |
| 464 | ||
| 465 | (provide 'ob-R) | |
| 466 | ||
| 467 | ||
| 468 | ||
| 469 | ;;; ob-R.el ends here | |
