Dear all,
here is a patch implementing category filtering in the agenda.
The patch is not 100% clean wrt documentation, but I throw it
now to get some feedback and some testing done.
Press "<" in the agenda to filter by category.
Press "< <" to filter by the category of the entry point.
Another "/ /" removes the filter. "/" + " " filters by the
default category ("General") since everything is in a category.
I find this last function quick and useful, so I also implemented
it for tag filtering: pressing "/ /" filters by tags from the entry
on the current line. A second "/ /" removes the filter.
Let me know if the category filtering works ok with you, and
if you find the new "/ /" behavior useful.
There is one limitation for now: it does not combine with Effort
filtering.
Thanks,
>From 948a38b403125359b59c5f5d520be6d053599b0d Mon Sep 17 00:00:00 2001
From: Bastien Guerry <b...@altern.org>
Date: Sun, 6 Nov 2011 19:26:28 +0100
Subject: [PATCH] Implement agenda filtering by category.
---
doc/org.texi | 6 +-
lisp/org-agenda.el | 234 ++++++++++++++++++++++++++++++++++++++++------------
lisp/org-faces.el | 6 ++
3 files changed, 189 insertions(+), 57 deletions(-)
diff --git a/doc/org.texi b/doc/org.texi
index 4a547d0..af189f0 100644
--- a/doc/org.texi
+++ b/doc/org.texi
@@ -7954,10 +7954,10 @@ the entire agenda view---in a block agenda, you should only set this in the
global options section, not in the section of an individual block.}
You will be prompted for a tag selection letter; @key{SPC} will mean any tag at
-all. Pressing @key{TAB} at that prompt will offer use completion to select a
-tag (including any tags that do not have a selection character). The command
+all. Pressing @key{TAB} at that prompt will use completion to select a
+tag (also including tags that do not have a selection character). The command
then hides all entries that do not contain or inherit this tag. When called
-with prefix arg, remove the entries that @emph{do} have the tag. A second
+with a prefix arguement, remove the entries that @emph{do} have the tag. A second
@kbd{/} at the prompt will turn off the filter and unhide any hidden entries.
If the first key you press is either @kbd{+} or @kbd{-}, the previous filter
will be narrowed by requiring or forbidding the selected additional tag.
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index bcc2de4..83c42f0 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -286,8 +286,14 @@ you can \"misuse\" it to also add other text to the header. However,
(list :tag "Deadline Warning days"
(const org-deadline-warning-days)
(integer :value 1))
+ (list :tag "Category filter preset"
+ (const org-agenda-category-filter-preset)
+ (list
+ (const :format "" quote)
+ (repeat
+ (string :tag "+category or -category"))))
(list :tag "Tags filter preset"
- (const org-agenda-filter-preset)
+ (const org-agenda-tag-filter-preset)
(list
(const :format "" quote)
(repeat
@@ -1949,6 +1955,7 @@ The following commands are available:
(org-defkey org-agenda-mode-map "}" 'org-agenda-manipulate-query-subtract-re)
(org-defkey org-agenda-mode-map "/" 'org-agenda-filter-by-tag)
(org-defkey org-agenda-mode-map "\\" 'org-agenda-filter-by-tag-refine)
+(org-defkey org-agenda-mode-map "<" 'org-agenda-filter-by-category)
(org-defkey org-agenda-mode-map ";" 'org-timer-set-timer)
(define-key org-agenda-mode-map "?" 'org-agenda-show-the-flagging-note)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-mg" 'org-mobile-pull)
@@ -3043,9 +3050,9 @@ removed from the entry content. Currently only `planning' is allowed here."
(defvar org-pre-agenda-window-conf nil)
(defvar org-agenda-columns-active nil)
(defvar org-agenda-name nil)
-(defvar org-agenda-filter nil)
-(defvar org-agenda-filter-while-redo nil)
-(defvar org-agenda-filter-preset nil
+(defvar org-agenda-tag-filter nil)
+(defvar org-agenda-tag-filter-while-redo nil)
+(defvar org-agenda-tag-filter-preset nil
"A preset of the tags filter used for secondary agenda filtering.
This must be a list of strings, each string must be a single tag preceded
by \"+\" or \"-\".
@@ -3055,13 +3062,21 @@ the entire agenda view. In a block agenda, it will not work reliably to
define a filter for one of the individual blocks. You need to set it in
the global options and expect it to be applied to the entire view.")
+(defvar org-agenda-category-filter-preset nil
+ "A preset of the categeory filter used for secondary agenda filtering.
+This must be a list of strings, each string must be a single category
+preceded by \"+\" or \"-\". See `org-agenda-tag-filter-preset' for
+details.")
+
(defun org-prepare-agenda (&optional name)
(setq org-todo-keywords-for-agenda nil)
(setq org-done-keywords-for-agenda nil)
(setq org-drawers-for-agenda nil)
(unless org-agenda-persistent-filter
- (setq org-agenda-filter nil))
- (put 'org-agenda-filter :preset-filter org-agenda-filter-preset)
+ (setq org-agenda-tag-filter nil
+ org-agenda-category-filter nil))
+ (put 'org-agenda-tag-filter :preset-filter org-agenda-tag-filter-preset)
+ (put 'org-agenda-category-filter :preset-filter org-agenda-category-filter-preset)
(if org-agenda-multi
(progn
(setq buffer-read-only nil)
@@ -3140,8 +3155,10 @@ the global options and expect it to be applied to the entire view.")
(org-habit-insert-consistency-graphs))
(run-hooks 'org-finalize-agenda-hook)
(setq org-agenda-type (org-get-at-bol 'org-agenda-type))
- (when (or org-agenda-filter (get 'org-agenda-filter :preset-filter))
- (org-agenda-filter-apply org-agenda-filter))
+ (when (or org-agenda-tag-filter (get 'org-agenda-tag-filter :preset-filter))
+ (org-agenda-filter-apply org-agenda-tag-filter 'tag))
+ (when (or org-agenda-category-filter (get 'org-agenda-category-filter :preset-filter))
+ (org-agenda-filter-apply org-agenda-category-filter 'category))
)))
(defun org-agenda-mark-clocking-task ()
@@ -3675,8 +3692,9 @@ given in `org-agenda-start-on-weekday'."
(setq p (plist-put p :tend clocktable-end))
(setq p (plist-put p :scope 'agenda))
(when (and (eq org-agenda-clockreport-mode 'with-filter)
- (setq filter (or org-agenda-filter-while-redo
- (get 'org-agenda-filter :preset-filter))))
+ ;; FIXME: allow category filters?
+ (setq filter (or org-agenda-tag-filter-while-redo
+ (get 'org-agenda-tag-filter :preset-filter))))
(setq p (plist-put p :tags (mapconcat (lambda (x)
(if (string-match "[<>=]" x)
""
@@ -6132,29 +6150,94 @@ in the agenda."
When this is the global TODO list, a prefix argument will be interpreted."
(interactive)
(let* ((org-agenda-keep-modes t)
- (filter org-agenda-filter)
- (preset (get 'org-agenda-filter :preset-filter))
- (org-agenda-filter-while-redo (or filter preset))
+ (tag-filter org-agenda-tag-filter)
+ (tag-preset (get 'org-agenda-tag-filter :preset-filter))
+ (cat-filter org-agenda-category-filter)
+ (cat-preset (get 'org-agenda-category-filter :preset-filter))
+ (org-agenda-tag-filter-while-redo (or tag-filter tag-preset))
(cols org-agenda-columns-active)
(line (org-current-line))
(window-line (- line (org-current-line (window-start))))
(lprops (get 'org-agenda-redo-command 'org-lprops)))
- (put 'org-agenda-filter :preset-filter nil)
+ (put 'org-agenda-tag-filter :preset-filter nil)
+ (put 'org-agenda-category-filter :preset-filter nil)
(and cols (org-columns-quit))
(message "Rebuilding agenda buffer...")
(org-let lprops '(eval org-agenda-redo-command))
(setq org-agenda-undo-list nil
org-agenda-pending-undo-list nil)
(message "Rebuilding agenda buffer...done")
- (put 'org-agenda-filter :preset-filter preset)
- (and (or filter preset) (org-agenda-filter-apply filter))
+ (put 'org-agenda-tag-filter :preset-filter tag-preset)
+ (put 'org-agenda-category-filter :preset-filter cat-preset)
+ (and (or tag-filter tag-preset) (org-agenda-filter-apply tag-filter 'tag))
+ (and (or cat-filter cat-preset) (org-agenda-filter-apply cat-filter 'category))
(and cols (org-called-interactively-p 'any) (org-agenda-columns))
(org-goto-line line)
(recenter window-line)))
-
(defvar org-global-tags-completion-table nil)
(defvar org-agenda-filter-form nil)
+(defvar org-agenda-filtered nil)
+
+(defun org-agenda-filter-by-category (strip &optional char narrow)
+ "Keep only those lines in the agenda buffer that have a specific category.
+The category is that of the current line."
+ (interactive "P")
+ (let ((current org-agenda-category-filter)
+ catfilter catchars curcat allcats allcatsalist)
+ ;; First gather all categories represented in this agenda:
+ (save-excursion
+ (goto-char 0)
+ (while (progn (beginning-of-line 2) (not (eobp)))
+ (when (setq curcat (get-text-property (point) 'org-category))
+ (push curcat allcats)))
+ (setq allcats (delete-dups (reverse allcats))))
+ (setq allcatsalist (mapcar (lambda(x) (cons (string-to-char x) x)) allcats)
+ catchars (mapconcat (lambda (x) (substring x 0 1)) allcats ""))
+ ;; Read the key:
+ (unless char
+ (message "%s by category [%s ], [TAB], [<]:category at point, [+-]:narrow: "
+ (if narrow "Narrow" "Filter") catchars)
+ (setq char (read-char)))
+ ;; Handle narrowing:
+ (when (member char '(?+ ?-))
+ (cond ((equal char ?-) (setq strip t narrow t))
+ ((equal char ?+) (setq strip nil narrow t)))
+ (message
+ "Narrow by category [%s ], [TAB], [<]:category at point: " catchars)
+ (setq char (read-char)))
+ (cond
+ ;; Use TAB to select a category
+ ((equal char ?\t)
+ (let ((completion-ignore-case t))
+ (setq catfilter (org-icompleting-read
+ "Category: " allcats)))
+ (setq org-agenda-category-filter
+ (list (concat "+" catfilter)))
+ (org-agenda-filter-apply org-agenda-category-filter 'category))
+ ;; Select categories at point or remove filter
+ ((equal char ?<)
+ (if org-agenda-filtered
+ (progn (org-agenda-filter-show-all)
+ (when (get 'org-agenda-category-filter :preset-filter)
+ (org-agenda-filter-apply org-agenda-category-filter 'category))
+ (setq org-agenda-filtered nil))
+ (setq org-agenda-category-filter
+ (list (concat "+" (or (org-get-at-bol 'org-category)
+ (error "No category at point")))))
+ (org-agenda-filter-apply org-agenda-category-filter 'category)))
+ ;; Only select entries with no category (i.e the "General category")
+ ((or (and (equal char ?\ ) (setq catfilter "General"))
+ (assoc char allcatsalist))
+ (setq org-agenda-category-filter
+ (cons (concat (if strip "-" "+")
+ (or catfilter (cdr (assoc char allcatsalist))))
+ (if narrow current nil)))
+ (org-agenda-filter-apply org-agenda-category-filter 'category)))
+ (org-agenda-redo)
+ (when org-agenda-category-filter
+ (message "Agenda filtered by category(s): %s" org-agenda-category-filter))))
+
(defun org-agenda-filter-by-tag (strip &optional char narrow)
"Keep only those lines in the agenda buffer that have a specific tag.
The tag is selected with its fast selection letter, as configured.
@@ -6178,7 +6261,7 @@ to switch to narrowing."
(effort-op org-agenda-filter-effort-default-operator)
(effort-prompt "")
(inhibit-read-only t)
- (current org-agenda-filter)
+ (current org-agenda-tag-filter)
maybe-refresh a n tag)
(unless char
(message
@@ -6217,21 +6300,28 @@ to switch to narrowing."
"Tag: " org-global-tags-completion-table))))
(cond
((equal char ?\r)
- (org-agenda-filter-by-tag-show-all)
+ (org-agenda-filter-show-all)
(when org-agenda-auto-exclude-function
- (setq org-agenda-filter '())
+ (setq org-agenda-tag-filter '())
(dolist (tag (org-agenda-get-represented-tags))
(let ((modifier (funcall org-agenda-auto-exclude-function tag)))
(if modifier
- (push modifier org-agenda-filter))))
- (if (not (null org-agenda-filter))
- (org-agenda-filter-apply org-agenda-filter)))
+ (push modifier org-agenda-tag-filter))))
+ (if (not (null org-agenda-tag-filter))
+ (org-agenda-filter-apply org-agenda-tag-filter 'tag)))
(setq maybe-refresh t))
((equal char ?/)
- (org-agenda-filter-by-tag-show-all)
- (when (get 'org-agenda-filter :preset-filter)
- (org-agenda-filter-apply org-agenda-filter))
- (setq maybe-refresh t))
+ (if org-agenda-filtered
+ (progn (org-agenda-filter-show-all)
+ (when (get 'org-agenda-tag-filter :preset-filter)
+ (org-agenda-filter-apply org-agenda-tag-filter 'tag))
+ (setq org-agenda-filtered nil
+ maybe-refresh t))
+ (setq org-agenda-tag-filter
+ (mapcar (lambda (tag) (concat "+" tag))
+ (org-get-at-bol 'tags)))
+ (org-agenda-filter-apply org-agenda-tag-filter 'tag)
+ (setq maybe-refresh t)))
((or (equal char ?\ )
(setq a (rassoc char alist))
(and (>= char ?0) (<= char ?9)
@@ -6242,17 +6332,19 @@ to switch to narrowing."
(setq tag "?eff")
a (cons tag nil))
(and tag (setq a (cons tag nil))))
- (org-agenda-filter-by-tag-show-all)
+ (org-agenda-filter-show-all)
(setq tag (car a))
- (setq org-agenda-filter
+ (setq org-agenda-tag-filter
(cons (concat (if strip "-" "+") tag)
(if narrow current nil)))
- (org-agenda-filter-apply org-agenda-filter)
+ (org-agenda-filter-apply org-agenda-tag-filter 'tag)
(setq maybe-refresh t))
(t (error "Invalid tag selection character %c" char)))
(when (and maybe-refresh
(eq org-agenda-clockreport-mode 'with-filter))
- (org-agenda-redo))))
+ (org-agenda-redo))
+ (when org-agenda-tag-filter
+ (message "Agenda filtered by tag(s): %s" org-agenda-tag-filter))))
(defun org-agenda-get-represented-tags ()
"Get a list of all tags currently represented in the agenda."
@@ -6270,20 +6362,31 @@ to switch to narrowing."
(interactive "P")
(org-agenda-filter-by-tag strip char 'refine))
-(defun org-agenda-filter-make-matcher ()
- "Create the form that tests a line for the agenda filter."
- (let (f f1)
- (dolist (x (append (get 'org-agenda-filter :preset-filter)
- org-agenda-filter))
+(defun org-agenda-filter-make-matcher (type)
+ "Create the form that tests a line for agenda filter of TYPE.
+TYPE can be either 'tag or 'category."
+ (let ((filter (if (eq type 'tag) org-agenda-tag-filter
+ org-agenda-category-filter))
+ f f1)
+ (dolist (x (delete-dups
+ (append (get (if (eq type 'tag) 'org-agenda-tag-filter
+ 'org-agenda-category-filter)
+ :preset-filter) filter)))
(if (member x '("-" "+"))
- (setq f1 (if (equal x "-") 'tags '(not tags)))
+ (if (eq type 'tag)
+ (setq f1 (if (equal x "-") 'tags '(not tags)))
+ (setq f1 (if (equal x "-") 'cat '(not cat))))
(if (string-match "[<=>?]" x)
(setq f1 (org-agenda-filter-effort-form x))
- (setq f1 (list 'member (downcase (substring x 1)) 'tags)))
+ (if (eq type 'tag)
+ (setq f1 (list 'member (downcase (substring x 1)) 'tags))
+ (setq f1 (list 'equal (substring x 1) 'cat)))
(if (equal (string-to-char x) ?-)
- (setq f1 (list 'not f1))))
+ (setq f1 (list 'not f1)))))
(push f1 f))
- (cons 'and (nreverse f))))
+ (if (eq type 'tag)
+ (cons 'and (nreverse f))
+ (cons 'or (nreverse f)))))
(defun org-agenda-filter-effort-form (e)
"Return the form to compare the effort of the current line with what E says.
@@ -6307,26 +6410,33 @@ If the line does not have an effort defined, return nil."
(funcall op (or eff (if org-sort-agenda-noeffort-is-high 32767 0))
value))))
-(defun org-agenda-filter-apply (filter)
+(defvar org-agenda-filter nil) ;; FIXME needed?
+(defvar org-agenda-filtered nil)
+(defun org-agenda-filter-apply (filter type)
"Set FILTER as the new agenda filter and apply it."
(let (tags)
- (setq org-agenda-filter filter
- org-agenda-filter-form (org-agenda-filter-make-matcher))
+ (setq org-agenda-filtered t)
+ (if (eq type 'tag)
+ (setq org-agenda-tag-filter filter)
+ (setq org-agenda-category-filter filter))
+ (setq org-agenda-filter-form
+ (org-agenda-filter-make-matcher type))
(org-agenda-set-mode-name)
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(if (org-get-at-bol 'org-marker)
(progn
- (setq tags (org-get-at-bol 'tags)) ; used in eval
+ (setq tags (org-get-at-bol 'tags) ; used in eval
+ cat (get-text-property (point) 'org-category))
(if (not (eval org-agenda-filter-form))
- (org-agenda-filter-by-tag-hide-line))
+ (org-agenda-filter-hide-line))
(beginning-of-line 2))
(beginning-of-line 2))))
(if (get-char-property (point) 'invisible)
(org-agenda-previous-line))))
-(defun org-agenda-filter-by-tag-hide-line ()
+(defun org-agenda-filter-hide-line ()
(let (ov)
(setq ov (make-overlay (max (point-min) (1- (point-at-bol)))
(point-at-eol)))
@@ -6345,10 +6455,11 @@ If the line does not have an effort defined, return nil."
(move-overlay ov (point-at-eol)
(overlay-end ov)))))))
-(defun org-agenda-filter-by-tag-show-all ()
+(defun org-agenda-filter-show-all ()
(mapc 'delete-overlay org-agenda-filter-overlays)
(setq org-agenda-filter-overlays nil)
- (setq org-agenda-filter nil)
+ (setq org-agenda-tag-filter nil)
+ (setq org-agenda-category-filter nil)
(setq org-agenda-filter-form nil)
(org-agenda-set-mode-name))
@@ -6764,16 +6875,31 @@ When called with a prefix argument, include all archive files as well."
((eq org-agenda-show-log 'clockcheck) " ClkCk")
(org-agenda-show-log " Log")
(t ""))
- ;; show tags used for filtering in a custom face
- (if (or org-agenda-filter (get 'org-agenda-filter
+ ;; show category used for filtering in a custom face
+ ;; FIXME
+ (if (or org-agenda-category-filter (get 'org-agenda-category-filter
+ :preset-filter))
+ '(:eval (org-propertize
+ (concat " <"
+ (mapconcat
+ 'identity
+ (append
+ (get 'org-agenda-category-filter :preset-filter)
+ org-agenda-category-filter)
+ "")
+ ">")
+ 'face 'org-agenda-filter-category
+ 'help-echo "Category used in filtering"))
+ "")
+ (if (or org-agenda-tag-filter (get 'org-agenda-tag-filter
:preset-filter))
'(:eval (org-propertize
(concat " {"
(mapconcat
'identity
(append
- (get 'org-agenda-filter :preset-filter)
- org-agenda-filter)
+ (get 'org-agenda-tag-filter :preset-filter)
+ org-agenda-tag-filter)
"")
"}")
'face 'org-agenda-filter-tags
@@ -8490,9 +8616,9 @@ details and examples."
(org-prepare-agenda-buffers files)
(while (setq file (pop files))
(setq entries
- (delq nil
+ (delq nil
(append entries
- (apply 'org-agenda-get-day-entries
+ (apply 'org-agenda-get-day-entries
file today scope)))))
;; Map thru entries and find if we should filter them out
(mapc
diff --git a/lisp/org-faces.el b/lisp/org-faces.el
index 7b7dfa7..fe3dc8d 100644
--- a/lisp/org-faces.el
+++ b/lisp/org-faces.el
@@ -678,6 +678,12 @@ month and 365.24 days for a year)."
"Face for tag(s) in the mode-line when filtering the agenda."
:group 'org-faces)
+(defface org-agenda-filter-category
+ (org-compatible-face 'modeline
+ nil)
+ "Face for the category in the mode-line when filtering the agenda."
+ :group 'org-faces)
+
(defface org-time-grid ;; originally copied from font-lock-variable-name-face
(org-compatible-face nil
'((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
--
1.7.7.2
--
Bastien
