Mercurial > emacs
changeset 36851:ea0bb03a9658
see ChangeLog
| author | John Wiegley <johnw@newartisans.com> |
|---|---|
| date | Fri, 16 Mar 2001 21:39:31 +0000 |
| parents | e1167ad75cde |
| children | 57da1ff61f52 |
| files | lisp/calendar/timeclock.el |
| diffstat | 1 files changed, 318 insertions(+), 91 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/calendar/timeclock.el Fri Mar 16 18:53:54 2001 +0000 +++ b/lisp/calendar/timeclock.el Fri Mar 16 21:39:31 2001 +0000 @@ -431,7 +431,7 @@ (interactive) (setq timeclock-discrepancy nil) (timeclock-find-discrep) - (if timeclock-modeline-display + (if (and timeclock-discrepancy timeclock-modeline-display) (timeclock-update-modeline)) timeclock-discrepancy) @@ -913,7 +913,7 @@ (now (current-time)) (todays-date (timeclock-time-to-date now)) last-date-limited last-date-seconds last-date - (line 0) last beg day entry) + (line 0) last beg day entry event) (with-temp-buffer (insert-file-contents (or filename timeclock-file)) (when recent-only @@ -940,11 +940,15 @@ (let ((date (timeclock-time-to-date (cadr event)))) (if (and last-date (not (equal date last-date))) - (setcar (cdr log-data) - (cons (cons last-date day) - (cadr log-data))) - (setq day (list (and last-date-limited - last-date-seconds)))) + (progn + (setcar (cdr log-data) + (cons (cons last-date day) + (cadr log-data))) + (setq day (list (and last-date-limited + last-date-seconds)))) + (unless day + (setq day (list (and last-date-limited + last-date-seconds))))) (setq last-date date last-date-limited nil))) ((equal (downcase (car event)) "o") @@ -963,7 +967,7 @@ (nconc day (list entry)) (setq desc (nth 2 entry)) (let ((proj (assoc desc (nth 2 log-data)))) - (if (not proj) + (if (null proj) (setcar (cddr log-data) (cons (cons desc (list entry)) (car (cddr log-data)))) @@ -983,90 +987,313 @@ ;; This is not implemented in terms of the functions above, because ;; it's a bit wasteful to read all of that data in, just to throw ;; away more than 90% of the information afterwards. - (let* ((now (current-time)) - (todays-date (timeclock-time-to-date now)) - (first t) (accum 0) - event beg last-date avg - last-date-limited last-date-seconds) - (unless timeclock-discrepancy - (setq timeclock-project-list nil - timeclock-last-project nil - timeclock-reason-list nil - timeclock-elapsed 0) - (with-temp-buffer - (insert-file-contents timeclock-file) - (goto-char (point-max)) - (unless (re-search-backward "^b\\s-+" nil t) - (goto-char (point-min))) - (while (setq event (timeclock-read-moment)) - (cond ((equal (car event) "b") - (setq accum (string-to-number (nth 2 event)))) - ((equal (car event) "h") - (setq last-date-limited - (timeclock-time-to-date (cadr event)) - last-date-seconds - (* (string-to-number (nth 2 event)) 3600.0))) - ((equal (car event) "i") - (when (and (nth 2 event) + (when (file-readable-p timeclock-file) + (let* ((now (current-time)) + (todays-date (timeclock-time-to-date now)) + (first t) (accum 0) + event beg last-date avg + last-date-limited last-date-seconds) + (unless timeclock-discrepancy + (setq timeclock-project-list nil + timeclock-last-project nil + timeclock-reason-list nil + timeclock-elapsed 0) + (with-temp-buffer + (insert-file-contents timeclock-file) + (goto-char (point-max)) + (unless (re-search-backward "^b\\s-+" nil t) + (goto-char (point-min))) + (while (setq event (timeclock-read-moment)) + (cond ((equal (car event) "b") + (setq accum (string-to-number (nth 2 event)))) + ((equal (car event) "h") + (setq last-date-limited + (timeclock-time-to-date (cadr event)) + last-date-seconds + (* (string-to-number (nth 2 event)) 3600.0))) + ((equal (car event) "i") + (when (and (nth 2 event) + (> (length (nth 2 event)) 0)) + (add-to-list 'timeclock-project-list (nth 2 event)) + (setq timeclock-last-project (nth 2 event))) + (let ((date (timeclock-time-to-date (cadr event)))) + (if (and timeclock-relative + (if last-date + (not (equal date last-date)) + first)) + (setq first nil + accum (- accum + (if last-date-limited + last-date-seconds + timeclock-workday)))) + (setq last-date date + last-date-limited nil) + (if beg + (error "Error in format of timelog file!") + (setq beg (timeclock-time-to-seconds (cadr event)))))) + ((equal (downcase (car event)) "o") + (if (and (nth 2 event) (> (length (nth 2 event)) 0)) - (add-to-list 'timeclock-project-list (nth 2 event)) - (setq timeclock-last-project (nth 2 event))) - (let ((date (timeclock-time-to-date (cadr event)))) - (if (and timeclock-relative - (if last-date - (not (equal date last-date)) - first)) - (setq first nil - accum (- accum - (if last-date-limited - last-date-seconds - timeclock-workday)))) - (setq last-date date - last-date-limited nil) - (if beg - (error "Error in format of timelog file!") - (setq beg (timeclock-time-to-seconds (cadr event)))))) - ((equal (downcase (car event)) "o") - (if (and (nth 2 event) - (> (length (nth 2 event)) 0)) - (add-to-list 'timeclock-reason-list (nth 2 event))) - (if (or timeclock-relative - (equal last-date todays-date)) - (if (not beg) - (error "Error in format of timelog file!") - (setq timeclock-last-period - (- (timeclock-time-to-seconds (cadr event)) beg) - accum (+ timeclock-last-period accum) - beg nil))) - (if (equal last-date todays-date) - (setq timeclock-elapsed - (+ timeclock-last-period timeclock-elapsed))))) - (setq timeclock-last-event event - timeclock-last-event-workday - (if (equal (timeclock-time-to-date now) - last-date-limited) - last-date-seconds - timeclock-workday)) - (forward-line)) - (setq timeclock-discrepancy accum))) - (setq accum (if today-only - timeclock-elapsed - timeclock-discrepancy)) - (if timeclock-last-event - (if (equal (car timeclock-last-event) "i") - (setq accum (+ accum (timeclock-last-period now))) - (if (not (equal (timeclock-time-to-date - (cadr timeclock-last-event)) - (timeclock-time-to-date now))) - (setq accum (- accum timeclock-last-event-workday))))) - (setq accum - (- accum - (if (and timeclock-last-event - (equal (timeclock-time-to-date - (cadr timeclock-last-event)) - (timeclock-time-to-date now))) - timeclock-last-event-workday - timeclock-workday))))) + (add-to-list 'timeclock-reason-list (nth 2 event))) + (if (or timeclock-relative + (equal last-date todays-date)) + (if (not beg) + (error "Error in format of timelog file!") + (setq timeclock-last-period + (- (timeclock-time-to-seconds (cadr event)) + beg) + accum (+ timeclock-last-period accum) + beg nil))) + (if (equal last-date todays-date) + (setq timeclock-elapsed + (+ timeclock-last-period timeclock-elapsed))))) + (setq timeclock-last-event event + timeclock-last-event-workday + (if (equal (timeclock-time-to-date now) + last-date-limited) + last-date-seconds + timeclock-workday)) + (forward-line)) + (setq timeclock-discrepancy accum))) + (setq accum (if today-only + timeclock-elapsed + timeclock-discrepancy)) + (if timeclock-last-event + (if (equal (car timeclock-last-event) "i") + (setq accum (+ accum (timeclock-last-period now))) + (if (not (equal (timeclock-time-to-date + (cadr timeclock-last-event)) + (timeclock-time-to-date now))) + (setq accum (- accum timeclock-last-event-workday))))) + (setq accum + (- accum + (if (and timeclock-last-event + (equal (timeclock-time-to-date + (cadr timeclock-last-event)) + (timeclock-time-to-date now))) + timeclock-last-event-workday + timeclock-workday)))))) + +;;; A reporting function that uses timeclock-log-data + +(defun timeclock-time-less-p (t1 t2) + "Say whether time T1 is less than time T2." + (or (< (car t1) (car t2)) + (and (= (car t1) (car t2)) + (< (nth 1 t1) (nth 1 t2))))) + +(defun timeclock-day-base (&optional time) + "Given a time within a day, return 0:0:0 within that day." + (let ((decoded (decode-time (or time (current-time))))) + (setcar (nthcdr 0 decoded) 0) + (setcar (nthcdr 1 decoded) 0) + (setcar (nthcdr 2 decoded) 0) + (apply 'encode-time decoded))) + +(defun timeclock-geometric-mean (l) + "Compute the geometric mean of the list L." + (let ((total 0) + (count 0)) + (while l + (setq total (+ total (car l)) + count (1+ count) + l (cdr l))) + (if (> count 0) + (/ total count) + 0))) + +(defun timeclock-generate-report (&optional html-p) + "Generate a summary report based on the current timelog file." + (interactive) + (let ((log (timeclock-log-data)) + (today (timeclock-day-base))) + (if html-p (insert "<p>")) + (insert "Currently ") + (let ((project (nth 2 timeclock-last-event)) + (begin (nth 1 timeclock-last-event)) + done) + (if (timeclock-currently-in-p) + (insert "IN") + (if (or (null project) (= (length project) 0)) + (progn (insert "Done Working Today") + (setq done t)) + (insert "OUT"))) + (unless done + (insert " since " (format-time-string "%Y/%m/%d %-I:%M %p" begin)) + (if html-p + (insert "<br>\n<b>") + (insert "\n*")) + (if (timeclock-currently-in-p) + (insert "Working on ")) + (if html-p + (insert "</b><br>\n") + (insert project "*\n")) + (let ((proj-data (cdr (assoc project (timeclock-project-alist log)))) + (two-weeks-ago (timeclock-seconds-to-time + (- (timeclock-time-to-seconds today) + (* 2 7 24 60 60)))) + two-week-len today-len) + (while proj-data + (if (not (timeclock-time-less-p + (timeclock-entry-begin (car proj-data)) today)) + (setq today-len (timeclock-entry-list-length proj-data) + proj-data nil) + (if (and (null two-week-len) + (not (timeclock-time-less-p + (timeclock-entry-begin (car proj-data)) + two-weeks-ago))) + (setq two-week-len (timeclock-entry-list-length proj-data))) + (setq proj-data (cdr proj-data)))) + (if (null two-week-len) + (setq two-week-len today-len)) + (if html-p (insert "<p>")) + (insert "\nTime spent on this task today: " + (timeclock-seconds-to-string today-len) + ". In the last two weeks: " + (timeclock-seconds-to-string two-week-len)) + (if html-p (insert "<br>")) + (insert "\n" + (timeclock-seconds-to-string (timeclock-workday-elapsed)) + " worked today, " + (timeclock-seconds-to-string (timeclock-workday-remaining)) + " remaining, done at " + (timeclock-when-to-leave-string) "\n"))) + (if html-p (insert "<p>")) + (insert "\nThere have been " + (number-to-string + (length (timeclock-day-alist log))) + " days of activity, starting " + (caar (last (timeclock-day-alist log)))) + (if html-p (insert "</p>")) + (when html-p + (insert "<p> +<table> +<td width=\"25\"><br></td><td> +<table border=1 cellpadding=3> +<tr><th><i>Statistics</i></th> + <th>Entire</th> + <th>-30 days</th> + <th>-3 mons</th> + <th>-6 mons</th> + <th>-1 year</th> +</tr>") + (let* ((day-list (timeclock-day-list)) + (thirty-days-ago (timeclock-seconds-to-time + (- (timeclock-time-to-seconds today) + (* 30 24 60 60)))) + (three-months-ago (timeclock-seconds-to-time + (- (timeclock-time-to-seconds today) + (* 90 24 60 60)))) + (six-months-ago (timeclock-seconds-to-time + (- (timeclock-time-to-seconds today) + (* 180 24 60 60)))) + (one-year-ago (timeclock-seconds-to-time + (- (timeclock-time-to-seconds today) + (* 365 24 60 60)))) + (time-in (vector (list t) (list t) (list t) (list t) (list t))) + (time-out (vector (list t) (list t) (list t) (list t) (list t))) + (breaks (vector (list t) (list t) (list t) (list t) (list t))) + (workday (vector (list t) (list t) (list t) (list t) (list t))) + (lengths (vector '(0 0) thirty-days-ago three-months-ago + six-months-ago one-year-ago))) + ;; collect statistics from complete timelog + (while day-list + (let ((i 0) (l 5)) + (while (< i l) + (unless (timeclock-time-less-p + (timeclock-day-begin (car day-list)) + (aref lengths i)) + (let ((base (timeclock-time-to-seconds + (timeclock-day-base + (timeclock-day-begin (car day-list)))))) + (nconc (aref time-in i) + (list (- (timeclock-time-to-seconds + (timeclock-day-begin (car day-list))) + base))) + (let ((span (timeclock-day-span (car day-list))) + (len (timeclock-day-length (car day-list))) + (req (timeclock-day-required (car day-list)))) + ;; If the day's actual work length is less than + ;; 70% of its span, then likely the exit time + ;; and break amount are not worthwhile adding to + ;; the statistic + (when (and (> span 0) + (> (/ (float len) (float span)) 0.70)) + (nconc (aref time-out i) + (list (- (timeclock-time-to-seconds + (timeclock-day-end (car day-list))) + base))) + (nconc (aref breaks i) (list (- span len)))) + (if req + (setq len (+ len (- timeclock-workday req)))) + (nconc (aref workday i) (list len))))) + (setq i (1+ i)))) + (setq day-list (cdr day-list))) + ;; average statistics + (let ((i 0) (l 5)) + (while (< i l) + (aset time-in i (timeclock-geometric-mean + (cdr (aref time-in i)))) + (aset time-out i (timeclock-geometric-mean + (cdr (aref time-out i)))) + (aset breaks i (timeclock-geometric-mean + (cdr (aref breaks i)))) + (aset workday i (timeclock-geometric-mean + (cdr (aref workday i)))) + (setq i (1+ i)))) + ;; Output the HTML table + (insert "<tr>\n") + (insert "<td align=\"center\">Time in</td>\n") + (let ((i 0) (l 5)) + (while (< i l) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref time-in i)) + "</td>\n") + (setq i (1+ i)))) + (insert "</tr>\n") + + (insert "<tr>\n") + (insert "<td align=\"center\">Time out</td>\n") + (let ((i 0) (l 5)) + (while (< i l) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref time-out i)) + "</td>\n") + (setq i (1+ i)))) + (insert "</tr>\n") + + (insert "<tr>\n") + (insert "<td align=\"center\">Break</td>\n") + (let ((i 0) (l 5)) + (while (< i l) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref breaks i)) + "</td>\n") + (setq i (1+ i)))) + (insert "</tr>\n") + + (insert "<tr>\n") + (insert "<td align=\"center\">Workday</td>\n") + (let ((i 0) (l 5)) + (while (< i l) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref workday i)) + "</td>\n") + (setq i (1+ i)))) + (insert "</tr>\n")) + (insert "<tfoot> +<td colspan=\"6\" align=\"center\"> + <i>These are approximate figures</i></td> +</tfoot> +</table> +</td></table>"))))) + +;;; A helpful little function + +(defun timeclock-visit-timelog () + "Open up the .timelog file in another window." + (interactive) + (find-file-other-window timeclock-file)) (provide 'timeclock)