From d1ba364572efc1346cbeb96dfecd59f8655e0a11 Mon Sep 17 00:00:00 2001 From: Eric Schulte Date: Sun, 4 Jul 2010 13:31:34 -0700 Subject: [PATCH] babel: cleaned up R code --- lisp/ob-R.el | 201 ++++++++++++++++++++++++++++----------------------- 1 file changed, 109 insertions(+), 92 deletions(-) diff --git a/lisp/ob-R.el b/lisp/ob-R.el index bbcb3ca45..325ad4ddb 100644 --- a/lisp/ob-R.el +++ b/lisp/ob-R.el @@ -48,26 +48,40 @@ (defvar org-babel-default-header-args:R '()) +(defvar org-babel-R-command "R --slave --no-save" + "Name of command to use for executing R code.") + (defun org-babel-expand-body:R (body params &optional processed-params) "Expand BODY according to PARAMS, return the expanded body." (let* ((processed-params (or processed-params (org-babel-process-params params))) - (vars (mapcar (lambda (i) (cons (car (nth i (nth 1 processed-params))) - (org-babel-reassemble-table - (cdr (nth i (nth 1 processed-params))) - (cdr (nth i (nth 4 processed-params))) - (cdr (nth i (nth 5 processed-params)))))) - (number-sequence 0 (1- (length (nth 1 processed-params)))))) + (vars (mapcar + (lambda (i) + (cons (car (nth i (nth 1 processed-params))) + (org-babel-reassemble-table + (cdr (nth i (nth 1 processed-params))) + (cdr (nth i (nth 4 processed-params))) + (cdr (nth i (nth 5 processed-params)))))) + (number-sequence 0 (1- (length (nth 1 processed-params)))))) (out-file (cdr (assoc :file params)))) - (concat - (if out-file (concat (org-babel-R-construct-graphics-device-call out-file params) "\n") "") - (mapconcat ;; define any variables - (lambda (pair) - (org-babel-R-assign-elisp (car pair) (cdr pair) - (equal "yes" (cdr (assoc :colnames params))) - (equal "yes" (cdr (assoc :rownames params))))) - vars "\n") - "\n" body "\n" (if out-file "dev.off()\n" "")))) + (mapconcat ;; define any variables + #'org-babel-trim + ((lambda (inside) + (if out-file + (append + (org-babel-R-construct-graphics-device-call out-file params) + inside + (list "dev.off()")) + inside)) + (append + (mapcar + (lambda (pair) + (org-babel-R-assign-elisp + (car pair) (cdr pair) + (equal "yes" (cdr (assoc :colnames params))) + (equal "yes" (cdr (assoc :rownames params))))) + vars) + (list body))) "\n"))) (defun org-babel-execute:R (body params) "Execute a block of R code with org-babel. This function is @@ -76,7 +90,8 @@ called by `org-babel-execute-src-block'." (save-excursion (let* ((processed-params (org-babel-process-params params)) (result-type (nth 3 processed-params)) - (session (org-babel-R-initiate-session (first processed-params) params)) + (session (org-babel-R-initiate-session + (first processed-params) params)) (colnames-p (cdr (assoc :colnames params))) (rownames-p (cdr (assoc :rownames params))) (out-file (cdr (assoc :file params))) @@ -88,6 +103,7 @@ called by `org-babel-execute-src-block'." (org-babel-pick-name (nth 4 processed-params) colnames-p)) (or (equal "yes" rownames-p) (org-babel-pick-name (nth 5 processed-params) rownames-p))))) + (message "result is %S" result) (or out-file result)))) (defun org-babel-prep-session:R (session params) @@ -97,9 +113,9 @@ called by `org-babel-execute-src-block'." (var-lines (mapcar (lambda (pair) (org-babel-R-assign-elisp - (car pair) (cdr pair) - (equal (cdr (assoc :colnames params)) "yes") - (equal (cdr (assoc :rownames params)) "yes"))) + (car pair) (cdr pair) + (equal (cdr (assoc :colnames params)) "yes") + (equal (cdr (assoc :rownames params)) "yes"))) vars))) (org-babel-comint-in-buffer session (mapc (lambda (var) @@ -147,9 +163,14 @@ called by `org-babel-execute-src-block'." (if (org-babel-comint-buffer-livep session) session (save-window-excursion - (R) - (rename-buffer (if (bufferp session) (buffer-name session) - (if (stringp session) session (buffer-name)))) (current-buffer)))))) + (require 'ess) (R) + (rename-buffer + (if (bufferp session) + (buffer-name session) + (if (stringp session) + session + (buffer-name)))) + (current-buffer)))))) (defun org-babel-R-construct-graphics-device-call (out-file params) "Construct the call to the graphics device." @@ -164,27 +185,36 @@ called by `org-babel-execute-src-block'." (:ps . "postscript") (:postscript . "postscript"))) (allowed-args '(:width :height :bg :units :pointsize - :antialias :quality :compression :res :type - :family :title :fonts :version :paper :encoding - :pagecentre :colormodel :useDingbats :horizontal)) - (device (and (string-match ".+\\.\\([^.]+\\)" out-file) (match-string 1 out-file))) + :antialias :quality :compression :res + :type :family :title :fonts :version + :paper :encoding :pagecentre :colormodel + :useDingbats :horizontal)) + (device (and (string-match ".+\\.\\([^.]+\\)" out-file) + (match-string 1 out-file))) (extra-args (cdr (assq :R-dev-args params))) filearg args) - (setq device (or (and device (cdr (assq (intern (concat ":" device)) devices))) "png")) - (setq filearg (if (member device '("pdf" "postscript" "svg")) "file" "filename")) - (setq args (mapconcat (lambda (pair) - (if (member (car pair) allowed-args) - (format ",%s=%s" (substring (symbol-name (car pair)) 1) (cdr pair)) "")) - params "")) - (format "%s(%s=\"%s\"%s%s%s)\n" device filearg out-file args (if extra-args "," "") (or extra-args "")))) + (setq device (or (and device (cdr (assq (intern (concat ":" device)) + devices))) "png")) + (setq filearg + (if (member device '("pdf" "postscript" "svg")) "file" "filename")) + (setq args (mapconcat + (lambda (pair) + (if (member (car pair) allowed-args) + (format ",%s=%s" + (substring (symbol-name (car pair)) 1) + (cdr pair)) "")) + params "")) + (format "%s(%s=\"%s\"%s%s%s)" + device filearg out-file args + (if extra-args "," "") (or extra-args "")))) (defvar org-babel-R-eoe-indicator "'org_babel_R_eoe'") (defvar org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"") (defvar org-babel-R-wrapper-method "main <- function ()\n{\n%s\n} write.table(main(), file=\"%s\", sep=\"\\t\", na=\"nil\",row.names=%s, col.names=%s, quote=FALSE)") +(defvar org-babel-R-wrapper-lastvar "write.table(.Last.value, file=\"%s\", sep=\"\\t\", na=\"nil\",row.names=%s, col.names=%s, quote=FALSE)") -(defvar inferior-ess-primary-prompt) -(defvar inferior-ess-secondary-prompt) -(defun org-babel-R-evaluate (session body result-type column-names-p row-names-p) +(defun org-babel-R-evaluate + (session body result-type column-names-p row-names-p) "Pass BODY to the R process in SESSION. If RESULT-TYPE equals 'output then return a list of the outputs of the statements in BODY, if RESULT-TYPE equals 'value then return the value of the @@ -192,65 +222,52 @@ last statement in BODY, as elisp." (if (not session) ;; external process evaluation (case result-type - (output - (with-temp-buffer - (insert body) - (org-babel-shell-command-on-region (point-min) (point-max) "R --slave --no-save" 'current-buffer 'replace) - (org-babel-trim (buffer-string)))) + (output (org-babel-eval org-babel-R-command body)) (value - (let* ((tmp-file (make-temp-file "R-out-functional-results")) exit-code - (stderr - (with-temp-buffer - (insert (format org-babel-R-wrapper-method - body tmp-file (if row-names-p "TRUE" "FALSE") (if column-names-p (if row-names-p "NA" "TRUE") "FALSE"))) - (setq exit-code (org-babel-shell-command-on-region - (point-min) (point-max) "R --no-save" nil 'replace (current-buffer))) - (buffer-string)))) - (if (> exit-code 0) (org-babel-error-notify exit-code stderr)) + (let ((tmp-file (make-temp-file "org-babel-R-results-"))) + (org-babel-eval org-babel-R-command + (format org-babel-R-wrapper-method + body tmp-file + (if row-names-p "TRUE" "FALSE") + (if column-names-p + (if row-names-p "NA" "TRUE") + "FALSE"))) (org-babel-R-process-value-result - (org-babel-import-elisp-from-file (org-babel-maybe-remote-file tmp-file)) - column-names-p)))) + (org-babel-import-elisp-from-file + (org-babel-maybe-remote-file tmp-file)) column-names-p)))) ;; comint session evaluation - (org-babel-comint-in-buffer session - (let* ((tmp-file (make-temp-file "org-babel-R")) - (full-body - (case result-type - (value - (mapconcat #'org-babel-chomp (list body - (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")) - org-babel-R-eoe-indicator) "\n")) - (output - (mapconcat #'org-babel-chomp (list body org-babel-R-eoe-indicator) "\n")))) - (raw - (org-babel-comint-with-output (session org-babel-R-eoe-output) - (insert full-body) (inferior-ess-send-input))) - (comint-prompt-regexp - (concat "^\\(" - inferior-ess-primary-prompt - "\\|" - inferior-ess-secondary-prompt - "\\)*")) - broke results) - (case result-type - (value (org-babel-R-process-value-result - (org-babel-import-elisp-from-file - (org-babel-maybe-remote-file tmp-file)) - column-names-p)) - (output - (flet ((extractor - (el) - (if (or broke - (and (string-match (regexp-quote org-babel-R-eoe-output) el) - (setq broke t))) - nil - (if (= (length el) 0) - nil - (if (string-match comint-prompt-regexp el) - (org-babel-trim (substring el (match-end 0))) - el))))) - (mapconcat - #'identity - (delete nil (mapcar #'extractor (mapcar #'org-babel-chomp raw))) "\n")))))))) + (case result-type + (value + (let ((tmp-file (make-temp-file "org-babel-R")) + broke) + (org-babel-comint-with-output (session org-babel-R-eoe-output) + (insert (mapconcat + #'org-babel-chomp + (list + body + (format org-babel-R-wrapper-lastvar + tmp-file + (if row-names-p "TRUE" "FALSE") + (if column-names-p + (if row-names-p "NA" "TRUE") + "FALSE")) + org-babel-R-eoe-indicator) "\n")) + (inferior-ess-send-input)) + (org-babel-R-process-value-result + (org-babel-import-elisp-from-file + (org-babel-maybe-remote-file tmp-file)) column-names-p))) + (output + (mapconcat + #'org-babel-chomp + (butlast + (delq nil + (mapcar + #'identity + (org-babel-comint-with-output (session org-babel-R-eoe-output) + (insert (mapconcat #'org-babel-chomp + (list body org-babel-R-eoe-indicator) + "\n")) + (inferior-ess-send-input)))) 2) "\n"))))) (defun org-babel-R-process-value-result (result column-names-p) "R-specific processing of return value prior to return to