From mboxrd@z Thu Jan 1 00:00:00 1970 From: Erwin Vrolijk Subject: [PATCH] Quarters added to clocktables Date: Fri, 19 Nov 2010 14:00:21 +0100 Message-ID: <4CE674E5.3080204@snow.nl> Mime-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1; format=flowed Content-Transfer-Encoding: 7bit Return-path: Received: from [140.186.70.92] (port=52357 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PJQZn-0008Gm-KM for emacs-orgmode@gnu.org; Fri, 19 Nov 2010 08:00:29 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1PJQZl-0006YN-Rp for emacs-orgmode@gnu.org; Fri, 19 Nov 2010 08:00:27 -0500 Received: from mx.snow.nl ([213.154.248.146]:35772) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1PJQZl-0006XP-G6 for emacs-orgmode@gnu.org; Fri, 19 Nov 2010 08:00:25 -0500 Received: from imap.snow.nl (unknown [213.154.248.156]) by mx.snow.nl (Postfix) with ESMTP id 5B9E8403E5 for ; Fri, 19 Nov 2010 14:00:22 +0100 (CET) Received: from scn-lan12.snowcn.snow.nl (scn-lan12.snowcn.snow.nl [10.9.8.32]) by imap.snow.nl (Postfix) with ESMTP id 4158C2004BA for ; Fri, 19 Nov 2010 14:00:22 +0100 (CET) List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Sender: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org To: emacs-orgmode@gnu.org Hi, I'm proud to present my first patch to orgmode. With this patch quarters are added to clocktables. It is now possible to show data for a quarter via the following syntax: :block thisq[-n] or :block lastq :block 2010-Q2 Other places where quarters might be handy (for instance repeating events quarterly) are still todo. I've patched two files, the main file lisp/org-clock.el and the documentation in doc/org.texti Regards, Erwin Vrolijk http://snow.nl diff --git a/doc/org.texi b/doc/org.texi index 06583d7..5f07dbd 100644 --- a/doc/org.texi +++ b/doc/org.texi @@ -5820,6 +5820,7 @@ be selected: 2007-12-31 @r{New year eve 2007} 2007-12 @r{December 2007} 2007-W50 @r{ISO-week 50 in 2007} + 2007-Q2 @r{2nd quarter in 2007} 2007 @r{the year 2007} today, yesterday, today-@var{N} @r{a relative day} thisweek, lastweek, thisweek-@var{N} @r{a relative week} diff --git a/lisp/org-clock.el b/lisp/org-clock.el index 3146926..1301fb8 100644 --- a/lisp/org-clock.el +++ b/lisp/org-clock.el @@ -1653,6 +1653,64 @@ buffer and update it." (re-search-forward "^[ \t]+#\\+END:.*" nil t) (>= (match-end 0) pos) start)))) +(defun org-day-of-week (day month year) + "Returns the day of the week as an integer." + (nth 6 + (decode-time + (date-to-time + (format "%d-%02d-%02dT00:00:00" year month day))))) + +(defun org-quarter-to-date (quarter year) + "Get the date (week day year) of the first day of a given quarter." + (cond + ((= quarter 1) + (setq startday (org-day-of-week 1 1 year)) + (cond + ((= startday 0) + (list 52 7 (- year 1))) + ((= startday 6) + (list 52 6 (- year 1))) + ((<= startday 4) + (list 1 startday year)) + ((> startday 4) + (list 53 startday (- year 1))) + ) + ) + ((= quarter 2) + (setq startday (org-day-of-week 1 4 year)) + (cond + ((= startday 0) + (list 13 startday year)) + ((< startday 4) + (list 14 startday year)) + ((>= startday 4) + (list 13 startday year)) + ) + ) + ((= quarter 3) + (setq startday (org-day-of-week 1 7 year)) + (cond + ((= startday 0) + (list 26 startday year)) + ((< startday 4) + (list 27 startday year)) + ((>= startday 4) + (list 26 startday year)) + ) + ) + ((= quarter 4) + (setq startday (org-day-of-week 1 10 year)) + (cond + ((= startday 0) + (list 39 startday year)) + ((<= startday 4) + (list 40 startday year)) + ((> startday 4) + (list 39 startday year)) + ) + ) + ) + ) (defun org-clock-special-range (key &optional time as-strings) "Return two times bordering a special time range. @@ -1670,6 +1728,10 @@ the returned times will be formatted strings." (dow (nth 6 tm)) (skey (symbol-name key)) (shift 0) + (q (cond ((>= (nth 4 tm) 10) 4) + ((>= (nth 4 tm) 7) 3) + ((>= (nth 4 tm) 4) 2) + ((>= (nth 4 tm) 1) 1))) s1 m1 h1 d1 month1 y1 diff ts te fm txt w date) (cond ((string-match "^[0-9]+$" skey) @@ -1687,19 +1749,35 @@ the returned times will be formatted strings." (setq d (nth 1 date) month (car date) y (nth 2 date) dow 1 key 'week)) + ((string-match "^\\([0-9]+\\)-[qQ]\\([1-4]\\)$" skey) + (require 'cal-iso) + (setq y (string-to-number (match-string 1 skey))) + (setq q (string-to-number (match-string 2 skey))) + (setq date (calendar-gregorian-from-absolute + (calendar-absolute-from-iso (org-quarter-to-date q y)))) + (setq d (nth 1 date) month (car date) y (nth 2 date) + dow 1 + key 'quarter)) ((string-match "^\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)-\\([0-9]\\{1,2\\}\\)$" skey) (setq y (string-to-number (match-string 1 skey)) month (string-to-number (match-string 2 skey)) d (string-to-number (match-string 3 skey)) key 'day)) + ; looking forward with quarters is not implemented yet. +; ((string-match "\\(\\(?:[-]\\|\\(?:!q\\)[+]\\)[0-9]+\\)$" skey) ((string-match "\\([-+][0-9]+\\)$" skey) (setq shift (string-to-number (match-string 1 skey)) - key (intern (substring skey 0 (match-beginning 1)))))) + key (intern (substring skey 0 (match-beginning 1)))) + (if(and (memq key '(quarter thisq)) (> shift 0)) + (error "Looking forward with quarters isn't implemented.") + ()))) + (when (= shift 0) - (cond ((eq key 'yesterday) (setq key 'today shift -1)) - ((eq key 'lastweek) (setq key 'week shift -1)) - ((eq key 'lastmonth) (setq key 'month shift -1)) - ((eq key 'lastyear) (setq key 'year shift -1)))) + (cond ((eq key 'yesterday) (setq key 'today shift -1)) + ((eq key 'lastweek) (setq key 'week shift -1)) + ((eq key 'lastmonth) (setq key 'month shift -1)) + ((eq key 'lastyear) (setq key 'year shift -1)) + ((eq key 'lastq) (setq key 'quarter shift -1)))) (cond ((memq key '(day today)) (setq d (+ d shift) h 0 m 0 h1 24 m1 0)) @@ -1708,6 +1786,29 @@ the returned times will be formatted strings." m 0 h 0 d (- d diff) d1 (+ 7 d))) ((memq key '(month thismonth)) (setq d 1 h 0 m 0 d1 1 month (+ month shift) month1 (1+ month) h1 0 m1 0)) + ((memq key '(quarter thisq)) + ; compute if this shift remains in this year + ; if not, compute how many years and quarters we have to shift (via floor*) + ; and compute the shifted years, months and quarters + (cond + ((< (+ (- q 1) shift) 0) ; shift not in this year + (setq interval (* -1 (+ (- q 1) shift))) + ; set tmp to ((years to shift) (quarters to shift)) + (setq tmp (floor* interval 4)) + ; due to the use of floor, 0 quarters actually means 4 + (if (= 0 (nth 1 tmp)) + (setq shiftedy (- y (nth 0 tmp)) + shiftedm 1 + shiftedq 1) + (setq shiftedy (- y (+ 1 (nth 0 tmp))) + shiftedm (- 13 (* 3 (nth 1 tmp))) + shiftedq (- 5 (nth 1 tmp)))) + (setq d 1 h 0 m 0 d1 1 month shiftedm month1 (+ 3 shiftedm) h1 0 m1 0 y shiftedy)) + ((> (+ q shift) 0) ; shift is whitin this year + (setq shiftedq (+ q shift)) + (setq shiftedy y) + (setq d 1 h 0 m 0 d1 1 month (+ 1 (* 3 (- (+ q shift) 1))) month1 (+ 4 (* 3 (- (+ q shift) 1))) h1 0 m1 0)))) + ((memq key '(year thisyear)) (setq m 0 h 0 d 1 month 1 y (+ y shift) y1 (1+ y))) (t (error "No such time block %s" key))) @@ -1723,10 +1824,19 @@ the returned times will be formatted strings." ((memq key '(month thismonth)) (setq txt (format-time-string "%B %Y" ts))) ((memq key '(year thisyear)) - (setq txt (format-time-string "the year %Y" ts)))) + (setq txt (format-time-string "the year %Y" ts))) + ((memq key '(quarter thisq)) + (setq txt (concatenate 'string (org-count-quarter shiftedq) " quarter of " (number-to-string shiftedy)))) + ) (if as-strings (list (format-time-string fm ts) (format-time-string fm te) txt) (list ts te txt)))) +(defun org-count-quarter (n) + (cond + ((= n 1) "1st") + ((= n 2) "2nd") + ((= n 3) "3rd") + ((= n 4) "4th"))) (defun org-clocktable-shift (dir n) "Try to shift the :block date of the clocktable at point. @@ -1750,17 +1860,19 @@ the currently selected interval size." ((equal s "yesterday") (setq s "today-1")) ((equal s "lastweek") (setq s "thisweek-1")) ((equal s "lastmonth") (setq s "thismonth-1")) - ((equal s "lastyear") (setq s "thisyear-1"))) + ((equal s "lastyear") (setq s "thisyear-1")) + ((equal s "lastq") (setq s "thisq-1"))) + (cond - ((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\)\\([-+][0-9]+\\)?$" s) + ((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\|thisq\\)\\([-+][0-9]+\\)?$" s) (setq block (match-string 1 s) shift (if (match-end 2) (string-to-number (match-string 2 s)) 0)) (setq shift (+ shift n)) (setq ins (if (= shift 0) block (format "%s%+d" block shift)))) - ((string-match "\\([0-9]+\\)\\(-\\([wW]?\\)\\([0-9]\\{1,2\\}\\)\\(-\\([0-9]\\{1,2\\}\\)\\)?\\)?" s) - ;; 1 1 2 3 3 4 4 5 6 6 5 2 + ((string-match "\\([0-9]+\\)\\(-\\([wWqQ]?\\)\\([0-9]\\{1,2\\}\\)\\(-\\([0-9]\\{1,2\\}\\)\\)?\\)?" s) + ;; 1 1 2 3 3 4 4 5 6 6 5 2 (setq y (string-to-number (match-string 1 s)) wp (and (match-end 3) (match-string 3 s)) mw (and (match-end 4) (string-to-number (match-string 4 s))) @@ -1769,12 +1881,28 @@ the currently selected interval size." (d (setq ins (format-time-string "%Y-%m-%d" (encode-time 0 0 0 (+ d n) m y)))) - ((and wp mw (> (length wp) 0)) + ((and wp (string-match "w\\|W" wp) mw (> (length wp) 0)) (require 'cal-iso) (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (list (+ mw n) 1 y)))) (setq ins (format-time-string "%G-W%V" (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date))))) + ((and wp (string-match "q\\|Q" wp) mw (> (length wp) 0)) + (require 'cal-iso) + ; if the 4th + 1 quarter is requested we flip to the 1st quarter of the next year + (if (> (+ mw n) 4) + (setq mw 0 + y (+ 1 y)) + ()) + ; if the 1st - 1 quarter is requested we flip to the 4th quarter of the previous year + (if (= (+ mw n) 0) + (setq mw 5 + y (- y 1)) + ()) + (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (org-quarter-to-date (+ mw n) y)))) + (setq ins (format-time-string + (concatenate 'string (number-to-string y) "-Q" (number-to-string (+ mw n))) + (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date))))) (mw (setq ins (format-time-string "%Y-%m"