forked from mirrors/org-mode
babel: cleaned up R code
This commit is contained in:
Eric Schulte
parent
7b3077dcd4
commit
d1ba364572
201
lisp/ob-R.el
201
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue