1
0
mirror of https://git.savannah.gnu.org/git/emacs/org-mode.git synced 2024-11-26 07:33:39 +00:00

table: Allow collapsing header into single line

* lisp/org-table.el (org-table-collapse-header): New function.

* lisp/org-plot.el (org-plot/gnuplot): Use org-table-collapse-header
and trust there will be no more leading `hline' symbols in lisp table.

* testing/lisp/test-org-table.el (test-org-table/to-lisp):
Adding tests to already existing to-lisp function.
(test-org-table/collapse-header): Adding tests to new
collapse-header function.

* testing/lisp/test-ox.el (test-org-export/has-header-p): Testing
exporting table with multi-line header.
This commit is contained in:
mfrasca 2020-06-12 11:42:34 -05:00 committed by Nicolas Goaziou
parent 0c1740c919
commit 73e367fca4
4 changed files with 100 additions and 7 deletions

View File

@ -289,14 +289,12 @@ line directly before or after the table."
(setf params (plist-put params (car pair) (cdr pair)))))
;; collect table and table information
(let* ((data-file (make-temp-file "org-plot"))
(table (org-table-to-lisp))
(num-cols (length (if (eq (nth 0 table) 'hline) (nth 1 table)
(nth 0 table)))))
(table (org-table-collapse-header (org-table-to-lisp)))
(num-cols (length (car table))))
(run-with-idle-timer 0.1 nil #'delete-file data-file)
(while (eq 'hline (car table)) (setf table (cdr table)))
(when (eq (cadr table) 'hline)
(setf params
(plist-put params :labels (nth 0 table))) ; headers to labels
(plist-put params :labels (car table))) ; headers to labels
(setf table (delq 'hline (cdr table)))) ; clean non-data from table
;; Collect options.
(save-excursion (while (and (equal 0 (forward-line -1))

View File

@ -5468,6 +5468,31 @@ The table is taken from the parameter TXT, or from the buffer at point."
(forward-line))
(nreverse table)))))
(defun org-table-collapse-header (table &optional separator max-header-lines)
"Collapse the lines before 'hline into a single header.
The given TABLE is a list of lists as returned by `org-table-to-lisp'.
The leading lines before the first `hline' symbol are considered
forming the table header. This function collapses all leading header
lines into a single header line, followed by the `hline' symbol, and
the rest of the TABLE. Header cells are glued together with a space,
or the given SEPARATOR."
(while (eq (car table) 'hline) (pop table))
(let* ((separator (or separator " "))
(max-header-lines (or max-header-lines 4))
(trailer table)
(header-lines (cl-loop for line in table
until (eq 'hline line)
collect (pop trailer))))
(if (and trailer (<= (length header-lines) max-header-lines))
(cons (apply #'cl-mapcar
(lambda (&rest x)
(org-trim
(mapconcat #'identity x separator)))
header-lines)
trailer)
table)))
(defun orgtbl-send-table (&optional maybe)
"Send a transformed version of table at point to the receiver position.
With argument MAYBE, fail quietly if no transformation is defined
@ -6149,7 +6174,7 @@ which will prompt for the width."
((numberp ask) ask)
(t 12))))
;; Skip any hline a the top of table.
(while (eq (car table) 'hline) (setq table (cdr table)))
(while (eq (car table) 'hline) (pop table))
;; Skip table header if any.
(dolist (x (or (cdr (memq 'hline table)) table))
(when (consp x)

View File

@ -1304,6 +1304,66 @@ See also `test-org-table/copy-field'."
(should (string= got
expect)))))
;;; Tables as Lisp
(ert-deftest test-org-table/to-lisp ()
"Test `orgtbl-to-lisp' specifications."
;; 2x2 no header
(should
(equal '(("a" "b") ("c" "d"))
(org-table-to-lisp "|a|b|\n|c|d|")))
;; 2x2 with 1-line header
(should
(equal '(("a" "b") hline ("c" "d"))
(org-table-to-lisp "|a|b|\n|-\n|c|d|")))
;; 2x4 with 2-line header
(should
(equal '(("a" "b") ("A" "B") hline ("c" "d") ("aa" "bb"))
(org-table-to-lisp "|a|b|\n|A|B|\n|-\n|c|d|\n|aa|bb|")))
;; leading hlines do not get stripped
(should
(equal '(hline ("a" "b") hline ("c" "d"))
(org-table-to-lisp "|-\n|a|b|\n|-\n|c|d|")))
(should
(equal '(hline ("a" "b") ("c" "d"))
(org-table-to-lisp "|-\n|a|b|\n|c|d|")))
(should
(equal '(hline hline hline hline ("a" "b") ("c" "d"))
(org-table-to-lisp "|-\n|-\n|-\n|-\n|a|b|\n|c|d|"))))
(ert-deftest test-org-table/collapse-header ()
"Test `orgtbl-to-lisp' specifications."
;; 2x2 no header - no collapsing
(should
(equal '(("a" "b") ("c" "d"))
(org-table-collapse-header (org-table-to-lisp "|a|b|\n|c|d|"))))
;; 2x2 with 1-line header - no collapsing
(should
(equal '(("a" "b") hline ("c" "d"))
(org-table-collapse-header (org-table-to-lisp "|a|b|\n|-\n|c|d|"))))
;; 2x4 with 2-line header - collapsed
(should
(equal '(("a A" "b B") hline ("c" "d") ("aa" "bb"))
(org-table-collapse-header (org-table-to-lisp "|a|b|\n|A|B|\n|-\n|c|d|\n|aa|bb|"))))
;; 2x4 with 2-line header, custom glue - collapsed
(should
(equal '(("a.A" "b.B") hline ("c" "d") ("aa" "bb"))
(org-table-collapse-header (org-table-to-lisp "|a|b|\n|A|B|\n|-\n|c|d|\n|aa|bb|") ".")))
;; 2x4 with 2-line header, threshold 1 - not collapsed
(should
(equal '(("a" "b") ("A" "B") hline ("c" "d") ("aa" "bb"))
(org-table-collapse-header (org-table-to-lisp "|a|b|\n|A|B|\n|-\n|c|d|\n|aa|bb|") nil 1)))
;; 2x4 with 2-line header, threshold 2 - collapsed
(should
(equal '(("a A" "b B") hline ("c" "d") ("aa" "bb"))
(org-table-collapse-header (org-table-to-lisp "|a|b|\n|A|B|\n|-\n|c|d|\n|aa|bb|") nil 2)))
;; 2x8 with 6-line header, default threshold 5 - not collapsed
(should
(equal '(("a" "b") ("A" "B") ("a" "b") ("A" "B") ("a" "b") ("A" "B") hline ("c" "d") ("aa" "bb"))
(org-table-collapse-header (org-table-to-lisp "|a|b|\n|A|B|\n|a|b|\n|A|B|\n|a|b|\n|A|B|\n|-\n|c|d|\n|aa|bb|")))))
;;; Radio Tables
(ert-deftest test-org-table/to-generic ()
@ -1905,7 +1965,7 @@ See also `test-org-table/copy-field'."
(org-table-sort-lines nil ?n)
(buffer-string)))))
;;; Formulas
(ert-deftest test-org-table/eval-formula ()

View File

@ -4129,6 +4129,16 @@ Another text. (ref:text)
(org-export-table-has-header-p
(org-element-map tree 'table 'identity info 'first-match)
info)))
;; With a multi-line header.
(should
(org-test-with-parsed-data "
| a | b |
| 0 | 1 |
|---+---|
| a | w |"
(org-export-table-has-header-p
(org-element-map tree 'table 'identity info 'first-match)
info)))
;; Without an header.
(should-not
(org-test-with-parsed-data "