summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNicolas Goaziou <mail@nicolasgoaziou.fr>2016-02-22 15:00:31 +0100
committerNicolas Goaziou <mail@nicolasgoaziou.fr>2016-02-23 13:18:34 +0100
commitde439a68c8c546f0901f9be2bda644a2a21c36b4 (patch)
tree1d5e9c408a047c12f7d714a6294767f674675126
parent633e4d4202389ce2430924e92019f8bf247960f3 (diff)
downloadorg-mode-de439a68c8c546f0901f9be2bda644a2a21c36b4.tar.gz
org-colview: Allow multiple summaries for a single property
* lisp/org-colview.el (org-columns--collect-values): (org-agenda-colview-summarize): Use column format specification as the unique identifier for the returned alist. * lisp/org-colview.el (org-columns--display-here): Store column format specification in a new overlay property. (org-columns--set-widths): (org-columns--display-here): Use column format specification instead of (org-columns--displayed-value): Since the same property can have multiple titles, use column specification instead of property as keys. (org-columns--collect-values): Apply signature change. (org-columns-update): Handle multiple columns for the same property. Also apply signature change to `org-columns--displayed-value'. (org-columns--compute-spec): New function. (org-columns-compute): (org-columns-compute-all): Use new function. * testing/lisp/test-org-colview.el (test-org-colview/columns-summary): (test-org-colview/columns-update): Add tests. * doc/org.texi (Column attributes): Document computation with multiple summary types for a given property.
-rw-r--r--doc/org.texi9
-rw-r--r--etc/ORG-NEWS3
-rw-r--r--lisp/org-colview.el209
-rw-r--r--testing/lisp/test-org-colview.el130
4 files changed, 246 insertions, 105 deletions
diff --git a/doc/org.texi b/doc/org.texi
index 4515efe..e423df7 100644
--- a/doc/org.texi
+++ b/doc/org.texi
@@ -5621,7 +5621,9 @@ optional. The individual parts have the following meaning:
@var{title} @r{The header text for the column. If omitted, the property}
@r{name is used.}
@{@var{summary-type}@} @r{The summary type. If specified, the column values for}
- @r{parent nodes are computed from the children.}
+ @r{parent nodes are computed from the children@footnote{If
+ more than one summary type apply to the property, the parent
+ values are computed according to the first of them.}.}
@r{Supported summary types are:}
@{+@} @r{Sum numbers in this column.}
@{+;%.1f@} @r{Like @samp{+}, but format result with @samp{%.1f}.}
@@ -5651,11 +5653,6 @@ optional. The individual parts have the following meaning:
@{est+@} @r{Add @samp{low-high} estimates.}
@end example
-@noindent
-Be aware that you can only have one summary type for any property you
-include. Subsequent columns referencing the same property will all display the
-same summary information.
-
The @code{est+} summary type requires further explanation. It is used for
combining estimates, expressed as @samp{low-high} ranges or plain numbers.
For example, instead of estimating a particular task will take 5 days, you
diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index f259b06..f76e519 100644
--- a/etc/ORG-NEWS
+++ b/etc/ORG-NEWS
@@ -217,6 +217,9 @@ The variable used to be a ~defvar~, it is now a ~defcustom~.
**** Allow custom summaries
It is now possible to add new summary types, or override those
provided by Org by customizing ~org-columns-summary-types~, which see.
+**** Allow multiple summaries for any property
+Columns can now summarize the same property using different summary
+types.
*** Preview LaTeX snippets in buffers not visiting files
*** New option ~org-attach-commit~
When non-nil, commit attachments with git, assuming the document is in
diff --git a/lisp/org-colview.el b/lisp/org-colview.el
index 5e5af48..3c2ba80 100644
--- a/lisp/org-colview.el
+++ b/lisp/org-colview.el
@@ -219,20 +219,18 @@ See `org-columns-summary-types' for details.")
"--"
["Quit" org-columns-quit t]))
-(defun org-columns--displayed-value (property value)
- "Return displayed value for PROPERTY in current entry.
+(defun org-columns--displayed-value (spec value)
+ "Return displayed value for specification SPEC in current entry.
-VALUE is the real value of the property, as a string.
-
-This function assumes `org-columns-current-fmt-compiled' is
-initialized."
+SPEC is a column format specification as stored in
+`org-columns-current-fmt-compiled'. VALUE is the real value to
+display, as a string."
(cond
((and (functionp org-columns-modify-value-for-display-function)
- (funcall
- org-columns-modify-value-for-display-function
- (nth 1 (assoc property org-columns-current-fmt-compiled))
- value)))
- ((equal property "ITEM")
+ (funcall org-columns-modify-value-for-display-function
+ (nth 1 spec)
+ value)))
+ ((equal (car spec) "ITEM")
(concat (make-string (1- (org-current-level))
(if org-hide-leading-stars ?\s ?*))
"* "
@@ -245,28 +243,30 @@ initialized."
When optional argument AGENDA is non-nil, assume the value is
meant for the agenda, i.e., caller is `org-agenda-columns'.
-Return a list of triplets (PROPERTY VALUE DISPLAYED) suitable for
+Return a list of triplets (SPEC VALUE DISPLAYED) suitable for
`org-columns--display-here'.
This function assumes `org-columns-current-fmt-compiled' is
initialized."
(mapcar
(lambda (spec)
- (let* ((p (car spec))
- (v (or (cdr (assoc p (get-text-property (point) 'org-summaries)))
- (org-entry-get (point) p 'selective t)
- (and agenda
- ;; Effort property is not defined. Try to use
- ;; appointment duration.
- org-agenda-columns-add-appointments-to-effort-sum
- (string= p (upcase org-effort-property))
- (get-text-property (point) 'duration)
- (org-propertize
- (org-minutes-to-clocksum-string
- (get-text-property (point) 'duration))
- 'face 'org-warning))
- "")))
- (list p v (org-columns--displayed-value p v))))
+ (pcase spec
+ (`(,p . ,_)
+ (let* ((v (or (cdr
+ (assoc spec (get-text-property (point) 'org-summaries)))
+ (org-entry-get (point) p 'selective t)
+ (and agenda
+ ;; Effort property is not defined. Try to
+ ;; use appointment duration.
+ org-agenda-columns-add-appointments-to-effort-sum
+ (string= p (upcase org-effort-property))
+ (get-text-property (point) 'duration)
+ (org-propertize
+ (org-minutes-to-clocksum-string
+ (get-text-property (point) 'duration))
+ 'face 'org-warning))
+ "")))
+ (list spec v (org-columns--displayed-value spec v))))))
org-columns-current-fmt-compiled))
(defun org-columns--set-widths (cache)
@@ -279,13 +279,13 @@ integers greater than 0."
(lambda (spec)
(pcase spec
(`(,_ ,_ ,(and width (pred wholenump)) . ,_) width)
- (`(,property ,name . ,_)
+ (`(,_ ,name . ,_)
;; No width is specified in the columns format.
;; Compute it by checking all possible values for
;; PROPERTY.
(let ((width (length name)))
(dolist (entry cache width)
- (let ((value (nth 2 (assoc property (cdr entry)))))
+ (let ((value (nth 2 (assoc spec (cdr entry)))))
(setq width (max (length value) width))))))))
org-columns-current-fmt-compiled))))
@@ -323,8 +323,8 @@ integers greater than 0."
(defun org-columns--display-here (columns &optional dateline)
"Overlay the current line with column display.
-COLUMNS is an alist (PROPERTY VALUE DISPLAYED). Optional
-argument DATELINE is non-nil when the face used should be
+COLUMNS is an alist (SPEC VALUE DISPLAYED). Optional argument
+DATELINE is non-nil when the face used should be
`org-agenda-column-dateline'."
(save-excursion
(beginning-of-line)
@@ -355,8 +355,9 @@ argument DATELINE is non-nil when the face used should be
(last (1- (length columns))))
(dolist (column columns)
(pcase column
- (`(,property ,original ,value)
- (let* ((width (aref org-columns-current-maxwidths i))
+ (`(,spec ,original ,value)
+ (let* ((property (car spec))
+ (width (aref org-columns-current-maxwidths i))
(fmt (format (if (= i last) "%%-%d.%ds |"
"%%-%d.%ds | ")
width width))
@@ -367,6 +368,7 @@ argument DATELINE is non-nil when the face used should be
(if dateline face1 face))))
(overlay-put ov 'keymap org-columns-map)
(overlay-put ov 'org-columns-key property)
+ (overlay-put ov 'org-columns-spec spec)
(overlay-put ov 'org-columns-value original)
(overlay-put ov 'org-columns-value-modified value)
(overlay-put ov 'org-columns-format fmt)
@@ -942,26 +944,26 @@ display, or in the #+COLUMNS line of the current buffer."
(org-with-wide-buffer
(let ((p (upcase property)))
(dolist (ov org-columns-overlays)
- (when (let ((key (overlay-get ov 'org-columns-key)))
- (and key (equal key p) (overlay-start ov)))
- (goto-char (overlay-start ov))
- (let ((value (cdr
- (assoc-string
- property
- (get-text-property (line-beginning-position)
- 'org-summaries)
- t))))
- (when value
- (let ((displayed (org-columns--displayed-value property value))
- (format (overlay-get ov 'org-columns-format))
- (width
- (aref org-columns-current-maxwidths (current-column))))
- (overlay-put ov 'org-columns-value value)
- (overlay-put ov 'org-columns-value-modified displayed)
- (overlay-put ov
- 'display
- (org-columns--overlay-text
- displayed format width property value))))))))))
+ (let ((key (overlay-get ov 'org-columns-key)))
+ (when (and key (equal key p) (overlay-start ov))
+ (goto-char (overlay-start ov))
+ (let* ((spec (overlay-get ov 'org-columns-spec))
+ (value
+ (or (cdr (assoc spec
+ (get-text-property (line-beginning-position)
+ 'org-summaries)))
+ (org-entry-get (point) key))))
+ (when value
+ (let ((displayed (org-columns--displayed-value spec value))
+ (format (overlay-get ov 'org-columns-format))
+ (width
+ (aref org-columns-current-maxwidths (current-column))))
+ (overlay-put ov 'org-columns-value value)
+ (overlay-put ov 'org-columns-value-modified displayed)
+ (overlay-put ov
+ 'display
+ (org-columns--overlay-text
+ displayed format width property value)))))))))))
(defun org-columns-redo ()
"Construct the column display again."
@@ -1092,20 +1094,21 @@ format instead. Otherwise, use H:M format."
(hms-flag (format-seconds "%h:%.2m:%.2s" seconds))
(t (format-seconds "%h:%.2m" seconds)))))
-;;;###autoload
-(defun org-columns-compute (property)
- "Summarize the values of property PROPERTY hierarchically."
- (interactive)
+(defun org-columns--compute-spec (spec &optional update)
+ "Update tree according to SPEC.
+SPEC is a column format specification. When optional argument
+UPDATE is non-nil, summarized values can replace existing ones in
+properties drawers."
(let* ((lmax (if (org-bound-and-true-p org-inlinetask-min-level)
org-inlinetask-min-level
29)) ;Hard-code deepest level.
(lvals (make-vector (1+ lmax) nil))
- (spec (assoc-string property org-columns-current-fmt-compiled t))
- (operator (nth 3 spec))
- (printf (nth 4 spec))
(level 0)
(inminlevel lmax)
- (last-level lmax))
+ (last-level lmax)
+ (property (car spec))
+ (printf (nth 4 spec))
+ (summarize (org-columns--summarize (nth 3 spec))))
(org-with-wide-buffer
;; Find the region to compute.
(goto-char org-columns-top-level-marker)
@@ -1122,49 +1125,63 @@ format instead. Otherwise, use H:M format."
(cond
((< level last-level)
;; Collect values from lower levels and inline tasks here
- ;; and summarize them using SUMMARIZE. Store them as text
- ;; property.
+ ;; and summarize them using SUMMARIZE. Store them in text
+ ;; property `org-summaries', in alist whose key is SPEC.
(let* ((summary
- (let ((all (append (and (/= last-level inminlevel)
- (aref lvals last-level))
- (aref lvals inminlevel))))
- (and all (funcall (org-columns--summarize operator)
- all printf)))))
- (let* ((summaries-alist (get-text-property pos 'org-summaries))
- (old (assoc-string property summaries-alist t))
- (new
- (cond
- (summary (propertize summary 'org-computed t 'face 'bold))
- (value-set value)
- (t ""))))
- (if old (setcdr old new)
- (push (cons property new) summaries-alist)
- (org-with-silent-modifications
- (add-text-properties pos (1+ pos)
- (list 'org-summaries summaries-alist)))))
- ;; When PROPERTY is set in current node, but its value
- ;; doesn't match the one computed, use the latter
- ;; instead.
- (when (and value summary (not (equal value summary)))
- (org-entry-put nil property summary))
+ (and summarize
+ (let ((values (append (and (/= last-level inminlevel)
+ (aref lvals last-level))
+ (aref lvals inminlevel))))
+ (and values (funcall summarize values printf))))))
+ ;; Leaf values are not summaries: do not mark them.
+ (when summary
+ (let* ((summaries-alist (get-text-property pos 'org-summaries))
+ (old (assoc spec summaries-alist)))
+ (if old (setcdr old summary)
+ (push (cons spec summary) summaries-alist)
+ (org-with-silent-modifications
+ (add-text-properties
+ pos (1+ pos) (list 'org-summaries summaries-alist)))))
+ ;; When PROPERTY exists in current node, even if empty,
+ ;; but its value doesn't match the one computed, use
+ ;; the latter instead.
+ (when (and update value (not (equal value summary)))
+ (org-entry-put (point) property summary)))
;; Add current to current level accumulator.
(when (or summary value-set)
(push (or summary value) (aref lvals level)))
;; Clear accumulators for deeper levels.
- (cl-loop for l from (1+ level) to lmax do
- (aset lvals l nil))))
+ (cl-loop for l from (1+ level) to lmax do (aset lvals l nil))))
(value-set (push value (aref lvals level)))
(t nil)))))))
+;;;###autoload
+(defun org-columns-compute (property)
+ "Summarize the values of PROPERTY hierarchically.
+Also update existing values for PROPERTY according to the first
+column specification."
+ (interactive)
+ (let ((main-flag t)
+ (upcase-prop (upcase property)))
+ (dolist (spec org-columns-current-fmt-compiled)
+ (pcase spec
+ (`(,(pred (equal upcase-prop)) . ,_)
+ (org-columns--compute-spec spec main-flag)
+ ;; Only the first summary can update the property value.
+ (when main-flag (setq main-flag nil)))))))
+
(defun org-columns-compute-all ()
"Compute all columns that have operators defined."
(org-with-silent-modifications
(remove-text-properties (point-min) (point-max) '(org-summaries t)))
- (let ((org-columns--time (float-time (current-time))))
+ (let ((org-columns--time (float-time (current-time)))
+ seen)
(dolist (spec org-columns-current-fmt-compiled)
- (pcase spec
- (`(,property ,_ ,_ ,operator ,_)
- (when operator (save-excursion (org-columns-compute property))))))))
+ (let ((property (car spec)))
+ ;; Property value is updated only the first time a given
+ ;; property is encountered.
+ (org-columns--compute-spec spec (not (member property seen)))
+ (push property seen)))))
(defun org-columns--summary-sum (values printf)
"Compute the sum of VALUES.
@@ -1556,9 +1573,9 @@ This will add overlays to the date lines, to show the summary for each day."
(let ((date (buffer-substring
(line-beginning-position)
(line-end-position))))
- (list "ITEM" date date)))
- (`(,prop ,_ ,_ nil ,_) (list prop "" ""))
- (`(,prop ,_ ,_ ,operator ,printf)
+ (list spec date date)))
+ (`(,_ ,_ ,_ nil ,_) (list spec "" ""))
+ (`(,_ ,_ ,_ ,operator ,printf)
(let* ((summarize (org-columns--summarize operator))
(values
;; Use real values for summary, not those
@@ -1566,13 +1583,13 @@ This will add overlays to the date lines, to show the summary for each day."
(delq nil
(mapcar
(lambda (e)
- (org-string-nw-p (nth 1 (assoc prop e))))
+ (org-string-nw-p (nth 1 (assoc spec e))))
entries)))
(final (if values (funcall summarize values printf)
"")))
(unless (equal final "")
(put-text-property 0 (length final) 'face 'bold final))
- (list prop final final)))))
+ (list spec final final)))))
fmt)
'dateline)
(setq-local org-agenda-columns-active t)))
diff --git a/testing/lisp/test-org-colview.el b/testing/lisp/test-org-colview.el
index 6989e7a..49200e3 100644
--- a/testing/lisp/test-org-colview.el
+++ b/testing/lisp/test-org-colview.el
@@ -504,7 +504,7 @@
"
(let ((org-columns-default-format "%A{est+}")) (org-columns))
(get-char-property (point) 'org-columns-value-modified))))
- ;; Test custom summary types.
+ ;; Allow custom summary types.
(should
(equal
"1|2"
@@ -521,7 +521,65 @@
(let ((org-columns-summary-types
'(("custom" . (lambda (s _) (mapconcat #'identity s "|")))))
(org-columns-default-format "%A{custom}")) (org-columns))
- (get-char-property (point) 'org-columns-value-modified)))))
+ (get-char-property (point) 'org-columns-value-modified))))
+ ;; Allow multiple summary types applied to the same property.
+ (should
+ (equal
+ '("42" "99")
+ (org-test-with-temp-text
+ "* H
+** S1
+:PROPERTIES:
+:A: 99
+:END:
+** S1
+:PROPERTIES:
+:A: 42
+:END:"
+ (let ((org-columns-default-format "%A{min} %A{max}")) (org-columns))
+ (list (get-char-property (point) 'org-columns-value-modified)
+ (get-char-property (1+ (point)) 'org-columns-value-modified)))))
+ ;; Allow mixing both summarized and non-summarized columns for
+ ;; a property. However, the first column takes precedence and
+ ;; updates the value.
+ (should
+ (equal
+ '("1000" "42")
+ (org-test-with-temp-text
+ "* H
+:PROPERTIES:
+:A: 1000
+:END:
+** S1
+:PROPERTIES:
+:A: 99
+:END:
+** S1
+:PROPERTIES:
+:A: 42
+:END:"
+ (let ((org-columns-default-format "%A %A{min}")) (org-columns))
+ (list (get-char-property (point) 'org-columns-value-modified)
+ (get-char-property (1+ (point)) 'org-columns-value-modified)))))
+ (should
+ (equal
+ '("42" "42")
+ (org-test-with-temp-text
+ "* H
+:PROPERTIES:
+:A: 1000
+:END:
+** S1
+:PROPERTIES:
+:A: 99
+:END:
+** S1
+:PROPERTIES:
+:A: 42
+:END:"
+ (let ((org-columns-default-format "%A{min} %A")) (org-columns))
+ (list (get-char-property (point) 'org-columns-value-modified)
+ (get-char-property (1+ (point)) 'org-columns-value-modified))))))
(ert-deftest test-org-colview/columns-new ()
"Test `org-columns-new' specifications."
@@ -616,6 +674,60 @@
(org-columns-update "A")
(list (get-char-property (point-min) 'org-columns-value)
(get-char-property (point-min) 'org-columns-value-modified)))))
+ ;; When multiple columns are using the same property, value is
+ ;; updated according to the specifications of the first one.
+ (should
+ (equal
+ "2"
+ (org-test-with-temp-text
+ "* H
+:PROPERTIES:
+:A: 1
+:END:
+** S
+:PROPERTIES:
+:A: 2
+:END:"
+ (let ((org-columns-default-format "%A{min} %A")) (org-columns))
+ (org-columns-update "A")
+ (org-entry-get nil "A"))))
+ (should
+ (equal
+ "1"
+ (org-test-with-temp-text
+ "* H
+:PROPERTIES:
+:A: 1
+:END:
+** S
+:PROPERTIES:
+:A: 2
+:END:"
+ (let ((org-columns-default-format "%A %A{min}")) (org-columns))
+ (org-columns-update "A")
+ (org-entry-get nil "A"))))
+ ;; Ensure modifications propagate in upper levels even when multiple
+ ;; summary types apply to the same property.
+ (should
+ (equal
+ '("1" "22")
+ (org-test-with-temp-text
+ "* H
+** S1
+:PROPERTIES:
+:A: 1
+:END:
+** S2
+:PROPERTIES:
+:A: <point>2
+:END:"
+ (save-excursion
+ (goto-char (point-min))
+ (let ((org-columns-default-format "%A{min} %A{max}")) (org-columns)))
+ (insert "2")
+ (org-columns-update "A")
+ (list (get-char-property 1 'org-columns-value)
+ (get-char-property 2 'org-columns-value-modified)))))
;; Ensure additional processing is done (e.g., ellipses, special
;; keywords fontification...).
(should
@@ -656,7 +768,19 @@
(org-columns-ellipses "..")
(org-inlinetask-min-level 15))
(org-columns))
- (get-char-property (point-min) 'org-columns-value))))))
+ (get-char-property (point-min) 'org-columns-value)))))
+ ;; Handle `org-columns-modify-value-for-display-function', even with
+ ;; multiple titles for the same property.
+ (should
+ (equal '("foo" "bar")
+ (org-test-with-temp-text "* H"
+ (let ((org-columns-default-format "%ITEM %ITEM(Name)")
+ (org-columns-modify-value-for-display-function
+ (lambda (title value)
+ (pcase title ("ITEM" "foo") ("Name" "bar") (_ "baz")))))
+ (org-columns))
+ (list (get-char-property 1 'org-columns-value-modified)
+ (get-char-property 2 'org-columns-value-modified))))))