diff options
Diffstat (limited to 'elpa/org-9.5.2/org-colview.el')
| -rw-r--r-- | elpa/org-9.5.2/org-colview.el | 1738 |
1 files changed, 0 insertions, 1738 deletions
diff --git a/elpa/org-9.5.2/org-colview.el b/elpa/org-9.5.2/org-colview.el deleted file mode 100644 index 9794382..0000000 --- a/elpa/org-9.5.2/org-colview.el +++ /dev/null @@ -1,1738 +0,0 @@ -;;; org-colview.el --- Column View in Org -*- lexical-binding: t; -*- - -;; Copyright (C) 2004-2021 Free Software Foundation, Inc. - -;; Author: Carsten Dominik <carsten.dominik@gmail.com> -;; Keywords: outlines, hypermedia, calendar, wp -;; Homepage: https://orgmode.org -;; -;; This file is part of GNU Emacs. -;; -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: - -;; This file contains the column view for Org. - -;;; Code: - -(require 'cl-lib) -(require 'org) - -(declare-function org-agenda-redo "org-agenda" (&optional all)) -(declare-function org-agenda-do-context-action "org-agenda" ()) -(declare-function org-clock-sum-today "org-clock" (&optional headline-filter)) -(declare-function org-element-extract-element "org-element" (element)) -(declare-function org-element-interpret-data "org-element" (data)) -(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated)) -(declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent)) -(declare-function org-element-property "org-element" (property element)) -(declare-function org-element-restriction "org-element" (element)) -(declare-function org-element-type "org-element" (element)) -(declare-function org-dynamic-block-define "org" (type func)) -(declare-function org-link-display-format "ol" (s)) -(declare-function org-link-open-from-string "ol" (s &optional arg)) -(declare-function face-remap-remove-relative "face-remap" (cookie)) -(declare-function face-remap-add-relative "face-remap" (face &rest specs)) - -(defvar org-agenda-columns-add-appointments-to-effort-sum) -(defvar org-agenda-columns-compute-summary-properties) -(defvar org-agenda-columns-show-summaries) -(defvar org-agenda-view-columns-initially) -(defvar org-inlinetask-min-level) - - -;;; Configuration - -(defcustom org-columns-modify-value-for-display-function nil - "Function that modifies values for display in column view. -For example, it can be used to cut out a certain part from a time stamp. -The function must take 2 arguments: - -column-title The title of the column (*not* the property name) -value The value that should be modified. - -The function should return the value that should be displayed, -or nil if the normal value should be used." - :group 'org-properties - :type '(choice (const nil) (function))) - -(defcustom org-columns-summary-types nil - "Alist between operators and summarize functions. - -Each association follows the pattern (LABEL . SUMMARIZE), -or (LABEL SUMMARIZE COLLECT) where - - LABEL is a string used in #+COLUMNS definition describing the - summary type. It can contain any character but \"}\". It is - case-sensitive. - - SUMMARIZE is a function called with two arguments. The first - argument is a non-empty list of values, as non-empty strings. - The second one is a format string or nil. It has to return - a string summarizing the list of values. - - COLLECT is a function called with one argument, a property - name. It is called in the context of a headline and must - return the collected property, or the empty string. You can - use this to only collect a property if a related conditional - properties is set, e.g., to return VACATION_DAYS only if - CONFIRMED is true. - -Note that the return value can become one value for an higher -order summary, so the function is expected to handle its own -output. - -Types defined in this variable take precedence over those defined -in `org-columns-summary-types-default', which see." - :group 'org-properties - :version "26.1" - :package-version '(Org . "9.0") - :type '(alist :key-type (string :tag " Label") - :value-type - (choice (function :tag "Summarize") - (list :tag "Collect and summarize" - (function :tag "Summarize") - (function :tag "Collect"))))) - - - -;;; Column View - -(defvar-local org-columns-overlays nil - "Holds the list of current column overlays.") - -(defvar-local org-columns-current-fmt nil - "Local variable, holds the currently active column format.") - -(defvar-local org-columns-current-fmt-compiled nil - "Local variable, holds the currently active column format. -This is the compiled version of the format.") - -(defvar-local org-columns-current-maxwidths nil - "Currently active maximum column widths, as a vector.") - -(defvar-local org-columns-begin-marker nil - "Points to the position where last a column creation command was called.") - -(defvar-local org-columns-top-level-marker nil - "Points to the position where current columns region starts.") - -(defvar org-columns--time 0.0 - "Number of seconds since the epoch, as a floating point number.") - -(defvar org-columns-map (make-sparse-keymap) - "The keymap valid in column display.") - -(defconst org-columns-summary-types-default - '(("+" . org-columns--summary-sum) - ("$" . org-columns--summary-currencies) - ("X" . org-columns--summary-checkbox) - ("X/" . org-columns--summary-checkbox-count) - ("X%" . org-columns--summary-checkbox-percent) - ("max" . org-columns--summary-max) - ("mean" . org-columns--summary-mean) - ("min" . org-columns--summary-min) - (":" . org-columns--summary-sum-times) - (":max" . org-columns--summary-max-time) - (":mean" . org-columns--summary-mean-time) - (":min" . org-columns--summary-min-time) - ("@max" . org-columns--summary-max-age) - ("@mean" . org-columns--summary-mean-age) - ("@min" . org-columns--summary-min-age) - ("est+" . org-columns--summary-estimate)) - "Map operators to summarize functions. -See `org-columns-summary-types' for details.") - -(defun org-columns-content () - "Switch to contents view while in columns view." - (interactive) - (org-overview) - (org-content)) - -(org-defkey org-columns-map "c" #'org-columns-content) -(org-defkey org-columns-map "o" #'org-overview) -(org-defkey org-columns-map "e" #'org-columns-edit-value) -(org-defkey org-columns-map "\C-c\C-t" #'org-columns-todo) -(org-defkey org-columns-map "\C-c\C-c" #'org-columns-toggle-or-columns-quit) -(org-defkey org-columns-map "\C-c\C-o" #'org-columns-open-link) -(org-defkey org-columns-map "v" #'org-columns-show-value) -(org-defkey org-columns-map "q" #'org-columns-quit) -(org-defkey org-columns-map "r" #'org-columns-redo) -(org-defkey org-columns-map "g" #'org-columns-redo) -(org-defkey org-columns-map [left] #'backward-char) -(org-defkey org-columns-map "\M-b" #'backward-char) -(org-defkey org-columns-map "a" #'org-columns-edit-allowed) -(org-defkey org-columns-map "s" #'org-columns-edit-attributes) -(org-defkey org-columns-map "\M-f" - (lambda () (interactive) (goto-char (1+ (point))))) -(org-defkey org-columns-map [right] - (lambda () (interactive) (goto-char (1+ (point))))) -(org-defkey org-columns-map [down] - (lambda () (interactive) - (let ((col (current-column))) - (beginning-of-line 2) - (while (and (org-invisible-p2) (not (eobp))) - (beginning-of-line 2)) - (move-to-column col) - (if (derived-mode-p 'org-agenda-mode) - (org-agenda-do-context-action))))) -(org-defkey org-columns-map [up] - (lambda () (interactive) - (let ((col (current-column))) - (beginning-of-line 0) - (while (and (org-invisible-p2) (not (bobp))) - (beginning-of-line 0)) - (move-to-column col) - (if (eq major-mode 'org-agenda-mode) - (org-agenda-do-context-action))))) -(org-defkey org-columns-map [(shift right)] #'org-columns-next-allowed-value) -(org-defkey org-columns-map "n" #'org-columns-next-allowed-value) -(org-defkey org-columns-map [(shift left)] #'org-columns-previous-allowed-value) -(org-defkey org-columns-map "p" #'org-columns-previous-allowed-value) -(org-defkey org-columns-map "<" #'org-columns-narrow) -(org-defkey org-columns-map ">" #'org-columns-widen) -(org-defkey org-columns-map [(meta right)] #'org-columns-move-right) -(org-defkey org-columns-map [(meta left)] #'org-columns-move-left) -(org-defkey org-columns-map [(shift meta right)] #'org-columns-new) -(org-defkey org-columns-map [(shift meta left)] #'org-columns-delete) -(dotimes (i 10) - (org-defkey org-columns-map (number-to-string i) - (lambda () (interactive) - (org-columns-next-allowed-value nil i)))) - -(easy-menu-define org-columns-menu org-columns-map "Org Column Menu." - '("Column" - ["Edit property" org-columns-edit-value t] - ["Next allowed value" org-columns-next-allowed-value t] - ["Previous allowed value" org-columns-previous-allowed-value t] - ["Show full value" org-columns-show-value t] - ["Edit allowed values" org-columns-edit-allowed t] - "--" - ["Edit column attributes" org-columns-edit-attributes t] - ["Increase column width" org-columns-widen t] - ["Decrease column width" org-columns-narrow t] - "--" - ["Move column right" org-columns-move-right t] - ["Move column left" org-columns-move-left t] - ["Add column" org-columns-new t] - ["Delete column" org-columns-delete t] - "--" - ["CONTENTS" org-columns-content t] - ["OVERVIEW" org-overview t] - ["Refresh columns display" org-columns-redo t] - "--" - ["Open link" org-columns-open-link t] - "--" - ["Quit" org-columns-quit t])) - -(defun org-columns--displayed-value (spec value &optional no-star) - "Return displayed value for specification SPEC in current entry. - -SPEC is a column format specification as stored in -`org-columns-current-fmt-compiled'. VALUE is the real value to -display, as a string. - -When NO-STAR is non-nil, do not add asterisks before displayed -value for ITEM property." - (or (and (functionp org-columns-modify-value-for-display-function) - (funcall org-columns-modify-value-for-display-function - (nth 1 spec) ;column name - value)) - (pcase spec - (`("ITEM" . ,_) - (let ((stars - (and (not no-star) - (concat (make-string (1- (org-current-level)) - (if org-hide-leading-stars ?\s ?*)) - "* ")))) - (concat stars (org-link-display-format value)))) - (`(,(or "DEADLINE" "SCHEDULED" "TIMESTAMP") . ,_) - (replace-regexp-in-string org-ts-regexp "[\\1]" value)) - (`(,_ ,_ ,_ ,_ nil) value) - ;; If PRINTF is set, assume we are displaying a number and - ;; obey to the format string. - (`(,_ ,_ ,_ ,_ ,printf) (format printf (string-to-number value))) - (_ (error "Invalid column specification format: %S" spec))))) - -(defun org-columns--collect-values (&optional compiled-fmt) - "Collect values for columns on the current line. - -Return a list of triplets (SPEC VALUE DISPLAYED) suitable for -`org-columns--display-here'. - -This function assumes `org-columns-current-fmt-compiled' is -initialized is set in the current buffer. However, it is -possible to override it with optional argument COMPILED-FMT." - (let ((summaries (get-text-property (point) 'org-summaries))) - (mapcar - (lambda (spec) - (pcase spec - (`(,p . ,_) - (let* ((v (or (cdr (assoc spec summaries)) - (org-entry-get (point) p 'selective t) - (and compiled-fmt ;assume `org-agenda-columns' - ;; 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) - (propertize (org-duration-from-minutes - (get-text-property (point) 'duration)) - 'face 'org-warning)) - ""))) - ;; A non-nil COMPILED-FMT means we're calling from Org - ;; Agenda mode, where we do not want leading stars for - ;; ITEM. Hence the optional argument for - ;; `org-columns--displayed-value'. - (list spec v (org-columns--displayed-value spec v compiled-fmt)))))) - (or compiled-fmt org-columns-current-fmt-compiled)))) - -(defun org-columns--set-widths (cache) - "Compute the maximum column widths from the format and CACHE. -This function sets `org-columns-current-maxwidths' as a vector of -integers greater than 0." - (setq org-columns-current-maxwidths - (apply #'vector - (mapcar - (lambda (spec) - (pcase spec - (`(,_ ,_ ,(and width (pred wholenump)) . ,_) width) - (`(,_ ,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 spec (cdr entry))))) - (setq width (max (length value) width)))))))) - org-columns-current-fmt-compiled)))) - -(defun org-columns--new-overlay (beg end &optional string face) - "Create a new column overlay and add it to the list." - (let ((ov (make-overlay beg end))) - (overlay-put ov 'face (or face 'secondary-selection)) - (org-overlay-display ov string face) - (push ov org-columns-overlays) - ov)) - -(defun org-columns--summarize (operator) - "Return summary function associated to string OPERATOR." - (pcase (or (assoc operator org-columns-summary-types) - (assoc operator org-columns-summary-types-default)) - (`nil (error "Unknown %S operator" operator)) - (`(,_ . ,(and (pred functionp) summarize)) summarize) - (`(,_ ,summarize ,_) summarize) - (_ (error "Invalid definition for operator %S" operator)))) - -(defun org-columns--collect (operator) - "Return collect function associated to string OPERATOR. -Return nil if no collect function is associated to OPERATOR." - (pcase (or (assoc operator org-columns-summary-types) - (assoc operator org-columns-summary-types-default)) - (`nil (error "Unknown %S operator" operator)) - (`(,_ . ,(pred functionp)) nil) ;default value - (`(,_ ,_ ,collect) collect) - (_ (error "Invalid definition for operator %S" operator)))) - -(defun org-columns--overlay-text (value fmt width property original) - "Return decorated VALUE string for columns overlay display. -FMT is a format string. WIDTH is the width of the column, as an -integer. PROPERTY is the property being displayed, as a string. -ORIGINAL is the real string, i.e., before it is modified by -`org-columns--displayed-value'." - (format fmt - (let ((v (org-columns-add-ellipses value width))) - (pcase property - ("PRIORITY" - (propertize v 'face (org-get-priority-face original))) - ("TAGS" - (if (not org-tags-special-faces-re) - (propertize v 'face 'org-tag) - (replace-regexp-in-string - org-tags-special-faces-re - (lambda (m) (propertize m 'face (org-get-tag-face m))) - v nil nil 1))) - ("TODO" (propertize v 'face (org-get-todo-face original))) - (_ v))))) - -(defvar org-columns-header-line-remap nil - "Store the relative remapping of column header-line. -This is needed to later remove this relative remapping.") - -(defun org-columns--display-here (columns &optional dateline) - "Overlay the current line with column display. -COLUMNS is an alist (SPEC VALUE DISPLAYED). Optional argument -DATELINE is non-nil when the face used should be -`org-agenda-column-dateline'." - (when (ignore-errors (require 'face-remap)) - (setq org-columns-header-line-remap - (face-remap-add-relative 'header-line '(:inherit default)))) - (save-excursion - (beginning-of-line) - (let* ((level-face (and (looking-at "\\(\\**\\)\\(\\* \\)") - (org-get-level-face 2))) - (ref-face (or level-face - (and (eq major-mode 'org-agenda-mode) - (org-get-at-bol 'face)) - 'default)) - (color (list :foreground (face-attribute ref-face :foreground))) - (font (list :family (face-attribute 'default :family))) - (face (list color font 'org-column ref-face)) - (face1 (list color font 'org-agenda-column-dateline ref-face))) - ;; Each column is an overlay on top of a character. So there has - ;; to be at least as many characters available on the line as - ;; columns to display. - (let ((columns (length org-columns-current-fmt-compiled)) - (chars (- (line-end-position) (line-beginning-position)))) - (when (> columns chars) - (save-excursion - (end-of-line) - (let ((inhibit-read-only t)) - (insert (make-string (- columns chars) ?\s)))))) - ;; Display columns. Create and install the overlay for the - ;; current column on the next character. - (let ((i 0) - (last (1- (length columns)))) - (dolist (column columns) - (pcase column - (`(,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)) - (ov (org-columns--new-overlay - (point) (1+ (point)) - (org-columns--overlay-text - value fmt width property original) - (if dateline face1 face)))) - (overlay-put ov 'keymap org-columns-map) - (overlay-put ov 'org-columns-key property) - (overlay-put ov 'org-columns-value original) - (overlay-put ov 'org-columns-value-modified value) - (overlay-put ov 'org-columns-format fmt) - (overlay-put ov 'line-prefix "") - (overlay-put ov 'wrap-prefix "") - (forward-char)))) - (cl-incf i))) - ;; Make the rest of the line disappear. - (let ((ov (org-columns--new-overlay (point) (line-end-position)))) - (overlay-put ov 'invisible t) - (overlay-put ov 'keymap org-columns-map) - (overlay-put ov 'line-prefix "") - (overlay-put ov 'wrap-prefix "")) - (let ((ov (make-overlay (1- (line-end-position)) - (line-beginning-position 2)))) - (overlay-put ov 'keymap org-columns-map) - (push ov org-columns-overlays)) - (with-silent-modifications - (let ((inhibit-read-only t)) - (put-text-property - (line-end-position 0) - (line-beginning-position 2) - 'read-only - (substitute-command-keys - "Type \\<org-columns-map>`\\[org-columns-edit-value]' \ -to edit property"))))))) - -(defun org-columns-add-ellipses (string width) - "Truncate STRING with WIDTH characters, with ellipses." - (cond - ((<= (length string) width) string) - ((<= width (length org-columns-ellipses)) - (substring org-columns-ellipses 0 width)) - (t (concat (substring string 0 (- width (length org-columns-ellipses))) - org-columns-ellipses)))) - -(defvar org-columns-full-header-line-format nil - "The full header line format, will be shifted by horizontal scrolling." ) -(defvar org-previous-header-line-format nil - "The header line format before column view was turned on.") -(defvar org-columns-inhibit-recalculation nil - "Inhibit recomputing of columns on column view startup.") -(defvar org-columns-flyspell-was-active nil - "Remember the state of `flyspell-mode' before column view. -Flyspell-mode can cause problems in columns view, so it is turned off -for the duration of the command.") - -(defvar header-line-format) -(defvar org-columns-previous-hscroll 0) - -(defun org-columns--display-here-title () - "Overlay the newline before the current line with the table title." - (interactive) - (let ((title "") - (linum-offset (org-line-number-display-width 'columns)) - (i 0)) - (dolist (column org-columns-current-fmt-compiled) - (pcase column - (`(,property ,name . ,_) - (let* ((width (aref org-columns-current-maxwidths i)) - (fmt (format "%%-%d.%ds | " width width))) - (setq title (concat title (format fmt (or name property))))))) - (cl-incf i)) - (setq-local org-previous-header-line-format header-line-format) - (setq org-columns-full-header-line-format - (concat - (org-add-props " " nil 'display `(space :align-to ,linum-offset)) - (org-add-props (substring title 0 -1) nil 'face 'org-column-title))) - (setq org-columns-previous-hscroll -1) - (add-hook 'post-command-hook #'org-columns-hscroll-title nil 'local))) - -(defun org-columns-hscroll-title () - "Set the `header-line-format' so that it scrolls along with the table." - (sit-for .0001) ; need to force a redisplay to update window-hscroll - (let ((hscroll (window-hscroll))) - (when (/= org-columns-previous-hscroll hscroll) - (setq header-line-format - (concat (substring org-columns-full-header-line-format 0 1) - (substring org-columns-full-header-line-format - (min (length org-columns-full-header-line-format) - (1+ hscroll)))) - org-columns-previous-hscroll hscroll) - (force-mode-line-update)))) - -(defvar org-colview-initial-truncate-line-value nil - "Remember the value of `truncate-lines' across colview.") - -;;;###autoload -(defun org-columns-remove-overlays () - "Remove all currently active column overlays." - (interactive) - (when (and (fboundp 'face-remap-remove-relative) - org-columns-header-line-remap) - (face-remap-remove-relative org-columns-header-line-remap)) - (when org-columns-overlays - (when (local-variable-p 'org-previous-header-line-format) - (setq header-line-format org-previous-header-line-format) - (kill-local-variable 'org-previous-header-line-format) - (remove-hook 'post-command-hook #'org-columns-hscroll-title 'local)) - (set-marker org-columns-begin-marker nil) - (when (markerp org-columns-top-level-marker) - (set-marker org-columns-top-level-marker nil)) - (with-silent-modifications - (mapc #'delete-overlay org-columns-overlays) - (setq org-columns-overlays nil) - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(read-only t)))) - (when org-columns-flyspell-was-active - (flyspell-mode 1)) - (when (local-variable-p 'org-colview-initial-truncate-line-value) - (setq truncate-lines org-colview-initial-truncate-line-value)))) - -(defun org-columns-show-value () - "Show the full value of the property." - (interactive) - (let ((value (get-char-property (point) 'org-columns-value))) - (message "Value is: %s" (or value "")))) - -(defvar org-agenda-columns-active) ;; defined in org-agenda.el - -(defun org-columns-quit () - "Remove the column overlays and in this way exit column editing." - (interactive) - (with-silent-modifications - (org-columns-remove-overlays) - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(read-only t)))) - (if (not (eq major-mode 'org-agenda-mode)) - (setq org-columns-current-fmt nil) - (setq org-agenda-columns-active nil) - (message - "Modification not yet reflected in Agenda buffer, use `r' to refresh"))) - -(defun org-columns-check-computed () - "Throw an error if current column value is computed." - (let ((spec (nth (current-column) org-columns-current-fmt-compiled))) - (and - (nth 3 spec) - (assoc spec (get-text-property (line-beginning-position) 'org-summaries)) - (error "This value is computed from the entry's children")))) - -(defun org-columns-todo (&optional _arg) - "Change the TODO state during column view." - (interactive "P") - (org-columns-edit-value "TODO")) - -(defun org-columns-toggle-or-columns-quit () - "Toggle checkbox at point, or quit column view." - (interactive) - (or (org-columns--toggle) - (org-columns-quit))) - -(defun org-columns--toggle () - "Toggle checkbox at point. Return non-nil if toggle happened, else nil. -See info documentation about realizing a suitable checkbox." - (when (string-match "\\`\\[[ xX-]\\]\\'" - (get-char-property (point) 'org-columns-value)) - (org-columns-next-allowed-value) - t)) - -(defvar org-overriding-columns-format nil - "When set, overrides any other format definition for the agenda. -Don't set this, this is meant for dynamic scoping. Set -`org-columns-default-format' and `org-columns-default-format-for-agenda' -instead. You should use this variable only in the local settings -section for a custom agenda view.") - -(defvar-local org-local-columns-format nil - "When set, overrides any other format definition for the agenda. -This can be set as a buffer local value to avoid interfering with -dynamic scoping for `org-overriding-columns-format'.") - -(defun org-columns-edit-value (&optional key) - "Edit the value of the property at point in column view. -Where possible, use the standard interface for changing this line." - (interactive) - (org-columns-check-computed) - (let* ((col (current-column)) - (bol (line-beginning-position)) - (eol (line-end-position)) - (pom (or (get-text-property bol 'org-hd-marker) (point))) - (key (or key (get-char-property (point) 'org-columns-key))) - (org-columns--time (float-time)) - (action - (pcase key - ("CLOCKSUM" - (user-error "This special column cannot be edited")) - ("ITEM" - (lambda () (org-with-point-at pom (org-edit-headline)))) - ("TODO" - (lambda () - (org-with-point-at pom (call-interactively #'org-todo)))) - ("PRIORITY" - (lambda () - (org-with-point-at pom - (call-interactively #'org-priority)))) - ("TAGS" - (lambda () - (org-with-point-at pom - (let ((org-fast-tag-selection-single-key - (if (eq org-fast-tag-selection-single-key 'expert) - t - org-fast-tag-selection-single-key))) - (call-interactively #'org-set-tags-command))))) - ("DEADLINE" - (lambda () - (org-with-point-at pom (call-interactively #'org-deadline)))) - ("SCHEDULED" - (lambda () - (org-with-point-at pom (call-interactively #'org-schedule)))) - ("BEAMER_ENV" - (lambda () - (org-with-point-at pom - (call-interactively #'org-beamer-select-environment)))) - (_ - (let* ((allowed (org-property-get-allowed-values pom key 'table)) - (value (get-char-property (point) 'org-columns-value)) - (nval (org-trim - (if (null allowed) (read-string "Edit: " value) - (completing-read - "Value: " allowed nil - (not (get-text-property - 0 'org-unrestricted (caar allowed)))))))) - (and (not (equal nval value)) - (lambda () (org-entry-put pom key nval)))))))) - (cond - ((null action)) - ((eq major-mode 'org-agenda-mode) - (org-columns--call action) - ;; The following let preserves the current format, and makes - ;; sure that in only a single file things need to be updated. - (let* ((org-overriding-columns-format org-columns-current-fmt) - (buffer (marker-buffer pom)) - (org-agenda-contributing-files - (list (with-current-buffer buffer - (buffer-file-name (buffer-base-buffer)))))) - (org-agenda-columns))) - (t - (let ((inhibit-read-only t)) - (with-silent-modifications - (remove-text-properties (max (point-min) (1- bol)) eol '(read-only t))) - (org-columns--call action)) - ;; Some properties can modify headline (e.g., "TODO"), and - ;; possible shuffle overlays. Make sure they are still all at - ;; the right place on the current line. - (let ((org-columns-inhibit-recalculation)) (org-columns-redo)) - (org-columns-update key) - (org-move-to-column col))))) - -(defun org-columns-edit-allowed () - "Edit the list of allowed values for the current property." - (interactive) - (let* ((pom (or (org-get-at-bol 'org-marker) - (org-get-at-bol 'org-hd-marker) - (point))) - (key (concat (or (get-char-property (point) 'org-columns-key) - (user-error "No column to edit at point")) - "_ALL")) - (allowed (org-entry-get pom key t)) - (new-value (read-string "Allowed: " allowed))) - ;; FIXME: Cover editing TODO, TAGS etc in-buffer settings.???? - ;; FIXME: Write back to #+PROPERTY setting if that is needed. - (org-entry-put - (cond ((marker-position org-entry-property-inherited-from) - org-entry-property-inherited-from) - ((marker-position org-columns-top-level-marker) - org-columns-top-level-marker) - (t pom)) - key new-value))) - -(defun org-columns--call (fun) - "Call function FUN while preserving heading visibility. -FUN is a function called with no argument." - (let ((hide-body (and (/= (line-end-position) (point-max)) - (save-excursion - (move-beginning-of-line 2) - (org-at-heading-p t))))) - (unwind-protect (funcall fun) - (when hide-body (outline-hide-entry))))) - -(defun org-columns-previous-allowed-value () - "Switch to the previous allowed value for this column." - (interactive) - (org-columns-next-allowed-value t)) - -(defun org-columns-next-allowed-value (&optional previous nth) - "Switch to the next allowed value for this column. -When PREVIOUS is set, go to the previous value. When NTH is -an integer, select that value." - (interactive) - (org-columns-check-computed) - (let* ((column (current-column)) - (key (get-char-property (point) 'org-columns-key)) - (value (get-char-property (point) 'org-columns-value)) - (pom (or (get-text-property (line-beginning-position) 'org-hd-marker) - (point))) - (allowed - (let ((all - (or (org-property-get-allowed-values pom key) - (pcase (nth column org-columns-current-fmt-compiled) - (`(,_ ,_ ,_ ,(or "X" "X/" "X%") ,_) '("[ ]" "[X]"))) - (org-colview-construct-allowed-dates value)))) - (if previous (reverse all) all)))) - (when (equal key "ITEM") (error "Cannot edit item headline from here")) - (unless (or allowed (member key '("SCHEDULED" "DEADLINE" "CLOCKSUM"))) - (error "Allowed values for this property have not been defined")) - (let* ((l (length allowed)) - (new - (cond - ((member key '("SCHEDULED" "DEADLINE" "CLOCKSUM")) - (if previous 'earlier 'later)) - ((integerp nth) - (when (> (abs nth) l) - (user-error "Only %d allowed values for property `%s'" l key)) - (nth (mod (1- nth) l) allowed)) - ((member value allowed) - (when (= l 1) (error "Only one allowed value for this property")) - (or (nth 1 (member value allowed)) (car allowed))) - (t (car allowed)))) - (action (lambda () (org-entry-put pom key new)))) - (cond - ((eq major-mode 'org-agenda-mode) - (org-columns--call action) - ;; The following let preserves the current format, and makes - ;; sure that in only a single file things need to be updated. - (let* ((org-overriding-columns-format org-columns-current-fmt) - (buffer (marker-buffer pom)) - (org-agenda-contributing-files - (list (with-current-buffer buffer - (buffer-file-name (buffer-base-buffer)))))) - (org-agenda-columns))) - (t - (let ((inhibit-read-only t)) - (remove-text-properties (line-end-position 0) (line-end-position) - '(read-only t)) - (org-columns--call action)) - ;; Some properties can modify headline (e.g., "TODO"), and - ;; possible shuffle overlays. Make sure they are still all at - ;; the right place on the current line. - (let ((org-columns-inhibit-recalculation)) (org-columns-redo)) - (org-columns-update key) - (org-move-to-column column)))))) - -(defun org-colview-construct-allowed-dates (s) - "Construct a list of three dates around the date in S. -This respects the format of the time stamp in S, active or non-active, -and also including time or not. S must be just a time stamp, no text -around it." - (when (and s (string-match (concat "^" org-ts-regexp3 "$") s)) - (let* ((time (org-parse-time-string s 'nodefaults)) - (active (equal (string-to-char s) ?<)) - (fmt (funcall (if (nth 1 time) 'cdr 'car) org-time-stamp-formats)) - time-before time-after) - (unless active (setq fmt (concat "[" (substring fmt 1 -1) "]"))) - (setf (car time) (or (car time) 0)) - (setf (nth 1 time) (or (nth 1 time) 0)) - (setf (nth 2 time) (or (nth 2 time) 0)) - (setq time-before (copy-sequence time)) - (setq time-after (copy-sequence time)) - (setf (nth 3 time-before) (1- (nth 3 time))) - (setf (nth 3 time-after) (1+ (nth 3 time))) - (mapcar (lambda (x) (format-time-string fmt (apply #'encode-time x))) - (list time-before time time-after))))) - -(defun org-columns-open-link (&optional arg) - (interactive "P") - (let ((value (get-char-property (point) 'org-columns-value))) - (org-link-open-from-string value arg))) - -;;;###autoload -(defun org-columns-get-format-and-top-level () - (let ((fmt (org-columns-get-format))) - (org-columns-goto-top-level) - fmt)) - -(defun org-columns-get-format (&optional fmt-string) - "Return columns format specifications. -When optional argument FMT-STRING is non-nil, use it as the -current specifications. This function also sets -`org-columns-current-fmt-compiled' and -`org-columns-current-fmt'." - (interactive) - (let ((format - (or fmt-string - (org-entry-get nil "COLUMNS" t) - (org-with-wide-buffer - (goto-char (point-min)) - (catch :found - (let ((case-fold-search t)) - (while (re-search-forward "^[ \t]*#\\+COLUMNS: .+$" nil t) - (let ((element (org-element-at-point))) - (when (eq (org-element-type element) 'keyword) - (throw :found (org-element-property :value element))))) - nil))) - org-columns-default-format))) - (setq org-columns-current-fmt format) - (org-columns-compile-format format) - format)) - -(defun org-columns-goto-top-level () - "Move to the beginning of the column view area. -Also sets `org-columns-top-level-marker' to the new position." - (unless (markerp org-columns-top-level-marker) - (setq org-columns-top-level-marker (make-marker))) - (goto-char - (move-marker - org-columns-top-level-marker - (cond ((org-before-first-heading-p) (point-min)) - ((org-entry-get nil "COLUMNS" t) org-entry-property-inherited-from) - (t (org-back-to-heading) (point)))))) - -;;;###autoload -(defun org-columns (&optional global columns-fmt-string) - "Turn on column view on an Org mode file. - -Column view applies to the whole buffer if point is before the first -headline. Otherwise, it applies to the first ancestor setting -\"COLUMNS\" property. If there is none, it defaults to the current -headline. With a `\\[universal-argument]' prefix \ argument, GLOBAL, -turn on column view for the whole buffer unconditionally. - -When COLUMNS-FMT-STRING is non-nil, use it as the column format." - (interactive "P") - (org-columns-remove-overlays) - (save-excursion - (when global (goto-char (point-min))) - (if (markerp org-columns-begin-marker) - (move-marker org-columns-begin-marker (point)) - (setq org-columns-begin-marker (point-marker))) - (org-columns-goto-top-level) - ;; Initialize `org-columns-current-fmt' and - ;; `org-columns-current-fmt-compiled'. - (let ((org-columns--time (float-time))) - (org-columns-get-format columns-fmt-string) - (unless org-columns-inhibit-recalculation (org-columns-compute-all)) - (save-restriction - (when (and (not global) (org-at-heading-p)) - (narrow-to-region (point) (org-end-of-subtree t t))) - (when (assoc "CLOCKSUM" org-columns-current-fmt-compiled) - (org-clock-sum)) - (when (assoc "CLOCKSUM_T" org-columns-current-fmt-compiled) - (org-clock-sum-today)) - (let ((cache - ;; Collect contents of columns ahead of time so as to - ;; compute their maximum width. - (org-scan-tags - (lambda () (cons (point) (org-columns--collect-values))) t org--matcher-tags-todo-only))) - (when cache - (org-columns--set-widths cache) - (org-columns--display-here-title) - (when (setq-local org-columns-flyspell-was-active - (bound-and-true-p flyspell-mode)) - (flyspell-mode 0)) - (unless (local-variable-p 'org-colview-initial-truncate-line-value) - (setq-local org-colview-initial-truncate-line-value - truncate-lines)) - (if (not global-visual-line-mode) - (setq truncate-lines t)) - (dolist (entry cache) - (goto-char (car entry)) - (org-columns--display-here (cdr entry))))))))) - -(defun org-columns-new (&optional spec &rest attributes) - "Insert a new column, to the left of the current column. -Interactively fill attributes for new column. When column format -specification SPEC is provided, edit it instead. - -When optional argument attributes can be a list of columns -specifications attributes to create the new column -non-interactively. See `org-columns-compile-format' for -details." - (interactive) - (let ((new (or attributes - (let ((prop - (completing-read - "Property: " - (mapcar #'list (org-buffer-property-keys t nil t)) - nil nil (nth 0 spec)))) - (list prop - (read-string (format "Column title [%s]: " prop) - (nth 1 spec)) - ;; Use `read-string' instead of `read-number' - ;; to allow empty width. - (let ((w (read-string - "Column width: " - (and (nth 2 spec) - (number-to-string (nth 2 spec)))))) - (and (org-string-nw-p w) (string-to-number w))) - (org-string-nw-p - (completing-read - "Summary: " - (delete-dups - (cons '("") ;Allow empty operator. - (mapcar (lambda (x) (list (car x))) - (append - org-columns-summary-types - org-columns-summary-types-default)))) - nil t (nth 3 spec))) - (org-string-nw-p - (read-string "Format: " (nth 4 spec)))))))) - (if spec - (progn (setcar spec (car new)) - (setcdr spec (cdr new))) - (push new (nthcdr (current-column) org-columns-current-fmt-compiled))) - (org-columns-store-format) - (org-columns-redo))) - -(defun org-columns-delete () - "Delete the column at point from columns view." - (interactive) - (let ((spec (nth (current-column) org-columns-current-fmt-compiled))) - (when (y-or-n-p (format "Are you sure you want to remove column %S? " - (nth 1 spec))) - (setq org-columns-current-fmt-compiled - (delq spec org-columns-current-fmt-compiled)) - (org-columns-store-format) - ;; This may leave a now wrong value in a node property. However - ;; updating it may prove counter-intuitive. See comments in - ;; `org-columns-move-right' for details. - (let ((org-columns-inhibit-recalculation t)) (org-columns-redo)) - (when (>= (current-column) (length org-columns-current-fmt-compiled)) - (backward-char))))) - -(defun org-columns-edit-attributes () - "Edit the attributes of the current column." - (interactive) - (org-columns-new (nth (current-column) org-columns-current-fmt-compiled))) - -(defun org-columns-widen (arg) - "Make the column wider by ARG characters." - (interactive "p") - (let* ((n (current-column)) - (entry (nth n org-columns-current-fmt-compiled)) - (width (aref org-columns-current-maxwidths n))) - (setq width (max 1 (+ width arg))) - (setcar (nthcdr 2 entry) width) - (org-columns-store-format) - (let ((org-columns-inhibit-recalculation t)) (org-columns-redo)))) - -(defun org-columns-narrow (arg) - "Make the column narrower by ARG characters." - (interactive "p") - (org-columns-widen (- arg))) - -(defun org-columns-move-right () - "Swap this column with the one to the right." - (interactive) - (let* ((n (current-column)) - (cell (nthcdr n org-columns-current-fmt-compiled)) - e) - (when (>= n (1- (length org-columns-current-fmt-compiled))) - (error "Cannot shift this column further to the right")) - (setq e (car cell)) - (setcar cell (car (cdr cell))) - (setcdr cell (cons e (cdr (cdr cell)))) - (org-columns-store-format) - ;; Do not compute again properties, since we're just moving - ;; columns around. It can put a property value a bit off when - ;; switching between an non-computed and a computed value for the - ;; same property, e.g. from "%A %A{+}" to "%A{+} %A". - ;; - ;; In this case, the value needs to be updated since the first - ;; column related to a property determines how its value is - ;; computed. However, (correctly) updating the value could be - ;; surprising, so we leave it as-is nonetheless. - (let ((org-columns-inhibit-recalculation t)) (org-columns-redo)) - (forward-char 1))) - -(defun org-columns-move-left () - "Swap this column with the one to the left." - (interactive) - (let* ((n (current-column))) - (when (= n 0) - (error "Cannot shift this column further to the left")) - (backward-char 1) - (org-columns-move-right) - (backward-char 1))) - -(defun org-columns-store-format () - "Store the text version of the current columns format. -The format is stored either in the COLUMNS property of the node -starting the current column display, or in a #+COLUMNS line of -the current buffer." - (let ((fmt (org-columns-uncompile-format org-columns-current-fmt-compiled))) - (setq-local org-columns-current-fmt fmt) - (when org-columns-overlays - (org-with-point-at org-columns-top-level-marker - (if (and (org-at-heading-p) (org-entry-get nil "COLUMNS")) - (org-entry-put nil "COLUMNS" fmt) - (goto-char (point-min)) - (let ((case-fold-search t)) - ;; Try to replace the first COLUMNS keyword available. - (catch :found - (while (re-search-forward "^[ \t]*#\\+COLUMNS:\\(.*\\)" nil t) - (let ((element (save-match-data (org-element-at-point)))) - (when (and (eq (org-element-type element) 'keyword) - (equal (org-element-property :key element) - "COLUMNS")) - (replace-match (concat " " fmt) t t nil 1) - (throw :found nil)))) - ;; No COLUMNS keyword in the buffer. Insert one at the - ;; beginning, right before the first heading, if any. - (goto-char (point-min)) - (unless (org-at-heading-p t) (outline-next-heading)) - (let ((inhibit-read-only t)) - (insert-before-markers "#+COLUMNS: " fmt "\n")))) - (setq-local org-columns-default-format fmt)))))) - -(defun org-columns-update (property) - "Recompute PROPERTY, and update the columns display for it." - (org-columns-compute property) - (org-with-wide-buffer - (let ((p (upcase property))) - (dolist (ov org-columns-overlays) - (let ((key (overlay-get ov 'org-columns-key))) - (when (and key (equal key p) (overlay-start ov)) - (goto-char (overlay-start ov)) - (let* ((spec (nth (current-column) org-columns-current-fmt-compiled)) - (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." - (interactive) - (when org-columns-overlays - (message "Recomputing columns...") - (org-with-point-at org-columns-begin-marker - (org-columns-remove-overlays) - (if (derived-mode-p 'org-mode) - ;; Since we already know the columns format, provide it - ;; instead of computing again. - (call-interactively #'org-columns org-columns-current-fmt) - (org-agenda-redo) - (call-interactively #'org-agenda-columns))) - (message "Recomputing columns...done"))) - -(defun org-columns-uncompile-format (compiled) - "Turn the compiled columns format back into a string representation. - -COMPILED is an alist, as returned by `org-columns-compile-format'." - (mapconcat - (lambda (spec) - (pcase spec - (`(,prop ,title ,width ,op ,printf) - (concat "%" - (and width (number-to-string width)) - prop - (and title (not (equal prop title)) (format "(%s)" title)) - (cond ((not op) nil) - (printf (format "{%s;%s}" op printf)) - (t (format "{%s}" op))))))) - compiled " ")) - -(defun org-columns-compile-format (fmt) - "Turn a column format string FMT into an alist of specifications. - -The alist has one entry for each column in the format. The elements of -that list are: -property the property name, as an upper-case string -title the title field for the columns, as a string -width the column width in characters, can be nil for automatic width -operator the summary operator, as a string, or nil -printf a printf format for computed values, as a string, or nil - -This function updates `org-columns-current-fmt-compiled'." - (setq org-columns-current-fmt-compiled nil) - (let ((start 0)) - (while (string-match - "%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\ -\\(?:{\\([^}]+\\)}\\)?\\s-*" - fmt start) - (setq start (match-end 0)) - (let* ((width (and (match-end 1) (string-to-number (match-string 1 fmt)))) - (prop (match-string-no-properties 2 fmt)) - (title (or (match-string-no-properties 3 fmt) prop)) - (operator (match-string-no-properties 4 fmt))) - (push (if (not operator) (list (upcase prop) title width nil nil) - (let (printf) - (when (string-match ";" operator) - (setq printf (substring operator (match-end 0))) - (setq operator (substring operator 0 (match-beginning 0)))) - (list (upcase prop) title width operator printf))) - org-columns-current-fmt-compiled))) - (setq org-columns-current-fmt-compiled - (nreverse org-columns-current-fmt-compiled)))) - - -;;;; Column View Summary - -(defun org-columns--age-to-minutes (s) - "Turn age string S into a number of minutes. -An age is either computed from a given time-stamp, or indicated -as a canonical duration, i.e., using units defined in -`org-duration-canonical-units'." - (cond - ((string-match-p org-ts-regexp s) - (/ (- org-columns--time - (float-time (org-time-string-to-time s))) - 60)) - ((org-duration-p s) (org-duration-to-minutes s t)) ;skip user units - (t (user-error "Invalid age: %S" s)))) - -(defun org-columns--format-age (minutes) - "Format MINUTES float as an age string." - (org-duration-from-minutes minutes - '(("d" . nil) ("h" . nil) ("min" . nil)) - t)) ;ignore user's custom units - -(defun org-columns--summary-apply-times (fun times) - "Apply FUN to time values TIMES. -Return the result as a duration." - (org-duration-from-minutes - (apply fun (mapcar #'org-duration-to-minutes times)) - (org-duration-h:mm-only-p times))) - -(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 (bound-and-true-p org-inlinetask-min-level) - org-inlinetask-min-level - 29)) ;Hard-code deepest level. - (lvals (make-vector (1+ lmax) nil)) - (level 0) - (inminlevel lmax) - (last-level lmax) - (property (car spec)) - (printf (nth 4 spec)) - ;; Special properties cannot be collected nor summarized, as - ;; they have their own way to be computed. Therefore, ignore - ;; any operator attached to them. - (operator (and (not (member property org-special-properties)) - (nth 3 spec))) - (collect (and operator (org-columns--collect operator))) - (summarize (and operator (org-columns--summarize operator)))) - (org-with-wide-buffer - ;; Find the region to compute. - (goto-char org-columns-top-level-marker) - (goto-char (condition-case nil (org-end-of-subtree t) (error (point-max)))) - ;; Walk the tree from the back and do the computations. - (while (re-search-backward - org-outline-regexp-bol org-columns-top-level-marker t) - (unless (or (= level 0) (eq level inminlevel)) - (setq last-level level)) - (setq level (org-reduced-level (org-outline-level))) - (let* ((pos (match-beginning 0)) - (value (if collect (funcall collect property) - (org-entry-get (point) property))) - (value-set (org-string-nw-p value))) - (cond - ((< level last-level) - ;; Collect values from lower levels and inline tasks here - ;; and summarize them using SUMMARIZE. Store them in text - ;; property `org-summaries', in alist whose key is SPEC. - (let* ((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) - (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. - ;; - ;; Ignore leading or trailing white spaces that might - ;; have been introduced in summary, since those are not - ;; significant in properties value. - (let ((new-value (org-trim summary))) - (when (and update value (not (equal value new-value))) - (org-entry-put (point) property new-value)))) - ;; 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)))) - (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." - (with-silent-modifications - (remove-text-properties (point-min) (point-max) '(org-summaries t))) - (let ((org-columns--time (float-time)) - seen) - (dolist (spec org-columns-current-fmt-compiled) - (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. -When PRINTF is non-nil, use it to format the result." - (format (or printf "%s") (apply #'+ (mapcar #'string-to-number values)))) - -(defun org-columns--summary-currencies (values _) - "Compute the sum of VALUES, with two decimals." - (format "%.2f" (apply #'+ (mapcar #'string-to-number values)))) - -(defun org-columns--summary-checkbox (check-boxes _) - "Summarize CHECK-BOXES with a check-box." - (let ((done (cl-count "[X]" check-boxes :test #'equal)) - (all (length check-boxes))) - (cond ((= done all) "[X]") - ((> done 0) "[-]") - (t "[ ]")))) - -(defun org-columns--summary-checkbox-count (check-boxes _) - "Summarize CHECK-BOXES with a check-box cookie." - (format "[%d/%d]" - (cl-count-if (lambda (b) (or (equal b "[X]") - (string-match-p "\\[\\([1-9]\\)/\\1\\]" b))) - check-boxes) - (length check-boxes))) - -(defun org-columns--summary-checkbox-percent (check-boxes _) - "Summarize CHECK-BOXES with a check-box percent." - (format "[%d%%]" - (round (* 100.0 (cl-count-if (lambda (b) (member b '("[X]" "[100%]"))) - check-boxes)) - (length check-boxes)))) - -(defun org-columns--summary-min (values printf) - "Compute the minimum of VALUES. -When PRINTF is non-nil, use it to format the result." - (format (or printf "%s") - (apply #'min (mapcar #'string-to-number values)))) - -(defun org-columns--summary-max (values printf) - "Compute the maximum of VALUES. -When PRINTF is non-nil, use it to format the result." - (format (or printf "%s") - (apply #'max (mapcar #'string-to-number values)))) - -(defun org-columns--summary-mean (values printf) - "Compute the mean of VALUES. -When PRINTF is non-nil, use it to format the result." - (format (or printf "%s") - (/ (apply #'+ (mapcar #'string-to-number values)) - (float (length values))))) - -(defun org-columns--summary-sum-times (times _) - "Sum TIMES." - (org-columns--summary-apply-times #'+ times)) - -(defun org-columns--summary-min-time (times _) - "Compute the minimum time among TIMES." - (org-columns--summary-apply-times #'min times)) - -(defun org-columns--summary-max-time (times _) - "Compute the maximum time among TIMES." - (org-columns--summary-apply-times #'max times)) - -(defun org-columns--summary-mean-time (times _) - "Compute the mean time among TIMES." - (org-columns--summary-apply-times - (lambda (&rest values) (/ (apply #'+ values) (float (length values)))) - times)) - -(defun org-columns--summary-min-age (ages _) - "Compute the minimum age among AGES." - (org-columns--format-age - (apply #'min (mapcar #'org-columns--age-to-minutes ages)))) - -(defun org-columns--summary-max-age (ages _) - "Compute the maximum age among AGES." - (org-columns--format-age - (apply #'max (mapcar #'org-columns--age-to-minutes ages)))) - -(defun org-columns--summary-mean-age (ages _) - "Compute the mean age among AGES." - (org-columns--format-age - (/ (apply #'+ (mapcar #'org-columns--age-to-minutes ages)) - (float (length ages))))) - -(defun org-columns--summary-estimate (estimates _) - "Combine a list of estimates, using mean and variance. -The mean and variance of the result will be the sum of the means -and variances (respectively) of the individual estimates." - (let ((mean 0) - (var 0)) - (dolist (e estimates) - (pcase (mapcar #'string-to-number (split-string e "-")) - (`(,low ,high) - (let ((m (/ (+ low high) 2.0))) - (cl-incf mean m) - (cl-incf var (- (/ (+ (* low low) (* high high)) 2.0) (* m m))))) - (`(,value) (cl-incf mean value)))) - (let ((sd (sqrt var))) - (format "%s-%s" - (format "%.0f" (- mean sd)) - (format "%.0f" (+ mean sd)))))) - - - -;;; Dynamic block for Column view - -(defun org-columns--capture-view (maxlevel match skip-empty exclude-tags format local) - "Get the column view of the current buffer. - -MAXLEVEL sets the level limit. SKIP-EMPTY tells whether to skip -empty rows, an empty row being one where all the column view -specifiers but ITEM are empty. EXCLUDE-TAGS is a list of tags -that will be excluded from the resulting view. FORMAT is a -format string for columns, or nil. When LOCAL is non-nil, only -capture headings in current subtree. - -This function returns a list containing the title row and all -other rows. Each row is a list of fields, as strings, or -`hline'." - (org-columns (not local) format) - (goto-char org-columns-top-level-marker) - (let ((columns (length org-columns-current-fmt-compiled)) - (has-item (assoc "ITEM" org-columns-current-fmt-compiled)) - table) - (org-map-entries - (lambda () - (when (get-char-property (point) 'org-columns-key) - (let (row) - (dotimes (i columns) - (let* ((col (+ (line-beginning-position) i)) - (p (get-char-property col 'org-columns-key))) - (push (org-quote-vert - (get-char-property col - (if (string= p "ITEM") - 'org-columns-value - 'org-columns-value-modified))) - row))) - (unless (or - (and skip-empty - (let ((r (delete-dups (remove "" row)))) - (or (null r) (and has-item (= (length r) 1))))) - (and exclude-tags - (cl-some (lambda (tag) (member tag exclude-tags)) - (org-get-tags)))) - (push (cons (org-reduced-level (org-current-level)) (nreverse row)) - table))))) - (if match - (concat match (and maxlevel (format "+LEVEL<=%d" maxlevel))) - (and maxlevel (format "LEVEL<=%d" maxlevel))) - (and local 'tree) - 'archive 'comment) - (org-columns-quit) - ;; Add column titles and a horizontal rule in front of the table. - (cons (mapcar #'cadr org-columns-current-fmt-compiled) - (cons 'hline (nreverse table))))) - -(defun org-columns--clean-item (item) - "Remove sensitive contents from string ITEM. -This includes objects that may not be duplicated within -a document, e.g., a target, or those forbidden in tables, e.g., -an inline src-block." - (let ((data (org-element-parse-secondary-string - item (org-element-restriction 'headline)))) - (org-element-map data - '(footnote-reference inline-babel-call inline-src-block target - radio-target statistics-cookie) - #'org-element-extract-element) - (org-no-properties (org-element-interpret-data data)))) - -;;;###autoload -(defun org-dblock-write:columnview (params) - "Write the column view table. - -PARAMS is a property list of parameters: - -`:id' (mandatory) - - The ID property of the entry where the columns view should be - built. When the symbol `local', call locally. When `global' - call column view with the cursor at the beginning of the - buffer (usually this means that the whole buffer switches to - column view). When \"file:path/to/file.org\", invoke column - view at the start of that file. Otherwise, the ID is located - using `org-id-find'. - -`:exclude-tags' - - List of tags to exclude from column view table. - -`:format' - - When non-nil, specify the column view format to use. - -`:hlines' - - When non-nil, insert a hline before each item. When - a number, insert a hline before each level inferior or equal - to that number. - -`:indent' - - When non-nil, indent each ITEM field according to its level. - -`:match' - - When set to a string, use this as a tags/property match filter. - -`:maxlevel' - - When set to a number, don't capture headlines below this level. - -`:skip-empty-rows' - - When non-nil, skip rows where all specifiers other than ITEM - are empty. - -`:vlines' - - When non-nil, make each column a column group to enforce - vertical lines." - (let ((table - (let ((id (plist-get params :id)) - view-file view-pos) - (pcase id - (`global nil) - ((or `local `nil) (setq view-pos (point))) - ((and (let id-string (format "%s" id)) - (guard (string-match "^file:\\(.*\\)" id-string))) - (setq view-file (match-string-no-properties 1 id-string)) - (unless (file-exists-p view-file) - (user-error "No such file: %S" id-string))) - ((and (let idpos (org-find-entry-with-id id)) (guard idpos)) - (setq view-pos idpos)) - ((let `(,filename . ,position) (org-id-find id)) - (setq view-file filename) - (setq view-pos position)) - (_ (user-error "Cannot find entry with :ID: %s" id))) - (with-current-buffer (if view-file (get-file-buffer view-file) - (current-buffer)) - (org-with-wide-buffer - (when view-pos (goto-char view-pos)) - (org-columns--capture-view (plist-get params :maxlevel) - (plist-get params :match) - (plist-get params :skip-empty-rows) - (plist-get params :exclude-tags) - (plist-get params :format) - view-pos)))))) - (when table - ;; Prune level information from the table. Also normalize - ;; headings: remove stars, add indentation entities, if - ;; required, and possibly precede some of them with a horizontal - ;; rule. - (let ((item-index - (let ((p (assoc "ITEM" org-columns-current-fmt-compiled))) - (and p (cl-position p - org-columns-current-fmt-compiled - :test #'equal)))) - (hlines (plist-get params :hlines)) - (indent (plist-get params :indent)) - new-table) - ;; Copy header and first rule. - (push (pop table) new-table) - (push (pop table) new-table) - (dolist (row table (setq table (nreverse new-table))) - (let ((level (car row))) - (when (and (not (eq (car new-table) 'hline)) - (or (eq hlines t) - (and (numberp hlines) (<= level hlines)))) - (push 'hline new-table)) - (when item-index - (let ((item (org-columns--clean-item (nth item-index (cdr row))))) - (setf (nth item-index (cdr row)) - (if (and indent (> level 1)) - (concat "\\_" (make-string (* 2 (1- level)) ?\s) item) - item)))) - (push (cdr row) new-table)))) - (when (plist-get params :vlines) - (setq table - (let ((size (length org-columns-current-fmt-compiled))) - (append (mapcar (lambda (x) (if (eq 'hline x) x (cons "" x))) - table) - (list (cons "/" (make-list size "<>"))))))) - (let ((content-lines (org-split-string (plist-get params :content) "\n")) - recalc) - ;; Insert affiliated keywords before the table. - (when content-lines - (while (string-match-p "\\`[ \t]*#\\+" (car content-lines)) - (insert (pop content-lines) "\n"))) - (save-excursion - ;; Insert table at point. - (insert - (mapconcat (lambda (row) - (if (eq row 'hline) "|-|" - (format "|%s|" (mapconcat #'identity row "|")))) - table - "\n")) - ;; Insert TBLFM lines following table. - (let ((case-fold-search t)) - (dolist (line content-lines) - (when (string-match-p "\\`[ \t]*#\\+TBLFM:" line) - (insert "\n" line) - (unless recalc (setq recalc t)))))) - (when recalc (org-table-recalculate 'all t)) - (org-table-align))))) - -;;;###autoload -(defun org-columns-insert-dblock () - "Create a dynamic block capturing a column view table." - (interactive) - (let ((id (completing-read - "Capture columns (local, global, entry with :ID: property) [local]: " - (append '(("global") ("local")) - (mapcar #'list (org-property-values "ID")))))) - (org-create-dblock - (list :name "columnview" - :hlines 1 - :id (cond ((string= id "global") 'global) - ((member id '("" "local")) 'local) - (id))))) - (org-update-dblock)) - -;;;###autoload -(eval-after-load 'org - '(progn - (org-dynamic-block-define "columnview" #'org-columns-insert-dblock))) - - -;;; Column view in the agenda - -;;;###autoload -(defun org-agenda-columns () - "Turn on or update column view in the agenda." - (interactive) - (org-columns-remove-overlays) - (if (markerp org-columns-begin-marker) - (move-marker org-columns-begin-marker (point)) - (setq org-columns-begin-marker (point-marker))) - (let* ((org-columns--time (float-time)) - (org-done-keywords org-done-keywords-for-agenda) - (fmt - (cond - ((bound-and-true-p org-overriding-columns-format)) - ((bound-and-true-p org-local-columns-format)) - ((bound-and-true-p org-columns-default-format-for-agenda)) - ((let ((m (org-get-at-bol 'org-hd-marker))) - (and m - (or (org-entry-get m "COLUMNS" t) - (with-current-buffer (marker-buffer m) - org-columns-default-format))))) - ((and (local-variable-p 'org-columns-current-fmt) - org-columns-current-fmt)) - ((let ((m (next-single-property-change (point-min) 'org-hd-marker))) - (and m - (let ((m (get-text-property m 'org-hd-marker))) - (or (org-entry-get m "COLUMNS" t) - (with-current-buffer (marker-buffer m) - org-columns-default-format)))))) - (t org-columns-default-format))) - (compiled-fmt (org-columns-compile-format fmt))) - (setq org-columns-current-fmt fmt) - (when org-agenda-columns-compute-summary-properties - (org-agenda-colview-compute org-columns-current-fmt-compiled)) - (save-excursion - ;; Collect properties for each headline in current view. - (goto-char (point-min)) - (let (cache) - (while (not (eobp)) - (let ((m (org-get-at-bol 'org-hd-marker))) - (when m - (push (cons (line-beginning-position) - ;; `org-columns-current-fmt-compiled' is - ;; initialized but only set locally to the - ;; agenda buffer. Since current buffer is - ;; changing, we need to force the original - ;; compiled-fmt there. - (org-with-point-at m - (org-columns--collect-values compiled-fmt))) - cache))) - (forward-line)) - (when cache - (org-columns--set-widths cache) - (org-columns--display-here-title) - (when (setq-local org-columns-flyspell-was-active - (bound-and-true-p flyspell-mode)) - (flyspell-mode 0)) - (dolist (entry cache) - (goto-char (car entry)) - (org-columns--display-here (cdr entry))) - (setq-local org-agenda-columns-active t) - (when org-agenda-columns-show-summaries - (org-agenda-colview-summarize cache))))))) - -(defun org-agenda-colview-summarize (cache) - "Summarize the summarizable columns in column view in the agenda. -This will add overlays to the date lines, to show the summary for each day." - (let ((fmt (mapcar - (lambda (spec) - (pcase spec - (`(,property ,title ,width . ,_) - (if (member property '("CLOCKSUM" "CLOCKSUM_T")) - (list property title width ":" nil) - spec)))) - org-columns-current-fmt-compiled))) - ;; Ensure there's at least one summation column. - (when (cl-some (lambda (spec) (nth 3 spec)) fmt) - (goto-char (point-max)) - (catch :complete - (while t - (when (or (get-text-property (point) 'org-date-line) - (eq (get-text-property (point) 'face) - 'org-agenda-structure)) - ;; OK, this is a date line that should be used. - (let (entries) - (let (rest) - (dolist (c cache) - (if (> (car c) (point)) - (push c entries) - (push c rest))) - (setq cache rest)) - ;; ENTRIES contains entries below the current one. - ;; CACHE is the rest. Compute the summaries for the - ;; properties we want, set nil properties for the rest. - (when (setq entries (mapcar #'cdr entries)) - (org-columns--display-here - (mapcar - (lambda (spec) - (pcase spec - (`("ITEM" . ,_) - ;; Replace ITEM with current date. Preserve - ;; properties for fontification. - (let ((date (buffer-substring - (line-beginning-position) - (line-end-position)))) - (list spec date date))) - (`(,_ ,_ ,_ nil ,_) (list spec "" "")) - (`(,_ ,_ ,_ ,operator ,printf) - (let* ((summarize (org-columns--summarize operator)) - (values - ;; Use real values for summary, not - ;; those prepared for display. - (delq nil - (mapcar - (lambda (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 spec final final))))) - fmt) - 'dateline)))) - (if (bobp) (throw :complete t) (forward-line -1))))))) - -(defun org-agenda-colview-compute (fmt) - "Compute the relevant columns in the contributing source buffers." - (dolist (file org-agenda-contributing-files) - (let ((b (find-buffer-visiting file))) - (with-current-buffer (or (buffer-base-buffer b) b) - (org-with-wide-buffer - (with-silent-modifications - (remove-text-properties (point-min) (point-max) '(org-summaries t))) - (goto-char (point-min)) - (org-columns-get-format-and-top-level) - (dolist (spec fmt) - (let ((prop (car spec))) - (cond - ((equal prop "CLOCKSUM") (org-clock-sum)) - ((equal prop "CLOCKSUM_T") (org-clock-sum-today)) - ((and (nth 3 spec) - (let ((a (assoc prop org-columns-current-fmt-compiled))) - (equal (nth 3 a) (nth 3 spec)))) - (org-columns-compute prop)))))))))) - - -(provide 'org-colview) - -;; Local variables: -;; generated-autoload-file: "org-loaddefs.el" -;; End: - -;;; org-colview.el ends here |