ADD scanners and agenda views for weekly and quarterly plans
This commit is contained in:
parent
103e197508
commit
f80f507a51
|
@ -348,7 +348,7 @@ that file as it currently sits on disk.")
|
||||||
;; (org-x-dag-file->ids (org-x-get-weekly-plan-file)))
|
;; (org-x-dag-file->ids (org-x-get-weekly-plan-file)))
|
||||||
|
|
||||||
(defun org-x-dag-filter-ids-tags (tags ids)
|
(defun org-x-dag-filter-ids-tags (tags ids)
|
||||||
(--filter (seq-set-equal-p (org-x-dag-id->tags t nil it) tags #'equal) ids))
|
(--filter (-intersection (org-x-dag-id->tags t nil it) tags) ids))
|
||||||
|
|
||||||
(defun org-x-dag-date-to-quarter-tags (date)
|
(defun org-x-dag-date-to-quarter-tags (date)
|
||||||
(-let (((y q) (org-x-dag-date-to-quarter date)))
|
(-let (((y q) (org-x-dag-date-to-quarter date)))
|
||||||
|
@ -1907,14 +1907,42 @@ FUTURE-LIMIT in a list."
|
||||||
(org-x-dag-with-id id
|
(org-x-dag-with-id id
|
||||||
(let ((alloc (-some->> (org-x-dag-get-local-property org-x-prop-allocate)
|
(let ((alloc (-some->> (org-x-dag-get-local-property org-x-prop-allocate)
|
||||||
(org-x-dag-allocation-fraction current-quarter)))
|
(org-x-dag-allocation-fraction current-quarter)))
|
||||||
(assignedp (org-x-dag-id->has-child-in-files-p id week-file)))
|
(assignedp (org-x-dag-id->has-child-in-files-p id week-file))
|
||||||
(-> (org-x-dag-format-tag-node "goal" nil id)
|
(tags (->> (org-x-dag-id->parents id)
|
||||||
|
(--mapcat (org-x-dag-id->tags id nil it))
|
||||||
|
(--filter (= (elt it 0) org-x-tag-category-prefix)))))
|
||||||
|
(-> (org-x-dag-format-tag-node "goal" tags id)
|
||||||
(org-add-props nil
|
(org-add-props nil
|
||||||
'x-assignedp assignedp
|
'x-assignedp assignedp
|
||||||
|
;; override face
|
||||||
|
'face (if assignedp 'org-warning 'default)
|
||||||
'x-alloc (or alloc 0)))))))
|
'x-alloc (or alloc 0)))))))
|
||||||
(org-x-with-file (org-x-qtp-get-file)
|
(org-x-with-file (org-x-qtp-get-file)
|
||||||
(-map #'format-id (org-x-dag->qtp-ids 'current))))))
|
(-map #'format-id (org-x-dag->qtp-ids 'current))))))
|
||||||
|
|
||||||
|
(defun org-x-dag-scan-weekly-plan ()
|
||||||
|
(let ((daily-file (list (org-x-get-daily-plan-file))))
|
||||||
|
(cl-flet
|
||||||
|
((format-id
|
||||||
|
(id)
|
||||||
|
(org-x-dag-with-id id
|
||||||
|
;; TODO this assigned thing needs to be limited in scope to the
|
||||||
|
; the current ids of the time period in question
|
||||||
|
(let* ((assignedp (org-x-dag-id->has-child-in-files-p id daily-file))
|
||||||
|
(day (-some->> (org-x-dag-id->tags t nil id)
|
||||||
|
;; TODO I guess this works...could be more precise
|
||||||
|
(--filter (s-matches-p "[A-Z]\\{3\\}" it))
|
||||||
|
(car)))
|
||||||
|
(daynum (car (rassoc day org-x-dag-weekly-tags))))
|
||||||
|
(-> (org-x-dag-format-tag-node "goal" nil id)
|
||||||
|
(org-add-props nil
|
||||||
|
'x-assignedp assignedp
|
||||||
|
'x-day-of-week (format "%d. %s" daynum day)
|
||||||
|
;; override face
|
||||||
|
'face (if assignedp 'org-warning 'default)))))))
|
||||||
|
(org-x-with-file (org-x-get-weekly-plan-file)
|
||||||
|
(-map #'format-id (org-x-dag->wkp-ids 'current))))))
|
||||||
|
|
||||||
;; (cl-flet
|
;; (cl-flet
|
||||||
;; ((format-id
|
;; ((format-id
|
||||||
;; (category id)
|
;; (category id)
|
||||||
|
@ -2099,5 +2127,58 @@ FUTURE-LIMIT in a list."
|
||||||
(/ (* mins d*) qt-mins)))
|
(/ (* mins d*) qt-mins)))
|
||||||
(e (error "Invalid allocation: %s" e))))))
|
(e (error "Invalid allocation: %s" e))))))
|
||||||
|
|
||||||
|
;;; AGENDA VIEWS
|
||||||
|
|
||||||
|
(defun org-x-dag-agenda-run-series (name files cmds)
|
||||||
|
(declare (indent 2))
|
||||||
|
(catch 'exit
|
||||||
|
(let ((org-agenda-buffer-name (format "*Agenda: %s*" name)))
|
||||||
|
(org-agenda-run-series name `((,@cmds) ((org-agenda-files ',files)))))))
|
||||||
|
|
||||||
|
(defun org-x-dag-agenda-call (buffer-name header-name type match files settings)
|
||||||
|
(declare (indent 5))
|
||||||
|
(let* ((n (or header-name buffer-name))
|
||||||
|
(s `((org-agenda-overriding-header ,n) ,@settings)))
|
||||||
|
(org-x-dag-agenda-run-series buffer-name files `((,type ,match ,s)))))
|
||||||
|
|
||||||
|
;; TODO the tags in the far column are redundant
|
||||||
|
(defun org-x-dag-agenda-quarterly-plan ()
|
||||||
|
(interactive)
|
||||||
|
(let ((match ''org-x-dag-scan-quarterly-plan)
|
||||||
|
(files (org-x-get-action-files))
|
||||||
|
(header (->> (org-x-dag->current-date)
|
||||||
|
(org-x-dag-date-to-quarter)
|
||||||
|
(apply #'format "Quarterly Plan: %d Q%d"))))
|
||||||
|
(org-x-dag-agenda-call "Quarterly Plan" nil #'org-x-dag-show-nodes match files
|
||||||
|
`((org-agenda-todo-ignore-with-date t)
|
||||||
|
(org-agenda-overriding-header ,header)
|
||||||
|
(org-agenda-sorting-strategy '(user-defined-up category-keep))
|
||||||
|
;; TODO add allocation (somehow)
|
||||||
|
(org-agenda-prefix-format '((tags . " ")))
|
||||||
|
(org-super-agenda-groups
|
||||||
|
'((:auto-map
|
||||||
|
(lambda (line)
|
||||||
|
(let ((bucket (car (get-text-property 1 'tags line))))
|
||||||
|
(--> (-map #'cdr org-x-life-categories)
|
||||||
|
(--find (equal (plist-get it :tag) bucket) it)
|
||||||
|
(plist-get it :desc)))))))))))
|
||||||
|
|
||||||
|
(defun org-x-dag-agenda-weekly-plan ()
|
||||||
|
(interactive)
|
||||||
|
(let* ((match ''org-x-dag-scan-weekly-plan)
|
||||||
|
(files (org-x-get-action-files))
|
||||||
|
(date (org-x-dag->current-date))
|
||||||
|
(header (->> (org-x-dag-date-to-week-number date)
|
||||||
|
(format "Weekly Plan: %d W%02d" (car date)))))
|
||||||
|
(org-x-dag-agenda-call "Weekly Plan" nil #'org-x-dag-show-nodes match files
|
||||||
|
`((org-agenda-todo-ignore-with-date t)
|
||||||
|
(org-agenda-overriding-header ,header)
|
||||||
|
(org-agenda-sorting-strategy '(user-defined-up category-keep))
|
||||||
|
(org-agenda-prefix-format '((tags . " ")))
|
||||||
|
(org-super-agenda-groups
|
||||||
|
'((:auto-map
|
||||||
|
(lambda (line)
|
||||||
|
(get-text-property 1 'x-day-of-week line)))))))))
|
||||||
|
|
||||||
(provide 'org-x-dag)
|
(provide 'org-x-dag)
|
||||||
;;; org-x-dag.el ends here
|
;;; org-x-dag.el ends here
|
||||||
|
|
Loading…
Reference in New Issue