* [PATCH] Quarters added to clocktables
@ 2010-11-19 13:00 Erwin Vrolijk
2010-11-27 7:09 ` Carsten Dominik
0 siblings, 1 reply; 5+ messages in thread
From: Erwin Vrolijk @ 2010-11-19 13:00 UTC (permalink / raw)
To: emacs-orgmode
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"
^ permalink raw reply related [flat|nested] 5+ messages in thread
* Re: [PATCH] Quarters added to clocktables
2010-11-19 13:00 [PATCH] Quarters added to clocktables Erwin Vrolijk
@ 2010-11-27 7:09 ` Carsten Dominik
2010-11-29 9:22 ` Erwin Vrolijk
0 siblings, 1 reply; 5+ messages in thread
From: Carsten Dominik @ 2010-11-27 7:09 UTC (permalink / raw)
To: Erwin Vrolijk; +Cc: emacs-orgmode
Hi Erwin,
this patch looks good. However, it does not apply cleanly to the
current head, and I need to ask you to sign the FSF papers for it.
Are you willing to do this?
Thanks
- Carsten
On Nov 19, 2010, at 2:00 PM, Erwin Vrolijk wrote:
> 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"
>
>
> _______________________________________________
> Emacs-orgmode mailing list
> Please use `Reply All' to send replies to the list.
> Emacs-orgmode@gnu.org
> http://lists.gnu.org/mailman/listinfo/emacs-orgmode
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [PATCH] Quarters added to clocktables
2010-11-27 7:09 ` Carsten Dominik
@ 2010-11-29 9:22 ` Erwin Vrolijk
2010-11-29 9:39 ` Carsten Dominik
2010-11-29 10:29 ` Carsten Dominik
0 siblings, 2 replies; 5+ messages in thread
From: Erwin Vrolijk @ 2010-11-29 9:22 UTC (permalink / raw)
To: Carsten Dominik; +Cc: emacs-orgmode
Hi Carsten,
Thank you for your feedback. The FSF papers are no problem, i've already
got them by mail.
Here are the new patches, patched to the current HEAD.
Regards,
Erwin Vrolijk
Snow B.V.
diff --git a/doc/org.texi b/doc/org.texi
index 17d6e65..a4073d0 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 e798027..a7c4a97 100644
--- a/lisp/org-clock.el
+++ b/lisp/org-clock.el
@@ -1654,6 +1654,65 @@ buffer and update it."
(>= (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.
Key is a symbol specifying the range and can be one of `today',
`yesterday',
@@ -1670,6 +1729,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,6 +1750,15 @@ 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))
@@ -1694,12 +1766,17 @@ the returned times will be formatted strings."
key 'day))
((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 +1785,28 @@ 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,11 +1822,21 @@ 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.
Point must be in the #+BEGIN: line of a clocktable, or this function
@@ -1750,45 +1859,63 @@ 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")))
- (cond
- ((string-match
"^\\(today\\|thisweek\\|thismonth\\|thisyear\\)\\([-+][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
- (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)))
- d (and (match-end 6) (string-to-number (match-string 6 s))))
- (cond
- (d (setq ins (format-time-string
- "%Y-%m-%d"
- (encode-time 0 0 0 (+ d n) m y))))
- ((and 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)))))
- (mw
- (setq ins (format-time-string
- "%Y-%m"
- (encode-time 0 0 0 1 (+ mw n) y))))
- (y
- (setq ins (number-to-string (+ y n))))))
- (t (error "Cannot shift clocktable block")))
- (when ins
- (goto-char b)
- (insert ins)
- (delete-region (point) (+ (point) (- e b)))
- (beginning-of-line 1)
- (org-update-dblock)
- t)))))
+ ((equal s "lastyear") (setq s "thisyear-1"))
+ ((equal s "lastq") (setq s "thisq-1")))
+
+ (cond
+ ((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]+\\)\\(-\\([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)))
+ d (and (match-end 6) (string-to-number (match-string 6 s))))
+ (cond
+ (d (setq ins (format-time-string
+ "%Y-%m-%d"
+ (encode-time 0 0 0 (+ d n) m y))))
+ ((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"
+ (encode-time 0 0 0 1 (+ mw n) y))))
+ (y
+ (setq ins (number-to-string (+ y n))))))
+ (t (error "Cannot shift clocktable block")))
+ (when ins
+ (goto-char b)
+ (insert ins)
+ (delete-region (point) (+ (point) (- e b)))
+ (beginning-of-line 1)
+ (org-update-dblock)
+ t)))))
(defun org-dblock-write:clocktable (params)
"Write the standard clocktable."
Carsten Dominik wrote:
> Hi Erwin,
>
> this patch looks good. However, it does not apply cleanly to the
> current head, and I need to ask you to sign the FSF papers for it.
> Are you willing to do this?
>
> Thanks
>
> - Carsten
>
> On Nov 19, 2010, at 2:00 PM, Erwin Vrolijk wrote:
>
>> 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"
>>
>>
>> _______________________________________________
>> Emacs-orgmode mailing list
>> Please use `Reply All' to send replies to the list.
>> Emacs-orgmode@gnu.org
>> http://lists.gnu.org/mailman/listinfo/emacs-orgmode
>
^ permalink raw reply related [flat|nested] 5+ messages in thread
* Re: [PATCH] Quarters added to clocktables
2010-11-29 9:22 ` Erwin Vrolijk
@ 2010-11-29 9:39 ` Carsten Dominik
2010-11-29 10:29 ` Carsten Dominik
1 sibling, 0 replies; 5+ messages in thread
From: Carsten Dominik @ 2010-11-29 9:39 UTC (permalink / raw)
To: Erwin Vrolijk; +Cc: emacs-orgmode
Hi Erwin,
I cannot get the patch to apply, probably because the mailer is
destroying it.
Can you please put the patch into a file and send it to me as an
attachment?
Thanks.
- Carsten
On Nov 29, 2010, at 10:22 AM, Erwin Vrolijk wrote:
> Hi Carsten,
>
> Thank you for your feedback. The FSF papers are no problem, i've
> already got them by mail.
> Here are the new patches, patched to the current HEAD.
>
> Regards,
> Erwin Vrolijk
> Snow B.V.
>
> diff --git a/doc/org.texi b/doc/org.texi
> index 17d6e65..a4073d0 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 e798027..a7c4a97 100644
> --- a/lisp/org-clock.el
> +++ b/lisp/org-clock.el
> @@ -1654,6 +1654,65 @@ buffer and update it."
> (>= (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.
> Key is a symbol specifying the range and can be one of `today',
> `yesterday',
> @@ -1670,6 +1729,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,6 +1750,15 @@ 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))
> @@ -1694,12 +1766,17 @@ the returned times will be formatted strings."
> key 'day))
> ((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 +1785,28 @@ 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,11 +1822,21 @@ 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.
> Point must be in the #+BEGIN: line of a clocktable, or this function
> @@ -1750,45 +1859,63 @@ 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")))
> - (cond
> - ((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\)\
> \([-+][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
> - (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)))
> - d (and (match-end 6) (string-to-number (match-string 6 s))))
> - (cond
> - (d (setq ins (format-time-string
> - "%Y-%m-%d"
> - (encode-time 0 0 0 (+ d n) m y))))
> - ((and 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)))))
> - (mw
> - (setq ins (format-time-string
> - "%Y-%m"
> - (encode-time 0 0 0 1 (+ mw n) y))))
> - (y
> - (setq ins (number-to-string (+ y n))))))
> - (t (error "Cannot shift clocktable block")))
> - (when ins
> - (goto-char b)
> - (insert ins)
> - (delete-region (point) (+ (point) (- e b)))
> - (beginning-of-line 1)
> - (org-update-dblock)
> - t)))))
> + ((equal s "lastyear") (setq s "thisyear-1"))
> + ((equal s "lastq") (setq s "thisq-1")))
> +
> + (cond
> + ((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]+\\)\\(-\\([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)))
> + d (and (match-end 6) (string-to-number (match-string 6
> s))))
> + (cond
> + (d (setq ins (format-time-string
> + "%Y-%m-%d"
> + (encode-time 0 0 0 (+ d n) m y))))
> + ((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"
> + (encode-time 0 0 0 1 (+ mw n) y))))
> + (y
> + (setq ins (number-to-string (+ y n))))))
> + (t (error "Cannot shift clocktable block")))
> + (when ins
> + (goto-char b)
> + (insert ins)
> + (delete-region (point) (+ (point) (- e b)))
> + (beginning-of-line 1)
> + (org-update-dblock)
> + t)))))
> (defun org-dblock-write:clocktable (params)
> "Write the standard clocktable."
>
>
>
> Carsten Dominik wrote:
>> Hi Erwin,
>>
>> this patch looks good. However, it does not apply cleanly to the
>> current head, and I need to ask you to sign the FSF papers for it.
>> Are you willing to do this?
>>
>> Thanks
>>
>> - Carsten
>>
>> On Nov 19, 2010, at 2:00 PM, Erwin Vrolijk wrote:
>>
>>> 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"
>>>
>>>
>>> _______________________________________________
>>> Emacs-orgmode mailing list
>>> Please use `Reply All' to send replies to the list.
>>> Emacs-orgmode@gnu.org
>>> http://lists.gnu.org/mailman/listinfo/emacs-orgmode
>>
>
- Carsten
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [PATCH] Quarters added to clocktables
2010-11-29 9:22 ` Erwin Vrolijk
2010-11-29 9:39 ` Carsten Dominik
@ 2010-11-29 10:29 ` Carsten Dominik
1 sibling, 0 replies; 5+ messages in thread
From: Carsten Dominik @ 2010-11-29 10:29 UTC (permalink / raw)
To: Erwin Vrolijk; +Cc: emacs-orgmode
On Nov 29, 2010, at 10:22 AM, Erwin Vrolijk wrote:
> Hi Carsten,
>
> Thank you for your feedback. The FSF papers are no problem, i've
> already got them by mail.
> Here are the new patches, patched to the current HEAD.
Hi Erwin,
I have applied your patches - please make sure that you complete the
FSF copyright assignment process and keep me up to date on how that is
going.
Thanks!
- Carsten
>
> Regards,
> Erwin Vrolijk
> Snow B.V.
>
> diff --git a/doc/org.texi b/doc/org.texi
> index 17d6e65..a4073d0 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 e798027..a7c4a97 100644
> --- a/lisp/org-clock.el
> +++ b/lisp/org-clock.el
> @@ -1654,6 +1654,65 @@ buffer and update it."
> (>= (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.
> Key is a symbol specifying the range and can be one of `today',
> `yesterday',
> @@ -1670,6 +1729,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,6 +1750,15 @@ 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))
> @@ -1694,12 +1766,17 @@ the returned times will be formatted strings."
> key 'day))
> ((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 +1785,28 @@ 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,11 +1822,21 @@ 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.
> Point must be in the #+BEGIN: line of a clocktable, or this function
> @@ -1750,45 +1859,63 @@ 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")))
> - (cond
> - ((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\)\
> \([-+][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
> - (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)))
> - d (and (match-end 6) (string-to-number (match-string 6 s))))
> - (cond
> - (d (setq ins (format-time-string
> - "%Y-%m-%d"
> - (encode-time 0 0 0 (+ d n) m y))))
> - ((and 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)))))
> - (mw
> - (setq ins (format-time-string
> - "%Y-%m"
> - (encode-time 0 0 0 1 (+ mw n) y))))
> - (y
> - (setq ins (number-to-string (+ y n))))))
> - (t (error "Cannot shift clocktable block")))
> - (when ins
> - (goto-char b)
> - (insert ins)
> - (delete-region (point) (+ (point) (- e b)))
> - (beginning-of-line 1)
> - (org-update-dblock)
> - t)))))
> + ((equal s "lastyear") (setq s "thisyear-1"))
> + ((equal s "lastq") (setq s "thisq-1")))
> +
> + (cond
> + ((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]+\\)\\(-\\([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)))
> + d (and (match-end 6) (string-to-number (match-string 6
> s))))
> + (cond
> + (d (setq ins (format-time-string
> + "%Y-%m-%d"
> + (encode-time 0 0 0 (+ d n) m y))))
> + ((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"
> + (encode-time 0 0 0 1 (+ mw n) y))))
> + (y
> + (setq ins (number-to-string (+ y n))))))
> + (t (error "Cannot shift clocktable block")))
> + (when ins
> + (goto-char b)
> + (insert ins)
> + (delete-region (point) (+ (point) (- e b)))
> + (beginning-of-line 1)
> + (org-update-dblock)
> + t)))))
> (defun org-dblock-write:clocktable (params)
> "Write the standard clocktable."
>
>
>
> Carsten Dominik wrote:
>> Hi Erwin,
>>
>> this patch looks good. However, it does not apply cleanly to the
>> current head, and I need to ask you to sign the FSF papers for it.
>> Are you willing to do this?
>>
>> Thanks
>>
>> - Carsten
>>
>> On Nov 19, 2010, at 2:00 PM, Erwin Vrolijk wrote:
>>
>>> 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"
>>>
>>>
>>> _______________________________________________
>>> Emacs-orgmode mailing list
>>> Please use `Reply All' to send replies to the list.
>>> Emacs-orgmode@gnu.org
>>> http://lists.gnu.org/mailman/listinfo/emacs-orgmode
>>
>
- Carsten
^ permalink raw reply [flat|nested] 5+ messages in thread
end of thread, other threads:[~2010-11-29 10:29 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2010-11-19 13:00 [PATCH] Quarters added to clocktables Erwin Vrolijk
2010-11-27 7:09 ` Carsten Dominik
2010-11-29 9:22 ` Erwin Vrolijk
2010-11-29 9:39 ` Carsten Dominik
2010-11-29 10:29 ` Carsten Dominik
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).