From e192ad71b61fd6ddf034a15c1012a99de00e5865 Mon Sep 17 00:00:00 2001 From: Aaron Ecay Date: Fri, 23 Jan 2015 12:33:51 -0500 Subject: [PATCH] ob-R: Fix table row/colname processing. * lisp/ob-R.el (org-babel-execute:R): Use babel-standard row/colname processing. Remove graphics-specific R code from here. (org-babel-R-construct-graphics-device-call): Absorb graphics-specific code. (org-babel-R-process-value-result): Remove function. (org-babel-R-evaluate-external-process): (org-babel-R-evaluate-session): Adapt callers. This is in line with a patch proposed by Eric Schulte: . Thanks to Sebastien for bringing it up again. * testing/lisp/test-ob-R.el (test-ob-R/colnames-from-r): (test-ob-R/colnames-from-org): (test-ob-R/rownames-from-r): (test-ob-R/rownames-from-org): (test-ob-R/row-and-colnames-from-r): (test-ob-R/row-and-colnames-from-org): New tests. --- lisp/ob-R.el | 108 ++++++++++++++++++++++++---------------------- testing/lisp/test-ob-R.el | 72 +++++++++++++++++++++++++++++++ 2 files changed, 128 insertions(+), 52 deletions(-) diff --git a/lisp/ob-R.el b/lisp/ob-R.el index 639b4f8..68aba30 100644 --- a/lisp/ob-R.el +++ b/lisp/ob-R.el @@ -155,36 +155,47 @@ This function is used when the table does not contain a header.") "Execute a block of R code. This function is called by `org-babel-execute-src-block'." (save-excursion - (let* ((result-params (cdr (assoc :result-params params))) - (result-type (cdr (assoc :result-type params))) + (let* ((result-params (cdr (assq :result-params params))) + (result-type (cdr (assq :result-type params))) (session (org-babel-R-initiate-session - (cdr (assoc :session params)) params)) - (colnames-p (cdr (assoc :colnames params))) - (rownames-p (cdr (assoc :rownames params))) - (graphics-file (and (member "graphics" (assq :result-params params)) + (cdr (assq :session params)) params)) + (graphics-file (and (member "graphics" result-params) (org-babel-graphical-output-file params))) + (colnames (cdr (assq :colnames params))) + (rownames (cdr (assq :rownames params))) + (inside (org-babel-expand-body:R body params graphics-file)) (full-body - (let ((inside - (list (org-babel-expand-body:R body params graphics-file)))) - (mapconcat 'identity - (if graphics-file - (append - (list (org-babel-R-construct-graphics-device-call - graphics-file params)) - inside - (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()")) - inside) - "\n"))) + (if graphics-file + (org-babel-R-construct-graphics-device-call + graphics-file params inside) + inside)) (result (org-babel-R-evaluate session full-body result-type result-params - (or (equal "yes" colnames-p) - (org-babel-pick-name - (cdr (assoc :colname-names params)) colnames-p)) - (or (equal "yes" rownames-p) - (org-babel-pick-name - (cdr (assoc :rowname-names params)) rownames-p))))) - (if graphics-file nil result)))) + (equal "yes" colnames) + (equal "yes" rownames)))) + (unless graphics-file + (org-babel-reassemble-table + result + (org-babel-pick-name + ;; In most cases, the original colnames have been passed + ;; into R and are coming back from there, thus we don't need + ;; the copy that babel stashed in the :colname-names entry. + ;; However, if :colnames nil is specified babel does not + ;; pass along the colnames to R, but is expected to reapply + ;; them to the table. ("nil" is a confusing name for this + ;; semantics, but that's how it is documented in the + ;; manual.) Only n this case must we permit access to + ;; babel's stored colnames. These remarks also apply to the + ;; rownames immediately below. + (when (equal colnames "nil") + (cdr (assq :colname-names params))) + colnames) + (org-babel-pick-name + ;; See above. + (when (equal rownames "nil") + (cdr (assq :rowname-names params))) + rownames)))))) (defun org-babel-prep-session:R (session params) "Prepare SESSION according to the header arguments specified in PARAMS." @@ -309,19 +320,20 @@ Each member of this list is a list with three members: 3. the name of the argument to this function which specifies the file to write to (typically \"file\" or \"filename\")") -(defun org-babel-R-construct-graphics-device-call (out-file params) +(defun org-babel-R-construct-graphics-device-call (out-file params code) "Construct the call to the graphics device." (let* ((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))) - (device-info (or (assq (intern (concat ":" device)) + (device-name (and (string-match ".+\\.\\([^.]+\\)" out-file) + (match-string 1 out-file))) + (device-info (or (assq (intern (concat ":" device-name)) org-babel-R-graphics-devices) (assq :png org-babel-R-graphics-devices))) - (extra-args (cdr (assq :R-dev-args params))) filearg args) + (extra-args (cdr (assq :R-dev-args params))) + filearg args device) (setq device (nth 1 device-info)) (setq filearg (nth 2 device-info)) (setq args (mapconcat @@ -331,9 +343,10 @@ Each member of this list is a list with three members: (substring (symbol-name (car pair)) 1) (cdr pair)) "")) params "")) - (format "%s(%s=\"%s\"%s%s%s); tryCatch({" + (format "%s(%s=\"%s\"%s%s%s); tryCatch({%s},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()" device filearg out-file args - (if extra-args "," "") (or extra-args "")))) + (if extra-args "," "") (or extra-args "") + code))) (defconst org-babel-R-eoe-indicator "'org_babel_R_eoe'") (defconst org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"") @@ -395,13 +408,12 @@ last statement in BODY, as elisp." "FALSE") (format "{function ()\n{\n%s\n}}()" body) (org-babel-process-file-name tmp-file 'noquote))) - (org-babel-R-process-value-result - (org-babel-result-cond result-params - (with-temp-buffer - (insert-file-contents tmp-file) - (buffer-string)) - (org-babel-import-elisp-from-file tmp-file '(16))) - column-names-p))) + (org-babel-result-cond result-params + (with-temp-buffer + (insert-file-contents tmp-file) + (buffer-string)) + (org-babel-import-elisp-from-file tmp-file '(16))) + column-names-p)) (output (org-babel-eval org-babel-R-command body)))) (defvar ess-eval-visibly-p) @@ -429,13 +441,12 @@ last statement in BODY, as elisp." (if row-names-p "NA" "TRUE") "FALSE") ".Last.value" (org-babel-process-file-name tmp-file 'noquote))) - (org-babel-R-process-value-result - (org-babel-result-cond result-params - (with-temp-buffer - (insert-file-contents tmp-file) - (buffer-string)) - (org-babel-import-elisp-from-file tmp-file '(16))) - column-names-p))) + (org-babel-result-cond result-params + (with-temp-buffer + (insert-file-contents tmp-file) + (buffer-string)) + (org-babel-import-elisp-from-file tmp-file '(16))) + column-names-p)) (output (mapconcat 'org-babel-chomp @@ -455,13 +466,6 @@ last statement in BODY, as elisp." "\n")) (inferior-ess-send-input)))))) "\n")))) -(defun org-babel-R-process-value-result (result column-names-p) - "R-specific processing of return value. -Insert hline if column names in output have been requested." - (if column-names-p - (cons (car result) (cons 'hline (cdr result))) - result)) - (provide 'ob-R) diff --git a/testing/lisp/test-ob-R.el b/testing/lisp/test-ob-R.el index e3f13f1..16bdd62 100644 --- a/testing/lisp/test-ob-R.el +++ b/testing/lisp/test-ob-R.el @@ -79,6 +79,78 @@ x (should (equal '(("col") ("a") ("b")) (org-babel-execute-src-block))))) +(ert-deftest test-ob-R/colnames-from-r () + (org-test-with-temp-text " +#+header: :colnames yes +#+begin_src R +y <- data.frame(x = c(1,2,3)) +y +#+end_src" + (org-babel-next-src-block) + (should (equal '(("x") hline (1) (2) (3)) + (org-babel-execute-src-block))))) + +(ert-deftest test-ob-R/colnames-from-org () + (org-test-with-temp-text " +#+header: :colnames '(\"foo\") +#+begin_src R +y <- data.frame(x = c(1,2,3)) +y +#+end_src" + (org-babel-next-src-block) + (should (equal '(("foo") hline (1) (2) (3)) + (org-babel-execute-src-block))))) + +(ert-deftest test-ob-R/rownames-from-r () + (org-test-with-temp-text " +#+header: :rownames yes +#+begin_src R +x <- data.frame(x = c(1,2,3)) +rownames(x) <- c(\"A\",\"B\",\"C\") +x +#+end_src" + (org-babel-next-src-block) + (should (equal '(("A" 1) ("B" 2) ("C" 3)) + (org-babel-execute-src-block))))) + +(ert-deftest test-ob-R/rownames-from-org () + (org-test-with-temp-text " +#+header: :rownames '(\"D\" \"E\" \"F\") +#+begin_src R +x <- data.frame(x = c(1,2,3)) +rownames(x) <- c(\"A\",\"B\",\"C\") +x +#+end_src" + (org-babel-next-src-block) + (should (equal '(("D" 1) ("E" 2) ("F" 3)) + (org-babel-execute-src-block))))) + +(ert-deftest test-ob-R/row-and-colnames-from-r () + (org-test-with-temp-text " +#+header: :rownames yes :colnames yes +#+begin_src R +y <- data.frame(x = c(1,2,3)) +rownames(y) <- c(\"A\",\"B\",\"C\") +y +#+end_src" + (org-babel-next-src-block) + (should (equal '(("" "x") hline ("A" 1) ("B" 2) ("C" 3)) + (org-babel-execute-src-block))))) + +(ert-deftest test-ob-R/row-and-colnames-from-org () + ;; NB: For R, the column of rownames doesn't itself have a colname, + ;; whereas for Org it must. + (org-test-with-temp-text " +#+header: :rownames '(\"D\" \"E\" \"F\") :colnames '(\"colnames\" \"foo\") +#+begin_src R +y <- data.frame(x = c(1,2,3)) +rownames(y) <- c(\"A\",\"B\",\"C\") +y +#+end_src" + (org-babel-next-src-block) + (should (equal '(("colnames" "foo") hline ("D" 1) ("E" 2) ("F" 3)) + (org-babel-execute-src-block))))) + (provide 'test-ob-R) ;;; test-ob-R.el ends here -- 2.2.2