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

ENH incoporate new timestamp splitter

This commit is contained in:
Nathan Dwarshuis 2021-04-13 23:55:03 -04:00
parent e17ac965a1
commit 7a956c0d44
2 changed files with 122 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1138,23 +1138,37 @@ and slow."
;; 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) ;; (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)
"Construct a timestamp plist to be used in further processing. "Construct a timestamp plist to be used in further processing.
The fields are as follows: The fields are as follows:
- UNIXTIME is the unixtime of the timestamp as an integer
- START-TIME is a list from `org-ml-timestamp-get-start-time'
- RANGE is the duration of the timestamp (could be 0) - RANGE is the duration of the timestamp (could be 0)
- OFFSET is the character offset of the timestamp in its file - 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" - FP the path to the file in which the timestamp resides"
(list :unixtime (round unixtime) (list :start-time start-time
:range (or range 0) :range range
:offset offset :offset offset
:type type
:hardness hardness
:filepath fp)) :filepath fp))
(defun org-x-cluster-ts-hard-p (ts) (defun org-x-cluster-ts-hard-p (ts)
@ -1168,24 +1182,14 @@ or active-range types are considered. Returns a new timestamp-plist
for TS." for TS."
(when ts (when ts
(let ((offset (org-element-property :begin hl)) (let ((offset (org-element-property :begin hl))
(hardness (org-x-cluster-ts-hard-p ts)) (start-time (org-ml-timestamp-get-start-time ts))
(start (->> (org-ml-timestamp-get-start-time ts)
(org-ml-time-to-unixtime)))
(range (org-ml-timestamp-get-range ts))) (range (org-ml-timestamp-get-range ts)))
(org-x-cluster-make-tsp start 0 offset fp hardness)))) (org-x-cluster-make-tsp start-time range offset fp))))
(defun org-x-cluster-effort-seconds (effort-str) (defun org-x-cluster-effort-seconds (effort-str)
"Convert EFFORT-STR into an integer in seconds from HH:MM format." "Convert EFFORT-STR into an integer in seconds from HH:MM format."
(-some->> effort-str (org-duration-to-minutes) (* 60))) (-some->> effort-str (org-duration-to-minutes) (* 60)))
;; (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 (hl fp) (defun org-x-cluster-extract-hl-sched (hl fp)
"Extract scheduled timestamp from headline HL in filepath FP. "Extract scheduled timestamp from headline HL in filepath FP.
@ -1195,10 +1199,8 @@ Create a new timestamp-plist and add to accumulator ACC."
(let* ((effort-raw (org-ml-headline-get-node-property "Effort" hl)) (let* ((effort-raw (org-ml-headline-get-node-property "Effort" hl))
(effort (if effort-raw (org-x-cluster-effort-seconds effort-raw) 0)) (effort (if effort-raw (org-x-cluster-effort-seconds effort-raw) 0))
(offset (org-ml-get-property :begin hl)) (offset (org-ml-get-property :begin hl))
(start-time (org-ml-timestamp-get-start-time ts)) (start-time (org-ml-timestamp-get-start-time ts)))
(start-epoch (org-ml-time-to-unixtime start-time)) (org-x-cluster-make-tsp start-time effort offset fp))))
(is-long (org-ml-time-is-long start-time)))
(org-x-cluster-make-tsp start-epoch effort offset fp is-long))))
(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.
@ -1254,23 +1256,22 @@ and added to accumulator ACC."
(->> (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)
(--reduce-from (let ((new (org-x-cluster-extract-hl it fp))) (--map (org-x-cluster-extract-hl it fp))
(if new (cons new acc) acc)) (-non-nil)))
nil)))
(defun org-x-cluster-extract-file (fp) (defun org-x-cluster-extract-file (fp)
"Extract timestamps from filepath FP and add to accumulator ACC." "Extract timestamps from filepath FP and add to accumulator ACC."
(with-current-buffer (find-file-noselect fp t) (with-current-buffer (find-file-noselect fp t)
(org-x-cluster-extract-buffer fp))) (org-x-cluster-extract-buffer fp)))
(defun org-x-cluster-append-unixtime (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 ()
"Return a list of timestamp-plists with desired filter settings." "Return a list of timestamp-plists with desired filter settings."
(->> (org-agenda-files) (->> (org-agenda-files)
(org-x-cluster-filter-files) (org-x-cluster-filter-files)
(--reduce-from (let ((new (org-x-cluster-extract-file it))) (-mapcat #'org-x-cluster-extract-file)))
(if new (append new acc) acc))
nil)
(org-x-cluster-filter-past)))
;; get conflict headlines ;; get conflict headlines
;; ;;
@ -1317,9 +1318,11 @@ as a pair. New CONLIST is returned."
Each member in the cons cell is a timestamp-plist." Each member in the cons cell is a timestamp-plist."
(->> (->>
(org-x-cluster-get-unprocessed) (org-x-cluster-get-unprocessed)
(--filter (plist-get it :hardness)) (--filter (org-ml-time-is-long (plist-get it :start-time)))
(org-x-cluster-append-unixtime)
(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)))
;; get overloaded days ;; get overloaded days
;; ;;
@ -1335,18 +1338,23 @@ Each member in the cons cell is a timestamp-plist."
(defun org-x-cluster-split-tsp-maybe (tsp) (defun org-x-cluster-split-tsp-maybe (tsp)
"Split TSP if it spans multiple days." "Split TSP if it spans multiple days."
;; NOTE, `encode-time' seems pretty slow but this is necessary since some ;; NOTE: `encode-time' seems pretty slow but this is necessary since some
;; barbarians in power insist on keep daylight savings time, which means I ;; barbarians in power insist on keep daylight savings time, which means I
;; can't just do straight modular arithmetic to find where each day boundary ;; can't just do straight modular arithmetic to find where each day boundary
;; lies. ;; lies.
(-let (((&plist :start-time :range :fp) tsp)) (cl-flet
((encode-float-time
(time)
(round (float-time (encode-time time)))))
(-let (((&plist :start-time :range :offset :filepath) tsp))
(if (= range 0) (list tsp) (if (= range 0) (list tsp)
(-let* (((y m d H M) start-time) ;; `encode-time' and `decode-time' might not use the right time zone
(start-time* (if (and H M) start-time `(,@start-time 0 0))) ;; unless specified manually
(start-epoch (->> `(0 ,(or M 0) ,(or H 0) ,d ,m ,y nil nil nil) (-let* ((tz (current-time-zone))
(encode-time) (start-time* (if (org-ml-time-is-long start-time) start-time
(float-time) `(,@start-time 0 0)))
(round))) ((y m d H M) start-time*)
(start-epoch (encode-float-time `(0 ,M ,H ,d ,m ,y nil nil ,tz)))
(end-epoch (+ start-epoch range)) (end-epoch (+ start-epoch range))
(next t) (next t)
(split-epoch nil) (split-epoch nil)
@ -1354,81 +1362,33 @@ Each member in the cons cell is a timestamp-plist."
(acc nil)) (acc nil))
(while next (while next
;; get the projected ending time ;; get the projected ending time
(-setq (M* H* d* m* y*) (-take 5 (cdr (decode-time end-epoch)))) (-setq (M* H* d* m* y*) (-take 5 (cdr (decode-time end-epoch tz))))
;; Get the epoch time on which to split. If not on a day boundary, ;; Get the epoch time on which to split. If not on a day boundary,
;; calculate the epoch time of the most recent day boundary. If on a ;; calculate the epoch time of the most recent day boundary. If on a
;; day boundary, split on the boundary one full day earlier by ;; day boundary, split on the boundary one full day earlier by
;; decrementing day by one ;; decrementing day by one
(when (and (= 0 M*) (= 0 H*)) (when (and (= 0 M*) (= 0 H*))
(setq d* (1- d*))) (setq d* (1- d*)))
(setq split-epoch (->> `(0 0 0 ,d* ,m* ,y* nil nil nil) (setq split-epoch (encode-float-time `(0 0 0 ,d* ,m* ,y* nil nil ,tz)))
(encode-time)
(float-time)
(round)))
;; If the split-epoch is less than or equal to the start, loop is ;; If the split-epoch is less than or equal to the start, loop is
;; done. Else add a new entry and reset the projected ending time to ;; done. Else add a new entry and reset the projected ending time to
;; the current split time; rinse and repeat. ;; the current split time; rinse and repeat.
(if (< start-epoch split-epoch) (if (< start-epoch split-epoch)
(setq acc (cons (list :start-time `(,y* ,m* ,d* 0 0) (setq acc (cons (org-x-cluster-make-tsp
:range (- end-epoch split-epoch) `(,y* ,m* ,d* 0 0) (- end-epoch split-epoch)
:fp fp) offset filepath)
acc) acc)
end-epoch split-epoch) end-epoch split-epoch)
(setq next nil (setq next nil
acc (cons (list :start-time start-time* acc (cons (org-x-cluster-make-tsp
:range (- end-epoch start-epoch) start-time* (- end-epoch start-epoch) offset filepath)
:fp fp)
acc))))
acc)))) acc))))
acc)))))
(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) (defun org-x-cluster-daily-split (tsps)
"Group timestamp-plist TSPS into sublists for each day." "Group timestamp-plist TSPS into sublists for each day."
(letrec ((tz-shift (lambda (tsp) (-> tsp current-time-zone car (+ tsp))))) (--partition-by (-take 3 (plist-get it :start-time)) tsps))
(->>
tsps
(--partition-by (--> it
(plist-get it :unixtime)
(funcall tz-shift it)
(floor it 86400))))))
(defun org-x-cluster-overloaded-p (tsps) (defun org-x-cluster-overloaded-p (tsps)
"Return t if total time of timestamp-plists in TSPS exceeds 24 hours. "Return t if total time of timestamp-plists in TSPS exceeds 24 hours.
@ -1447,7 +1407,9 @@ is overloaded. If a day is not overloaded there will be nothing for it
in the returned list." in the returned list."
(->> (org-x-cluster-get-unprocessed) (->> (org-x-cluster-get-unprocessed)
(--filter (< 0 (plist-get it :range))) (--filter (< 0 (plist-get it :range)))
(org-x-cluster-split-day-bounds) (-mapcat #'org-x-cluster-split-tsp-maybe)
(org-x-cluster-append-unixtime)
(org-x-cluster-filter-past)
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime))) (--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
(org-x-cluster-daily-split) (org-x-cluster-daily-split)
(--filter (org-x-cluster-overloaded-p it)))) (--filter (org-x-cluster-overloaded-p it))))

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

