Re: [O] [babel, bug?] colnames with a list of columns does not work

[Aaron Ecay]

Hi Sebastien,

2015ko urtarrilak 23an, Sebastien Vauban-ek idatzi zuen:
> Yes, you just show that the documentation is not up-to-date, as that
> functionality *is* implemented for most languages.
> 
> Doing some bit of archeology, I just found out that:
> 
> - Eric wrote a patch to support the above (but it hasn't be applied),
> 
> - I (!) even wrote a test of that functionality (for a shell block) in
>   `testing/lisp/test-ob.el'.
> 
> See https://lists.gnu.org/archive/html/emacs-orgmode/2013-04/msg00527.html:

Thanks for bringing this back to the surface.  I reworked Eric’s patch
(which no longer applied cleanly).  The result is attached.  With this
patch:
- Both row/colnames set from R and from Org should work
- If they are set in both ways, the Org ones will win

There are tests for this behavior.

There is a slight mismatch between R and Org.  R considers the colnames
(C) and rownames (R) separate from the table (X):

  CCCC
R XXXX
R XXXX
R XXXX

On the other hand, Babel assigns a colname to the column of rownames:

C CCCC
R XXXX
R XXXX
R XXXX

So, R users will need to watch out for this.  I wasn’t sure where to
document it – maybe Worg?  (There’s a comment about it in the test
suite, but that hardly counts.)

>From e192ad71b61fd6ddf034a15c1012a99de00e5865 Mon Sep 17 00:00:00 2001
From: Aaron Ecay <address@hidden>
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:
<http://mid.gmane.org/address@hidden>.  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

Thanks,

-- 
Aaron Ecay