From 3bafc3504cb51bc9ce52fe6be2bc55c077cbba44 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 20 Jan 2019 05:59:22 -0500 Subject: [PATCH] cleaned up org-cluster, added docstrings, and added hotkeys --- conf.org | 364 +++++++++++++++++++++++++++++++++---------------------- 1 file changed, 218 insertions(+), 146 deletions(-) diff --git a/conf.org b/conf.org index 089d732..9a392fc 100644 --- a/conf.org +++ b/conf.org @@ -1445,48 +1445,83 @@ 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) #+END_SRC -*** conflict detection -Somehow org-mode has no way to detect conflicts between tasks with timestamps (!!??). Luckily I can make my own. -**** backend -The algorithm to detect conflicts scans all org files and stores conflicts in a list of pairs of each heading with a conflicting timestamp. - -Steps for this algorithm: -1. make a list of all entries with timestamps -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 a new list (this is what is used to make the display) - -This should be O(n) (best case/no conflicts) to O(n^2) (worst case/everything conflicts) +*** 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 +**** extraction filters +These control which types of headlines are processed by org-cluster #+BEGIN_SRC emacs-lisp -(defun nd/org-conflict-make-entry (ts range offset fp hardness +(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 + '("incubator" "peripheral") + "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 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 +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) - (list :timestamp ts + "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-conflict-ts-hard-p (ts) + +(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-conflict-parse-ts (ts hl fp) + +(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-conflict-ts-hard-p ts)) + (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) - (round 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-conflict-make-entry start range offset fp hardness)) - (nd/org-conflict-make-entry start 0 offset fp hardness))))) - -(defun nd/org-conflict-effort-seconds (effort-str) + (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 @@ -1503,26 +1538,35 @@ This should be O(n) (best case/no conflicts) to O(n^2) (worst case/everything co (* 60)))) (t (error (format "Unknown effort: %s'" effort-str))))))) -(defun nd/org-conflict-extract (acc fun objs &rest args) +(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-conflict-extract-hl-sched (acc hl fp) +(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)) - (ts-ft (->> ts (org-element-property :raw-value) org-2ft round)) + (unixtime (->> ts (org-element-property :raw-value) org-2ft)) (range (-some->> hl (org-element-property :EFFORT) - nd/org-conflict-effort-seconds)) - (hardness (nd/org-conflict-ts-hard-p ts)) + nd/org-cluster-effort-seconds)) + (hardness (nd/org-cluster-ts-hard-p ts)) (offset (org-element-property :begin hl))) - (if (= 0 ts-ft) acc - (-> ts-ft - (nd/org-conflict-make-entry range offset fp hardness 'scheduled) + (if (= 0 unixtime) acc + (-> unixtime + (nd/org-cluster-make-tsp range offset fp hardness 'scheduled) (cons acc))))) -(defun nd/org-conflict-extract-hl-ts (acc hl fp) +(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) @@ -1536,143 +1580,185 @@ This should be O(n) (best case/no conflicts) to O(n^2) (worst case/everything co (or (eq 'active (org-element-property :type it)) (eq 'active-range (org-element-property :type it))) it) - (--map (nd/org-conflict-parse-ts it hl fp) it) + (--map (nd/org-cluster-parse-ts it hl fp) it) (append acc it))) -(defun nd/org-conflict-extract-hl (acc hl fp) +(defun nd/org-cluster-extract-hl (acc hl fp) + "Extract timestamps from headline HL in filepath FP and store in ACC." (-> acc - (nd/org-conflict-extract-hl-sched hl fp) - (nd/org-conflict-extract-hl-ts hl fp))) + (nd/org-cluster-extract-hl-sched hl fp) + (nd/org-cluster-extract-hl-ts hl fp))) -(defun nd/org-conflict-filter-todo (hls) - (if (not nd/org-conficts-filter-todo) hls +(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-conficts-filtered-todo) + nd/org-cluster-filtered-todo) hls))) -(defun nd/org-conflict-filter-files (fps) - (if (not nd/org-conficts-filter-files) fps +(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-conficts-filtered-files) + (-find (lambda (s) (string-match-p s it)) nd/org-cluster-filtered-files) fps))) -(defun nd/org-conflict-filter-past (tss) - (if (not nd/org-conficts-filter-past) tss +(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 :timestamp) ft) tss)))) + (--remove (< (plist-get it :unixtime) ft) tsps)))) -(defun nd/org-conflict-filter-habit (hls) - (if (not nd/org-conficts-filter-habit) hls +(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-conflict-extract-file (acc fp) +(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-conflict-filter-todo it) - (nd/org-conflict-filter-habit it) - (nd/org-conflict-extract acc #'nd/org-conflict-extract-hl it fp))) + (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 +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). -(defun nd/org-conflict-conflicting-p (ts-a ts-b) +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 ts-a :timestamp)) - (start-b (plist-get ts-b :timestamp)) - (end-a (+ start-a (plist-get ts-a :range)))) + (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/find-conflict (ts ts-list conlist) - (->> ts-list - (--take-while (nd/org-conflict-conflicting-p ts it)) - (--map (cons ts it)) +(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-conflict-build-conlist (ts-list) +(defun nd/org-cluster-build-conlist (tsps) + "Build a list of conflict pairs from timestamp-plist TSPS." (let ((conlist)) - (while (< 1 (length ts-list)) - (setq conlist (nd/find-conflict (car ts-list) (cdr ts-list) conlist) - ts-list (cdr ts-list))) + (while (< 1 (length tsps)) + (setq conlist (nd/org-cluster-find-conflict (car tsps) + (cdr tsps) + conlist) + tsps (cdr tsps))) conlist)) -(defun nd/org-conflict-split-day-bounds (tss) +(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 +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 ts) - (nd/org-conflict-make-entry start + (lambda (start end tsp) + (nd/org-cluster-make-tsp start (- end start) - (plist-get ts :offset) - (plist-get ts :filepath) - (plist-get ts :hardness) - (plist-get ts :type)))) + (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 ts) + (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 ts) - (funcall split start start* ts)) - (list (funcall new start end ts)))))) + (cons (funcall new start* end tsp) + (funcall split start start* tsp)) + (list (funcall new start end tsp)))))) (split-maybe - (lambda (ts) - (let* ((start (plist-get ts :timestamp)) - (end (+ start (plist-get ts :range))) + (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 ts) - ts))))) - (--mapcat (funcall split-maybe it) tss))) + (funcall split start end tsp) + tsp))))) + (--mapcat (funcall split-maybe it) tsps))) -(defun nd/org-overlist-overloaded-p (tss) - (letrec ((ts2diff - (lambda (ts) - (let ((start (plist-get ts :timestamp))) - (- (-> ts (plist-get :range) (+ start)) start))))) - (->> tss (--map (funcall ts2diff it)) -sum (<= 86400)))) - -(defun nd/org-overlist-daily-split (tss) - (letrec ((tz-shift (lambda (ts) (-> ts current-time-zone car (+ ts))))) +(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))))) (->> - tss + tsps (--partition-by (--> it - (plist-get it :timestamp) + (plist-get it :unixtime) (funcall tz-shift it) (floor it 86400)))))) - -;; TODO, this isn't DRY -(defun nd/org-conflict-get () + +(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." (->> - ;; (list "~/Org/reference/testconflict.org") - (org-agenda-files) - nd/org-conflict-filter-files - (nd/org-conflict-extract nil #'nd/org-conflict-extract-file) - nd/org-conflict-filter-past - (--filter (plist-get it :hardness)) - (--sort (< (plist-get it :timestamp) (plist-get other :timestamp))) - nd/org-conflict-build-conlist)) - -(defun nd/org-overlist-get () - (->> - ;; (list "~/Org/reference/testconflict.org") - (org-agenda-files) - nd/org-conflict-filter-files - (nd/org-conflict-extract nil #'nd/org-conflict-extract-file) - nd/org-conflict-filter-past + (nd/org-cluster-get-unprocessed) (--filter (< 0 (plist-get it :range))) - nd/org-conflict-split-day-bounds - (--sort (< (plist-get it :timestamp) (plist-get other :timestamp))) - nd/org-overlist-daily-split - (--filter (nd/org-overlist-overloaded-p it)))) + 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 -To display any conflicts, 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 which displays each conflict pair in sequentional fashion. +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/get-conflict-header-text (ts-entry) +(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)) @@ -1721,12 +1807,12 @@ MARKER for use in the conflict agenda view." 'ts-date ts-date 'type "timestamp"))))) -(defun nd/org-conflct-ts-fmt (ts) +(defun nd/org-cluster-ts-fmt (ts) (let ((fmt "[%Y-%m-%d]")) - (--> ts (plist-get it :timestamp) (format-time-string fmt it)))) + (--> ts (plist-get it :unixtime) (format-time-string fmt it)))) ;; TODO...waaaaay too wet (not DRY) -(defun nd/org-conflicts (&optional arg) +(defun nd/org-cluster-show-conflicts (&optional arg) (interactive "P") (if org-agenda-overriding-arguments @@ -1748,7 +1834,7 @@ MARKER for use in the conflict agenda view." (org-compile-prefix-format 'agenda) ;; (org-set-sorting-strategy 'todo) - (setq org-agenda-redo-command '(nd/org-conflicts)) + (setq org-agenda-redo-command '(nd/org-cluster-show-conflicts)) (insert "Conflicting Headings: \n") (add-text-properties (point-min) (1- (point)) @@ -1757,12 +1843,12 @@ MARKER for use in the conflict agenda view." (org-agenda-mark-header-line (point-min)) (-some-> - (nd/org-conflict-get) + (nd/org-cluster-get-conflicts) (--each (insert (concat - "At " (nd/org-conflct-ts-fmt (car it)) "\n" - (nd/get-conflict-header-text (car it)) "\n" - (nd/get-conflict-header-text (cdr it)) "\n" + "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 @@ -1777,7 +1863,7 @@ MARKER for use in the conflict agenda view." (org-agenda-finalize) (setq buffer-read-only t)))) -(defun nd/org-overloaded (&optional arg) +(defun nd/org-cluster-show-overloads (&optional arg) (interactive "P") (if org-agenda-overriding-arguments @@ -1799,7 +1885,7 @@ MARKER for use in the conflict agenda view." (org-compile-prefix-format 'agenda) ;; (org-set-sorting-strategy 'todo) - (setq org-agenda-redo-command '(nd/org-overloaded)) + (setq org-agenda-redo-command '(nd/org-cluster-show-overloads)) (insert "Overloaded Days: \n") (add-text-properties (point-min) (1- (point)) @@ -1808,11 +1894,11 @@ MARKER for use in the conflict agenda view." (org-agenda-mark-header-line (point-min)) (-some-> - (nd/org-overlist-get) + (nd/org-cluster-get-overloads) (--each (insert (concat - "On " (nd/org-conflct-ts-fmt (car it)) "\n" - (mapconcat #'nd/get-conflict-header-text it "\n") + "On " (nd/org-cluster-ts-fmt (car it)) "\n" + (mapconcat #'nd/org-cluster-headline-text it "\n") "\n")))) ;; clean up and finalize @@ -1827,22 +1913,6 @@ MARKER for use in the conflict agenda view." (org-agenda-finalize) (setq buffer-read-only t)))) #+END_SRC -**** filters -#+BEGIN_SRC emacs-lisp -(defvar nd/org-conficts-filter-files t) - -(defconst nd/org-conficts-filtered-files - '("incubator" "peripheral")) - -(defvar nd/org-conficts-filter-todo t) - -(defconst nd/org-conficts-filtered-todo - '("CANC" "DONE")) - -(defvar nd/org-conficts-filter-past t) - -(defvar nd/org-conficts-filter-habit t) -#+END_SRC *** agenda **** targets The agenda files are limited to as few as possible to keep scanning and startup reasonably fast. @@ -3606,6 +3676,8 @@ The function keys are nice because they are almost (not always) free in every mo (global-set-key (kbd "") 'org-agenda) (global-set-key (kbd "") 'org-capture) (global-set-key (kbd "") 'cfw:open-org-calendar) +(global-set-key (kbd "C-") 'nd/org-cluster-show-conflicts) +(global-set-key (kbd "C-S-") 'nd/org-cluster-show-overloads) (global-set-key (kbd "") 'org-clock-goto) (global-set-key (kbd "") 'ansi-term) (global-set-key (kbd "") 'helm-command-prefix)