@ -430,64 +430,68 @@ Forms are denoted like %(FORM)%."
(defmacro org-x--test-time-splitter-specs (&rest specs) (defmacro org-x--test-time-splitter-specs (&rest specs)
(declare (indent 0)) (declare (indent 0))
;; 3 args for clarity, currently does nothing functional ;; 3 args for clarity, currently does nothing functional
(let ((forms (->> (-partition 4 specs) (let ((forms
(--map (-let (((title input _useless-sugar output) it)) (->> (-partition 4 specs)
(--map (-let* (((title input _useless-sugar output) it)
(extra '(:offset 0 :filepath "bass4urface"))
(input* (append input extra))
(output* (--map (append it extra) output)))
`(it ,title `(it ,title
(expect (org-x-cluster-split-tsp-maybe ,input) (expect (org-x-cluster-split-tsp-maybe ',input*)
:to-equal :to-equal
,output))))))) ',output*)))))))
`(describe "Time splitter" `(describe "Time splitter"
,@forms))) ,@forms)))
(org-x--test-time-splitter-specs (org-x--test-time-splitter-specs
"zero range" "zero range"
'(:start-time (2021 1 1 0 0) :range 0 :fp "") (:start-time (2021 1 1 0 0) :range 0)
=> '((:start-time (2021 1 1 0 0) :range 0 :fp "")) => ((:start-time (2021 1 1 0 0) :range 0))
"1-hour range" "1-hour range"
'(:start-time (2021 1 1 0 0) :range 3600 :fp "") (:start-time (2021 1 1 0 0) :range 3600)
=> '((:start-time (2021 1 1 0 0) :range 3600 :fp "")) => ((:start-time (2021 1 1 0 0) :range 3600))
"12-hour range (noon start)" "12-hour range (noon start)"
'(:start-time (2021 1 1 12 0) :range 43200 :fp "") (:start-time (2021 1 1 12 0) :range 43200)
=> '((:start-time (2021 1 1 12 0) :range 43200 :fp "")) => ((:start-time (2021 1 1 12 0) :range 43200))
"24-hour range (day boundary)" "24-hour range (day boundary)"
'(:start-time (2021 1 1 0 0) :range 86400 :fp "") (:start-time (2021 1 1 0 0) :range 86400)
=> '((:start-time (2021 1 1 0 0) :range 86400 :fp "")) => ((:start-time (2021 1 1 0 0) :range 86400))
"24-hour range (noon start)" "24-hour range (noon start)"
'(:start-time (2021 1 1 12 0) :range 86400 :fp "") (:start-time (2021 1 1 12 0) :range 86400)
=> '((:start-time (2021 1 1 12 0) :range 43200 :fp "") => ((:start-time (2021 1 1 12 0) :range 43200)
(:start-time (2021 1 2 0 0) :range 43200 :fp "")) (:start-time (2021 1 2 0 0) :range 43200))
"48-hour range (day boundary)" "48-hour range (day boundary)"
'(:start-time (2021 1 1 0 0) :range 172800 :fp "") (:start-time (2021 1 1 0 0) :range 172800)
=> '((:start-time (2021 1 1 0 0) :range 86400 :fp "") => ((:start-time (2021 1 1 0 0) :range 86400)
(:start-time (2021 1 2 0 0) :range 86400 :fp "")) (:start-time (2021 1 2 0 0) :range 86400))
"48-hour range (noon start)" "48-hour range (noon start)"
'(:start-time (2021 1 1 12 0) :range 172800 :fp "") (:start-time (2021 1 1 12 0) :range 172800)
=> '((:start-time (2021 1 1 12 0) :range 43200 :fp "") => ((:start-time (2021 1 1 12 0) :range 43200)
(:start-time (2021 1 2 0 0) :range 86400 :fp "") (:start-time (2021 1 2 0 0) :range 86400)
(:start-time (2021 1 3 0 0) :range 43200 :fp "")) (:start-time (2021 1 3 0 0) :range 43200))
"zero range (short)" "zero range (short)"
'(:start-time (2021 1 1) :range 0 :fp "") (:start-time (2021 1 1) :range 0)
=> '((:start-time (2021 1 1) :range 0 :fp "")) => ((:start-time (2021 1 1) :range 0))
"1-hour range (short)" "1-hour range (short)"
'(:start-time (2021 1 1) :range 3600 :fp "") (:start-time (2021 1 1) :range 3600)
=> '((:start-time (2021 1 1 0 0) :range 3600 :fp "")) => ((:start-time (2021 1 1 0 0) :range 3600))
"24-hour range (short)" "24-hour range (short)"
'(:start-time (2021 1 1) :range 86400 :fp "") (:start-time (2021 1 1) :range 86400)
=> '((:start-time (2021 1 1 0 0) :range 86400 :fp "")) => ((:start-time (2021 1 1 0 0) :range 86400))
"48-hour range (short)" "48-hour range (short)"
'(:start-time (2021 1 1) :range 172800 :fp "") (:start-time (2021 1 1) :range 172800)
=> '((:start-time (2021 1 1 0 0) :range 86400 :fp "") => ((:start-time (2021 1 1 0 0) :range 86400)
(:start-time (2021 1 2 0 0) :range 86400 :fp ""))) (:start-time (2021 1 2 0 0) :range 86400)))
(provide 'org-x-test-buffer-state) (provide 'org-x-test-buffer-state)
;;; org-x-test-buffer-state.el ends here ;;; org-x-test-buffer-state.el ends here