REF make clustering code prettier
This commit is contained in:
parent
7f1426ee2b
commit
2ba47588ba
|
@ -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.
|
||||||
|
|
||||||
|
@ -1227,8 +1208,7 @@ 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)))
|
||||||
|
|
||||||
|
@ -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,8 +1280,7 @@ 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)))
|
||||||
|
|
||||||
|
@ -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,17 +1398,15 @@ 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
|
|
||||||
'face nil
|
|
||||||
'done-face 'org-agenda-done
|
'done-face 'org-agenda-done
|
||||||
'org-not-done-regexp org-not-done-regexp
|
'org-not-done-regexp org-not-done-regexp
|
||||||
'org-todo-regexp org-todo-regexp
|
'org-todo-regexp org-todo-regexp
|
||||||
|
@ -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)
|
||||||
|
"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))
|
(setq arg org-agenda-overriding-arguments))
|
||||||
|
|
||||||
(if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil))
|
(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
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue