From de439a68c8c546f0901f9be2bda644a2a21c36b4 Mon Sep 17 00:00:00 2001 From: Nicolas Goaziou Date: Mon, 22 Feb 2016 15:00:31 +0100 Subject: [PATCH] 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. --- doc/org.texi | 9 +- etc/ORG-NEWS | 3 + lisp/org-colview.el | 209 +++++++++++++++++-------------- testing/lisp/test-org-colview.el | 130 ++++++++++++++++++- 4 files changed, 246 insertions(+), 105 deletions(-) diff --git a/doc/org.texi b/doc/org.texi index 4515efe0b..e423df77f 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 f259b065a..f76e51958 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 5e5af4869..3c2ba803c 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 6989e7a75..49200e303 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: 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))))))