mirror of
https://git.savannah.gnu.org/git/emacs/org-mode.git
synced 2024-09-30 04:27:48 +00:00
babel: cleaned up R code
This commit is contained in:
parent
7b3077dcd4
commit
d1ba364572
159
lisp/ob-R.el
159
lisp/ob-R.el
|
@ -48,26 +48,40 @@
|
||||||
|
|
||||||
(defvar org-babel-default-header-args:R '())
|
(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)
|
(defun org-babel-expand-body:R (body params &optional processed-params)
|
||||||
"Expand BODY according to PARAMS, return the expanded body."
|
"Expand BODY according to PARAMS, return the expanded body."
|
||||||
(let* ((processed-params (or processed-params
|
(let* ((processed-params (or processed-params
|
||||||
(org-babel-process-params params)))
|
(org-babel-process-params params)))
|
||||||
(vars (mapcar (lambda (i) (cons (car (nth i (nth 1 processed-params)))
|
(vars (mapcar
|
||||||
|
(lambda (i)
|
||||||
|
(cons (car (nth i (nth 1 processed-params)))
|
||||||
(org-babel-reassemble-table
|
(org-babel-reassemble-table
|
||||||
(cdr (nth i (nth 1 processed-params)))
|
(cdr (nth i (nth 1 processed-params)))
|
||||||
(cdr (nth i (nth 4 processed-params)))
|
(cdr (nth i (nth 4 processed-params)))
|
||||||
(cdr (nth i (nth 5 processed-params))))))
|
(cdr (nth i (nth 5 processed-params))))))
|
||||||
(number-sequence 0 (1- (length (nth 1 processed-params))))))
|
(number-sequence 0 (1- (length (nth 1 processed-params))))))
|
||||||
(out-file (cdr (assoc :file 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
|
(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)
|
(lambda (pair)
|
||||||
(org-babel-R-assign-elisp (car pair) (cdr pair)
|
(org-babel-R-assign-elisp
|
||||||
|
(car pair) (cdr pair)
|
||||||
(equal "yes" (cdr (assoc :colnames params)))
|
(equal "yes" (cdr (assoc :colnames params)))
|
||||||
(equal "yes" (cdr (assoc :rownames params)))))
|
(equal "yes" (cdr (assoc :rownames params)))))
|
||||||
vars "\n")
|
vars)
|
||||||
"\n" body "\n" (if out-file "dev.off()\n" ""))))
|
(list body))) "\n")))
|
||||||
|
|
||||||
(defun org-babel-execute:R (body params)
|
(defun org-babel-execute:R (body params)
|
||||||
"Execute a block of R code with org-babel. This function is
|
"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
|
(save-excursion
|
||||||
(let* ((processed-params (org-babel-process-params params))
|
(let* ((processed-params (org-babel-process-params params))
|
||||||
(result-type (nth 3 processed-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)))
|
(colnames-p (cdr (assoc :colnames params)))
|
||||||
(rownames-p (cdr (assoc :rownames params)))
|
(rownames-p (cdr (assoc :rownames params)))
|
||||||
(out-file (cdr (assoc :file 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))
|
(org-babel-pick-name (nth 4 processed-params) colnames-p))
|
||||||
(or (equal "yes" rownames-p)
|
(or (equal "yes" rownames-p)
|
||||||
(org-babel-pick-name (nth 5 processed-params) rownames-p)))))
|
(org-babel-pick-name (nth 5 processed-params) rownames-p)))))
|
||||||
|
(message "result is %S" result)
|
||||||
(or out-file result))))
|
(or out-file result))))
|
||||||
|
|
||||||
(defun org-babel-prep-session:R (session params)
|
(defun org-babel-prep-session:R (session params)
|
||||||
|
@ -147,9 +163,14 @@ called by `org-babel-execute-src-block'."
|
||||||
(if (org-babel-comint-buffer-livep session)
|
(if (org-babel-comint-buffer-livep session)
|
||||||
session
|
session
|
||||||
(save-window-excursion
|
(save-window-excursion
|
||||||
(R)
|
(require 'ess) (R)
|
||||||
(rename-buffer (if (bufferp session) (buffer-name session)
|
(rename-buffer
|
||||||
(if (stringp session) session (buffer-name)))) (current-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)
|
(defun org-babel-R-construct-graphics-device-call (out-file params)
|
||||||
"Construct the call to the graphics device."
|
"Construct the call to the graphics device."
|
||||||
|
@ -164,27 +185,36 @@ called by `org-babel-execute-src-block'."
|
||||||
(:ps . "postscript")
|
(:ps . "postscript")
|
||||||
(:postscript . "postscript")))
|
(:postscript . "postscript")))
|
||||||
(allowed-args '(:width :height :bg :units :pointsize
|
(allowed-args '(:width :height :bg :units :pointsize
|
||||||
:antialias :quality :compression :res :type
|
:antialias :quality :compression :res
|
||||||
:family :title :fonts :version :paper :encoding
|
:type :family :title :fonts :version
|
||||||
:pagecentre :colormodel :useDingbats :horizontal))
|
:paper :encoding :pagecentre :colormodel
|
||||||
(device (and (string-match ".+\\.\\([^.]+\\)" out-file) (match-string 1 out-file)))
|
:useDingbats :horizontal))
|
||||||
|
(device (and (string-match ".+\\.\\([^.]+\\)" out-file)
|
||||||
|
(match-string 1 out-file)))
|
||||||
(extra-args (cdr (assq :R-dev-args params))) filearg args)
|
(extra-args (cdr (assq :R-dev-args params))) filearg args)
|
||||||
(setq device (or (and device (cdr (assq (intern (concat ":" device)) devices))) "png"))
|
(setq device (or (and device (cdr (assq (intern (concat ":" device))
|
||||||
(setq filearg (if (member device '("pdf" "postscript" "svg")) "file" "filename"))
|
devices))) "png"))
|
||||||
(setq args (mapconcat (lambda (pair)
|
(setq filearg
|
||||||
|
(if (member device '("pdf" "postscript" "svg")) "file" "filename"))
|
||||||
|
(setq args (mapconcat
|
||||||
|
(lambda (pair)
|
||||||
(if (member (car pair) allowed-args)
|
(if (member (car pair) allowed-args)
|
||||||
(format ",%s=%s" (substring (symbol-name (car pair)) 1) (cdr pair)) ""))
|
(format ",%s=%s"
|
||||||
|
(substring (symbol-name (car pair)) 1)
|
||||||
|
(cdr pair)) ""))
|
||||||
params ""))
|
params ""))
|
||||||
(format "%s(%s=\"%s\"%s%s%s)\n" device filearg out-file args (if extra-args "," "") (or extra-args ""))))
|
(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-indicator "'org_babel_R_eoe'")
|
||||||
(defvar org-babel-R-eoe-output "[1] \"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}
|
(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)")
|
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)
|
(defun org-babel-R-evaluate
|
||||||
(defvar inferior-ess-secondary-prompt)
|
(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
|
"Pass BODY to the R process in SESSION. If RESULT-TYPE equals
|
||||||
'output then return a list of the outputs of the statements in
|
'output then return a list of the outputs of the statements in
|
||||||
BODY, if RESULT-TYPE equals 'value then return the value of the
|
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)
|
(if (not session)
|
||||||
;; external process evaluation
|
;; external process evaluation
|
||||||
(case result-type
|
(case result-type
|
||||||
(output
|
(output (org-babel-eval org-babel-R-command body))
|
||||||
(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))))
|
|
||||||
(value
|
(value
|
||||||
(let* ((tmp-file (make-temp-file "R-out-functional-results")) exit-code
|
(let ((tmp-file (make-temp-file "org-babel-R-results-")))
|
||||||
(stderr
|
(org-babel-eval org-babel-R-command
|
||||||
(with-temp-buffer
|
(format org-babel-R-wrapper-method
|
||||||
(insert (format org-babel-R-wrapper-method
|
body tmp-file
|
||||||
body tmp-file (if row-names-p "TRUE" "FALSE") (if column-names-p (if row-names-p "NA" "TRUE") "FALSE")))
|
(if row-names-p "TRUE" "FALSE")
|
||||||
(setq exit-code (org-babel-shell-command-on-region
|
(if column-names-p
|
||||||
(point-min) (point-max) "R --no-save" nil 'replace (current-buffer)))
|
(if row-names-p "NA" "TRUE")
|
||||||
(buffer-string))))
|
"FALSE")))
|
||||||
(if (> exit-code 0) (org-babel-error-notify exit-code stderr))
|
|
||||||
(org-babel-R-process-value-result
|
(org-babel-R-process-value-result
|
||||||
(org-babel-import-elisp-from-file (org-babel-maybe-remote-file tmp-file))
|
(org-babel-import-elisp-from-file
|
||||||
column-names-p))))
|
(org-babel-maybe-remote-file tmp-file)) column-names-p))))
|
||||||
;; comint session evaluation
|
;; comint session evaluation
|
||||||
(org-babel-comint-in-buffer session
|
|
||||||
(let* ((tmp-file (make-temp-file "org-babel-R"))
|
|
||||||
(full-body
|
|
||||||
(case result-type
|
(case result-type
|
||||||
(value
|
(value
|
||||||
(mapconcat #'org-babel-chomp (list body
|
(let ((tmp-file (make-temp-file "org-babel-R"))
|
||||||
(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"))
|
broke)
|
||||||
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)
|
(org-babel-comint-with-output (session org-babel-R-eoe-output)
|
||||||
(insert full-body) (inferior-ess-send-input)))
|
(insert (mapconcat
|
||||||
(comint-prompt-regexp
|
#'org-babel-chomp
|
||||||
(concat "^\\("
|
(list
|
||||||
inferior-ess-primary-prompt
|
body
|
||||||
"\\|"
|
(format org-babel-R-wrapper-lastvar
|
||||||
inferior-ess-secondary-prompt
|
tmp-file
|
||||||
"\\)*"))
|
(if row-names-p "TRUE" "FALSE")
|
||||||
broke results)
|
(if column-names-p
|
||||||
(case result-type
|
(if row-names-p "NA" "TRUE")
|
||||||
(value (org-babel-R-process-value-result
|
"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-import-elisp-from-file
|
||||||
(org-babel-maybe-remote-file tmp-file))
|
(org-babel-maybe-remote-file tmp-file)) column-names-p)))
|
||||||
column-names-p))
|
|
||||||
(output
|
(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
|
(mapconcat
|
||||||
|
#'org-babel-chomp
|
||||||
|
(butlast
|
||||||
|
(delq nil
|
||||||
|
(mapcar
|
||||||
#'identity
|
#'identity
|
||||||
(delete nil (mapcar #'extractor (mapcar #'org-babel-chomp raw))) "\n"))))))))
|
(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)
|
(defun org-babel-R-process-value-result (result column-names-p)
|
||||||
"R-specific processing of return value prior to return to
|
"R-specific processing of return value prior to return to
|
||||||
|
|
Loading…
Reference in a new issue