From: Nicolas Goaziou <mail@nicolasgoaziou.fr>
To: emacs-orgmode@gnu.org
Subject: Re: org table toggle narrowing and true column hiding
Date: Tue, 27 Jun 2017 23:46:03 +0200 [thread overview]
Message-ID: <874lv1hzok.fsf@nicolasgoaziou.fr> (raw)
In-Reply-To: <87lgogdm9q.fsf@mat.ucm.es> (Uwe Brauer's message of "Sun, 25 Jun 2017 17:12:33 +0000")
[-- Attachment #1: Type: text/plain, Size: 2019 bytes --]
Hello,
Uwe Brauer <oub@mat.ucm.es> writes:
> Here are my impressions.
>
>
> - (org-table-hide-column nil) works nicely! I can hide several columns: I
> start with the first, hide it, move to the second hide etc
>
> - however (org-table-hide-column 1) etc did not work as expected,
> the first column was hidden but when I called
> (org-table-hide-column 2) that column was not hidden! Then I
> found out the culprit. I had the cursor on a different column. So
> (org-table-hide-column 1) seems to work best if the cursor is not
> on the table!
>
> - would it be possible to hide various column on the fly. Either by
> marking them or running (org-table-hide-column 1 2 3) or
> something like this.
>
> Thanks very much for this, I would it very useful and think it should be
> included at some point in master.
I toyed a bit further with the idea, and re-designed the whole thing.
The new implementation provides a single user-facing function:
`org-table-toggle-column-visibility'. Here is its docstring:
Shrink or expand current column in an Org table.
When optional argument ARG is a string, use it as white space
separated list of column ranges. A column range can be one of
the following patterns:
N column N only
N-M every column between N and M (both inclusive)
N- every column between N (inclusive) and the last column
-M every column between the first one and M (inclusive)
- every column
When called with `C-u' prefix, ask for the range specification.
When called with `C-u C-u' prefix, expand all columns.
In particular, when called with a prefix argument, it allows you to
type, e.g., "1-3 5 6-" and have columns 1, 2, 3, 5, 6 and onward shrunk
or expanded, according to their current state. I find it quite
efficient.
I imagine it can be useful when handling wide tables, but so can "<cX>"
cookies.
Anyway, feedback welcome.
Regards,
--
Nicolas Goaziou
[-- Attachment #2: 0001-org-table-Implement-shrunk-columns.patch --]
[-- Type: text/x-diff, Size: 40592 bytes --]
From 893393d728b0d6bf90a1e01a0a699b0dec7051c2 Mon Sep 17 00:00:00 2001
From: Nicolas Goaziou <mail@nicolasgoaziou.fr>
Date: Tue, 27 Jun 2017 23:06:02 +0200
Subject: [PATCH] org-table: Implement shrunk columns
* lisp/org-table.el (org-table-shrunk-column-display): New variable.
(org-table-with-shrunk-columns): New macro.
(org-table--shrunk-field):
(org-table--list-shrunk-columns):
(org-table--shrink-field):
(org-table--read-column-selection):
(org-table--expand-all-columns):
(org-table-toggle-column-visibility): New functions.
(org-table-align):
(org-table-get-field):
(org-table-insert-column):
(org-table-delete-column):
(org-table-move-column):
(org-table-move-row):
(org-table-insert-row):
(org-table-insert-hline): Use new functions.
(org-table-kill-row):
(org-table-overlay-coordinates):
(org-table-toggle-coordinate-overlays): Tiny refactoring.
---
lisp/org-table.el | 777 +++++++++++++++++++++++++++++++++++++-----------------
1 file changed, 530 insertions(+), 247 deletions(-)
diff --git a/lisp/org-table.el b/lisp/org-table.el
index 595c4e9e1..818917c79 100644
--- a/lisp/org-table.el
+++ b/lisp/org-table.el
@@ -423,6 +423,14 @@ prevents it from hanging emacs."
:version "26.1"
:package-version '(Org . "8.3"))
+(defcustom org-table-shrunk-column-display "…"
+ "String used to display a shrunk column."
+ :group 'org-table-import-export
+ :type 'string
+ :version "26.1"
+ :package-version '(Org . "9.1")
+ :safe (lambda (v) (and (stringp v) (not (equal v "")))))
+
(defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)"
"Regexp matching a line marked for automatic recalculation.")
@@ -510,6 +518,20 @@ Field is restored even in case of abnormal exit."
(org-table-goto-column ,column)
(set-marker ,line nil)))))
+(defmacro org-table-with-shrunk-columns (&rest body)
+ "Expand all columns before executing BODY, then shrink them again."
+ (declare (debug (body)))
+ (org-with-gensyms (shrunk-columns begin end)
+ `(let ((,begin (copy-marker (org-table-begin)))
+ (,end (copy-marker (org-table-end) t))
+ (,shrunk-columns (org-table--list-shrunk-columns)))
+ (org-with-point-at ,begin (org-table--expand-all-columns ,begin ,end))
+ (unwind-protect
+ (progn ,@body)
+ (org-table--shrink-columns ,shrunk-columns ,begin ,end)
+ (set-marker ,begin nil)
+ (set-marker ,end nil)))))
+
;;;###autoload
(defun org-table-create-with-table.el ()
"Use the table.el package to insert a new table.
@@ -758,8 +780,8 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
(defun org-table-align ()
"Align the table at point by aligning all vertical bars."
(interactive)
- (let* ((beg (org-table-begin))
- (end (copy-marker (org-table-end))))
+ (let ((beg (org-table-begin))
+ (end (copy-marker (org-table-end))))
(org-table-save-field
;; Make sure invisible characters in the table are at the right
;; place since column widths take them into account.
@@ -767,154 +789,155 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
(move-marker org-table-aligned-begin-marker beg)
(move-marker org-table-aligned-end-marker end)
(goto-char beg)
- (let* ((indent (progn (looking-at "[ \t]*") (match-string 0)))
- ;; Table's rows. Separators are replaced by nil. Trailing
- ;; spaces are also removed.
- (lines (mapcar (lambda (l)
- (and (not (string-match-p "\\`[ \t]*|-" l))
- (let ((l (org-trim l)))
- (remove-text-properties
- 0 (length l) '(display t org-cwidth t) l)
- l)))
- (org-split-string (buffer-substring beg end) "\n")))
- ;; Get the data fields by splitting the lines.
- (fields (mapcar (lambda (l) (org-split-string l " *| *"))
- (remq nil lines)))
- ;; Compute number of fields in the longest line. If the
- ;; table contains no field, create a default table.
- (maxfields (if fields (apply #'max (mapcar #'length fields))
- (kill-region beg end)
- (org-table-create org-table-default-size)
- (user-error "Empty table - created default table")))
- ;; A list of empty strings to fill any short rows on output.
- (emptycells (make-list maxfields ""))
- lengths typenums)
- ;; Check for special formatting.
- (dotimes (i maxfields)
- (let ((column (mapcar (lambda (x) (or (nth i x) "")) fields))
- fmax falign)
- ;; Look for an explicit width or alignment.
- (when (save-excursion
- (or (re-search-forward "| *<[lrc][0-9]*> *\\(|\\|$\\)" end t)
- (and org-table-do-narrow
- (re-search-forward
- "| *<[lrc]?[0-9]+> *\\(|\\|$\\)" end t))))
- (catch :exit
- (dolist (cell column)
- (when (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)?>\\'" cell)
- (when (match-end 1) (setq falign (match-string 1 cell)))
- (when (and org-table-do-narrow (match-end 2))
- (setq fmax (string-to-number (match-string 2 cell))))
- (when (or falign fmax) (throw :exit nil)))))
- ;; Find fields that are wider than FMAX, and shorten them.
- (when fmax
- (dolist (x column)
- (when (> (org-string-width x) fmax)
- (org-add-props x nil
- 'help-echo
- (concat
- "Clipped table field, use `\\[org-table-edit-field]' to \
+ (org-table-with-shrunk-columns
+ (let* ((indent (progn (looking-at "[ \t]*") (match-string 0)))
+ ;; Table's rows. Separators are replaced by nil. Trailing
+ ;; spaces are also removed.
+ (lines (mapcar (lambda (l)
+ (and (not (string-match-p "\\`[ \t]*|-" l))
+ (let ((l (org-trim l)))
+ (remove-text-properties
+ 0 (length l) '(display t org-cwidth t) l)
+ l)))
+ (org-split-string (buffer-substring beg end) "\n")))
+ ;; Get the data fields by splitting the lines.
+ (fields (mapcar (lambda (l) (org-split-string l " *| *"))
+ (remq nil lines)))
+ ;; Compute number of fields in the longest line. If the
+ ;; table contains no field, create a default table.
+ (maxfields (if fields (apply #'max (mapcar #'length fields))
+ (kill-region beg end)
+ (org-table-create org-table-default-size)
+ (user-error "Empty table - created default table")))
+ ;; A list of empty strings to fill any short rows on output.
+ (emptycells (make-list maxfields ""))
+ lengths typenums)
+ ;; Check for special formatting.
+ (dotimes (i maxfields)
+ (let ((column (mapcar (lambda (x) (or (nth i x) "")) fields))
+ fmax falign)
+ ;; Look for an explicit width or alignment.
+ (when (save-excursion
+ (or (re-search-forward "| *<[lrc][0-9]*> *\\(|\\|$\\)" end t)
+ (and org-table-do-narrow
+ (re-search-forward
+ "| *<[lrc]?[0-9]+> *\\(|\\|$\\)" end t))))
+ (catch :exit
+ (dolist (cell column)
+ (when (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)?>\\'" cell)
+ (when (match-end 1) (setq falign (match-string 1 cell)))
+ (when (and org-table-do-narrow (match-end 2))
+ (setq fmax (string-to-number (match-string 2 cell))))
+ (when (or falign fmax) (throw :exit nil)))))
+ ;; Find fields that are wider than FMAX, and shorten them.
+ (when fmax
+ (dolist (x column)
+ (when (> (org-string-width x) fmax)
+ (org-add-props x nil
+ 'help-echo
+ (concat
+ "Clipped table field, use `\\[org-table-edit-field]' to \
edit. Full value is:\n"
- (substring-no-properties x)))
- (let ((l (length x))
- (f1 (min fmax
- (or (string-match org-bracket-link-regexp x)
- fmax)))
- (f2 1))
- (unless (> f1 1)
- (user-error
- "Cannot narrow field starting with wide link \"%s\""
- (match-string 0 x)))
- (if (= (org-string-width x) l) (setq f2 f1)
- (setq f2 1)
- (while (< (org-string-width (substring x 0 f2)) f1)
- (cl-incf f2)))
- (add-text-properties f2 l (list 'org-cwidth t) x)
- (add-text-properties
- (if (>= (string-width (substring x (1- f2) f2)) 2) (1- f2)
- (- f2 2))
- f2
- (list 'display org-narrow-column-arrow)
- x))))))
- ;; Get the maximum width for each column
- (push (apply #'max (or fmax 1) 1 (mapcar #'org-string-width column))
- lengths)
- ;; Get the fraction of numbers among non-empty cells to
- ;; decide about alignment of the column.
- (if falign (push (equal (downcase falign) "r") typenums)
- (let ((cnt 0)
- (frac 0.0))
- (dolist (x column)
- (unless (equal x "")
- (setq frac
- (/ (+ (* frac cnt)
- (if (string-match-p org-table-number-regexp x)
- 1
- 0))
- (cl-incf cnt)))))
- (push (>= frac org-table-number-fraction) typenums)))))
- (setq lengths (nreverse lengths))
- (setq typenums (nreverse typenums))
- ;; Store alignment of this table, for later editing of single
- ;; fields.
- (setq org-table-last-alignment typenums)
- (setq org-table-last-column-widths lengths)
- ;; With invisible characters, `format' does not get the field
- ;; width right So we need to make these fields wide by hand.
- ;; Invisible characters may be introduced by fontified links,
- ;; emphasis, macros or sub/superscripts.
- (when (or (text-property-any beg end 'invisible 'org-link)
- (text-property-any beg end 'invisible t))
- (dotimes (i maxfields)
- (let ((len (nth i lengths)))
- (dotimes (j (length fields))
- (let* ((c (nthcdr i (nth j fields)))
- (cell (car c)))
- (when (and
- (stringp cell)
- (let ((l (length cell)))
- (or (text-property-any 0 l 'invisible 'org-link cell)
- (text-property-any beg end 'invisible t)))
- (< (org-string-width cell) len))
- (let ((s (make-string (- len (org-string-width cell)) ?\s)))
- (setcar c (if (nth i typenums) (concat s cell)
- (concat cell s))))))))))
-
- ;; Compute the formats needed for output of the table.
- (let ((hfmt (concat indent "|"))
- (rfmt (concat indent "|"))
- (rfmt1 " %%%s%ds |")
- (hfmt1 "-%s-+"))
- (dolist (l lengths (setq hfmt (concat (substring hfmt 0 -1) "|")))
- (let ((ty (if (pop typenums) "" "-"))) ; Flush numbers right.
- (setq rfmt (concat rfmt (format rfmt1 ty l)))
- (setq hfmt (concat hfmt (format hfmt1 (make-string l ?-))))))
- ;; Replace modified lines only. Check not only contents, but
- ;; also columns' width.
- (dolist (l lines)
- (let ((line
- (if l (apply #'format rfmt (append (pop fields) emptycells))
- hfmt))
- (previous (buffer-substring (point) (line-end-position))))
- (if (and (equal previous line)
- (let ((a 0)
- (b 0))
- (while (and (progn
- (setq a (next-single-property-change
- a 'org-cwidth previous))
- (setq b (next-single-property-change
- b 'org-cwidth line)))
- (eq a b)))
- (eq a b)))
- (forward-line)
- (insert line "\n")
- (delete-region (point) (line-beginning-position 2))))))
- (when (and orgtbl-mode (not (derived-mode-p 'org-mode)))
- (goto-char org-table-aligned-begin-marker)
- (while (org-hide-wide-columns org-table-aligned-end-marker)))
- (set-marker end nil)
- (when org-table-overlay-coordinates (org-table-overlay-coordinates))
- (setq org-table-may-need-update nil)))))
+ (substring-no-properties x)))
+ (let ((l (length x))
+ (f1 (min fmax
+ (or (string-match org-bracket-link-regexp x)
+ fmax)))
+ (f2 1))
+ (unless (> f1 1)
+ (user-error
+ "Cannot narrow field starting with wide link \"%s\""
+ (match-string 0 x)))
+ (if (= (org-string-width x) l) (setq f2 f1)
+ (setq f2 1)
+ (while (< (org-string-width (substring x 0 f2)) f1)
+ (cl-incf f2)))
+ (add-text-properties f2 l (list 'org-cwidth t) x)
+ (add-text-properties
+ (if (>= (string-width (substring x (1- f2) f2)) 2) (1- f2)
+ (- f2 2))
+ f2
+ (list 'display org-narrow-column-arrow)
+ x))))))
+ ;; Get the maximum width for each column
+ (push (apply #'max (or fmax 1) 1 (mapcar #'org-string-width column))
+ lengths)
+ ;; Get the fraction of numbers among non-empty cells to
+ ;; decide about alignment of the column.
+ (if falign (push (equal (downcase falign) "r") typenums)
+ (let ((cnt 0)
+ (frac 0.0))
+ (dolist (x column)
+ (unless (equal x "")
+ (setq frac
+ (/ (+ (* frac cnt)
+ (if (string-match-p org-table-number-regexp x)
+ 1
+ 0))
+ (cl-incf cnt)))))
+ (push (>= frac org-table-number-fraction) typenums)))))
+ (setq lengths (nreverse lengths))
+ (setq typenums (nreverse typenums))
+ ;; Store alignment of this table, for later editing of single
+ ;; fields.
+ (setq org-table-last-alignment typenums)
+ (setq org-table-last-column-widths lengths)
+ ;; With invisible characters, `format' does not get the field
+ ;; width right So we need to make these fields wide by hand.
+ ;; Invisible characters may be introduced by fontified links,
+ ;; emphasis, macros or sub/superscripts.
+ (when (or (text-property-any beg end 'invisible 'org-link)
+ (text-property-any beg end 'invisible t))
+ (dotimes (i maxfields)
+ (let ((len (nth i lengths)))
+ (dotimes (j (length fields))
+ (let* ((c (nthcdr i (nth j fields)))
+ (cell (car c)))
+ (when (and
+ (stringp cell)
+ (let ((l (length cell)))
+ (or (text-property-any 0 l 'invisible 'org-link cell)
+ (text-property-any beg end 'invisible t)))
+ (< (org-string-width cell) len))
+ (let ((s (make-string (- len (org-string-width cell)) ?\s)))
+ (setcar c (if (nth i typenums) (concat s cell)
+ (concat cell s))))))))))
+
+ ;; Compute the formats needed for output of the table.
+ (let ((hfmt (concat indent "|"))
+ (rfmt (concat indent "|"))
+ (rfmt1 " %%%s%ds |")
+ (hfmt1 "-%s-+"))
+ (dolist (l lengths (setq hfmt (concat (substring hfmt 0 -1) "|")))
+ (let ((ty (if (pop typenums) "" "-"))) ; Flush numbers right.
+ (setq rfmt (concat rfmt (format rfmt1 ty l)))
+ (setq hfmt (concat hfmt (format hfmt1 (make-string l ?-))))))
+ ;; Replace modified lines only. Check not only contents, but
+ ;; also columns' width.
+ (dolist (l lines)
+ (let ((line
+ (if l (apply #'format rfmt (append (pop fields) emptycells))
+ hfmt))
+ (previous (buffer-substring (point) (line-end-position))))
+ (if (and (equal previous line)
+ (let ((a 0)
+ (b 0))
+ (while (and (progn
+ (setq a (next-single-property-change
+ a 'org-cwidth previous))
+ (setq b (next-single-property-change
+ b 'org-cwidth line)))
+ (eq a b)))
+ (eq a b)))
+ (forward-line)
+ (insert line "\n")
+ (delete-region (point) (line-beginning-position 2))))))
+ (when (and orgtbl-mode (not (derived-mode-p 'org-mode)))
+ (goto-char org-table-aligned-begin-marker)
+ (while (org-hide-wide-columns org-table-aligned-end-marker)))
+ (set-marker end nil)
+ (when org-table-overlay-coordinates (org-table-overlay-coordinates))
+ (setq org-table-may-need-update nil))))))
;;;###autoload
(defun org-table-begin (&optional table-type)
@@ -1275,7 +1298,16 @@ value."
(let* ((pos (match-beginning 0))
(val (buffer-substring pos (match-end 0))))
(when replace
- (replace-match (if (equal replace "") " " replace) t t))
+ ;; Since we are going to remove any hidden field, do not relay
+ ;; on `org-table--hidden-field' as it could be GC'ed before
+ ;; second check.
+ (let* ((hide-overlay (org-table--shrunk-field))
+ (begin (and hide-overlay (overlay-start hide-overlay))))
+ (when hide-overlay (delete-overlay hide-overlay))
+ (replace-match (if (equal replace "") " " replace) t t)
+ (when hide-overlay
+ (move-overlay hide-overlay
+ begin (+ begin (min 1 (length replace)))))))
(goto-char (min (line-end-position) (1+ pos)))
val)))
@@ -1377,9 +1409,11 @@ However, when FORCE is non-nil, create new columns if necessary."
(interactive)
(unless (org-at-table-p) (user-error "Not at a table"))
(org-table-find-dataline)
- (let* ((col (max 1 (org-table-current-column)))
- (beg (org-table-begin))
- (end (copy-marker (org-table-end))))
+ (let ((col (max 1 (org-table-current-column)))
+ (beg (org-table-begin))
+ (end (copy-marker (org-table-end)))
+ (shrunk-columns (org-table--list-shrunk-columns)))
+ (org-table--expand-all-columns beg end)
(org-table-save-field
(goto-char beg)
(while (< (point) end)
@@ -1387,8 +1421,14 @@ However, when FORCE is non-nil, create new columns if necessary."
(org-table-goto-column col t)
(insert "| "))
(forward-line)))
- (set-marker end nil)
(org-table-align)
+ ;; Shift appropriately stored shrunk column numbers, then hide the
+ ;; columns again.
+ (org-table--shrink-columns (mapcar (lambda (c) (if (< c col) c (1+ c)))
+ shrunk-columns)
+ beg end)
+ (set-marker end nil)
+ ;; Fix TBLFM formulas, if desirable.
(when (or (not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm "Fix formulas? "))
(org-table-fix-formulas "$" nil (1- col) 1)
@@ -1443,9 +1483,11 @@ non-nil, the one above is used."
(unless (org-at-table-p) (user-error "Not at a table"))
(org-table-find-dataline)
(org-table-check-inside-data-field)
- (let ((col (org-table-current-column))
- (beg (org-table-begin))
- (end (copy-marker (org-table-end))))
+ (let* ((col (org-table-current-column))
+ (beg (org-table-begin))
+ (end (copy-marker (org-table-end)))
+ (shrunk-columns (remq col (org-table--list-shrunk-columns))))
+ (org-table--expand-all-columns beg end)
(org-table-save-field
(goto-char beg)
(while (< (point) end)
@@ -1455,9 +1497,15 @@ non-nil, the one above is used."
(and (looking-at "|[^|\n]+|")
(replace-match "|")))
(forward-line)))
- (set-marker end nil)
(org-table-goto-column (max 1 (1- col)))
(org-table-align)
+ ;; Shift appropriately stored shrunk column numbers, then hide the
+ ;; columns again.
+ (org-table--shrink-columns (mapcar (lambda (c) (if (< c col) c (1+ c)))
+ shrunk-columns)
+ beg end)
+ (set-marker end nil)
+ ;; Fix TBLFM formulas, if desirable.
(when (or (not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm "Fix formulas? "))
(org-table-fix-formulas
@@ -1470,6 +1518,7 @@ non-nil, the one above is used."
"Move column to the right."
(interactive)
(org-table-move-column nil))
+
;;;###autoload
(defun org-table-move-column-left ()
"Move column to the left."
@@ -1492,33 +1541,49 @@ non-nil, the one above is used."
(user-error "Cannot move column further left"))
(when (and (not left) (looking-at "[^|\n]*|[^|\n]*$"))
(user-error "Cannot move column further right"))
- (org-table-save-field
- (goto-char beg)
- (while (< (point) end)
- (unless (org-at-table-hline-p)
- (org-table-goto-column col1 t)
- (when (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|")
- (transpose-regions
- (match-beginning 1) (match-end 1)
- (match-beginning 2) (match-end 2))))
- (forward-line)))
- (set-marker end nil)
- (org-table-goto-column colpos)
- (org-table-align)
- (when (or (not org-table-fix-formulas-confirm)
- (funcall org-table-fix-formulas-confirm "Fix formulas? "))
- (org-table-fix-formulas
- "$" (list (cons (number-to-string col) (number-to-string colpos))
- (cons (number-to-string colpos) (number-to-string col))))
- (org-table-fix-formulas
- "$LR" (list (cons (number-to-string col) (number-to-string colpos))
- (cons (number-to-string colpos) (number-to-string col)))))))
+ (let ((shrunk-columns (org-table--list-shrunk-columns)))
+ (org-table--expand-all-columns beg end)
+ (org-table-save-field
+ (goto-char beg)
+ (while (< (point) end)
+ (unless (org-at-table-hline-p)
+ (org-table-goto-column col1 t)
+ (when (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|")
+ (transpose-regions
+ (match-beginning 1) (match-end 1)
+ (match-beginning 2) (match-end 2))))
+ (forward-line)))
+ (org-table-goto-column colpos)
+ (org-table-align)
+ ;; Shift appropriately stored shrunk column numbers, then shrink
+ ;; the columns again.
+ (org-table--shrink-columns
+ (mapcar (lambda (c)
+ (cond ((and (= col c) left) (1- c))
+ ((= col c) (1+ c))
+ ((and (= col (1+ c)) left) (1+ c))
+ ((and (= col (1- c)) (not left) (1- c)))
+ (t c)))
+ shrunk-columns)
+ beg end)
+ (set-marker end nil)
+ ;; Fix TBLFM formulas, if desirable.
+ (when (or (not org-table-fix-formulas-confirm)
+ (funcall org-table-fix-formulas-confirm "Fix formulas? "))
+ (org-table-fix-formulas
+ "$" (list (cons (number-to-string col) (number-to-string colpos))
+ (cons (number-to-string colpos) (number-to-string col))))
+ (org-table-fix-formulas
+ "$LR" (list
+ (cons (number-to-string col) (number-to-string colpos))
+ (cons (number-to-string colpos) (number-to-string col))))))))
;;;###autoload
(defun org-table-move-row-down ()
"Move table row down."
(interactive)
(org-table-move-row nil))
+
;;;###autoload
(defun org-table-move-row-up ()
"Move table row up."
@@ -1541,23 +1606,25 @@ non-nil, the one above is used."
(unless (org-at-table-p)
(goto-char pos)
(user-error "Cannot move row further"))
- (setq hline2p (looking-at org-table-hline-regexp))
- (goto-char pos)
- (beginning-of-line 1)
- (setq pos (point))
- (setq txt (buffer-substring (point) (1+ (point-at-eol))))
- (delete-region (point) (1+ (point-at-eol)))
- (beginning-of-line tonew)
- (insert txt)
- (beginning-of-line 0)
- (org-move-to-column col)
- (unless (or hline1p hline2p
- (not (or (not org-table-fix-formulas-confirm)
- (funcall org-table-fix-formulas-confirm
- "Fix formulas? "))))
- (org-table-fix-formulas
- "@" (list (cons (number-to-string dline1) (number-to-string dline2))
- (cons (number-to-string dline2) (number-to-string dline1)))))))
+ (org-table-with-shrunk-columns
+ (setq hline2p (looking-at org-table-hline-regexp))
+ (goto-char pos)
+ (beginning-of-line 1)
+ (setq pos (point))
+ (setq txt (buffer-substring (point) (1+ (point-at-eol))))
+ (delete-region (point) (1+ (point-at-eol)))
+ (beginning-of-line tonew)
+ (insert txt)
+ (beginning-of-line 0)
+ (org-move-to-column col)
+ (unless (or hline1p hline2p
+ (not (or (not org-table-fix-formulas-confirm)
+ (funcall org-table-fix-formulas-confirm
+ "Fix formulas? "))))
+ (org-table-fix-formulas
+ "@" (list
+ (cons (number-to-string dline1) (number-to-string dline2))
+ (cons (number-to-string dline2) (number-to-string dline1))))))))
;;;###autoload
(defun org-table-insert-row (&optional arg)
@@ -1565,47 +1632,48 @@ non-nil, the one above is used."
With prefix ARG, insert below the current line."
(interactive "P")
(unless (org-at-table-p) (user-error "Not at a table"))
- (let* ((line (buffer-substring (line-beginning-position) (line-end-position)))
- (new (org-table-clean-line line)))
- ;; Fix the first field if necessary
- (if (string-match "^[ \t]*| *[#$] *|" line)
- (setq new (replace-match (match-string 0 line) t t new)))
- (beginning-of-line (if arg 2 1))
- ;; Buffer may not end of a newline character, so ensure
- ;; (beginning-of-line 2) moves point to a new line.
- (unless (bolp) (insert "\n"))
- (let (org-table-may-need-update) (insert-before-markers new "\n"))
- (beginning-of-line 0)
- (re-search-forward "| ?" (line-end-position) t)
- (when (or org-table-may-need-update org-table-overlay-coordinates)
- (org-table-align))
- (when (or (not org-table-fix-formulas-confirm)
- (funcall org-table-fix-formulas-confirm "Fix formulas? "))
- (org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1))))
+ (org-table-with-shrunk-columns
+ (let* ((line (buffer-substring (line-beginning-position) (line-end-position)))
+ (new (org-table-clean-line line)))
+ ;; Fix the first field if necessary
+ (when (string-match "^[ \t]*| *[#$] *|" line)
+ (setq new (replace-match (match-string 0 line) t t new)))
+ (beginning-of-line (if arg 2 1))
+ ;; Buffer may not end of a newline character, so ensure
+ ;; (beginning-of-line 2) moves point to a new line.
+ (unless (bolp) (insert "\n"))
+ (let (org-table-may-need-update) (insert-before-markers new "\n"))
+ (beginning-of-line 0)
+ (re-search-forward "| ?" (line-end-position) t)
+ (when (or org-table-may-need-update org-table-overlay-coordinates)
+ (org-table-align))
+ (when (or (not org-table-fix-formulas-confirm)
+ (funcall org-table-fix-formulas-confirm "Fix formulas? "))
+ (org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1)))))
;;;###autoload
(defun org-table-insert-hline (&optional above)
"Insert a horizontal-line below the current line into the table.
With prefix ABOVE, insert above the current line."
(interactive "P")
- (if (not (org-at-table-p))
- (user-error "Not at a table"))
- (when (eobp) (insert "\n") (backward-char 1))
- (if (not (string-match-p "|[ \t]*$" (org-current-line-string)))
- (org-table-align))
- (let ((line (org-table-clean-line
- (buffer-substring (point-at-bol) (point-at-eol))))
- (col (current-column)))
- (while (string-match "|\\( +\\)|" line)
- (setq line (replace-match
- (concat "+" (make-string (- (match-end 1) (match-beginning 1))
- ?-) "|") t t line)))
- (and (string-match "\\+" line) (setq line (replace-match "|" t t line)))
- (beginning-of-line (if above 1 2))
- (insert line "\n")
- (beginning-of-line (if above 1 -1))
- (org-move-to-column col)
- (and org-table-overlay-coordinates (org-table-align))))
+ (unless (org-at-table-p) (user-error "Not at a table"))
+ (when (eobp) (save-excursion (insert "\n")))
+ (unless (string-match-p "|[ \t]*$" (org-current-line-string))
+ (org-table-align))
+ (org-table-with-shrunk-columns
+ (let ((line (org-table-clean-line
+ (buffer-substring (point-at-bol) (point-at-eol))))
+ (col (current-column)))
+ (while (string-match "|\\( +\\)|" line)
+ (setq line (replace-match
+ (concat "+" (make-string (- (match-end 1) (match-beginning 1))
+ ?-) "|") t t line)))
+ (and (string-match "\\+" line) (setq line (replace-match "|" t t line)))
+ (beginning-of-line (if above 1 2))
+ (insert line "\n")
+ (beginning-of-line (if above 1 -1))
+ (org-move-to-column col)
+ (when org-table-overlay-coordinates (org-table-align)))))
;;;###autoload
(defun org-table-hline-and-move (&optional same-column)
@@ -1638,8 +1706,7 @@ In particular, this does handle wide and invisible characters."
(defun org-table-kill-row ()
"Delete the current row or horizontal line from the table."
(interactive)
- (if (not (org-at-table-p))
- (user-error "Not at a table"))
+ (unless (org-at-table-p) (user-error "Not at a table"))
(let ((col (current-column))
(dline (org-table-current-dline)))
(kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max)))
@@ -3783,6 +3850,222 @@ minutes or seconds."
secs0)))))
(if (< secs 0) (concat "-" res) res)))
+
+\f
+;;; Columns shrinking
+
+(defun org-table--shrunk-field ()
+ "Non-nil if current field is narrowed.
+When non-nil, return the overlay narrowing the field."
+ (cl-some (lambda (o)
+ (and (eq 'table-column-hide (overlay-get o 'org-overlay-type))
+ o))
+ (overlays-in (1- (point)) (1+ (point)))))
+
+(defun org-table--list-shrunk-columns ()
+ "List currently shrunk columns in table at point."
+ (save-excursion
+ ;; We really check shrunk columns in current row only. It could
+ ;; be wrong if all rows do not contain the same number of columns
+ ;; (i.e. the table is not properly aligned). As a consequence,
+ ;; some columns may not be shrunk again upon aligning the table.
+ ;;
+ ;; For example, in the following table, cursor is on first row and
+ ;; "<>» indicates a shrunk column.
+ ;;
+ ;; | |
+ ;; | | <> |
+ ;;
+ ;; Aligning table from the first row will not shrink again the
+ ;; second row, which was not visible initially.
+ ;;
+ ;; However, fixing it requires to check every row, which may be
+ ;; slow on large tables. Moreover, the hindrance of this
+ ;; pathological case is very limited.
+ (beginning-of-line)
+ (search-forward "|")
+ (let ((separator (if (org-at-table-hline-p) "+" "|"))
+ (column 1)
+ (shrunk (and (org-table--shrunk-field) (list 1)))
+ (end (line-end-position)))
+ (while (search-forward separator end t)
+ (cl-incf column)
+ (when (org-table--shrunk-field) (push column shrunk)))
+ (nreverse shrunk))))
+
+(defun org-table--shrink-field ()
+ "Shrink current field.
+
+Field is shrunk under a one character large overlay. The latter
+has the following properties:
+
+ `org-overlay-type'
+
+ Set to `table-column-hide'. Used to identify overlays
+ responsible for the task.
+
+ `org-table-column-overlays'
+
+ It is a list with the pattern (siblings . COLUMN-OVERLAYS)
+ where COLUMN-OVERLAYS is the list of all overlays hiding the
+ same column.
+
+Whenever the text behind or next the overlay is modified, all the
+overlays in the column are deleted, effectively displaying the
+column again.
+
+Return overlay used to hide the field."
+ (unless (org-table--shrunk-field)
+ (let* ((separator-re (if (org-at-table-hline-p) "[|+]" "|"))
+ (beg
+ (save-excursion
+ (if (re-search-backward separator-re (line-beginning-position) t)
+ (match-end 0)
+ (point))))
+ (end (if (re-search-forward separator-re (line-end-position) 'move)
+ (1- (point))
+ (point))) ;no closing "|" in last column
+ (field (org-trim (buffer-substring-no-properties beg end)))
+ (show-before-edit
+ (list (lambda (o &rest _)
+ ;; Removing one overlay removes all other overlays
+ ;; in the same column.
+ (mapc #'delete-overlay
+ (cdr (overlay-get o 'org-table-column-overlays))))))
+ (o (make-overlay beg end)))
+ (overlay-put o 'help-echo field)
+ (overlay-put o 'insert-behind-hooks show-before-edit)
+ (overlay-put o 'insert-in-front-hooks show-before-edit)
+ (overlay-put o 'modification-hooks show-before-edit)
+ (overlay-put o 'org-overlay-type 'table-column-hide)
+ ;; Make sure overlays stays on top of table coordinates
+ ;; overlays. See `org-table-overlay-coordinates'.
+ (overlay-put o 'priority 1)
+ (org-overlay-display o org-table-shrunk-column-display 'org-table t)
+ o)))
+
+(defun org-table--read-column-selection (select max)
+ "Read column selection select as a list of numbers.
+
+SELECT is a string containing column ranges, separated by white
+space characters, see `org-table-hide-column' for details. MAX
+is the maximum column number.
+
+Return value is a sorted list of numbers. Ignore any number
+outside of the [1;MAX] range."
+ (catch :all
+ (sort
+ (delete-dups
+ (cl-mapcan
+ (lambda (s)
+ (cond
+ ((member s '("-" "1-")) (throw :all (number-sequence 1 max)))
+ ((string-match-p "\\`[0-9]+\\'" s)
+ (let ((n (string-to-number s)))
+ (and (> n 0) (<= n max) (list n))))
+ ((string-match "\\`\\([0-9]+\\)?-\\([0-9]+\\)?\\'" s)
+ (let ((n (match-string 1 s))
+ (m (match-string 2 s)))
+ (number-sequence (if n (max 1 (string-to-number n))
+ 1)
+ (if m (min max (string-to-number m))
+ max))))
+ (t nil))) ;invalid specification
+ (split-string select)))
+ #'<)))
+
+(defun org-table--shrink-columns (columns beg end)
+ "Shrink COLUMNS in an Org table.
+COLUMNS is a sorted list of column numbers. BEG and END are,
+respectively, the beginning position and the end position of the
+table."
+ (org-with-wide-buffer
+ (dolist (c columns)
+ (goto-char beg)
+ (let ((chain (list 'siblings)))
+ (while (< (point) end)
+ ;; Move to COLUMN.
+ (catch :continue
+ (let ((separator (if (org-at-table-hline-p) "+" "|")))
+ (search-forward "|")
+ (or (= c 1) ;already there
+ (search-forward separator (line-end-position) t (1- c))
+ (throw :continue nil))) ;skip invalid columns
+ ;; Link overlay to the other overlays in the same column.
+ (let ((new-overlay (org-table--shrink-field)))
+ (push new-overlay (cdr chain))
+ (overlay-put new-overlay 'org-table-column-overlays chain)))
+ (forward-line))))))
+
+(defun org-table--expand-all-columns (beg end)
+ "Expand all columns in an Org table.
+BEG and END are, respectively, the beginning position and the end
+position of the table."
+ (remove-overlays beg end 'org-overlay-type 'table-column-hide))
+
+;;;###autoload
+(defun org-table-toggle-column-visibility (&optional arg)
+ "Shrink or expand current column in an Org table.
+
+When optional argument ARG is a string, use it as white space
+separated list of column ranges. A column range can be one of
+the following patterns:
+
+ N column N only
+ N-M every column between N and M (both inclusive)
+ N- every column between N (inclusive) and the last column
+ -M every column between the first one and M (inclusive)
+ - every column
+
+When called with `\\[universal-argument]' prefix, ask for the \
+range specification.
+
+When called with `\\[universal-argument] \\[universal-argument]' \
+prefix, expand all columns."
+ (interactive "P")
+ (cond ((not (org-at-table-p)) (user-error "Not in a table"))
+ ((and (not arg)
+ (save-excursion
+ (skip-chars-backward "^|" (line-beginning-position))
+ (or (bolp) (looking-at-p "[ \t]*$"))))
+ ;; Point is either before first column or past last one.
+ (user-error "Not in a valid column")))
+ (let* ((pos (point))
+ (begin (org-table-begin))
+ (end (org-table-end))
+ ;; Compute an upper bound for the number of columns.
+ ;; Nonexistent columns are ignored anyway.
+ (max-columns (/ (- (line-end-position) (line-beginning-position)) 2))
+ (shrunk (org-table--list-shrunk-columns))
+ (columns (pcase arg
+ (`nil
+ ;; Find current column, even when on a hline.
+ (let ((separator (if (org-at-table-hline-p) "+" "|"))
+ (c 1))
+ (save-excursion
+ (beginning-of-line)
+ (search-forward "|" pos t)
+ (while (search-forward separator pos t) (cl-incf c)))
+ (list c)))
+ ((pred stringp)
+ (org-table--read-column-selection arg max-columns))
+ (`(4)
+ (org-table--read-column-selection
+ (read-string "Column ranges (e.g. 2-4 6-): ")
+ max-columns))
+ (`(16) nil)
+ (_ (user-error "Invalid argument: %S" arg)))))
+ (org-table--expand-all-columns begin end)
+ (unless (equal arg '(16))
+ (org-table--shrink-columns (cl-set-exclusive-or columns shrunk) begin end)
+ ;; Move before overlay if point is under it.
+ (let ((o (org-table--shrunk-field)))
+ (when o (goto-char (overlay-start o)))))))
+
+
+\f
+;;; Formula editing
+
(defun org-table-fedit-convert-buffer (function)
"Convert all references in this buffer, using FUNCTION."
(let ((origin (copy-marker (line-beginning-position))))
@@ -4213,7 +4496,7 @@ FACE, when non-nil, for the highlight."
(mapc 'delete-overlay org-table-coordinate-overlays)
(setq org-table-coordinate-overlays nil)
(save-excursion
- (let ((id 0) (ih 0) hline eol s1 s2 str ic ov beg)
+ (let ((id 0) (ih 0) hline eol str ov)
(goto-char (org-table-begin))
(while (org-at-table-p)
(setq eol (point-at-eol))
@@ -4224,17 +4507,17 @@ FACE, when non-nil, for the highlight."
(format "%4d" (setq id (1+ id)))))
(org-overlay-before-string ov str 'org-special-keyword 'evaporate)
(when hline
- (setq ic 0)
- (while (re-search-forward "[+|]\\(-+\\)" eol t)
- (setq beg (1+ (match-beginning 0))
- ic (1+ ic)
- s1 (concat "$" (int-to-string ic))
- s2 (org-number-to-letters ic)
- str (if (eq org-table-use-standard-references t) s2 s1))
- (setq ov (make-overlay beg (+ beg (length str))))
- (push ov org-table-coordinate-overlays)
- (org-overlay-display ov str 'org-special-keyword 'evaporate)))
- (beginning-of-line 2)))))
+ (let ((ic 0))
+ (while (re-search-forward "[+|]\\(-+\\)" eol t)
+ (cl-incf ic)
+ (let* ((beg (1+ (match-beginning 0)))
+ (s1 (format "$%d" ic))
+ (s2 (org-number-to-letters ic))
+ (str (if (eq t org-table-use-standard-references) s2 s1))
+ (ov (make-overlay beg (+ beg (length str)))))
+ (push ov org-table-coordinate-overlays)
+ (org-overlay-display ov str 'org-special-keyword 'evaporate)))))
+ (forward-line)))))
;;;###autoload
(defun org-table-toggle-coordinate-overlays ()
@@ -4243,8 +4526,8 @@ FACE, when non-nil, for the highlight."
(setq org-table-overlay-coordinates (not org-table-overlay-coordinates))
(message "Tables Row/Column numbers display turned %s"
(if org-table-overlay-coordinates "on" "off"))
- (if (and (org-at-table-p) org-table-overlay-coordinates)
- (org-table-align))
+ (when (and (org-at-table-p) org-table-overlay-coordinates)
+ (org-table-align))
(unless org-table-overlay-coordinates
(mapc 'delete-overlay org-table-coordinate-overlays)
(setq org-table-coordinate-overlays nil)))
--
2.13.1
next prev parent reply other threads:[~2017-06-27 21:46 UTC|newest]
Thread overview: 17+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-06-21 9:24 org table toggle narrowing and true column hiding Uwe Brauer
2017-06-22 18:06 ` Nicolas Goaziou
2017-06-23 9:49 ` Uwe Brauer
2017-06-24 8:48 ` Nicolas Goaziou
2017-06-24 21:06 ` Uwe Brauer
2017-06-24 23:10 ` Nicolas Goaziou
2017-06-25 17:12 ` Uwe Brauer
2017-06-27 21:46 ` Nicolas Goaziou [this message]
2017-06-28 9:46 ` Uwe Brauer
2017-06-28 19:35 ` Samuel Wales
2017-06-28 19:39 ` Nicolas Goaziou
2017-06-28 20:53 ` Samuel Wales
2017-06-28 21:51 ` Nicolas Goaziou
2017-06-29 8:00 ` [rows?] (was: org table toggle narrowing and true column hiding) Uwe Brauer
2017-07-01 9:57 ` [rows?] Nicolas Goaziou
2017-06-23 16:23 ` org table toggle narrowing and true column hiding Michael Brand
2017-06-23 21:21 ` Uwe Brauer
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.orgmode.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=874lv1hzok.fsf@nicolasgoaziou.fr \
--to=mail@nicolasgoaziou.fr \
--cc=emacs-orgmode@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).