REF move clustering code to org-x
This commit is contained in:
parent
8990cb417d
commit
d9bc5863a1
491
etc/conf.org
491
etc/conf.org
|
|
@ -2413,488 +2413,13 @@ The modeline is a nice place to indicate if something is clocked in or out. Unfo
|
||||||
(setq spaceline-highlight-face-func 'nd/spaceline-highlight-face-clocked)
|
(setq spaceline-highlight-face-func 'nd/spaceline-highlight-face-clocked)
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
*** clustering
|
*** clustering
|
||||||
Org mode has no way of detecting if conflicts exist. It also has no way of alerting someone if they have overbooked their schedule
|
Org mode has no way of detecting if conflicts exist. It also has no way of alerting someone if they have overbooked their schedule.
|
||||||
**** extraction filters
|
|
||||||
:PROPERTIES:
|
|
||||||
:ID: 8384e715-dfe2-4197-9b0e-88bb32c3afa0
|
|
||||||
:END:
|
|
||||||
These control which types of headlines are processed by org-cluster
|
|
||||||
#+BEGIN_SRC emacs-lisp
|
|
||||||
(defvar nd/org-cluster-filter-files t
|
|
||||||
"Set to t if files should be filtered in org-cluster.
|
|
||||||
This option does nothing unless `nd/org-cluster-filtered-files' is
|
|
||||||
also non-nil.")
|
|
||||||
|
|
||||||
(defconst nd/org-cluster-filtered-files
|
The main code is defined in =org-x= so the following is only to set some domain-specific options.
|
||||||
'("incubator" "peripheral")
|
#+begin_src emacs-lisp
|
||||||
"Files that should be excluded from org-cluster analysis.
|
(setq org-x-cluster-filtered-files '("incubator" "peripheral")
|
||||||
These are pattern-matched so they do not need to be exact names
|
org-x-cluster-filtered-todo '("CANC" "DONE"))
|
||||||
or paths.")
|
#+end_src
|
||||||
|
|
||||||
(defvar nd/org-cluster-filter-todo t
|
|
||||||
"Set to t if todo keywords should be filtered in org-cluster.
|
|
||||||
This option does nothing unless `nd/org-cluster-filtered-todo' is
|
|
||||||
also non-nil.")
|
|
||||||
|
|
||||||
(defconst nd/org-cluster-filtered-todo
|
|
||||||
'("CANC" "DONE")
|
|
||||||
"TODO keywords that should be filtered from org-cluster analysis.")
|
|
||||||
|
|
||||||
(defvar nd/org-cluster-filter-past t
|
|
||||||
"Set to t to exclude files from before now in org-cluster analysis.")
|
|
||||||
|
|
||||||
(defvar nd/org-cluster-filter-habit nil
|
|
||||||
"Set to t to exclude habits from org-cluster analysis.")
|
|
||||||
#+END_SRC
|
|
||||||
**** timestamp extraction and filtering
|
|
||||||
:PROPERTIES:
|
|
||||||
:ID: 3f39fe19-b89e-47f1-80d4-e6a532788527
|
|
||||||
:END:
|
|
||||||
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.
|
|
||||||
|
|
||||||
The main object that is passed around during extraction and processing is the timestamp-plist as described in =nd/org-cluster-make-tsp= below.
|
|
||||||
#+BEGIN_SRC emacs-lisp
|
|
||||||
(defun nd/org-cluster-make-tsp (unixtime range offset fp hardness
|
|
||||||
&optional type)
|
|
||||||
"Construct a timestamp plist to be used in further processing.
|
|
||||||
UNIXTIME is the unixtime of the timestamp as an integer, RANGE is the
|
|
||||||
duration of the timestamp (could be 0), OFFSET is the character offset
|
|
||||||
of the timestamp in the file represented with filepath FP, HARDNESS
|
|
||||||
is a boolean denoting if the timestamp is 'hard' (has minutes and
|
|
||||||
hours) or 'soft' (only a date). TYPE can be optionally supplied to
|
|
||||||
denote kinds of timestamps (only 'scheduled' for now)."
|
|
||||||
(list :unixtime (round unixtime)
|
|
||||||
:range (or range 0)
|
|
||||||
:offset offset
|
|
||||||
:type type
|
|
||||||
:hardness hardness
|
|
||||||
:filepath fp))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-ts-hard-p (ts)
|
|
||||||
"Return non-nil if the timestamp TS has hours/minutes."
|
|
||||||
(org-element-property :hour-start ts))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-parse-ts (ts hl fp)
|
|
||||||
"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))
|
|
||||||
(hardness (nd/org-cluster-ts-hard-p ts))
|
|
||||||
(split
|
|
||||||
(lambda (ts &optional end)
|
|
||||||
(--> ts
|
|
||||||
(org-timestamp-split-range it end)
|
|
||||||
(org-element-property :raw-value it)
|
|
||||||
(org-2ft it))))
|
|
||||||
(start (funcall split ts)))
|
|
||||||
(if (eq (org-element-property :type ts) 'active-range)
|
|
||||||
(let ((range (--> ts (funcall split it t) (- it start))))
|
|
||||||
(nd/org-cluster-make-tsp start range offset fp hardness))
|
|
||||||
(nd/org-cluster-make-tsp start 0 offset fp hardness)))))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-effort-seconds (effort-str)
|
|
||||||
"Convert EFFORT-STR into an integer in seconds from HH:MM format."
|
|
||||||
(let ((effort-str (string-trim effort-str)))
|
|
||||||
(save-match-data
|
|
||||||
(cond
|
|
||||||
((string-match "^\\([0-9]+\\):\\([0-6][0-9]\\)$" effort-str)
|
|
||||||
(let ((hours (->> effort-str
|
|
||||||
(match-string 1)
|
|
||||||
string-to-number
|
|
||||||
(* 60))))
|
|
||||||
(->> effort-str
|
|
||||||
(match-string 2)
|
|
||||||
string-to-number
|
|
||||||
(+ hours)
|
|
||||||
(* 60))))
|
|
||||||
(t (error (format "Unknown effort: %s'" effort-str)))))))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-extract (acc fun objs &rest args)
|
|
||||||
"Run FUN on each of OBJS and put results into accumulator ACC.
|
|
||||||
FUN is a function that takes the accumulator as its first argument,
|
|
||||||
one member of OBJS as the second, and ARGS as the rest if supplied."
|
|
||||||
(while objs
|
|
||||||
(setq acc (apply fun acc (car objs) args)
|
|
||||||
objs (cdr objs)))
|
|
||||||
acc)
|
|
||||||
|
|
||||||
(defun nd/org-cluster-extract-hl-sched (acc hl fp)
|
|
||||||
"Extract scheduled timestamp from headline HL in filepath FP.
|
|
||||||
Create a new timestamp-plist and add to accumulator ACC."
|
|
||||||
(let* ((ts (org-element-property :scheduled hl))
|
|
||||||
(unixtime (->> ts (org-element-property :raw-value) org-2ft))
|
|
||||||
(range (-some->> hl
|
|
||||||
(org-element-property :EFFORT)
|
|
||||||
nd/org-cluster-effort-seconds))
|
|
||||||
(hardness (nd/org-cluster-ts-hard-p ts))
|
|
||||||
(offset (org-element-property :begin hl)))
|
|
||||||
(if (= 0 unixtime) acc
|
|
||||||
(-> unixtime
|
|
||||||
(nd/org-cluster-make-tsp range offset fp hardness 'scheduled)
|
|
||||||
(cons acc)))))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-extract-hl-ts (acc 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."
|
|
||||||
(--> hl
|
|
||||||
(assoc 'section it)
|
|
||||||
(org-element-contents it)
|
|
||||||
(--remove
|
|
||||||
(or (eq 'planning (org-element-type it))
|
|
||||||
(eq 'property-drawer (org-element-type it))
|
|
||||||
(eq 'drawer (org-element-type it)))
|
|
||||||
it)
|
|
||||||
(org-element-map it 'timestamp #'identity)
|
|
||||||
(--filter
|
|
||||||
(or (eq 'active (org-element-property :type it))
|
|
||||||
(eq 'active-range (org-element-property :type it)))
|
|
||||||
it)
|
|
||||||
(--map (nd/org-cluster-parse-ts it hl fp) it)
|
|
||||||
(append acc it)))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-extract-hl (acc hl fp)
|
|
||||||
"Extract timestamps from headline HL in filepath FP and store in ACC."
|
|
||||||
(-> acc
|
|
||||||
(nd/org-cluster-extract-hl-sched hl fp)
|
|
||||||
(nd/org-cluster-extract-hl-ts hl fp)))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-filter-todo (hls)
|
|
||||||
"Filter certain TODO keywords from headline list HLS."
|
|
||||||
(if (not nd/org-cluster-filter-todo) hls
|
|
||||||
(--remove
|
|
||||||
(member (org-element-property :todo-keyword it)
|
|
||||||
nd/org-cluster-filtered-todo)
|
|
||||||
hls)))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-filter-files (fps)
|
|
||||||
"Filter certain file names from files list FPS."
|
|
||||||
(if (not nd/org-cluster-filter-files) fps
|
|
||||||
(--remove
|
|
||||||
(-find (lambda (s) (string-match-p s it)) nd/org-cluster-filtered-files)
|
|
||||||
fps)))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-filter-past (tsps)
|
|
||||||
"Filter out timestamp-plists in list TSPS if they start in the past."
|
|
||||||
(if (not nd/org-cluster-filter-past) tsps
|
|
||||||
(let ((ft (float-time)))
|
|
||||||
(--remove (< (plist-get it :unixtime) ft) tsps))))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-filter-habit (hls)
|
|
||||||
"Filter headlines from headline list HLS that are habits."
|
|
||||||
(if (not nd/org-cluster-filter-habit) hls
|
|
||||||
(--remove (org-element-property :STYLE it) hls)))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-extract-file (acc fp)
|
|
||||||
"Extract timestamps from filepath FP and add to accumulator ACC."
|
|
||||||
(-->
|
|
||||||
fp
|
|
||||||
(find-file-noselect it t)
|
|
||||||
(with-current-buffer it (org-element-parse-buffer))
|
|
||||||
(org-element-map it 'headline #'identity)
|
|
||||||
(nd/org-cluster-filter-todo it)
|
|
||||||
(nd/org-cluster-filter-habit it)
|
|
||||||
(nd/org-cluster-extract acc #'nd/org-cluster-extract-hl it fp)))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-get-unprocessed ()
|
|
||||||
"Return a list of timestamp-plists with desired filter settings."
|
|
||||||
(->>
|
|
||||||
;; (list "~/Org/reference/testconflict.org")
|
|
||||||
(org-agenda-files)
|
|
||||||
nd/org-cluster-filter-files
|
|
||||||
(nd/org-cluster-extract nil #'nd/org-cluster-extract-file)
|
|
||||||
nd/org-cluster-filter-past))
|
|
||||||
#+END_SRC
|
|
||||||
**** conflict detection
|
|
||||||
:PROPERTIES:
|
|
||||||
:ID: 6b777ec6-3898-4855-8664-84b13f468920
|
|
||||||
:END:
|
|
||||||
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.
|
|
||||||
#+BEGIN_SRC emacs-lisp
|
|
||||||
(defun nd/org-cluster-conflicting-p (tsp-a tsp-b)
|
|
||||||
"Return t if timestamps TS-A and TS-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))
|
|
||||||
(end-a (-> tsp-a (plist-get :range) (+ start-a))))
|
|
||||||
(or (= start-a start-b) (< start-b end-a))))
|
|
||||||
|
|
||||||
(defun nd/org-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."
|
|
||||||
(->> tsps
|
|
||||||
(--take-while (nd/org-cluster-conflicting-p tsp it))
|
|
||||||
(--map (cons tsp it))
|
|
||||||
(append conlist)))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-build-conlist (tsps)
|
|
||||||
"Build a list of conflict pairs from timestamp-plist TSPS."
|
|
||||||
(let ((conlist))
|
|
||||||
(while (< 1 (length tsps))
|
|
||||||
(setq conlist (nd/org-cluster-find-conflict (car tsps)
|
|
||||||
(cdr tsps)
|
|
||||||
conlist)
|
|
||||||
tsps (cdr tsps)))
|
|
||||||
conlist))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-get-conflicts ()
|
|
||||||
"Return a list of cons cells representing conflict pairs.
|
|
||||||
Each member in the cons cell is a timestamp-plist."
|
|
||||||
(->>
|
|
||||||
(nd/org-cluster-get-unprocessed)
|
|
||||||
(--filter (plist-get it :hardness))
|
|
||||||
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
|
|
||||||
nd/org-cluster-build-conlist))
|
|
||||||
#+END_SRC
|
|
||||||
**** overload detection
|
|
||||||
:PROPERTIES:
|
|
||||||
:ID: fe65a792-6b2c-47c0-84a1-98fc4115a04b
|
|
||||||
:END:
|
|
||||||
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
|
|
||||||
#+BEGIN_SRC emacs-lisp
|
|
||||||
(defun nd/org-cluster-split-day-bounds (tsps)
|
|
||||||
"Split timestamp-plists in TSPS via daily boundaries.
|
|
||||||
Returns a new timestamp-plist with equal or greater length depending
|
|
||||||
on how many members needed splitting."
|
|
||||||
(letrec
|
|
||||||
((new
|
|
||||||
(lambda (start end tsp)
|
|
||||||
(nd/org-cluster-make-tsp start
|
|
||||||
(- end start)
|
|
||||||
(plist-get tsp :offset)
|
|
||||||
(plist-get tsp :filepath)
|
|
||||||
(plist-get tsp :hardness)
|
|
||||||
(plist-get tsp :type))))
|
|
||||||
;; need to temporarily offset the epoch time so day
|
|
||||||
;; boundaries line up in local time
|
|
||||||
(split
|
|
||||||
(lambda (start end tsp)
|
|
||||||
(let* ((tzs-a (-> start current-time-zone car))
|
|
||||||
(tzs-b (-> end current-time-zone car))
|
|
||||||
(start* (-> end (+ tzs-b) (ceiling 86400) 1- (* 86400) (- tzs-b))))
|
|
||||||
(if (> start* (-> start (+ tzs-a) (floor 86400) (* 86400) (- tzs-a)))
|
|
||||||
(cons (funcall new start* end tsp)
|
|
||||||
(funcall split start start* tsp))
|
|
||||||
(list (funcall new start end tsp))))))
|
|
||||||
(split-maybe
|
|
||||||
(lambda (tsp)
|
|
||||||
(let* ((start (plist-get tsp :unixtime))
|
|
||||||
(end (+ start (plist-get tsp :range)))
|
|
||||||
(tzs (-> start current-time-zone car)))
|
|
||||||
(if (< (-> start (+ tzs) (ceiling 86400)) end)
|
|
||||||
(funcall split start end tsp)
|
|
||||||
tsp)))))
|
|
||||||
(--mapcat (funcall split-maybe it) tsps)))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-daily-split (tsps)
|
|
||||||
"Group timestamp-plist TSPS into sublists for each day."
|
|
||||||
(letrec ((tz-shift (lambda (tsp) (-> tsp current-time-zone car (+ tsp)))))
|
|
||||||
(->>
|
|
||||||
tsps
|
|
||||||
(--partition-by (--> it
|
|
||||||
(plist-get it :unixtime)
|
|
||||||
(funcall tz-shift it)
|
|
||||||
(floor it 86400))))))
|
|
||||||
|
|
||||||
(defun nd/org-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."
|
|
||||||
(letrec ((ts2diff
|
|
||||||
(lambda (tsp)
|
|
||||||
(let ((start (plist-get tsp :unixtime)))
|
|
||||||
(- (-> tsp (plist-get :range) (+ start)) start)))))
|
|
||||||
(->> tsps (--map (funcall ts2diff it)) -sum (<= 86400))))
|
|
||||||
|
|
||||||
(defun nd/org-cluster-get-overloads ()
|
|
||||||
"Return list of lists of timestamp-plists grouped by day.
|
|
||||||
Anything present represents all the tasks in a single day if that day
|
|
||||||
is overloaded. If a day is not overloaded there will be nothing for it
|
|
||||||
in the returned list."
|
|
||||||
(->>
|
|
||||||
(nd/org-cluster-get-unprocessed)
|
|
||||||
(--filter (< 0 (plist-get it :range)))
|
|
||||||
nd/org-cluster-split-day-bounds
|
|
||||||
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
|
|
||||||
nd/org-cluster-daily-split
|
|
||||||
(--filter (nd/org-cluster-overloaded-p it))))
|
|
||||||
#+END_SRC
|
|
||||||
**** frontend
|
|
||||||
:PROPERTIES:
|
|
||||||
:ID: 43ad0b41-43a7-4d66-a260-0c0e3767469b
|
|
||||||
:END:
|
|
||||||
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.
|
|
||||||
#+BEGIN_SRC emacs-lisp
|
|
||||||
(defun nd/org-cluster-headline-text (ts-entry)
|
|
||||||
"Return string with text properties representing the org header for
|
|
||||||
MARKER for use in the conflict agenda view."
|
|
||||||
(let* ((offset (plist-get ts-entry :offset))
|
|
||||||
(ts-marker (--> ts-entry
|
|
||||||
(plist-get it :filepath)
|
|
||||||
(find-file-noselect it)
|
|
||||||
(with-current-buffer it
|
|
||||||
(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 nd/org-cluster-ts-fmt (ts)
|
|
||||||
(let ((fmt "[%Y-%m-%d]"))
|
|
||||||
(--> ts (plist-get it :unixtime) (format-time-string fmt it))))
|
|
||||||
|
|
||||||
;; TODO...waaaaay too wet (not DRY)
|
|
||||||
(defun nd/org-cluster-show-conflicts (&optional arg)
|
|
||||||
(interactive "P")
|
|
||||||
|
|
||||||
(if org-agenda-overriding-arguments
|
|
||||||
(setq arg org-agenda-overriding-arguments))
|
|
||||||
|
|
||||||
(if (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 "*Org Conflicts*"))
|
|
||||||
|
|
||||||
(org-agenda-prepare)
|
|
||||||
;; (org-compile-prefix-format 'todo)
|
|
||||||
(org-compile-prefix-format 'agenda)
|
|
||||||
;; (org-set-sorting-strategy 'todo)
|
|
||||||
|
|
||||||
(setq org-agenda-redo-command '(nd/org-cluster-show-conflicts))
|
|
||||||
|
|
||||||
(insert "Conflicting Headings: \n")
|
|
||||||
(add-text-properties (point-min) (1- (point))
|
|
||||||
(list 'face 'org-agenda-structure
|
|
||||||
'short-heading "Conflicts"))
|
|
||||||
(org-agenda-mark-header-line (point-min))
|
|
||||||
|
|
||||||
(-some->
|
|
||||||
(nd/org-cluster-get-conflicts)
|
|
||||||
(--each
|
|
||||||
(insert (concat
|
|
||||||
"At " (nd/org-cluster-ts-fmt (car it)) "\n"
|
|
||||||
(nd/org-cluster-headline-text (car it)) "\n"
|
|
||||||
(nd/org-cluster-headline-text (cdr it)) "\n"
|
|
||||||
"\n"))))
|
|
||||||
|
|
||||||
;; 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 nd/org-cluster-show-overloads (&optional arg)
|
|
||||||
(interactive "P")
|
|
||||||
|
|
||||||
(if org-agenda-overriding-arguments
|
|
||||||
(setq arg org-agenda-overriding-arguments))
|
|
||||||
|
|
||||||
(if (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 "*Org Overloads*"))
|
|
||||||
|
|
||||||
(org-agenda-prepare)
|
|
||||||
;; (org-compile-prefix-format 'todo)
|
|
||||||
(org-compile-prefix-format 'agenda)
|
|
||||||
;; (org-set-sorting-strategy 'todo)
|
|
||||||
|
|
||||||
(setq org-agenda-redo-command '(nd/org-cluster-show-overloads))
|
|
||||||
|
|
||||||
(insert "Overloaded Days: \n")
|
|
||||||
(add-text-properties (point-min) (1- (point))
|
|
||||||
(list 'face 'org-agenda-structure
|
|
||||||
'short-heading "Overloads"))
|
|
||||||
(org-agenda-mark-header-line (point-min))
|
|
||||||
|
|
||||||
(-some->
|
|
||||||
(nd/org-cluster-get-overloads)
|
|
||||||
(--each
|
|
||||||
(insert (concat
|
|
||||||
"On " (nd/org-cluster-ts-fmt (car it)) "\n"
|
|
||||||
(mapconcat #'nd/org-cluster-headline-text it "\n")
|
|
||||||
"\n"))))
|
|
||||||
|
|
||||||
;; 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))))
|
|
||||||
#+END_SRC
|
|
||||||
*** agenda
|
*** agenda
|
||||||
:PROPERTIES:
|
:PROPERTIES:
|
||||||
:ID: 73c154c8-e13e-4e90-8a1d-77c3be067502
|
:ID: 73c154c8-e13e-4e90-8a1d-77c3be067502
|
||||||
|
|
@ -4674,8 +4199,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>") 'nd/org-cluster-show-conflicts)
|
(global-set-key (kbd "C-<f3>") 'org-x-cluster-show-conflicts)
|
||||||
(global-set-key (kbd "C-S-<f3>") 'nd/org-cluster-show-overloads)
|
(global-set-key (kbd "C-S-<f3>") 'org-x-cluster-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)
|
||||||
|
|
|
||||||
|
|
@ -66,6 +66,30 @@
|
||||||
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
|
(defvar org-x-agenda-hide-incubator-tags t
|
||||||
|
|
@ -1108,5 +1132,460 @@ and slow."
|
||||||
(org-ml-supercontents-set-logbook nil it)
|
(org-ml-supercontents-set-logbook nil it)
|
||||||
it))))))
|
it))))))
|
||||||
|
|
||||||
|
;; 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 (unixtime range offset fp hardness &optional type)
|
||||||
|
"Construct a timestamp plist to be used in further processing.
|
||||||
|
|
||||||
|
The fields are as follows:
|
||||||
|
- UNIXTIME is the unixtime of the timestamp as an integer
|
||||||
|
- RANGE is the duration of the timestamp (could be 0)
|
||||||
|
- OFFSET is the character offset of the timestamp in its file
|
||||||
|
- HARDNESS is a boolean denoting if the timestamp is 'hard' (has minutes and
|
||||||
|
hours) or 'soft' (only a date).
|
||||||
|
- TYPE can be optionally supplied to denote kinds of timestamps
|
||||||
|
(only 'scheduled' for now).
|
||||||
|
- FP the path to the file in which the timestamp resides"
|
||||||
|
(list :unixtime (round unixtime)
|
||||||
|
:range (or range 0)
|
||||||
|
:offset offset
|
||||||
|
:type type
|
||||||
|
:hardness hardness
|
||||||
|
: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 (ts hl fp)
|
||||||
|
"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))
|
||||||
|
(hardness (org-x-cluster-ts-hard-p ts))
|
||||||
|
(split
|
||||||
|
(lambda (ts &optional end)
|
||||||
|
(--> ts
|
||||||
|
(org-timestamp-split-range it end)
|
||||||
|
(org-element-property :raw-value it)
|
||||||
|
(org-2ft it))))
|
||||||
|
(start (funcall split ts)))
|
||||||
|
(if (eq (org-element-property :type ts) 'active-range)
|
||||||
|
(let ((range (--> ts (funcall split it t) (- it start))))
|
||||||
|
(org-x-cluster-make-tsp start range offset fp hardness))
|
||||||
|
(org-x-cluster-make-tsp start 0 offset fp hardness)))))
|
||||||
|
|
||||||
|
(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) (* 60)))
|
||||||
|
;; (let ((effort-str (string-trim effort-str)))
|
||||||
|
;; (save-match-data
|
||||||
|
;; (cond
|
||||||
|
;; ((string-match "^\\([0-9]+\\):\\([0-6][0-9]\\)$" effort-str)
|
||||||
|
;; (let ((hours (->> effort-str
|
||||||
|
;; (match-string 1)
|
||||||
|
;; string-to-number
|
||||||
|
;; (* 60))))
|
||||||
|
;; (->> effort-str
|
||||||
|
;; (match-string 2)
|
||||||
|
;; string-to-number
|
||||||
|
;; (+ hours)
|
||||||
|
;; (* 60))))
|
||||||
|
;; (t (error (format "Unknown effort: %s'" effort-str)))))))
|
||||||
|
|
||||||
|
(defun org-x-cluster-extract (acc fun objs &rest args)
|
||||||
|
"Run FUN on each of OBJS and put results into accumulator ACC.
|
||||||
|
FUN is a function that takes the accumulator as its first argument,
|
||||||
|
one member of OBJS as the second, and ARGS as the rest if supplied."
|
||||||
|
(while objs
|
||||||
|
(setq acc (apply fun acc (car objs) args)
|
||||||
|
objs (cdr objs)))
|
||||||
|
acc)
|
||||||
|
|
||||||
|
(defun org-x-cluster-extract-hl-sched (acc hl fp)
|
||||||
|
"Extract scheduled timestamp from headline HL in filepath FP.
|
||||||
|
Create a new timestamp-plist and add to accumulator ACC."
|
||||||
|
(let* ((ts (org-element-property :scheduled hl))
|
||||||
|
(unixtime (->> ts (org-element-property :raw-value) org-2ft))
|
||||||
|
(range (-some->> hl
|
||||||
|
(org-element-property :EFFORT)
|
||||||
|
org-x-cluster-effort-seconds))
|
||||||
|
(hardness (org-x-cluster-ts-hard-p ts))
|
||||||
|
(offset (org-element-property :begin hl)))
|
||||||
|
(if (= 0 unixtime) acc
|
||||||
|
(-> unixtime
|
||||||
|
(org-x-cluster-make-tsp range offset fp hardness 'scheduled)
|
||||||
|
(cons acc)))))
|
||||||
|
|
||||||
|
(defun org-x-cluster-extract-hl-ts (acc 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."
|
||||||
|
(--> hl
|
||||||
|
(assoc 'section it)
|
||||||
|
(org-element-contents it)
|
||||||
|
(--remove
|
||||||
|
(or (eq 'planning (org-element-type it))
|
||||||
|
(eq 'property-drawer (org-element-type it))
|
||||||
|
(eq 'drawer (org-element-type it)))
|
||||||
|
it)
|
||||||
|
(org-element-map it 'timestamp #'identity)
|
||||||
|
(--filter
|
||||||
|
(or (eq 'active (org-element-property :type it))
|
||||||
|
(eq 'active-range (org-element-property :type it)))
|
||||||
|
it)
|
||||||
|
(--map (org-x-cluster-parse-ts it hl fp) it)
|
||||||
|
(append acc it)))
|
||||||
|
|
||||||
|
(defun org-x-cluster-extract-hl (acc hl fp)
|
||||||
|
"Extract timestamps from headline HL in filepath FP and store in ACC."
|
||||||
|
(-> acc
|
||||||
|
(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-file (acc fp)
|
||||||
|
"Extract timestamps from filepath FP and add to accumulator ACC."
|
||||||
|
(-->
|
||||||
|
fp
|
||||||
|
(find-file-noselect it t)
|
||||||
|
(with-current-buffer it (org-element-parse-buffer))
|
||||||
|
(org-element-map it 'headline #'identity)
|
||||||
|
(org-x-cluster-filter-todo it)
|
||||||
|
(org-x-cluster-filter-habit it)
|
||||||
|
(org-x-cluster-extract acc #'org-x-cluster-extract-hl it fp)))
|
||||||
|
|
||||||
|
(defun org-x-cluster-get-unprocessed ()
|
||||||
|
"Return a list of timestamp-plists with desired filter settings."
|
||||||
|
(->>
|
||||||
|
;; (list "~/Org/reference/testconflict.org")
|
||||||
|
(org-agenda-files)
|
||||||
|
org-x-cluster-filter-files
|
||||||
|
(org-x-cluster-extract nil #'org-x-cluster-extract-file)
|
||||||
|
org-x-cluster-filter-past))
|
||||||
|
|
||||||
|
;; 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 TS-A and TS-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))
|
||||||
|
(end-a (-> tsp-a (plist-get :range) (+ start-a))))
|
||||||
|
(or (= start-a start-b) (< start-b end-a))))
|
||||||
|
|
||||||
|
(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."
|
||||||
|
(->> tsps
|
||||||
|
(--take-while (org-x-cluster-conflicting-p tsp it))
|
||||||
|
(--map (cons 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-get-conflicts ()
|
||||||
|
"Return a list of cons cells representing conflict pairs.
|
||||||
|
Each member in the cons cell is a timestamp-plist."
|
||||||
|
(->>
|
||||||
|
(org-x-cluster-get-unprocessed)
|
||||||
|
(--filter (plist-get it :hardness))
|
||||||
|
(--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-day-bounds (tsps)
|
||||||
|
"Split timestamp-plists in TSPS via daily boundaries.
|
||||||
|
Returns a new timestamp-plist with equal or greater length depending
|
||||||
|
on how many members needed splitting."
|
||||||
|
(letrec
|
||||||
|
((new
|
||||||
|
(lambda (start end tsp)
|
||||||
|
(org-x-cluster-make-tsp start
|
||||||
|
(- end start)
|
||||||
|
(plist-get tsp :offset)
|
||||||
|
(plist-get tsp :filepath)
|
||||||
|
(plist-get tsp :hardness)
|
||||||
|
(plist-get tsp :type))))
|
||||||
|
;; need to temporarily offset the epoch time so day
|
||||||
|
;; boundaries line up in local time
|
||||||
|
(split
|
||||||
|
(lambda (start end tsp)
|
||||||
|
(let* ((tzs-a (-> start current-time-zone car))
|
||||||
|
(tzs-b (-> end current-time-zone car))
|
||||||
|
(start* (-> end (+ tzs-b) (ceiling 86400) 1- (* 86400) (- tzs-b))))
|
||||||
|
(if (> start* (-> start (+ tzs-a) (floor 86400) (* 86400) (- tzs-a)))
|
||||||
|
(cons (funcall new start* end tsp)
|
||||||
|
(funcall split start start* tsp))
|
||||||
|
(list (funcall new start end tsp))))))
|
||||||
|
(split-maybe
|
||||||
|
(lambda (tsp)
|
||||||
|
(let* ((start (plist-get tsp :unixtime))
|
||||||
|
(end (+ start (plist-get tsp :range)))
|
||||||
|
(tzs (-> start current-time-zone car)))
|
||||||
|
(if (< (-> start (+ tzs) (ceiling 86400)) end)
|
||||||
|
(funcall split start end tsp)
|
||||||
|
tsp)))))
|
||||||
|
(--mapcat (funcall split-maybe it) tsps)))
|
||||||
|
|
||||||
|
(defun org-x-cluster-daily-split (tsps)
|
||||||
|
"Group timestamp-plist TSPS into sublists for each day."
|
||||||
|
(letrec ((tz-shift (lambda (tsp) (-> tsp current-time-zone car (+ tsp)))))
|
||||||
|
(->>
|
||||||
|
tsps
|
||||||
|
(--partition-by (--> it
|
||||||
|
(plist-get it :unixtime)
|
||||||
|
(funcall tz-shift it)
|
||||||
|
(floor it 86400))))))
|
||||||
|
|
||||||
|
(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."
|
||||||
|
(letrec ((ts2diff
|
||||||
|
(lambda (tsp)
|
||||||
|
(let ((start (plist-get tsp :unixtime)))
|
||||||
|
(- (-> tsp (plist-get :range) (+ start)) start)))))
|
||||||
|
(->> tsps (--map (funcall ts2diff it)) -sum (<= 86400))))
|
||||||
|
|
||||||
|
(defun org-x-cluster-get-overloads ()
|
||||||
|
"Return list of lists of timestamp-plists grouped by day.
|
||||||
|
Anything present represents all the tasks in a single day if that day
|
||||||
|
is overloaded. If a day is not overloaded there will be nothing for it
|
||||||
|
in the returned list."
|
||||||
|
(->>
|
||||||
|
(org-x-cluster-get-unprocessed)
|
||||||
|
(--filter (< 0 (plist-get it :range)))
|
||||||
|
org-x-cluster-split-day-bounds
|
||||||
|
(--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 (ts-entry)
|
||||||
|
"Return string with text properties representing the org header for
|
||||||
|
MARKER for use in the conflict agenda view."
|
||||||
|
(let* ((offset (plist-get ts-entry :offset))
|
||||||
|
(ts-marker (--> ts-entry
|
||||||
|
(plist-get it :filepath)
|
||||||
|
(find-file-noselect it)
|
||||||
|
(with-current-buffer it
|
||||||
|
(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 (ts)
|
||||||
|
(let ((fmt "[%Y-%m-%d]"))
|
||||||
|
(--> ts (plist-get it :unixtime) (format-time-string fmt it))))
|
||||||
|
|
||||||
|
;; TODO...waaaaay too wet (not DRY)
|
||||||
|
(defun org-x-cluster-show-conflicts (&optional arg)
|
||||||
|
(interactive "P")
|
||||||
|
|
||||||
|
(if org-agenda-overriding-arguments
|
||||||
|
(setq arg org-agenda-overriding-arguments))
|
||||||
|
|
||||||
|
(if (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 "*Org Conflicts*"))
|
||||||
|
|
||||||
|
(org-agenda-prepare)
|
||||||
|
;; (org-compile-prefix-format 'todo)
|
||||||
|
(org-compile-prefix-format 'agenda)
|
||||||
|
;; (org-set-sorting-strategy 'todo)
|
||||||
|
|
||||||
|
(setq org-agenda-redo-command '(org-x-cluster-show-conflicts))
|
||||||
|
|
||||||
|
(insert "Conflicting Headings: \n")
|
||||||
|
(add-text-properties (point-min) (1- (point))
|
||||||
|
(list 'face 'org-agenda-structure
|
||||||
|
'short-heading "Conflicts"))
|
||||||
|
(org-agenda-mark-header-line (point-min))
|
||||||
|
|
||||||
|
(-some->
|
||||||
|
(org-x-cluster-get-conflicts)
|
||||||
|
(--each
|
||||||
|
(insert (concat
|
||||||
|
"At " (org-x-cluster-ts-fmt (car it)) "\n"
|
||||||
|
(org-x-cluster-headline-text (car it)) "\n"
|
||||||
|
(org-x-cluster-headline-text (cdr it)) "\n"
|
||||||
|
"\n"))))
|
||||||
|
|
||||||
|
;; 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-overloads (&optional arg)
|
||||||
|
(interactive "P")
|
||||||
|
|
||||||
|
(if org-agenda-overriding-arguments
|
||||||
|
(setq arg org-agenda-overriding-arguments))
|
||||||
|
|
||||||
|
(if (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 "*Org Overloads*"))
|
||||||
|
|
||||||
|
(org-agenda-prepare)
|
||||||
|
;; (org-compile-prefix-format 'todo)
|
||||||
|
(org-compile-prefix-format 'agenda)
|
||||||
|
;; (org-set-sorting-strategy 'todo)
|
||||||
|
|
||||||
|
(setq org-agenda-redo-command '(org-x-cluster-show-overloads))
|
||||||
|
|
||||||
|
(insert "Overloaded Days: \n")
|
||||||
|
(add-text-properties (point-min) (1- (point))
|
||||||
|
(list 'face 'org-agenda-structure
|
||||||
|
'short-heading "Overloads"))
|
||||||
|
(org-agenda-mark-header-line (point-min))
|
||||||
|
|
||||||
|
(-some->
|
||||||
|
(org-x-cluster-get-overloads)
|
||||||
|
(--each
|
||||||
|
(insert (concat
|
||||||
|
"On " (org-x-cluster-ts-fmt (car it)) "\n"
|
||||||
|
(mapconcat #'org-x-cluster-headline-text it "\n")
|
||||||
|
"\n"))))
|
||||||
|
|
||||||
|
;; 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))))
|
||||||
|
|
||||||
(provide 'org-x)
|
(provide 'org-x)
|
||||||
;;; org-x.el ends here
|
;;; org-x.el ends here
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue