[PATCH] Add Quarterly option to standard-reports/transaction.scm
Edward J. Huff
ejhuff at huff20may77.us
Wed May 4 12:54:44 EDT 2005
Add "Quarterly" option to standard-reports/transaction.scm.
Add support functions to app-utils.scm and date-utilities.scm
to support finding the quarter of a given date, and to
format it as Q1, Q2, Q3, or Q4. Fix a bug in the as-yet-unused
function gnc:timepair-get-month-day. Make use of the existing
support functions instead of re-inventing them in transaction.scm.
Move all uses of strftime from transaction.scm to date-utilities.scm.
app-utils/app-utils.scm and app-utils/date-utilities.scm
(gnc:date-get-quarter) new exported function
(gnc:timepair-get-quarter) new exported function
(gnc:timepair-get-month-day) fix bug
(gnc:date-get-year-string) new exported function
(gnc:date-get-quarter-string) new exported function
(gnc:date-get-quarter-year-string) new exported function
(gnc:date-get-month-year-string) new exported function
standard-reports/transaction.scm
(timepair-same-year) use gnc:timepair-get-year
(timepair-same-quarter) new function
(timepair-same-month) use gnc:timepair-get-month
(split-same-quarter-p) new function
(render-month-subheading) use gnc:date-get-month-year-string
(render-quarter-subheading) new function
(render-year-subheading) use gnc:date-get-year-string
(render-month-subtotal) use gnc:date-get-month-year-string
(render-quarter-subtotal) new function
(render-year-subtotal) use gnc:date-get-year-string
(trep-options-generator) in date-comp-funcs-assoc-list add 'quarterly vector
Index: src/app-utils/app-utils.scm
===================================================================
RCS file: /home/cvs/cvsroot/gnucash/src/app-utils/app-utils.scm,v
retrieving revision 1.24
diff -u -r1.24 app-utils.scm
--- src/app-utils/app-utils.scm 15 Jan 2004 23:41:26 -0000 1.24
+++ src/app-utils/app-utils.scm 3 May 2005 17:30:12 -0000
@@ -137,16 +137,22 @@
(export gnc:timepair->date)
(export gnc:date->timepair)
(export gnc:date-get-year)
+(export gnc:date-get-quarter)
(export gnc:date-get-month-day)
(export gnc:date-get-month)
(export gnc:date-get-week-day)
(export gnc:date-get-year-day)
(export gnc:timepair-get-year)
+(export gnc:timepair-get-quarter)
(export gnc:timepair-get-month-day)
(export gnc:timepair-get-month)
(export gnc:timepair-get-week-day)
(export gnc:timepair-get-year-day)
+(export gnc:date-get-year-string)
+(export gnc:date-get-quarter-string)
+(export gnc:date-get-quarter-year-string)
(export gnc:date-get-month-string)
+(export gnc:date-get-month-year-string)
(export gnc:leap-year?)
(export gnc:days-in-year)
(export gnc:days-in-month)
Index: src/app-utils/date-utilities.scm
===================================================================
RCS file: /home/cvs/cvsroot/gnucash/src/app-utils/date-utilities.scm,v
retrieving revision 1.5
diff -u -r1.5 date-utilities.scm
--- src/app-utils/date-utilities.scm 5 Apr 2003 04:18:15 -0000 1.5
+++ src/app-utils/date-utilities.scm 3 May 2005 17:30:14 -0000
@@ -38,6 +38,8 @@
;; get stuff from localtime date vector
(define (gnc:date-get-year datevec)
(+ 1900 (tm:year datevec)))
+(define (gnc:date-get-quarter datevec)
+ (+ (quotient (tm:mon datevec) 3) 1))
(define (gnc:date-get-month-day datevec)
(tm:mday datevec))
;; get month with january==1
@@ -53,8 +55,11 @@
(define (gnc:timepair-get-year tp)
(gnc:date-get-year (gnc:timepair->date tp)))
+(define (gnc:timepair-get-quarter tp)
+ (gnc:date-get-quarter (gnc:timepair->date tp)))
+
(define (gnc:timepair-get-month-day tp)
- (gnc:date-get-month (gnc:timepair->date tp)))
+ (gnc:date-get-month-day (gnc:timepair->date tp)))
(define (gnc:timepair-get-month tp)
(gnc:date-get-month (gnc:timepair->date tp)))
@@ -65,9 +70,24 @@
(define (gnc:timepair-get-year-day tp)
(gnc:date-get-year-day (gnc:timepair->date tp)))
+(define (gnc:date-get-year-string datevec)
+ (strftime "%Y" datevec))
+
+(define (gnc:date-get-quarter-string datevec)
+ (sprintf #f "Q%d" (gnc:date-get-quarter datevec)))
+
+(define (gnc:date-get-quarter-year-string datevec)
+ (string-append
+ (gnc:date-get-quarter-string datevec)
+ " "
+ (gnc:date-get-year-string datevec)))
+
(define (gnc:date-get-month-string datevec)
(strftime "%B" datevec))
+(define (gnc:date-get-month-year-string datevec)
+ (strftime "%B %Y" datevec))
+
;; is leap year?
(define (gnc:leap-year? year)
(if (= (remainder year 4) 0)
Index: src/report/standard-reports/transaction.scm
===================================================================
RCS file: /home/cvs/cvsroot/gnucash/src/report/standard-reports/transaction.scm,v
retrieving revision 1.21
diff -u -r1.21 transaction.scm
--- src/report/standard-reports/transaction.scm 14 Jul 2004 15:30:16 -0000 1.21
+++ src/report/standard-reports/transaction.scm 3 May 2005 17:30:24 -0000
@@ -81,19 +81,29 @@
(= (gnc:split-compare-other-account-codes a b) 0))
(define (timepair-same-year tp-a tp-b)
- (= (tm:year (gnc:timepair->date tp-a))
- (tm:year (gnc:timepair->date tp-b))))
+ (= (gnc:timepair-get-year tp-a)
+ (gnc:timepair-get-year tp-b)))
+
+(define (timepair-same-quarter tp-a tp-b)
+ (and (timepair-same-year tp-a tp-b)
+ (= (gnc:timepair-get-quarter tp-a)
+ (gnc:timepair-get-quarter tp-b))))
(define (timepair-same-month tp-a tp-b)
(and (timepair-same-year tp-a tp-b)
- (= (tm:mon (gnc:timepair->date tp-a))
- (tm:mon (gnc:timepair->date tp-b)))))
+ (= (gnc:timepair-get-month tp-a)
+ (gnc:timepair-get-month tp-b))))
(define (split-same-month-p a b)
(let ((tp-a (gnc:transaction-get-date-posted (gnc:split-get-parent a)))
(tp-b (gnc:transaction-get-date-posted (gnc:split-get-parent b))))
(timepair-same-month tp-a tp-b)))
+(define (split-same-quarter-p a b)
+ (let ((tp-a (gnc:transaction-get-date-posted (gnc:split-get-parent a)))
+ (tp-b (gnc:transaction-get-date-posted (gnc:split-get-parent b))))
+ (timepair-same-quarter tp-a tp-b)))
+
(define (split-same-year-p a b)
(let ((tp-a (gnc:transaction-get-date-posted (gnc:split-get-parent a)))
(tp-b (gnc:transaction-get-date-posted (gnc:split-get-parent b))))
@@ -158,15 +168,24 @@
table width subheading-style)))
(define (render-month-subheading split table width subheading-style column-vector)
- (let ((tm (gnc:timepair->date (gnc:transaction-get-date-posted
- (gnc:split-get-parent split)))))
- (add-subheading-row (strftime "%B %Y" tm)
- table width subheading-style)))
+ (add-subheading-row (gnc:date-get-month-year-string
+ (gnc:timepair->date
+ (gnc:transaction-get-date-posted
+ (gnc:split-get-parent split))))
+ table width subheading-style))
+
+(define (render-quarter-subheading split table width subheading-style column-vector)
+ (add-subheading-row (gnc:date-get-quarter-year-string
+ (gnc:timepair->date
+ (gnc:transaction-get-date-posted
+ (gnc:split-get-parent split))))
+ table width subheading-style))
(define (render-year-subheading split table width subheading-style column-vector)
- (add-subheading-row (strftime "%Y" (gnc:timepair->date
- (gnc:transaction-get-date-posted
- (gnc:split-get-parent split))))
+ (add-subheading-row (gnc:date-get-year-string
+ (gnc:timepair->date
+ (gnc:transaction-get-date-posted
+ (gnc:split-get-parent split))))
table width subheading-style))
@@ -227,16 +246,25 @@
(let ((tm (gnc:timepair->date (gnc:transaction-get-date-posted
(gnc:split-get-parent split)))))
(add-subtotal-row table width
- (total-string (strftime "%B %Y" tm))
+ (total-string (gnc:date-get-month-year-string tm))
total-collector subtotal-style export?)))
+(define (render-quarter-subtotal
+ table width split total-collector subtotal-style column-vector export?)
+ (let ((tm (gnc:timepair->date (gnc:transaction-get-date-posted
+ (gnc:split-get-parent split)))))
+ (add-subtotal-row table width
+ (total-string (gnc:date-get-quarter-year-string tm))
+ total-collector subtotal-style export?)))
+
+
(define (render-year-subtotal
table width split total-collector subtotal-style column-vector export?)
(let ((tm (gnc:timepair->date (gnc:transaction-get-date-posted
(gnc:split-get-parent split)))))
(add-subtotal-row table width
- (total-string (strftime "%Y" tm))
+ (total-string (gnc:date-get-year-string tm))
total-collector subtotal-style export?)))
@@ -645,6 +673,7 @@
(vector 'none (N_ "None") (N_ "None"))
;;(vector 'weekly (N_ "Weekly") (N_ "Weekly"))
(vector 'monthly (N_ "Monthly") (N_ "Monthly"))
+ (vector 'quarterly (N_ "Quarterly") (N_ "Quarterly"))
(vector 'yearly (N_ "Yearly") (N_ "Yearly")))))
;; primary sorting criterion
@@ -1105,6 +1134,8 @@
(cons 'none (vector #f #f #f))
(cons 'monthly (vector split-same-month-p render-month-subheading
render-month-subtotal))
+ (cons 'quarterly (vector split-same-quarter-p render-quarter-subheading
+ render-quarter-subtotal))
(cons 'yearly (vector split-same-year-p render-year-subheading
render-year-subtotal))))
More information about the gnucash-patches
mailing list