ndwarshuis
/
emacs-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF make clustering code prettier

This commit is contained in:
Nathan Dwarshuis 2021-04-16 00:19:19 -04:00
parent 7f1426ee2b
commit 2ba47588ba
2 changed files with 97 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

236
local/lib/org-x/org-x.el
View File

@ -1132,31 +1132,12 @@ and slow."
(org-ml-supercontents-set-logbook nil it) (org-ml-supercontents-set-logbook nil it)
it)))))) it))))))
;; clustering ;; inter-headline clustering
;; ;;
;; Conflicts and overloads begin with the same list to process, which is created ;; 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 ;; using `org-element-parse-buffer' and a variety of filtering functions to
;; extract relevent timestamps. ;; 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-make-tsp (start-time range offset fp) (defun org-x-cluster-make-tsp (start-time range offset fp)
"Construct a timestamp plist to be used in further processing. "Construct a timestamp plist to be used in further processing.
@ -1203,7 +1184,7 @@ Create a new timestamp-plist and add to accumulator ACC."
(defun org-x-cluster-extract-hl-ts (hl fp) (defun org-x-cluster-extract-hl-ts (hl fp)
"Extract timestamps from headline HL in filepath FP. "Extract timestamps from headline HL in filepath FP.
All active timestamps that are not in drawers or the planning header All active timestamps that are not in drawers or the planning header
are considered. Each timestamp is converted into a new timestamp-plist are considered. Each timestamp is converted into a new timestamp-plist
and added to accumulator ACC." and added to accumulator ACC."
(-some->> hl (-some->> hl
@ -1227,10 +1208,9 @@ and added to accumulator ACC."
(defun org-x-cluster-filter-todo (hls) (defun org-x-cluster-filter-todo (hls)
"Filter certain TODO keywords from headline list HLS." "Filter certain TODO keywords from headline list HLS."
(if (not org-x-cluster-filter-todo) hls (if (not org-x-cluster-filter-todo) hls
(--remove (--remove (member (org-element-property :todo-keyword it)
(member (org-element-property :todo-keyword it)
org-x-cluster-filtered-todo) org-x-cluster-filtered-todo)
hls))) hls)))
(defun org-x-cluster-filter-files (fps) (defun org-x-cluster-filter-files (fps)
"Filter certain file names from files list FPS." "Filter certain file names from files list FPS."
@ -1251,7 +1231,8 @@ and added to accumulator ACC."
(--remove (org-element-property :STYLE it) hls))) (--remove (org-element-property :STYLE it) hls)))
(defun org-x-cluster-extract-buffer (fp) (defun org-x-cluster-extract-buffer (fp)
"Extract headlines from the current buffer for clustering analysis." "Extract headlines from the current buffer for clustering analysis.
FP is the filepath to the current buffer."
(->> (org-ml-parse-headlines 'all) (->> (org-ml-parse-headlines 'all)
(org-x-cluster-filter-todo) (org-x-cluster-filter-todo)
(org-x-cluster-filter-habit) (org-x-cluster-filter-habit)
@ -1264,6 +1245,9 @@ and added to accumulator ACC."
(org-x-cluster-extract-buffer fp))) (org-x-cluster-extract-buffer fp)))
(defun org-x-cluster-append-unixtime (tsps) (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)) (--map (append (list :unixtime (org-ml-time-to-unixtime (plist-get it :start-time))) it) tsps))
(defun org-x-cluster-get-unprocessed () (defun org-x-cluster-get-unprocessed ()
@ -1286,7 +1270,7 @@ and added to accumulator ACC."
;; are found push the pair to new list. ;; are found push the pair to new list.
(defun org-x-cluster-conflicting-p (tsp-a tsp-b) (defun org-x-cluster-conflicting-p (tsp-a tsp-b)
"Return t if timestamps TS-A and TS-B conflict." "Return t if timestamps TSP-A and TSP-B conflict."
;; assume that ts-a starts before ts-b ;; assume that ts-a starts before ts-b
(let ((start-a (plist-get tsp-a :unixtime)) (let ((start-a (plist-get tsp-a :unixtime))
(start-b (plist-get tsp-b :unixtime))) (start-b (plist-get tsp-b :unixtime)))
@ -1296,10 +1280,9 @@ and added to accumulator ACC."
"Test if timestamp-plist TSP conflicts with any in TSPS. "Test if timestamp-plist TSP conflicts with any in TSPS.
If found, anything in TSPS is cons'd with TSP and added to CONLIST If found, anything in TSPS is cons'd with TSP and added to CONLIST
as a pair. New CONLIST is returned." as a pair. New CONLIST is returned."
(->> tsps (->> (--take-while (org-x-cluster-conflicting-p tsp it) tsps)
(--take-while (org-x-cluster-conflicting-p tsp it)) (--map (list tsp it))
(--map (list tsp it)) (append conlist)))
(append conlist)))
(defun org-x-cluster-build-conlist (tsps) (defun org-x-cluster-build-conlist (tsps)
"Build a list of conflict pairs from timestamp-plist TSPS." "Build a list of conflict pairs from timestamp-plist TSPS."
@ -1309,19 +1292,16 @@ as a pair. New CONLIST is returned."
tsps (cdr tsps))) tsps (cdr tsps)))
conlist)) conlist))
(defun org-x-cluster-get-conflicts* (tsps) (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) (->> (--filter (org-ml-time-is-long (plist-get it :start-time)) tsps)
(org-x-cluster-append-unixtime) (org-x-cluster-append-unixtime)
(org-x-cluster-filter-past) (org-x-cluster-filter-past)
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime))) (--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
(org-x-cluster-build-conlist))) (org-x-cluster-build-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)
(org-x-cluster-get-conflicts*)))
;; get overloaded days ;; get overloaded days
;; ;;
;; Overloads are defined as days that have more than 24 hours worth of scheduled ;; Overloads are defined as days that have more than 24 hours worth of scheduled
@ -1393,11 +1373,14 @@ It is assumed the TSPS represents tasks and appointments within one
day." day."
(<= 86400 (-sum (--map (plist-get it :range) tsps)))) (<= 86400 (-sum (--map (plist-get it :range) tsps))))
(defun org-x-cluster-get-overloads* (tsps) (defun org-x-cluster-group-overloads (tsps)
"Return list of lists of timestamp-plists grouped by day. "Group TSPS by overloaded day.
Anything present represents all the tasks in a single day if that day A day is overloaded if it has TSPs whose :range properties sum to
is overloaded. If a day is not overloaded there will be nothing for it greater than 24 hours. TSPs which span multiple days will be
in the returned list." 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 (->> tsps
(--filter (< 0 (plist-get it :range))) (--filter (< 0 (plist-get it :range)))
(-mapcat #'org-x-cluster-split-tsp-maybe) (-mapcat #'org-x-cluster-split-tsp-maybe)
@ -1407,14 +1390,6 @@ in the returned list."
(org-x-cluster-daily-split) (org-x-cluster-daily-split)
(--filter (org-x-cluster-overloaded-p it)))) (--filter (org-x-cluster-overloaded-p it))))
(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)
(org-x-cluster-get-overloads*)))
;; conflict/overload frontend ;; conflict/overload frontend
;; I could just fetch the org headings and throw them into a new buffer. But ;; I could just fetch the org headings and throw them into a new buffer. But
@ -1423,27 +1398,25 @@ in the returned list."
;; adjust hotkeys, etc. So the obvious and hacky solution is to throw together a ;; adjust hotkeys, etc. So the obvious and hacky solution is to throw together a
;; quick-n-dirty agenda buffer. ;; quick-n-dirty agenda buffer.
(defun org-x-cluster-headline-text (ts-entry) (defun org-x-cluster-headline-text (tsp)
"Return string with text properties representing the org header for "Return string for headline text represented by TSP.
MARKER for use in the conflict agenda view." Returned string will have text properties to enable wizzy, fun
(let* ((offset (plist-get ts-entry :offset)) things in the agenda like jumpy to the target headline from the
(ts-marker (--> ts-entry agenda buffer."
(plist-get it :filepath) (-let* (((&plist :offset :filepath) tsp)
(find-file-noselect it) (ts-marker (with-current-buffer (find-file-noselect filepath)
(with-current-buffer it (copy-marker offset)))
(copy-marker offset)))) (props (list 'face nil
(props (list 'done-face 'org-agenda-done
'face nil 'org-not-done-regexp org-not-done-regexp
'done-face 'org-agenda-done 'org-todo-regexp org-todo-regexp
'org-not-done-regexp org-not-done-regexp 'org-complex-heading-regexp org-complex-heading-regexp
'org-todo-regexp org-todo-regexp 'mouse-face 'highlight))
'org-complex-heading-regexp org-complex-heading-regexp
'mouse-face 'highlight))
marker priority category level tags todo-state marker priority category level tags todo-state
ts-date ts-date-type ts-date-pair ts-date ts-date-type ts-date-pair
txt beg end inherited-tags todo-state-end-pos) txt beg end inherited-tags todo-state-end-pos)
(with-current-buffer (marker-buffer ts-marker) (with-current-buffer (marker-buffer ts-marker)
(save-excursion (save-excursion
(goto-char ts-marker) (goto-char ts-marker)
@ -1466,24 +1439,44 @@ MARKER for use in the conflict agenda view."
priority (1+ (org-get-priority txt))) priority (1+ (org-get-priority txt)))
(org-add-props txt props (org-add-props txt props
'org-marker marker 'org-hd-marker marker 'org-marker marker
'org-hd-marker marker
'priority priority 'priority priority
'level level 'level level
'ts-date ts-date 'ts-date ts-date
'type "timestamp"))))) 'type "timestamp")))))
(defun org-x-cluster-ts-fmt (ts) (defun org-x-cluster-ts-fmt (tsp)
(let ((fmt "[%Y-%m-%d]")) "Return formatted day-level timestamp for TSP."
(--> ts (plist-get it :unixtime) (format-time-string fmt it)))) (format-time-string "[%Y-%m-%d]" (plist-get tsp :unixtime)))
;; TODO...waaaaay too wet (not DRY) (defun org-x-cluster-format-conflict (grouped-tsp)
(defun org-x-cluster-show-conflicts (&optional arg) "Return GROUPED-TSPs formatted for conflict agenda buffer."
(interactive "P") (format "On %s\n%s\n"
(org-x-cluster-ts-fmt (car grouped-tsp))
(mapconcat #'org-x-cluster-headline-text grouped-tsp "\n")))
(if org-agenda-overriding-arguments (defun org-x-cluster-format-overload (grouped-tsp)
(setq arg org-agenda-overriding-arguments)) "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")))
(if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil)) (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)) (let* ((today (org-today))
(date (calendar-gregorian-from-absolute today)) (date (calendar-gregorian-from-absolute today))
@ -1492,79 +1485,22 @@ MARKER for use in the conflict agenda view."
rtn rtnall files file pos) rtn rtnall files file pos)
(catch 'exit (catch 'exit
(when org-agenda-sticky (setq org-agenda-buffer-name "*Org Conflicts*")) (when org-agenda-sticky
(setq org-agenda-buffer-name (format "*Org %s*" short-name)))
(org-agenda-prepare) (org-agenda-prepare)
;; (org-compile-prefix-format 'todo)
(org-compile-prefix-format 'agenda) (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 (cadr 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)) (setq org-agenda-redo-command '(org-x-cluster-show-overloads))
(insert "Overloaded Days: \n") (insert (format "%s: \n" title))
(add-text-properties (point-min) (1- (point)) (add-text-properties (point-min) (1- (point))
(list 'face 'org-agenda-structure (list 'face 'org-agenda-structure
'short-heading "Overloads")) 'short-heading short-name))
(org-agenda-mark-header-line (point-min)) (org-agenda-mark-header-line (point-min))
(-some-> (-some-> (funcall cluster-fun (org-x-cluster-get-unprocessed))
(org-x-cluster-get-overloads) (--each (insert (funcall format-fun it))))
(--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 ;; clean up and finalize
(goto-char (point-min)) (goto-char (point-min))
@ -1578,5 +1514,23 @@ MARKER for use in the conflict agenda view."
(org-agenda-finalize) (org-agenda-finalize)
(setq buffer-read-only t)))) (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

4
local/lib/org-x/test/org-x-test-buffer-state.el
View File

@ -430,7 +430,7 @@ 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-cluster-extract-buffer "fp")
(org-x-cluster-get-conflicts*) (org-x-cluster-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)))
@ -518,7 +518,7 @@ Forms are denoted like %(FORM)%."
(org-x--test-buffer-strings "Overloads" (org-x--test-buffer-strings "Overloads"
(->> (org-x-cluster-extract-buffer "fp") (->> (org-x-cluster-extract-buffer "fp")
(org-x-cluster-get-overloads*) (org-x-cluster-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)))