Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
Sort entries in an org-mode clocktable by category instead of file. Requires (and probably abuses) dash.el
(defun my-org-clocktable-formatter (ipos tables params)
"Custom formatter for org-mode clocktables which groups by category rather than file.
It uses `org-clock-clocktable-formatter' for the insertion of the table after sorting
the items into tables based on an items category property. Thus all parameters supported
by `org-clock-clocktable-formatter' are supported. To use this to sort a clocktable add
`:properties (\"CATEGORY\") :formatter my-org-clocktable-formatter' to that clocktable's
(let* ((tt (-flatten-n 1 (-map #'-last-item tables)))
(formatter (or org-clock-clocktable-formatter
(newprops (remove "CATEGORY" (plist-get params :properties)))
(newparams (plist-put (plist-put params :multifile t) :properties newprops))
;; Compute net clocked time for each item
(setq tt
(let* ((it-level (car it))
(it-time (nth 4 it))
(it-subtree (--take-while (< it-level (car it))
(-drop (1+ it-index) tt)))
(it-children (--filter (= (1+ it-level) (car it))
(-replace-at 4 (- it-time (-sum (--map (nth 4 it) it-children)))
;; Add index (ie id) and indexes of parents (these are needed in the
;; sorting step). This can probably be written more functionally using --reduce?
;; At least without having to modify hist.
(setq tt
(let (hist)
(--map-indexed (let* ((it-level (car it))
(it-hist (-drop (- (length hist)
it-level -1)
(setq hist (cons it-index it-hist))
(cons it-index (cons it-hist it)))
;; Now comes the important phase: sorting, where we copy items with >0 net time
;; into newtables based on their category, and we copy their parents when
;; appropriate.
(--each tt (let* ((it-hist (nth 1 it))
(it-time (nth 6 it))
(it-prop (-last-item it))
(it-cat (alist-get "CATEGORY" it-prop nil nil #'string=))
;; Find the index of the table for category: it-cat or if
;; it doesn't yet exist add it to the start of newtables.
(cat-pos (or
(--find-index (string= (car it) it-cat) newtables)
(progn (push (list it-cat nil) newtables) 0)))
(cat-members (-map #'car (-last-item (nth cat-pos newtables))))
(or (--find-index (member it
(length it-hist)))
;; replace the time of copied parents with 0 since if a
;; parents is being copied and has time >0 then it has
;; already been placed in the table for a different
;; category. ie. We don't want time double counted.
(--map (-replace-at 6 0 (nth it tt))
(-take it-parent it-hist))))
(when (not (= 0 it-time))
(setf (-last-item (nth cat-pos newtables))
(append (cons it hist-to-add)
(-last-item (nth cat-pos newtables)))))))
(--each newtables (setf (-last-item it) (reverse (-last-item it))))
;; Cleanup, remove ids and list of parents, as they are no longer needed.
(setq newtables
(--map (list (car it) 0 (--map (-drop 2 it) (-last-item it))) newtables))
;; Recompute the total times for each node.
;; (replace this with --each and setf?)
(setq newtables
(--map (let* ((it-children (sum-direct-children-org 1 (-last-item it)))
(it-total-time (-sum
(--map (nth 4 it)
(--filter (= 1 (car it))
(list (car it) it-total-time it-children))
;; Actually insert the clocktable now.
(funcall formatter ipos newtables newparams)
;; Replace "File" with "Category" in the "file" column and "*File time*" with "*
;; Category time*" in the table.
(org-table-goto-line 1)
(insert "Category")
(let ((n 2))
(while (org-table-goto-line n)
;; This won't work if there are addition columns eg. Property column.
;; Instead look forward along each line to see if that regexp is matched?
(when (looking-at "\\*File time\\* .*\| *\\*.*[0-9]:[0-9][0-9]\\*")
(insert "*Category time*")
(incf n)))))
(defun sum-direct-children-org (level children)
"Update the time LEVEL nodes recursively to be the sum of the times of its children.
Used in `my-org-clocktable-formatter' to go from net times back to tatal times."
(let ((subtrees (-partition-before-pred (lambda (it) (= level (car it))) children)))
(-flatten-n 1
(--map (let ((it-children (sum-direct-children-org (1+ level)
(cdr it))))
(cons (--update-at
4 (+ it
(--map (nth 4 it)
(--filter (= (1+ level)
(car it))
(car it))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment