REF move org-x-cluster (now org-x-agg) to own file
This commit is contained in:
parent
2ba47588ba
commit
0703e6f067
|
|
@ -2419,8 +2419,8 @@ Org mode has no way of detecting if conflicts exist. It also has no way of alert
|
||||||
|
|
||||||
The main code is defined in =org-x= so the following is only to set some domain-specific options.
|
The main code is defined in =org-x= so the following is only to set some domain-specific options.
|
||||||
#+begin_src emacs-lisp
|
#+begin_src emacs-lisp
|
||||||
(setq org-x-cluster-filtered-files '("incubator" "peripheral")
|
(setq org-x-agg-filtered-files '("incubator" "peripheral")
|
||||||
org-x-cluster-filtered-todo '("CANC" "DONE"))
|
org-x-agg-filtered-keywords '("CANC" "DONE"))
|
||||||
#+end_src
|
#+end_src
|
||||||
*** agenda
|
*** agenda
|
||||||
:PROPERTIES:
|
:PROPERTIES:
|
||||||
|
|
@ -4209,8 +4209,8 @@ The function keys are nice because they are almost (not always) free in every mo
|
||||||
(global-set-key (kbd "<f1>") 'org-agenda)
|
(global-set-key (kbd "<f1>") 'org-agenda)
|
||||||
(global-set-key (kbd "<f2>") 'org-capture)
|
(global-set-key (kbd "<f2>") 'org-capture)
|
||||||
(global-set-key (kbd "<f3>") 'cfw:open-org-calendar)
|
(global-set-key (kbd "<f3>") 'cfw:open-org-calendar)
|
||||||
(global-set-key (kbd "C-<f3>") 'org-x-cluster-show-conflicts)
|
(global-set-key (kbd "C-<f3>") 'org-x-agg-show-conflicts)
|
||||||
(global-set-key (kbd "C-S-<f3>") 'org-x-cluster-show-overloads)
|
(global-set-key (kbd "C-S-<f3>") 'org-x-agg-show-overloads)
|
||||||
(global-set-key (kbd "<f4>") 'org-clock-goto)
|
(global-set-key (kbd "<f4>") 'org-clock-goto)
|
||||||
(global-set-key (kbd "C-<f4>") 'org-tomato-user-get-summary)
|
(global-set-key (kbd "C-<f4>") 'org-tomato-user-get-summary)
|
||||||
(global-set-key (kbd "C-S-<f4>") 'org-tomato-user-pomodoro-goto)
|
(global-set-key (kbd "C-S-<f4>") 'org-tomato-user-pomodoro-goto)
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,467 @@
|
||||||
|
;;; org-x-agg.el --- Org Aggregation Commands -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2021 Nathan Dwarshuis
|
||||||
|
|
||||||
|
;; This program 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.
|
||||||
|
|
||||||
|
;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Functions to aggregate headlines, usually on the basis of timestamps (eg
|
||||||
|
;; finding conflicting timestamps and similar operations).
|
||||||
|
|
||||||
|
;; Most of this code was written under intense sleep deprivation at a hackathon
|
||||||
|
;; after failing to get a project off the ground. The code has been cleaned
|
||||||
|
;; since ;)
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'org)
|
||||||
|
(require 'org-ml)
|
||||||
|
(require 'dash)
|
||||||
|
|
||||||
|
;;; CUSTOMIZABLE VARS
|
||||||
|
|
||||||
|
(defvar org-x-agg-filtered-files nil
|
||||||
|
"Files that should be excluded from aggregation analysis.
|
||||||
|
These are pattern-matched so they do not need to be exact names
|
||||||
|
or paths.")
|
||||||
|
|
||||||
|
(defvar org-x-agg-filtered-keywords nil
|
||||||
|
"TODO keywords that should be filtered from aggregation analysis.")
|
||||||
|
|
||||||
|
(defvar org-x-agg-filter-past t
|
||||||
|
"Set to t to exclude files from before now in aggregation analysis.")
|
||||||
|
|
||||||
|
(defvar org-x-agg-filter-habit nil
|
||||||
|
"Set to t to exclude habits from aggregation analysis.")
|
||||||
|
|
||||||
|
;;; INTERNAL FUNCTIONS
|
||||||
|
|
||||||
|
;; In order to aggregate headlines, get a list of metadata called 'timespans'
|
||||||
|
;; which contain the 'active' timestamp from a headline, its range, and
|
||||||
|
;; offset/file information so I can trace the timespan back to the original
|
||||||
|
;; headline. The 'active' timestamp of a headline is either the scheduled
|
||||||
|
;; timestamp if the headline is a todo item (task) or the first active timestamp
|
||||||
|
;; otherwise.
|
||||||
|
|
||||||
|
(defun org-x-agg--make-timespan (start-time range offset filepath)
|
||||||
|
"Construct a timespan to be used in further processing.
|
||||||
|
|
||||||
|
'Timespans' are plists with the following keys:
|
||||||
|
|
||||||
|
- START-TIME is a list from `org-ml-timestamp-get-start-time'
|
||||||
|
- RANGE is the duration of the timestamp (could be 0)
|
||||||
|
- OFFSET is the character offset of the timestamp in its file
|
||||||
|
- FILEPATH is the path to the file in which the timestamp
|
||||||
|
resides"
|
||||||
|
(list :start-time start-time
|
||||||
|
:range range
|
||||||
|
:offset offset
|
||||||
|
:filepath filepath))
|
||||||
|
|
||||||
|
(defun org-x-agg--timestamp-to-timespan (headline filepath timestamp)
|
||||||
|
"Parse a TIMESTAMP belonging to HEADLINE in file at FILEPATH.
|
||||||
|
TIMESTAMP is an object as described in the org-element API.
|
||||||
|
Returns a new timespan."
|
||||||
|
(when timestamp
|
||||||
|
(let ((offset (org-element-property :begin headline))
|
||||||
|
(start-time (org-ml-timestamp-get-start-time timestamp))
|
||||||
|
(range (org-ml-timestamp-get-range timestamp)))
|
||||||
|
(org-x-agg--make-timespan start-time range offset filepath))))
|
||||||
|
|
||||||
|
(defun org-x-agg--effort-to-seconds (effort-str)
|
||||||
|
"Return EFFORT-STR as an integer in seconds."
|
||||||
|
(-some->> effort-str (org-duration-to-minutes) (round) (* 60)))
|
||||||
|
|
||||||
|
(defun org-x-agg--headline-get-timespan-scheduled (headline filepath)
|
||||||
|
"Return timestamp from HEADLINE in FILEPATH as timespan.
|
||||||
|
Only the scheduled timestamp is considered if any."
|
||||||
|
(-when-let (ts (-some->> (org-ml-headline-get-planning headline)
|
||||||
|
(org-ml-get-property :scheduled)))
|
||||||
|
(let* ((effort-raw (org-ml-headline-get-node-property "Effort" headline))
|
||||||
|
(effort (if effort-raw (org-x-agg--effort-to-seconds effort-raw) 0))
|
||||||
|
(offset (org-ml-get-property :begin headline))
|
||||||
|
(start-time (org-ml-timestamp-get-start-time ts)))
|
||||||
|
(org-x-agg--make-timespan start-time effort offset filepath))))
|
||||||
|
|
||||||
|
;; TODO this should be in org-ml
|
||||||
|
(defun org-x-agg--get-logbook-config ()
|
||||||
|
"Return a config list with current logbook settings.
|
||||||
|
This is a plist meant to be consumed by
|
||||||
|
`org-ml-headline-get-supercontents' and friends."
|
||||||
|
(list :log-into-drawer org-log-into-drawer
|
||||||
|
:clock-into-drawer org-clock-into-drawer
|
||||||
|
:clock-out-notes org-log-note-clock-out))
|
||||||
|
|
||||||
|
(defun org-x-agg--headline-get-timespan-active (headline filepath)
|
||||||
|
"Return timestamp from HEADLINE in FILEPATH as timespan.
|
||||||
|
Only the first active timestamp is considered if any."
|
||||||
|
(-some->> headline
|
||||||
|
(org-ml-headline-get-contents (org-x-agg--get-logbook-config))
|
||||||
|
(apply #'org-ml-build-section)
|
||||||
|
(org-ml-match '(:first :any * (:and timestamp
|
||||||
|
(:or (:type 'active)
|
||||||
|
(:type 'active-range)))))
|
||||||
|
(car)
|
||||||
|
(org-x-agg--timestamp-to-timespan headline filepath)))
|
||||||
|
|
||||||
|
(defun org-x-agg--headline-get-timespans (headline filepath)
|
||||||
|
"Return timestamp from HEADLINE in FILEPATH as new timespan.
|
||||||
|
If HEADLINE has a todo keyword, only consider the scheduled
|
||||||
|
timestamp. Else only consider the first active timestamp in the
|
||||||
|
contents of HEADLINE. Return nil if no timestamps exists meeting
|
||||||
|
these conditions."
|
||||||
|
(if (org-ml-get-property :todo-keyword headline)
|
||||||
|
(org-x-agg--headline-get-timespan-scheduled headline filepath)
|
||||||
|
(org-x-agg--headline-get-timespan-active headline filepath)))
|
||||||
|
|
||||||
|
(defun org-x-agg--headlines-filter-keywords (headlines)
|
||||||
|
"Return HEADLINES without keywords in `org-x-agg-filtered-keywords'."
|
||||||
|
(if (not org-x-agg-filtered-keywords) headlines
|
||||||
|
(--remove (member (org-element-property :todo-keyword it)
|
||||||
|
org-x-agg-filtered-keywords)
|
||||||
|
headlines)))
|
||||||
|
|
||||||
|
(defun org-x-agg--filter-files (filepaths)
|
||||||
|
"Return FILEPATHS with paths meeting a pattern filtered out."
|
||||||
|
(if (not org-x-agg-filtered-files) filepaths
|
||||||
|
(--remove
|
||||||
|
(-find (lambda (s) (string-match-p s it)) org-x-agg-filtered-files)
|
||||||
|
filepaths)))
|
||||||
|
|
||||||
|
(defun org-x-agg--timespans-remove-past (timespans)
|
||||||
|
"Return TIMESPANS without those starting in the past."
|
||||||
|
(if (not org-x-agg-filter-past) timespans
|
||||||
|
(let ((ft (float-time)))
|
||||||
|
(--remove (< (plist-get it :unixtime) ft) timespans))))
|
||||||
|
|
||||||
|
(defun org-x-agg--headlines-remove-habits (headlines)
|
||||||
|
"Return HEADLINES without those that are habits."
|
||||||
|
(if (not org-x-agg-filter-habit) headlines
|
||||||
|
(--remove (org-element-property :STYLE it) headlines)))
|
||||||
|
|
||||||
|
(defun org-x-agg--get-timespans-from-buffer (filepath)
|
||||||
|
"Return timespans for current buffer.
|
||||||
|
FILEPATH is the path to the current buffer."
|
||||||
|
(->> (org-ml-parse-headlines 'all)
|
||||||
|
(org-x-agg--headlines-filter-keywords)
|
||||||
|
(org-x-agg--headlines-remove-habits)
|
||||||
|
(--map (org-x-agg--headline-get-timespans it filepath))
|
||||||
|
(-non-nil)))
|
||||||
|
|
||||||
|
(defun org-x-agg--get-timespans-from-file (filepath)
|
||||||
|
"Return timespans from org-file at FILEPATH."
|
||||||
|
(with-current-buffer (find-file-noselect filepath t)
|
||||||
|
(org-x-agg--get-timespans-from-buffer filepath)))
|
||||||
|
|
||||||
|
(defun org-x-agg--get-all-timespans ()
|
||||||
|
"Return a list of timespans with desired filter settings."
|
||||||
|
(->> (org-agenda-files)
|
||||||
|
(org-x-agg--filter-files)
|
||||||
|
(-mapcat #'org-x-agg--get-timespans-from-file)))
|
||||||
|
|
||||||
|
(defun org-x-agg--timespans-append-unixtime (timespans)
|
||||||
|
"Append a :unixtime property to TIMESPANS.
|
||||||
|
The new property will contain an integer representing the unix
|
||||||
|
time of the :start-time property."
|
||||||
|
(cl-flet
|
||||||
|
((append-unixtime
|
||||||
|
(span)
|
||||||
|
`(:unixtime ,(org-ml-time-to-unixtime (plist-get span :start-time)) ,@span)))
|
||||||
|
(-map #'append-unixtime timespans)))
|
||||||
|
|
||||||
|
;; get conflict headlines
|
||||||
|
;;
|
||||||
|
;; This algorithm builds a list of pairs, with each pair being a two tasks that
|
||||||
|
;; conflicts. It should be O(n) (best case/no conflicts) to O(n^2) (worst
|
||||||
|
;; case/everything conflicts), although this relies on the list being sorted
|
||||||
|
;; which should be O(nlog(n)) (merge sort?).
|
||||||
|
;;
|
||||||
|
;; Steps for this:
|
||||||
|
;; 1. Sort timespan list
|
||||||
|
;; 2. For each timespan:
|
||||||
|
;; 2.1 For each timespan after the current timespan
|
||||||
|
;; If conflict found, add the two timespans being compared to new list,
|
||||||
|
;; else break out of inner loop and advance outer loop at (2.)
|
||||||
|
;;
|
||||||
|
;; NOTE: sorting ensures that timespans can be skipped once one non-conflict is
|
||||||
|
;; found, which is what makes this algorithm approach O(n) as the number of
|
||||||
|
;; conflicts -> 0.
|
||||||
|
|
||||||
|
(defun org-x-agg--timespans-are-conflicting-p (span-a span-b)
|
||||||
|
"Return t if timespans SPAN-A and SPAN-B conflict."
|
||||||
|
;; assume that a starts before b
|
||||||
|
(let ((start-a (plist-get span-a :unixtime))
|
||||||
|
(start-b (plist-get span-b :unixtime)))
|
||||||
|
(or (= start-a start-b) (< start-b (+ start-a (plist-get span-a :range))))))
|
||||||
|
|
||||||
|
(defun org-x-agg--timespan-append-conflict (cur-timespan timespans conlist)
|
||||||
|
"Test if CUR-TIMESPAN conflicts with any in TIMESPANS.
|
||||||
|
Each conflicting timespan will be paired with TIMESPAN like
|
||||||
|
\(CUR CONFLICTING) and appended to CONLIST. New CONLIST is
|
||||||
|
returned."
|
||||||
|
(->> timespans
|
||||||
|
(--take-while (org-x-agg--timespans-are-conflicting-p cur-timespan it))
|
||||||
|
(--map (list cur-timespan it))
|
||||||
|
(append conlist)))
|
||||||
|
|
||||||
|
(defun org-x-agg--timespans-build-conlist (timespans)
|
||||||
|
"Return conflicting pairs from TIMESPANS."
|
||||||
|
(let ((conlist))
|
||||||
|
(while (< 1 (length timespans))
|
||||||
|
(setq conlist (org-x-agg--timespan-append-conflict (car timespans)
|
||||||
|
(cdr timespans)
|
||||||
|
conlist)
|
||||||
|
timespans (cdr timespans)))
|
||||||
|
conlist))
|
||||||
|
|
||||||
|
(defun org-x-agg--timespans-group-conflicts (timespans)
|
||||||
|
"Return TIMESPANS that conflict with each other.
|
||||||
|
The returned list will be a list of pairs of timespans
|
||||||
|
like (SPAN-a SPAN-b) which are two timespans that conflict."
|
||||||
|
(->> (--filter (org-ml-time-is-long (plist-get it :start-time)) timespans)
|
||||||
|
(org-x-agg--timespans-append-unixtime)
|
||||||
|
(org-x-agg--timespans-remove-past)
|
||||||
|
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
|
||||||
|
(org-x-agg--timespans-build-conlist)))
|
||||||
|
|
||||||
|
;; get overloaded days
|
||||||
|
;;
|
||||||
|
;; Overloads are defined as days that have more than 24 hours worth of scheduled
|
||||||
|
;; material. The algorithm itself is O(n) as it is basically just a bunch of
|
||||||
|
;; filtering functions that walk through the list, but it assumes the list is
|
||||||
|
;; sorted which can be achieved with O(nlog(n)) (merge sort?).
|
||||||
|
;;
|
||||||
|
;; Steps for the algorithm:
|
||||||
|
;; 1. filter only ranged entries (unranged entries have zero time)
|
||||||
|
;; 2. split timespans if they span multiple days
|
||||||
|
;; 3. sort from earliest to latest starting time
|
||||||
|
;; 4. partition list by starting day
|
||||||
|
;; 5. sum the timespans in each day, keeping those that exceed 24 hours
|
||||||
|
|
||||||
|
(defun org-x-agg--split-timespan-by-day (timespan)
|
||||||
|
"Split TIMESPAN if it spans multiple days."
|
||||||
|
;; NOTE: `encode-time' seems pretty slow but this is necessary since some
|
||||||
|
;; barbarians in power insist on keep daylight savings time, which means I
|
||||||
|
;; can't just do straight modular arithmetic to find where each day boundary
|
||||||
|
;; lies.
|
||||||
|
(cl-flet
|
||||||
|
((encode-float-time
|
||||||
|
(time)
|
||||||
|
(round (float-time (encode-time time)))))
|
||||||
|
(-let (((&plist :start-time :range :offset :filepath) timespan))
|
||||||
|
(if (= range 0) (list timespan)
|
||||||
|
;; `encode-time' and `decode-time' might not use the right time zone
|
||||||
|
;; unless specified manually
|
||||||
|
(-let* ((tz (current-time-zone))
|
||||||
|
(start-time* (if (org-ml-time-is-long start-time) start-time
|
||||||
|
`(,@(-take 3 start-time) 0 0)))
|
||||||
|
((y m d H M) start-time*)
|
||||||
|
(start-epoch (encode-float-time `(0 ,M ,H ,d ,m ,y nil nil ,tz)))
|
||||||
|
(end-epoch (+ start-epoch range))
|
||||||
|
(next t)
|
||||||
|
(split-epoch nil)
|
||||||
|
((M* H* d* m* y*) '(nil nil nil nil nil))
|
||||||
|
(acc nil))
|
||||||
|
(while next
|
||||||
|
;; get the projected ending time
|
||||||
|
(-setq (M* H* d* m* y*) (-take 5 (cdr (decode-time end-epoch tz))))
|
||||||
|
;; Get the epoch time on which to split. If not on a day boundary,
|
||||||
|
;; calculate the epoch time of the most recent day boundary. If on a
|
||||||
|
;; day boundary, split on the boundary one full day earlier by
|
||||||
|
;; decrementing day by one
|
||||||
|
(when (and (= 0 M*) (= 0 H*))
|
||||||
|
(setq d* (1- d*)))
|
||||||
|
(setq split-epoch (encode-float-time `(0 0 0 ,d* ,m* ,y* nil nil ,tz)))
|
||||||
|
;; If the split-epoch is less than or equal to the start, loop is
|
||||||
|
;; done. Else add a new entry and reset the projected ending time to
|
||||||
|
;; the current split time; rinse and repeat.
|
||||||
|
(if (< start-epoch split-epoch)
|
||||||
|
(setq acc (cons (org-x-agg--make-timespan
|
||||||
|
`(,y* ,m* ,d* 0 0) (- end-epoch split-epoch)
|
||||||
|
offset filepath)
|
||||||
|
acc)
|
||||||
|
end-epoch split-epoch)
|
||||||
|
(setq next nil
|
||||||
|
acc (cons (org-x-agg--make-timespan
|
||||||
|
start-time* (- end-epoch start-epoch) offset filepath)
|
||||||
|
acc))))
|
||||||
|
acc)))))
|
||||||
|
|
||||||
|
(defun org-x-agg--timespans-partition-by-day (timespans)
|
||||||
|
"Return TIMESPANS partitioned by day.
|
||||||
|
Assume TIMESPANS is sorted according to :start-time."
|
||||||
|
(--partition-by (-take 3 (plist-get it :start-time)) timespans))
|
||||||
|
|
||||||
|
(defun org-x-agg--timespan-is-overloaded-p (timespans)
|
||||||
|
"Return t if sum of TIMESPANS exceeds 24 hours.
|
||||||
|
It is assumed the TIMESPANS all start within one day."
|
||||||
|
(<= 86400 (-sum (--map (plist-get it :range) timespans))))
|
||||||
|
|
||||||
|
(defun org-x-agg--timespans-group-overloads (timespans)
|
||||||
|
"Group TIMESPANS by overloaded day.
|
||||||
|
A day is overloaded if it has timespans whose :range properties
|
||||||
|
sum to greater than 24 hours. Timespans across multiple days will
|
||||||
|
be split along day boundaries according to local time zone before
|
||||||
|
grouping is performed. Returned list will be a list of lists
|
||||||
|
like (SPAN1 SPAN2 ...) which are timespans in a single day that
|
||||||
|
is overloaded."
|
||||||
|
(->> timespans
|
||||||
|
(--filter (< 0 (plist-get it :range)))
|
||||||
|
(-mapcat #'org-x-agg--split-timespan-by-day)
|
||||||
|
(org-x-agg--timespans-append-unixtime)
|
||||||
|
(org-x-agg--timespans-remove-past)
|
||||||
|
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
|
||||||
|
(org-x-agg--timespans-partition-by-day)
|
||||||
|
(--filter (org-x-agg--timespan-is-overloaded-p it))))
|
||||||
|
|
||||||
|
;;; AGENDA FRONTEND
|
||||||
|
|
||||||
|
;; I could just fetch the org headings and throw them into a new buffer. But
|
||||||
|
;; that's boring, and quite limiting. I basically want all the perks of an
|
||||||
|
;; agenda buffer...tab-follow, the nice parent display at the bottom, time
|
||||||
|
;; adjust hotkeys, etc. So the obvious and hacky solution is to throw together a
|
||||||
|
;; quick-n-dirty agenda buffer.
|
||||||
|
|
||||||
|
(defun org-x-agg--get-headline-text (timespan)
|
||||||
|
"Return string for headline text represented by TIMESPAN.
|
||||||
|
Returned string will have text properties to enable wizzy, fun
|
||||||
|
things in the agenda like jumpy to the target headline from the
|
||||||
|
agenda buffer."
|
||||||
|
(-let* (((&plist :offset :filepath) timespan)
|
||||||
|
(ts-marker (with-current-buffer (find-file-noselect filepath)
|
||||||
|
(copy-marker offset)))
|
||||||
|
(props (list 'face nil
|
||||||
|
'done-face 'org-agenda-done
|
||||||
|
'org-not-done-regexp org-not-done-regexp
|
||||||
|
'org-todo-regexp org-todo-regexp
|
||||||
|
'org-complex-heading-regexp org-complex-heading-regexp
|
||||||
|
'mouse-face 'highlight))
|
||||||
|
marker priority category level tags ts-date ts-date-pair txt
|
||||||
|
inherited-tags)
|
||||||
|
|
||||||
|
(with-current-buffer (marker-buffer ts-marker)
|
||||||
|
(save-excursion
|
||||||
|
(goto-char ts-marker)
|
||||||
|
|
||||||
|
(setq marker (org-agenda-new-marker (point))
|
||||||
|
category (org-get-category)
|
||||||
|
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
|
||||||
|
ts-date (car ts-date-pair)
|
||||||
|
txt (org-get-heading t)
|
||||||
|
inherited-tags
|
||||||
|
(or (eq org-agenda-show-inherited-tags 'always)
|
||||||
|
(and (listp org-agenda-show-inherited-tags)
|
||||||
|
(memq 'todo org-agenda-show-inherited-tags))
|
||||||
|
(and (eq org-agenda-show-inherited-tags t)
|
||||||
|
(or (eq org-agenda-use-tag-inheritance t)
|
||||||
|
(memq 'todo org-agenda-use-tag-inheritance))))
|
||||||
|
tags (org-get-tags nil (not inherited-tags))
|
||||||
|
level (make-string (org-reduced-level (org-outline-level)) ? )
|
||||||
|
txt (org-agenda-format-item "" txt level category tags t)
|
||||||
|
priority (1+ (org-get-priority txt)))
|
||||||
|
|
||||||
|
(org-add-props txt props
|
||||||
|
'org-marker marker
|
||||||
|
'org-hd-marker marker
|
||||||
|
'priority priority
|
||||||
|
'level level
|
||||||
|
'ts-date ts-date
|
||||||
|
'type "timestamp")))))
|
||||||
|
|
||||||
|
(defun org-x-agg--format-timespan (timespan)
|
||||||
|
"Return formatted day-level timestamp for TIMESPAN."
|
||||||
|
(format-time-string "[%Y-%m-%d]" (plist-get timespan :unixtime)))
|
||||||
|
|
||||||
|
(defun org-x-agg--format-conflict (grouped-timespans)
|
||||||
|
"Return GROUPED-TIMESPANS formatted for conflict agenda buffer."
|
||||||
|
(format "On %s\n%s\n"
|
||||||
|
(org-x-agg--format-timespan (car grouped-timespans))
|
||||||
|
(mapconcat #'org-x-agg--get-headline-text grouped-timespans "\n")))
|
||||||
|
|
||||||
|
(defun org-x-agg--format-overload (grouped-timespans)
|
||||||
|
"Return GROUPED-TIMESPANS formatted for overload agenda buffer."
|
||||||
|
(format "On %s\n%s\n"
|
||||||
|
(org-x-agg--format-timespan (car grouped-timespans))
|
||||||
|
(mapconcat #'org-x-agg--get-headline-text grouped-timespans "\n")))
|
||||||
|
|
||||||
|
(defun org-x-agg--show-agenda (short-name title cluster-fun format-fun arg)
|
||||||
|
"Show an inter-headline cluster agenda buffer.
|
||||||
|
SHORT-NAME is a one-word name describing the buffer which will be
|
||||||
|
used in the name of the buffer. TITLE will be displayed at the
|
||||||
|
top of the buffer. CLUSTER-FUN is a function that takes a list of
|
||||||
|
timespans and returned a grouped list of timespans. FORMAT-FUN is
|
||||||
|
a function that takes one member from the list provided by
|
||||||
|
CLUSTER-FUN and returns a string with text properties to be
|
||||||
|
inserted into the agenda buffer. ARG is an argument provided by
|
||||||
|
some calling interactive function."
|
||||||
|
(when org-agenda-overriding-arguments
|
||||||
|
(setq arg org-agenda-overriding-arguments))
|
||||||
|
|
||||||
|
(when (and (stringp arg) (not (string-match "\\S-" arg)))
|
||||||
|
(setq arg nil))
|
||||||
|
|
||||||
|
(let ((completion-ignore-case t)
|
||||||
|
(org-agenda-prefix-format '((agenda . " %-12:c %-5:e "))))
|
||||||
|
|
||||||
|
(catch 'exit
|
||||||
|
(when org-agenda-sticky
|
||||||
|
(setq org-agenda-buffer-name (format "*Org %s*" short-name)))
|
||||||
|
|
||||||
|
(org-agenda-prepare)
|
||||||
|
(org-compile-prefix-format 'agenda)
|
||||||
|
|
||||||
|
(setq org-agenda-redo-command '(org-x-agg--show-overloads))
|
||||||
|
|
||||||
|
(insert (format "%s: \n" title))
|
||||||
|
(add-text-properties (point-min) (1- (point))
|
||||||
|
(list 'face 'org-agenda-structure
|
||||||
|
'short-heading short-name))
|
||||||
|
(org-agenda-mark-header-line (point-min))
|
||||||
|
|
||||||
|
(-some-> (funcall cluster-fun (org-x-agg--get-all-timespans))
|
||||||
|
(--each (insert (funcall format-fun it))))
|
||||||
|
|
||||||
|
;; clean up and finalize
|
||||||
|
(goto-char (point-min))
|
||||||
|
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
|
||||||
|
(add-text-properties
|
||||||
|
(point-min) (point-max)
|
||||||
|
`(org-agenda-type agenda
|
||||||
|
org-last-args ,arg
|
||||||
|
org-redo-cmd ,org-agenda-redo-command
|
||||||
|
org-series-cmd ,org-cmd))
|
||||||
|
(org-agenda-finalize)
|
||||||
|
(setq buffer-read-only t))))
|
||||||
|
|
||||||
|
(defun org-x-agg-show-conflicts (&optional arg)
|
||||||
|
"Show list of conflicting headlines in agenda buffer.
|
||||||
|
ARG is something that I'm not sure if I need."
|
||||||
|
(interactive "P")
|
||||||
|
(org-x-agg--show-agenda "Conflicts" "Conflicting Headlines"
|
||||||
|
#'org-x-agg--timespans-group-conflicts
|
||||||
|
#'org-x-agg--format-conflict
|
||||||
|
arg))
|
||||||
|
|
||||||
|
(defun org-x-agg-show-overloads (&optional arg)
|
||||||
|
"Show list of overloaded days in agenda buffer.
|
||||||
|
ARG is something that I'm not sure if I need."
|
||||||
|
(interactive "P")
|
||||||
|
(org-x-agg--show-agenda "Overloads" "Overloaded Days"
|
||||||
|
#'org-x-agg--timespans-group-overloads
|
||||||
|
#'org-x-agg--format-overload
|
||||||
|
arg))
|
||||||
|
|
||||||
|
(provide 'org-x-agg)
|
||||||
|
;;; org-x-agg.el ends here
|
||||||
|
|
@ -31,6 +31,7 @@
|
||||||
(require 'dash)
|
(require 'dash)
|
||||||
(require 's)
|
(require 's)
|
||||||
(require 'org)
|
(require 'org)
|
||||||
|
(require 'org-x-agg)
|
||||||
|
|
||||||
;; constants
|
;; constants
|
||||||
|
|
||||||
|
|
@ -66,35 +67,8 @@
|
||||||
Currently used to tell skip functions when they can hop over
|
Currently used to tell skip functions when they can hop over
|
||||||
entire subtrees to save time and ignore tasks")
|
entire subtrees to save time and ignore tasks")
|
||||||
|
|
||||||
(defvar org-x-cluster-filter-files t
|
|
||||||
"Set to t if files should be filtered in org-cluster.
|
|
||||||
This option does nothing unless `org-x-cluster-filtered-files' is
|
|
||||||
also non-nil.")
|
|
||||||
|
|
||||||
(defvar org-x-cluster-filtered-files nil
|
|
||||||
"Files that should be excluded from org-cluster analysis.
|
|
||||||
These are pattern-matched so they do not need to be exact names
|
|
||||||
or paths.")
|
|
||||||
|
|
||||||
(defvar org-x-cluster-filter-todo t
|
|
||||||
"Set to t if todo keywords should be filtered in org-cluster.
|
|
||||||
This option does nothing unless `org-x-cluster-filtered-todo' is
|
|
||||||
also non-nil.")
|
|
||||||
|
|
||||||
(defvar org-x-cluster-filtered-todo nil
|
|
||||||
"TODO keywords that should be filtered from org-cluster analysis.")
|
|
||||||
|
|
||||||
(defvar org-x-cluster-filter-past t
|
|
||||||
"Set to t to exclude files from before now in org-cluster analysis.")
|
|
||||||
|
|
||||||
(defvar org-x-cluster-filter-habit nil
|
|
||||||
"Set to t to exclude habits from org-cluster analysis.")
|
|
||||||
|
|
||||||
;; internal vars
|
;; internal vars
|
||||||
|
|
||||||
(defvar org-x-agenda-hide-incubator-tags t
|
|
||||||
"If true, don't show incubator headings.")
|
|
||||||
|
|
||||||
(defvar org-x-agenda-hasprop-filter nil)
|
(defvar org-x-agenda-hasprop-filter nil)
|
||||||
|
|
||||||
;; list
|
;; list
|
||||||
|
|
@ -487,6 +461,8 @@ should be this function again)."
|
||||||
|
|
||||||
(t (error (concat "invalid keyword detected: " keyword)))))))
|
(t (error (concat "invalid keyword detected: " keyword)))))))
|
||||||
|
|
||||||
|
;; iterators
|
||||||
|
|
||||||
(defun org-x--clone-get-iterator-project-status (kw)
|
(defun org-x--clone-get-iterator-project-status (kw)
|
||||||
(cond
|
(cond
|
||||||
((or (org-x-is-scheduled-heading-p)
|
((or (org-x-is-scheduled-heading-p)
|
||||||
|
|
@ -561,6 +537,8 @@ Allowed statuscodes are in list `nd/get-iter-statuscodes.' where
|
||||||
(org-forward-heading-same-level 1 t)))
|
(org-forward-heading-same-level 1 t)))
|
||||||
cur-status))
|
cur-status))
|
||||||
|
|
||||||
|
;; periodicals
|
||||||
|
|
||||||
(defun org-x-get-periodical-status ()
|
(defun org-x-get-periodical-status ()
|
||||||
"Get the status of a periodical.
|
"Get the status of a periodical.
|
||||||
Allowed statuscodes are in list `nd/get-peri-statuscodes.' where
|
Allowed statuscodes are in list `nd/get-peri-statuscodes.' where
|
||||||
|
|
@ -628,28 +606,9 @@ function will simply return the point of the next headline."
|
||||||
(not (cl-intersection neg-tags-list heading-tags :test 'equal)))
|
(not (cl-intersection neg-tags-list heading-tags :test 'equal)))
|
||||||
(org-x-skip-heading)))))
|
(org-x-skip-heading)))))
|
||||||
|
|
||||||
;; interactive functions
|
;;; INTERACTIVE FUNCTIONS
|
||||||
|
|
||||||
(defun org-x-mark-subtree-keyword (new-keyword &optional exclude no-log)
|
;; cloning
|
||||||
"Change the todo keyword of all tasks in a subtree to NEW-KEYWORD.
|
|
||||||
If EXCLUDE is given, it should be a list of todo keywords; any headline
|
|
||||||
matching a keyword in this list will not be changed. If NO-LOG is t,
|
|
||||||
don't log changes in the logbook."
|
|
||||||
(let ((subtree-end (save-excursion (org-end-of-subtree t)))
|
|
||||||
(org-todo-log-states (unless no-log org-todo-log-states)))
|
|
||||||
(if (not (listp exclude))
|
|
||||||
(error "Exclude must be a list if provided"))
|
|
||||||
(save-excursion
|
|
||||||
(while (< (point) subtree-end)
|
|
||||||
(let ((keyword (org-x-is-todoitem-p)))
|
|
||||||
(if (and keyword (not (member keyword exclude)))
|
|
||||||
(org-todo new-keyword)))
|
|
||||||
(outline-next-heading)))))
|
|
||||||
|
|
||||||
(defun org-x-mark-subtree-done ()
|
|
||||||
"Mark all tasks in subtree as DONE unless they are already CANC."
|
|
||||||
(interactive)
|
|
||||||
(org-x-mark-subtree-keyword "DONE" '("CANC")))
|
|
||||||
|
|
||||||
(defun org-x--reset-headline (headline)
|
(defun org-x--reset-headline (headline)
|
||||||
"Reset HEADLINE node to incomplete state.
|
"Reset HEADLINE node to incomplete state.
|
||||||
|
|
@ -723,7 +682,6 @@ SHIFT is a string specifier denoting the amount to shift, eg
|
||||||
(-let (((T unit) (convert-shift shift)))
|
(-let (((T unit) (convert-shift shift)))
|
||||||
(--map-indexed (shift-timestamps T unit (1+ it-index) it) headlines))))))
|
(--map-indexed (shift-timestamps T unit (1+ it-index) it) headlines))))))
|
||||||
|
|
||||||
;; TODO make "CREATED" timestamp reflect when these things are cloned
|
|
||||||
(defun org-x-clone-subtree-with-time-shift (n)
|
(defun org-x-clone-subtree-with-time-shift (n)
|
||||||
"Like `org-clone-subtree-with-time-shift' except reset items and todos.
|
"Like `org-clone-subtree-with-time-shift' except reset items and todos.
|
||||||
N is the number of clones to produce."
|
N is the number of clones to produce."
|
||||||
|
|
@ -763,6 +721,31 @@ N is the number of clones to produce."
|
||||||
(org-ml-match-do '(section property-drawer) (lambda (it) (org-ml-fold it)) post)
|
(org-ml-match-do '(section property-drawer) (lambda (it) (org-ml-fold it)) post)
|
||||||
(org-ml-match-do '(headline) (lambda (it) (org-ml-fold it)) post))))
|
(org-ml-match-do '(headline) (lambda (it) (org-ml-fold it)) post))))
|
||||||
|
|
||||||
|
;; marking subtrees
|
||||||
|
|
||||||
|
(defun org-x-mark-subtree-keyword (new-keyword &optional exclude no-log)
|
||||||
|
"Change the todo keyword of all tasks in a subtree to NEW-KEYWORD.
|
||||||
|
If EXCLUDE is given, it should be a list of todo keywords; any headline
|
||||||
|
matching a keyword in this list will not be changed. If NO-LOG is t,
|
||||||
|
don't log changes in the logbook."
|
||||||
|
(let ((subtree-end (save-excursion (org-end-of-subtree t)))
|
||||||
|
(org-todo-log-states (unless no-log org-todo-log-states)))
|
||||||
|
(if (not (listp exclude))
|
||||||
|
(error "Exclude must be a list if provided"))
|
||||||
|
(save-excursion
|
||||||
|
(while (< (point) subtree-end)
|
||||||
|
(let ((keyword (org-x-is-todoitem-p)))
|
||||||
|
(if (and keyword (not (member keyword exclude)))
|
||||||
|
(org-todo new-keyword)))
|
||||||
|
(outline-next-heading)))))
|
||||||
|
|
||||||
|
(defun org-x-mark-subtree-done ()
|
||||||
|
"Mark all tasks in subtree as DONE unless they are already CANC."
|
||||||
|
(interactive)
|
||||||
|
(org-x-mark-subtree-keyword "DONE" '("CANC")))
|
||||||
|
|
||||||
|
;; logbook
|
||||||
|
|
||||||
(defun org-x-log-delete ()
|
(defun org-x-log-delete ()
|
||||||
"Delete logbook drawer of subtree."
|
"Delete logbook drawer of subtree."
|
||||||
(interactive)
|
(interactive)
|
||||||
|
|
@ -778,11 +761,6 @@ N is the number of clones to produce."
|
||||||
(delete-region (region-beginning) (region-end))
|
(delete-region (region-beginning) (region-end))
|
||||||
(org-remove-empty-drawer-at (point)))))
|
(org-remove-empty-drawer-at (point)))))
|
||||||
|
|
||||||
(defun org-x-delete-subtree ()
|
|
||||||
"Delete the entire subtree under the current heading without sending to kill ring."
|
|
||||||
(interactive)
|
|
||||||
(org-back-to-heading t)
|
|
||||||
(delete-region (point) (+ 1 (save-excursion (org-end-of-subtree)))))
|
|
||||||
|
|
||||||
(defun org-x-clock-range (&optional arg)
|
(defun org-x-clock-range (&optional arg)
|
||||||
"Add a completed clock entry to the current heading.
|
"Add a completed clock entry to the current heading.
|
||||||
|
|
@ -804,6 +782,7 @@ ARG, ask for a range in minutes in place of the second date."
|
||||||
(t
|
(t
|
||||||
(let ((s (org-ml-unixtime-to-time-long t1))
|
(let ((s (org-ml-unixtime-to-time-long t1))
|
||||||
(e (org-ml-unixtime-to-time-long t2)))
|
(e (org-ml-unixtime-to-time-long t2)))
|
||||||
|
;; TODO rewrite this in terms of org-ml code
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(org-clock-find-position nil)
|
(org-clock-find-position nil)
|
||||||
(org-indent-line)
|
(org-indent-line)
|
||||||
|
|
@ -811,6 +790,67 @@ ARG, ask for a range in minutes in place of the second date."
|
||||||
(org-ml-to-string)
|
(org-ml-to-string)
|
||||||
(insert))))))))
|
(insert))))))))
|
||||||
|
|
||||||
|
(defun org-x-refile-logbook ()
|
||||||
|
"Refile the current headline with it's logbook.
|
||||||
|
The original target headline is left in place but without the
|
||||||
|
logbook. Intended use is for habits and repeating tasks that
|
||||||
|
build up massive logbook entries that will make my org files huge
|
||||||
|
and slow."
|
||||||
|
(interactive)
|
||||||
|
(let ((acat (org-get-category))
|
||||||
|
(atime (format-time-string (substring (cdr org-time-stamp-formats) 1 -1)))
|
||||||
|
(afile (abbreviate-file-name
|
||||||
|
(or (buffer-file-name (buffer-base-buffer))
|
||||||
|
(error "No file associated to buffer"))))
|
||||||
|
(apath (s-join "/" (org-get-outline-path)))
|
||||||
|
(atags (->> (org-get-tags)
|
||||||
|
(--filter (get-text-property 0 'inherited it))
|
||||||
|
(s-join " ")))
|
||||||
|
(config (list :log-into-drawer org-log-into-drawer
|
||||||
|
:clock-into-drawer org-clock-into-drawer)))
|
||||||
|
;; TODO this is basically a function version of org-archive and could
|
||||||
|
;; be refactored/reused as a separate function
|
||||||
|
(cl-flet
|
||||||
|
((archive
|
||||||
|
(atime afile _apath acat atodo atags target headline)
|
||||||
|
(let* ((level-shift (-some-> (org-ml-get-property :level headline)
|
||||||
|
(1-)
|
||||||
|
(-)))
|
||||||
|
(headline*
|
||||||
|
(->> (org-ml-clone-node headline)
|
||||||
|
(org-ml-set-property :todo-keyword "DONE")
|
||||||
|
(org-ml-headline-map-planning*
|
||||||
|
(let ((time (->> (float-time)
|
||||||
|
(org-ml-unixtime-to-time-long))))
|
||||||
|
(org-ml-planning-set-timestamp! :closed time it)))
|
||||||
|
(org-ml-headline-set-node-property "ARCHIVE_TIME" atime)
|
||||||
|
(org-ml-headline-set-node-property "ARCHIVE_FILE" afile)
|
||||||
|
(org-ml-headline-set-node-property "ARCHIVE_OLPATH" afile)
|
||||||
|
(org-ml-headline-set-node-property "ARCHIVE_CATEGORY" acat)
|
||||||
|
(org-ml-headline-set-node-property "ARCHIVE_TODO" atodo)
|
||||||
|
(org-ml-headline-set-node-property "ARCHIVE_ITAGS" atags)
|
||||||
|
(org-ml-shift-property :level level-shift)
|
||||||
|
(org-ml-match-map* '(:any * headline)
|
||||||
|
(org-ml-shift-property :level level-shift it)))))
|
||||||
|
;; TODO this currently does not refile under specific headlines
|
||||||
|
(with-current-buffer (find-file-noselect target)
|
||||||
|
(org-ml-insert (point-max) headline*)))))
|
||||||
|
(org-ml-update-this-subtree*
|
||||||
|
(let ((atodo (org-ml-get-property :todo-keyword it))
|
||||||
|
(target (format "%s_archive" afile)))
|
||||||
|
(archive atime afile apath acat atodo atags target it)
|
||||||
|
(org-ml-headline-map-supercontents* config
|
||||||
|
(org-ml-supercontents-set-logbook nil it)
|
||||||
|
it))))))
|
||||||
|
|
||||||
|
(defun org-x-delete-subtree ()
|
||||||
|
"Delete entire subtree under point without sending to kill ring."
|
||||||
|
(interactive)
|
||||||
|
(org-back-to-heading t)
|
||||||
|
(delete-region (point) (1+ (save-excursion (org-end-of-subtree)))))
|
||||||
|
|
||||||
|
;; lift buffer commands into agenda context
|
||||||
|
|
||||||
(defmacro org-x-agenda-cmd-wrapper (get-head &rest body)
|
(defmacro org-x-agenda-cmd-wrapper (get-head &rest body)
|
||||||
"Execute BODY in context of agenda buffer.
|
"Execute BODY in context of agenda buffer.
|
||||||
Specifically, navigate to the original header, execute BODY, then
|
Specifically, navigate to the original header, execute BODY, then
|
||||||
|
|
@ -866,60 +906,30 @@ It will clone the last entry in the selected subtree."
|
||||||
nil
|
nil
|
||||||
(call-interactively #'org-x-clock-range)))
|
(call-interactively #'org-x-clock-range)))
|
||||||
|
|
||||||
(defun org-x-agenda-filter-non-context ()
|
;; agenda heading navigation functions
|
||||||
"Filter all tasks with context tags."
|
|
||||||
(interactive)
|
|
||||||
(let* ((tags-list (mapcar #'car org-tag-alist))
|
|
||||||
(context-tags (append
|
|
||||||
(org-x-filter-list-prefix "@" tags-list)
|
|
||||||
(org-x-filter-list-prefix "#" tags-list))))
|
|
||||||
(setq org-agenda-tag-filter
|
|
||||||
(mapcar (lambda (tag) (concat "-" tag)) context-tags))
|
|
||||||
(org-agenda-filter-apply org-agenda-tag-filter 'tag)))
|
|
||||||
|
|
||||||
(defun org-x-agenda-filter-non-peripheral ()
|
|
||||||
"Filter all tasks that don't have peripheral tags."
|
|
||||||
(interactive)
|
|
||||||
(let* ((peripheral-tags '("PERIPHERAL")))
|
|
||||||
(setq org-agenda-tag-filter
|
|
||||||
(mapcar (lambda (tag) (concat "-" tag)) peripheral-tags))
|
|
||||||
(org-agenda-filter-apply org-agenda-tag-filter 'tag)))
|
|
||||||
|
|
||||||
(defun org-x-agenda-filter-non-effort ()
|
|
||||||
"Filter agenda by non-effort tasks."
|
|
||||||
(interactive)
|
|
||||||
(setq org-x-agenda-hasprop-filter '("-Effort"))
|
|
||||||
(org-agenda-filter-apply org-x-agenda-hasprop-filter 'hasprop))
|
|
||||||
|
|
||||||
(defun org-x-agenda-filter-delegate ()
|
|
||||||
"Filter agenda by tasks with an external delegate."
|
|
||||||
(interactive)
|
|
||||||
(setq org-x-agenda-hasprop-filter '("+DELEGATE"))
|
|
||||||
(org-agenda-filter-apply org-x-agenda-hasprop-filter 'hasprop))
|
|
||||||
|
|
||||||
(defun org-x-agenda--seek-heading (&optional back)
|
(defun org-x-agenda--seek-heading (&optional back)
|
||||||
"Go to next or previous agenda heading.
|
"Go to next or previous agenda heading.
|
||||||
If BACK is t seek backward, else forward. Ignore blank lines."
|
If BACK is t seek backward, else forward. Ignore blank lines."
|
||||||
(let* ((limit (if back (point-min) (point-max)))
|
(cl-flet
|
||||||
(inc (if back -1 1))
|
((is-valid-header
|
||||||
(is-valid-header
|
()
|
||||||
(lambda ()
|
(let ((h (buffer-substring (line-beginning-position)
|
||||||
(let ((h (buffer-substring (line-beginning-position)
|
(line-end-position))))
|
||||||
(line-end-position))))
|
(and (not (equal h ""))
|
||||||
(and
|
|
||||||
(not (equal h ""))
|
|
||||||
(get-text-property 0 'org-agenda-structural-header h)))))
|
(get-text-property 0 'org-agenda-structural-header h)))))
|
||||||
(next
|
(let* ((limit (if back (point-min) (point-max)))
|
||||||
(let ((header-point))
|
(inc (if back -1 1))
|
||||||
(save-excursion
|
(next
|
||||||
(while (and (< 0 (abs (- limit (point))))
|
(let ((header-point))
|
||||||
(not header-point))
|
(save-excursion
|
||||||
(forward-line inc)
|
(while (and (< 0 (abs (- limit (point)))) (not header-point))
|
||||||
(when (funcall is-valid-header)
|
(forward-line inc)
|
||||||
(setq header-point (point))))
|
(when (is-valid-header)
|
||||||
header-point))))
|
(setq header-point (point))))
|
||||||
(if next (goto-char next)
|
header-point))))
|
||||||
(message (if back "Cannot move up" "Cannot move down")))))
|
(if next (goto-char next)
|
||||||
|
(message (if back "Cannot move up" "Cannot move down"))))))
|
||||||
|
|
||||||
(defun org-x-agenda-previous-heading ()
|
(defun org-x-agenda-previous-heading ()
|
||||||
"Go to the previous agenda heading or end of buffer."
|
"Go to the previous agenda heading or end of buffer."
|
||||||
|
|
@ -931,6 +941,9 @@ If BACK is t seek backward, else forward. Ignore blank lines."
|
||||||
(interactive)
|
(interactive)
|
||||||
(org-x-agenda--seek-heading))
|
(org-x-agenda--seek-heading))
|
||||||
|
|
||||||
|
;; timestamp shifter
|
||||||
|
|
||||||
|
;; TODO refactor in terms of org-ml to make cleaner/safer
|
||||||
(defun org-x-time-shift ()
|
(defun org-x-time-shift ()
|
||||||
"Shift all scheduled and deadlined timestamps in the current subtree."
|
"Shift all scheduled and deadlined timestamps in the current subtree."
|
||||||
(interactive)
|
(interactive)
|
||||||
|
|
@ -963,6 +976,8 @@ If BACK is t seek backward, else forward. Ignore blank lines."
|
||||||
(funcall shift-ts-maybe 'deadline)
|
(funcall shift-ts-maybe 'deadline)
|
||||||
(outline-next-heading)))))
|
(outline-next-heading)))))
|
||||||
|
|
||||||
|
;; agenda filtering
|
||||||
|
|
||||||
;; In order to implement the =hasprop= filter, the functions
|
;; In order to implement the =hasprop= filter, the functions
|
||||||
;; =org-agenda-filter-make-matcher= and =org-agenda-filter-remove-all= need to
|
;; =org-agenda-filter-make-matcher= and =org-agenda-filter-remove-all= need to
|
||||||
;; be advised in order to add the functionality for the =hasprop= filter type.
|
;; be advised in order to add the functionality for the =hasprop= filter type.
|
||||||
|
|
@ -973,6 +988,37 @@ If BACK is t seek backward, else forward. Ignore blank lines."
|
||||||
;; to different filter types). Note this does not give a shiny indicator at the
|
;; to different filter types). Note this does not give a shiny indicator at the
|
||||||
;; bottom of spaceline like the built-in filter does...oh well.
|
;; bottom of spaceline like the built-in filter does...oh well.
|
||||||
|
|
||||||
|
(defun org-x-agenda-filter-non-context ()
|
||||||
|
"Filter all tasks with context tags."
|
||||||
|
(interactive)
|
||||||
|
(let* ((tags-list (mapcar #'car org-tag-alist))
|
||||||
|
(context-tags (append
|
||||||
|
(org-x-filter-list-prefix "@" tags-list)
|
||||||
|
(org-x-filter-list-prefix "#" tags-list))))
|
||||||
|
(setq org-agenda-tag-filter
|
||||||
|
(mapcar (lambda (tag) (concat "-" tag)) context-tags))
|
||||||
|
(org-agenda-filter-apply org-agenda-tag-filter 'tag)))
|
||||||
|
|
||||||
|
(defun org-x-agenda-filter-non-peripheral ()
|
||||||
|
"Filter all tasks that don't have peripheral tags."
|
||||||
|
(interactive)
|
||||||
|
(let* ((peripheral-tags '("PERIPHERAL")))
|
||||||
|
(setq org-agenda-tag-filter
|
||||||
|
(mapcar (lambda (tag) (concat "-" tag)) peripheral-tags))
|
||||||
|
(org-agenda-filter-apply org-agenda-tag-filter 'tag)))
|
||||||
|
|
||||||
|
(defun org-x-agenda-filter-non-effort ()
|
||||||
|
"Filter agenda by non-effort tasks."
|
||||||
|
(interactive)
|
||||||
|
(setq org-x-agenda-hasprop-filter '("-Effort"))
|
||||||
|
(org-agenda-filter-apply org-x-agenda-hasprop-filter 'hasprop))
|
||||||
|
|
||||||
|
(defun org-x-agenda-filter-delegate ()
|
||||||
|
"Filter agenda by tasks with an external delegate."
|
||||||
|
(interactive)
|
||||||
|
(setq org-x-agenda-hasprop-filter '("+DELEGATE"))
|
||||||
|
(org-agenda-filter-apply org-x-agenda-hasprop-filter 'hasprop))
|
||||||
|
|
||||||
(defun org-x-agenda-filter-make-matcher-prop (filter type &rest _args)
|
(defun org-x-agenda-filter-make-matcher-prop (filter type &rest _args)
|
||||||
"Override the standard match filter.
|
"Override the standard match filter.
|
||||||
This will return matching matcher form for FILTER and TYPE
|
This will return matching matcher form for FILTER and TYPE
|
||||||
|
|
@ -1079,458 +1125,5 @@ If ARG is non-nil use long timestamp format."
|
||||||
|
|
||||||
(add-hook 'org-capture-before-finalize-hook #'org-x-set-creation-time)
|
(add-hook 'org-capture-before-finalize-hook #'org-x-set-creation-time)
|
||||||
|
|
||||||
(defun org-x-refile-logbook ()
|
|
||||||
"Refile the current headline with it's logbook.
|
|
||||||
The original target headline is left in place but without the
|
|
||||||
logbook. Intended use is for habits and repeating tasks that
|
|
||||||
build up massive logbook entries that will make my org files huge
|
|
||||||
and slow."
|
|
||||||
(interactive)
|
|
||||||
(let ((acat (org-get-category))
|
|
||||||
(atime (format-time-string (substring (cdr org-time-stamp-formats) 1 -1)))
|
|
||||||
(afile (abbreviate-file-name
|
|
||||||
(or (buffer-file-name (buffer-base-buffer))
|
|
||||||
(error "No file associated to buffer"))))
|
|
||||||
(apath (s-join "/" (org-get-outline-path)))
|
|
||||||
(atags (->> (org-get-tags)
|
|
||||||
(--filter (get-text-property 0 'inherited it))
|
|
||||||
(s-join " ")))
|
|
||||||
(config (list :log-into-drawer org-log-into-drawer
|
|
||||||
:clock-into-drawer org-clock-into-drawer)))
|
|
||||||
;; TODO this is basically a function version of org-archive and could
|
|
||||||
;; be refactored/reused as a separate function
|
|
||||||
(cl-flet
|
|
||||||
((archive
|
|
||||||
(atime afile _apath acat atodo atags target headline)
|
|
||||||
(let* ((level-shift (-some-> (org-ml-get-property :level headline)
|
|
||||||
(1-)
|
|
||||||
(-)))
|
|
||||||
(headline*
|
|
||||||
(->> (org-ml-clone-node headline)
|
|
||||||
(org-ml-set-property :todo-keyword "DONE")
|
|
||||||
(org-ml-headline-map-planning*
|
|
||||||
(let ((time (->> (float-time)
|
|
||||||
(org-ml-unixtime-to-time-long))))
|
|
||||||
(org-ml-planning-set-timestamp! :closed time it)))
|
|
||||||
(org-ml-headline-set-node-property "ARCHIVE_TIME" atime)
|
|
||||||
(org-ml-headline-set-node-property "ARCHIVE_FILE" afile)
|
|
||||||
(org-ml-headline-set-node-property "ARCHIVE_OLPATH" afile)
|
|
||||||
(org-ml-headline-set-node-property "ARCHIVE_CATEGORY" acat)
|
|
||||||
(org-ml-headline-set-node-property "ARCHIVE_TODO" atodo)
|
|
||||||
(org-ml-headline-set-node-property "ARCHIVE_ITAGS" atags)
|
|
||||||
(org-ml-shift-property :level level-shift)
|
|
||||||
(org-ml-match-map* '(:any * headline)
|
|
||||||
(org-ml-shift-property :level level-shift it)))))
|
|
||||||
;; TODO this currently does not refile under specific headlines
|
|
||||||
(with-current-buffer (find-file-noselect target)
|
|
||||||
(org-ml-insert (point-max) headline*)))))
|
|
||||||
(org-ml-update-this-subtree*
|
|
||||||
(let ((atodo (org-ml-get-property :todo-keyword it))
|
|
||||||
(target (format "%s_archive" afile)))
|
|
||||||
(archive atime afile apath acat atodo atags target it)
|
|
||||||
(org-ml-headline-map-supercontents* config
|
|
||||||
(org-ml-supercontents-set-logbook nil it)
|
|
||||||
it))))))
|
|
||||||
|
|
||||||
;; inter-headline clustering
|
|
||||||
;;
|
|
||||||
;; Conflicts and overloads begin with the same list to process, which is created
|
|
||||||
;; using `org-element-parse-buffer' and a variety of filtering functions to
|
|
||||||
;; extract relevent timestamps.
|
|
||||||
|
|
||||||
(defun org-x-cluster-make-tsp (start-time range offset fp)
|
|
||||||
"Construct a timestamp plist to be used in further processing.
|
|
||||||
|
|
||||||
The fields are as follows:
|
|
||||||
|
|
||||||
- START-TIME is a list from `org-ml-timestamp-get-start-time'
|
|
||||||
- RANGE is the duration of the timestamp (could be 0)
|
|
||||||
- OFFSET is the character offset of the timestamp in its file
|
|
||||||
- FP the path to the file in which the timestamp resides"
|
|
||||||
(list :start-time start-time
|
|
||||||
:range range
|
|
||||||
:offset offset
|
|
||||||
:filepath fp))
|
|
||||||
|
|
||||||
(defun org-x-cluster-ts-hard-p (ts)
|
|
||||||
"Return non-nil if the timestamp TS has hours/minutes."
|
|
||||||
(org-element-property :hour-start ts))
|
|
||||||
|
|
||||||
(defun org-x-cluster-parse-ts (hl fp ts)
|
|
||||||
"Parse a timestamp TS belonging to headline HL and filepath FP.
|
|
||||||
TS is an object as described in the org-element API. Only active
|
|
||||||
or active-range types are considered. Returns a new timestamp-plist
|
|
||||||
for TS."
|
|
||||||
(when ts
|
|
||||||
(let ((offset (org-element-property :begin hl))
|
|
||||||
(start-time (org-ml-timestamp-get-start-time ts))
|
|
||||||
(range (org-ml-timestamp-get-range ts)))
|
|
||||||
(org-x-cluster-make-tsp start-time range offset fp))))
|
|
||||||
|
|
||||||
(defun org-x-cluster-effort-seconds (effort-str)
|
|
||||||
"Convert EFFORT-STR into an integer in seconds from HH:MM format."
|
|
||||||
(-some->> effort-str (org-duration-to-minutes) (round) (* 60)))
|
|
||||||
|
|
||||||
(defun org-x-cluster-extract-hl-sched (hl fp)
|
|
||||||
"Extract scheduled timestamp from headline HL in filepath FP.
|
|
||||||
Create a new timestamp-plist and add to accumulator ACC."
|
|
||||||
(-when-let (ts (-some->> (org-ml-headline-get-planning hl)
|
|
||||||
(org-ml-get-property :scheduled)))
|
|
||||||
(let* ((effort-raw (org-ml-headline-get-node-property "Effort" hl))
|
|
||||||
(effort (if effort-raw (org-x-cluster-effort-seconds effort-raw) 0))
|
|
||||||
(offset (org-ml-get-property :begin hl))
|
|
||||||
(start-time (org-ml-timestamp-get-start-time ts)))
|
|
||||||
(org-x-cluster-make-tsp start-time effort offset fp))))
|
|
||||||
|
|
||||||
(defun org-x-cluster-extract-hl-ts (hl fp)
|
|
||||||
"Extract timestamps from headline HL in filepath FP.
|
|
||||||
All active timestamps that are not in drawers or the planning header
|
|
||||||
are considered. Each timestamp is converted into a new timestamp-plist
|
|
||||||
and added to accumulator ACC."
|
|
||||||
(-some->> hl
|
|
||||||
(org-ml-headline-get-contents
|
|
||||||
(list :log-into-drawer org-log-into-drawer
|
|
||||||
:clock-into-drawer org-clock-into-drawer
|
|
||||||
:clock-out-notes org-log-note-clock-out))
|
|
||||||
(apply #'org-ml-build-section)
|
|
||||||
(org-ml-match '(:first :any * (:and timestamp
|
|
||||||
(:or (:type 'active)
|
|
||||||
(:type 'active-range)))))
|
|
||||||
(car)
|
|
||||||
(org-x-cluster-parse-ts hl fp)))
|
|
||||||
|
|
||||||
(defun org-x-cluster-extract-hl (hl fp)
|
|
||||||
"Extract timestamps from headline HL in filepath FP and store in ACC."
|
|
||||||
(if (org-ml-get-property :todo-keyword hl)
|
|
||||||
(org-x-cluster-extract-hl-sched hl fp)
|
|
||||||
(org-x-cluster-extract-hl-ts hl fp)))
|
|
||||||
|
|
||||||
(defun org-x-cluster-filter-todo (hls)
|
|
||||||
"Filter certain TODO keywords from headline list HLS."
|
|
||||||
(if (not org-x-cluster-filter-todo) hls
|
|
||||||
(--remove (member (org-element-property :todo-keyword it)
|
|
||||||
org-x-cluster-filtered-todo)
|
|
||||||
hls)))
|
|
||||||
|
|
||||||
(defun org-x-cluster-filter-files (fps)
|
|
||||||
"Filter certain file names from files list FPS."
|
|
||||||
(if (not org-x-cluster-filter-files) fps
|
|
||||||
(--remove
|
|
||||||
(-find (lambda (s) (string-match-p s it)) org-x-cluster-filtered-files)
|
|
||||||
fps)))
|
|
||||||
|
|
||||||
(defun org-x-cluster-filter-past (tsps)
|
|
||||||
"Filter out timestamp-plists in list TSPS if they start in the past."
|
|
||||||
(if (not org-x-cluster-filter-past) tsps
|
|
||||||
(let ((ft (float-time)))
|
|
||||||
(--remove (< (plist-get it :unixtime) ft) tsps))))
|
|
||||||
|
|
||||||
(defun org-x-cluster-filter-habit (hls)
|
|
||||||
"Filter headlines from headline list HLS that are habits."
|
|
||||||
(if (not org-x-cluster-filter-habit) hls
|
|
||||||
(--remove (org-element-property :STYLE it) hls)))
|
|
||||||
|
|
||||||
(defun org-x-cluster-extract-buffer (fp)
|
|
||||||
"Extract headlines from the current buffer for clustering analysis.
|
|
||||||
FP is the filepath to the current buffer."
|
|
||||||
(->> (org-ml-parse-headlines 'all)
|
|
||||||
(org-x-cluster-filter-todo)
|
|
||||||
(org-x-cluster-filter-habit)
|
|
||||||
(--map (org-x-cluster-extract-hl it fp))
|
|
||||||
(-non-nil)))
|
|
||||||
|
|
||||||
(defun org-x-cluster-extract-file (fp)
|
|
||||||
"Extract timestamps from filepath FP and add to accumulator ACC."
|
|
||||||
(with-current-buffer (find-file-noselect fp t)
|
|
||||||
(org-x-cluster-extract-buffer fp)))
|
|
||||||
|
|
||||||
(defun org-x-cluster-append-unixtime (tsps)
|
|
||||||
"Append a :unixtime property to TSPS.
|
|
||||||
The new property will contain an integer representing the unix
|
|
||||||
time of the :start-time property."
|
|
||||||
(--map (append (list :unixtime (org-ml-time-to-unixtime (plist-get it :start-time))) it) tsps))
|
|
||||||
|
|
||||||
(defun org-x-cluster-get-unprocessed ()
|
|
||||||
"Return a list of timestamp-plists with desired filter settings."
|
|
||||||
(->> (org-agenda-files)
|
|
||||||
(org-x-cluster-filter-files)
|
|
||||||
(-mapcat #'org-x-cluster-extract-file)))
|
|
||||||
|
|
||||||
;; get conflict headlines
|
|
||||||
;;
|
|
||||||
;; This algorithm builds a list of pairs, with each pair being a two tasks that
|
|
||||||
;; conflict and should be O(n) (best case/no conflicts) to O(n^2) (worst
|
|
||||||
;; case/everything conflicts).
|
|
||||||
;;
|
|
||||||
;; Steps for this:
|
|
||||||
;; 1. make a list of all entries containing timestamps (active and scheduled)
|
|
||||||
;; 2. sort timestamp list
|
|
||||||
;; 3. Walk through list and compare entries immediately after (sorting ensures
|
|
||||||
;; that entries can be skipped once one non-conflict is found). If conflicts
|
|
||||||
;; are found push the pair to new list.
|
|
||||||
|
|
||||||
(defun org-x-cluster-conflicting-p (tsp-a tsp-b)
|
|
||||||
"Return t if timestamps TSP-A and TSP-B conflict."
|
|
||||||
;; assume that ts-a starts before ts-b
|
|
||||||
(let ((start-a (plist-get tsp-a :unixtime))
|
|
||||||
(start-b (plist-get tsp-b :unixtime)))
|
|
||||||
(or (= start-a start-b) (< start-b (+ start-a (plist-get tsp-a :range))))))
|
|
||||||
|
|
||||||
(defun org-x-cluster-find-conflict (tsp tsps conlist)
|
|
||||||
"Test if timestamp-plist TSP conflicts with any in TSPS.
|
|
||||||
If found, anything in TSPS is cons'd with TSP and added to CONLIST
|
|
||||||
as a pair. New CONLIST is returned."
|
|
||||||
(->> (--take-while (org-x-cluster-conflicting-p tsp it) tsps)
|
|
||||||
(--map (list tsp it))
|
|
||||||
(append conlist)))
|
|
||||||
|
|
||||||
(defun org-x-cluster-build-conlist (tsps)
|
|
||||||
"Build a list of conflict pairs from timestamp-plist TSPS."
|
|
||||||
(let ((conlist))
|
|
||||||
(while (< 1 (length tsps))
|
|
||||||
(setq conlist (org-x-cluster-find-conflict (car tsps) (cdr tsps) conlist)
|
|
||||||
tsps (cdr tsps)))
|
|
||||||
conlist))
|
|
||||||
|
|
||||||
(defun org-x-cluster-group-conflicts (tsps)
|
|
||||||
"Return TSPS that conflict with each other.
|
|
||||||
The returned list will be a list of pairs of TSPs like (TSP-a TSP-b) which
|
|
||||||
are two TSPs that conflict."
|
|
||||||
(->> (--filter (org-ml-time-is-long (plist-get it :start-time)) tsps)
|
|
||||||
(org-x-cluster-append-unixtime)
|
|
||||||
(org-x-cluster-filter-past)
|
|
||||||
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
|
|
||||||
(org-x-cluster-build-conlist)))
|
|
||||||
|
|
||||||
;; get overloaded days
|
|
||||||
;;
|
|
||||||
;; Overloads are defined as days that have more than 24 hours worth of scheduled
|
|
||||||
;; material. The algorithm is O(n) as it is basically just a bunch of filtering
|
|
||||||
;; functions that walk through the list.
|
|
||||||
;;
|
|
||||||
;; Steps for the algorithm:
|
|
||||||
;; 1. filter only ranged entries (unranged entries have zero time)
|
|
||||||
;; 2. maybe split timestamps if they span multiple days
|
|
||||||
;; 3. sort from earliest to latest starting time
|
|
||||||
;; 4. sum the range of timestamps in each day, keeping those that exceed 24 hours
|
|
||||||
|
|
||||||
(defun org-x-cluster-split-tsp-maybe (tsp)
|
|
||||||
"Split TSP if it spans multiple days."
|
|
||||||
;; NOTE: `encode-time' seems pretty slow but this is necessary since some
|
|
||||||
;; barbarians in power insist on keep daylight savings time, which means I
|
|
||||||
;; can't just do straight modular arithmetic to find where each day boundary
|
|
||||||
;; lies.
|
|
||||||
(cl-flet
|
|
||||||
((encode-float-time
|
|
||||||
(time)
|
|
||||||
(round (float-time (encode-time time)))))
|
|
||||||
(-let (((&plist :start-time :range :offset :filepath) tsp))
|
|
||||||
(if (= range 0) (list tsp)
|
|
||||||
;; `encode-time' and `decode-time' might not use the right time zone
|
|
||||||
;; unless specified manually
|
|
||||||
(-let* ((tz (current-time-zone))
|
|
||||||
(start-time* (if (org-ml-time-is-long start-time) start-time
|
|
||||||
`(,@(-take 3 start-time) 0 0)))
|
|
||||||
((y m d H M) start-time*)
|
|
||||||
(start-epoch (encode-float-time `(0 ,M ,H ,d ,m ,y nil nil ,tz)))
|
|
||||||
(end-epoch (+ start-epoch range))
|
|
||||||
(next t)
|
|
||||||
(split-epoch nil)
|
|
||||||
((M* H* d* m* y*) '(nil nil nil nil nil))
|
|
||||||
(acc nil))
|
|
||||||
(while next
|
|
||||||
;; get the projected ending time
|
|
||||||
(-setq (M* H* d* m* y*) (-take 5 (cdr (decode-time end-epoch tz))))
|
|
||||||
;; Get the epoch time on which to split. If not on a day boundary,
|
|
||||||
;; calculate the epoch time of the most recent day boundary. If on a
|
|
||||||
;; day boundary, split on the boundary one full day earlier by
|
|
||||||
;; decrementing day by one
|
|
||||||
(when (and (= 0 M*) (= 0 H*))
|
|
||||||
(setq d* (1- d*)))
|
|
||||||
(setq split-epoch (encode-float-time `(0 0 0 ,d* ,m* ,y* nil nil ,tz)))
|
|
||||||
;; If the split-epoch is less than or equal to the start, loop is
|
|
||||||
;; done. Else add a new entry and reset the projected ending time to
|
|
||||||
;; the current split time; rinse and repeat.
|
|
||||||
(if (< start-epoch split-epoch)
|
|
||||||
(setq acc (cons (org-x-cluster-make-tsp
|
|
||||||
`(,y* ,m* ,d* 0 0) (- end-epoch split-epoch)
|
|
||||||
offset filepath)
|
|
||||||
acc)
|
|
||||||
end-epoch split-epoch)
|
|
||||||
(setq next nil
|
|
||||||
acc (cons (org-x-cluster-make-tsp
|
|
||||||
start-time* (- end-epoch start-epoch) offset filepath)
|
|
||||||
acc))))
|
|
||||||
acc)))))
|
|
||||||
|
|
||||||
(defun org-x-cluster-daily-split (tsps)
|
|
||||||
"Group timestamp-plist TSPS into sublists for each day."
|
|
||||||
(--partition-by (-take 3 (plist-get it :start-time)) tsps))
|
|
||||||
|
|
||||||
(defun org-x-cluster-overloaded-p (tsps)
|
|
||||||
"Return t if total time of timestamp-plists in TSPS exceeds 24 hours.
|
|
||||||
It is assumed the TSPS represents tasks and appointments within one
|
|
||||||
day."
|
|
||||||
(<= 86400 (-sum (--map (plist-get it :range) tsps))))
|
|
||||||
|
|
||||||
(defun org-x-cluster-group-overloads (tsps)
|
|
||||||
"Group TSPS by overloaded day.
|
|
||||||
A day is overloaded if it has TSPs whose :range properties sum to
|
|
||||||
greater than 24 hours. TSPs which span multiple days will be
|
|
||||||
split along day boundaries according to local time zone before
|
|
||||||
grouping is performed. Returned list will be a list of lists
|
|
||||||
like (TSP1 TSP2 ...) which are TSPs in a single day that is
|
|
||||||
overloaded."
|
|
||||||
(->> tsps
|
|
||||||
(--filter (< 0 (plist-get it :range)))
|
|
||||||
(-mapcat #'org-x-cluster-split-tsp-maybe)
|
|
||||||
(org-x-cluster-append-unixtime)
|
|
||||||
(org-x-cluster-filter-past)
|
|
||||||
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
|
|
||||||
(org-x-cluster-daily-split)
|
|
||||||
(--filter (org-x-cluster-overloaded-p it))))
|
|
||||||
|
|
||||||
;; conflict/overload frontend
|
|
||||||
|
|
||||||
;; I could just fetch the org headings and throw them into a new buffer. But
|
|
||||||
;; that's boring, and quite limiting. I basically want all the perks of an
|
|
||||||
;; agenda buffer...tab-follow, the nice parent display at the bottom, time
|
|
||||||
;; adjust hotkeys, etc. So the obvious and hacky solution is to throw together a
|
|
||||||
;; quick-n-dirty agenda buffer.
|
|
||||||
|
|
||||||
(defun org-x-cluster-headline-text (tsp)
|
|
||||||
"Return string for headline text represented by TSP.
|
|
||||||
Returned string will have text properties to enable wizzy, fun
|
|
||||||
things in the agenda like jumpy to the target headline from the
|
|
||||||
agenda buffer."
|
|
||||||
(-let* (((&plist :offset :filepath) tsp)
|
|
||||||
(ts-marker (with-current-buffer (find-file-noselect filepath)
|
|
||||||
(copy-marker offset)))
|
|
||||||
(props (list 'face nil
|
|
||||||
'done-face 'org-agenda-done
|
|
||||||
'org-not-done-regexp org-not-done-regexp
|
|
||||||
'org-todo-regexp org-todo-regexp
|
|
||||||
'org-complex-heading-regexp org-complex-heading-regexp
|
|
||||||
'mouse-face 'highlight))
|
|
||||||
marker priority category level tags todo-state
|
|
||||||
ts-date ts-date-type ts-date-pair
|
|
||||||
txt beg end inherited-tags todo-state-end-pos)
|
|
||||||
|
|
||||||
(with-current-buffer (marker-buffer ts-marker)
|
|
||||||
(save-excursion
|
|
||||||
(goto-char ts-marker)
|
|
||||||
|
|
||||||
(setq marker (org-agenda-new-marker (point))
|
|
||||||
category (org-get-category)
|
|
||||||
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
|
|
||||||
ts-date (car ts-date-pair)
|
|
||||||
ts-date-type (cdr ts-date-pair)
|
|
||||||
txt (org-get-heading t)
|
|
||||||
inherited-tags
|
|
||||||
(or (eq org-agenda-show-inherited-tags 'always)
|
|
||||||
(and (listp org-agenda-show-inherited-tags)
|
|
||||||
(memq 'todo org-agenda-show-inherited-tags))
|
|
||||||
(and (eq org-agenda-show-inherited-tags t)
|
|
||||||
(or (eq org-agenda-use-tag-inheritance t)
|
|
||||||
(memq 'todo org-agenda-use-tag-inheritance))))
|
|
||||||
tags (org-get-tags-at nil (not inherited-tags))
|
|
||||||
level (make-string (org-reduced-level (org-outline-level)) ? )
|
|
||||||
txt (org-agenda-format-item "" txt level category tags t)
|
|
||||||
priority (1+ (org-get-priority txt)))
|
|
||||||
|
|
||||||
(org-add-props txt props
|
|
||||||
'org-marker marker
|
|
||||||
'org-hd-marker marker
|
|
||||||
'priority priority
|
|
||||||
'level level
|
|
||||||
'ts-date ts-date
|
|
||||||
'type "timestamp")))))
|
|
||||||
|
|
||||||
(defun org-x-cluster-ts-fmt (tsp)
|
|
||||||
"Return formatted day-level timestamp for TSP."
|
|
||||||
(format-time-string "[%Y-%m-%d]" (plist-get tsp :unixtime)))
|
|
||||||
|
|
||||||
(defun org-x-cluster-format-conflict (grouped-tsp)
|
|
||||||
"Return GROUPED-TSPs formatted for conflict agenda buffer."
|
|
||||||
(format "On %s\n%s\n"
|
|
||||||
(org-x-cluster-ts-fmt (car grouped-tsp))
|
|
||||||
(mapconcat #'org-x-cluster-headline-text grouped-tsp "\n")))
|
|
||||||
|
|
||||||
(defun org-x-cluster-format-overload (grouped-tsp)
|
|
||||||
"Return GROUPED-TSPs formatted for overload agenda buffer."
|
|
||||||
(format "On %s\n%s\n"
|
|
||||||
(org-x-cluster-ts-fmt (car grouped-tsp))
|
|
||||||
(mapconcat #'org-x-cluster-headline-text grouped-tsp "\n")))
|
|
||||||
|
|
||||||
(defun org-x-cluster-show-agenda (short-name title cluster-fun format-fun arg)
|
|
||||||
"Show an inter-headline cluster agenda buffer.
|
|
||||||
SHORT-NAME is a one-word name describing the buffer which will be
|
|
||||||
used in the name of the buffer. TITLE will be displayed at the
|
|
||||||
top of the buffer. CLUSTER-FUN is a function that takes a list of
|
|
||||||
TSPs and returned a grouped list of TSPs. FORMAT-FUN is a
|
|
||||||
function that takes one member from the list provided by
|
|
||||||
CLUSTER-FUN and returns a string with text properties to be
|
|
||||||
inserted into the agenda buffer. ARG is an argument provided by some
|
|
||||||
calling interactive function."
|
|
||||||
(when org-agenda-overriding-arguments
|
|
||||||
(setq arg org-agenda-overriding-arguments))
|
|
||||||
|
|
||||||
(when (and (stringp arg) (not (string-match "\\S-" arg)))
|
|
||||||
(setq arg nil))
|
|
||||||
|
|
||||||
(let* ((today (org-today))
|
|
||||||
(date (calendar-gregorian-from-absolute today))
|
|
||||||
(completion-ignore-case t)
|
|
||||||
(org-agenda-prefix-format '((agenda . " %-12:c %-5:e ")))
|
|
||||||
rtn rtnall files file pos)
|
|
||||||
|
|
||||||
(catch 'exit
|
|
||||||
(when org-agenda-sticky
|
|
||||||
(setq org-agenda-buffer-name (format "*Org %s*" short-name)))
|
|
||||||
|
|
||||||
(org-agenda-prepare)
|
|
||||||
(org-compile-prefix-format 'agenda)
|
|
||||||
|
|
||||||
(setq org-agenda-redo-command '(org-x-cluster-show-overloads))
|
|
||||||
|
|
||||||
(insert (format "%s: \n" title))
|
|
||||||
(add-text-properties (point-min) (1- (point))
|
|
||||||
(list 'face 'org-agenda-structure
|
|
||||||
'short-heading short-name))
|
|
||||||
(org-agenda-mark-header-line (point-min))
|
|
||||||
|
|
||||||
(-some-> (funcall cluster-fun (org-x-cluster-get-unprocessed))
|
|
||||||
(--each (insert (funcall format-fun it))))
|
|
||||||
|
|
||||||
;; clean up and finalize
|
|
||||||
(goto-char (point-min))
|
|
||||||
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
|
|
||||||
(add-text-properties
|
|
||||||
(point-min) (point-max)
|
|
||||||
`(org-agenda-type agenda
|
|
||||||
org-last-args ,arg
|
|
||||||
org-redo-cmd ,org-agenda-redo-command
|
|
||||||
org-series-cmd ,org-cmd))
|
|
||||||
(org-agenda-finalize)
|
|
||||||
(setq buffer-read-only t))))
|
|
||||||
|
|
||||||
(defun org-x-cluster-show-conflicts (&optional arg)
|
|
||||||
"Show list of conflicting headlines in agenda buffer.
|
|
||||||
ARG is something that I'm not sure if I need."
|
|
||||||
(interactive "P")
|
|
||||||
(org-x-cluster-show-agenda "Conflicts" "Conflicting Headlines"
|
|
||||||
#'org-x-cluster-group-conflicts
|
|
||||||
#'org-x-cluster-format-conflict
|
|
||||||
arg))
|
|
||||||
|
|
||||||
(defun org-x-cluster-show-overloads (&optional arg)
|
|
||||||
"Show list of overloaded days in agenda buffer.
|
|
||||||
ARG is something that I'm not sure if I need."
|
|
||||||
(interactive "P")
|
|
||||||
(org-x-cluster-show-agenda "Overloads" "Overloaded Days"
|
|
||||||
#'org-x-cluster-group-overloads
|
|
||||||
#'org-x-cluster-format-overload
|
|
||||||
arg))
|
|
||||||
|
|
||||||
(provide 'org-x)
|
(provide 'org-x)
|
||||||
;;; org-x.el ends here
|
;;; org-x.el ends here
|
||||||
|
|
|
||||||
|
|
@ -429,8 +429,8 @@ Forms are denoted like %(FORM)%."
|
||||||
|
|
||||||
|
|
||||||
(org-x--test-buffer-strings "Conflicts"
|
(org-x--test-buffer-strings "Conflicts"
|
||||||
(->> (org-x-cluster-extract-buffer "fp")
|
(->> (org-x-agg--get-timespans-from-buffer "fp")
|
||||||
(org-x-cluster-group-conflicts)
|
(org-x-agg--timespans-group-conflicts)
|
||||||
;; drop the :unixtime key from the front to make testing easier
|
;; drop the :unixtime key from the front to make testing easier
|
||||||
(--map (--map (-drop 2 it) it)))
|
(--map (--map (-drop 2 it) it)))
|
||||||
|
|
||||||
|
|
@ -517,8 +517,8 @@ Forms are denoted like %(FORM)%."
|
||||||
(:start-time (2022 1 1 12 10) :range 900 :offset 157 :filepath "fp"))))
|
(:start-time (2022 1 1 12 10) :range 900 :offset 157 :filepath "fp"))))
|
||||||
|
|
||||||
(org-x--test-buffer-strings "Overloads"
|
(org-x--test-buffer-strings "Overloads"
|
||||||
(->> (org-x-cluster-extract-buffer "fp")
|
(->> (org-x-agg--get-timespans-from-buffer "fp")
|
||||||
(org-x-cluster-group-overloads)
|
(org-x-agg--timespans-group-overloads)
|
||||||
;; drop the :unixtime key from the front to make testing easier
|
;; drop the :unixtime key from the front to make testing easier
|
||||||
(--map (--map (-drop 2 it) it)))
|
(--map (--map (-drop 2 it) it)))
|
||||||
|
|
||||||
|
|
@ -608,7 +608,7 @@ Forms are denoted like %(FORM)%."
|
||||||
(input* (append input extra))
|
(input* (append input extra))
|
||||||
(output* (--map (append it extra) output)))
|
(output* (--map (append it extra) output)))
|
||||||
`(it ,title
|
`(it ,title
|
||||||
(expect (org-x-cluster-split-tsp-maybe ',input*)
|
(expect (org-x-agg--split-timespan-by-day ',input*)
|
||||||
:to-equal
|
:to-equal
|
||||||
',output*)))))))
|
',output*)))))))
|
||||||
`(describe "Time splitter"
|
`(describe "Time splitter"
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue