r23027 - gnucash/trunk/src/report - reports: faster versions of category, net-barchart and net-linechart reports
Geert Janssens
gjanssens at code.gnucash.org
Sun Jun 2 06:33:27 EDT 2013
Author: gjanssens
Date: 2013-06-02 06:33:27 -0400 (Sun, 02 Jun 2013)
New Revision: 23027
Trac: http://svn.gnucash.org/trac/changeset/23027
Added:
gnucash/trunk/src/report/report-system/report-collectors.scm
Modified:
gnucash/trunk/src/report/report-system/Makefile.am
gnucash/trunk/src/report/standard-reports/Makefile.am
gnucash/trunk/src/report/standard-reports/category-barchart.scm
gnucash/trunk/src/report/standard-reports/net-barchart.scm
gnucash/trunk/src/report/standard-reports/net-linechart.scm
gnucash/trunk/src/report/standard-reports/test/test-generic-category-report.scm
gnucash/trunk/src/report/standard-reports/test/test-standard-category-report.scm
Log:
reports: faster versions of category, net-barchart and net-linechart reports
Author: Peter Broadbery <p.broadbery at gmail.com>
Modified: gnucash/trunk/src/report/report-system/Makefile.am
===================================================================
--- gnucash/trunk/src/report/report-system/Makefile.am 2013-06-02 10:32:39 UTC (rev 23026)
+++ gnucash/trunk/src/report/report-system/Makefile.am 2013-06-02 10:33:27 UTC (rev 23027)
@@ -62,7 +62,8 @@
gncmodscm_DATA = \
collectors.scm \
- list-extras.scm
+ list-extras.scm \
+ report-collectors.scm
gncscmmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash/report/
Added: gnucash/trunk/src/report/report-system/report-collectors.scm
===================================================================
--- gnucash/trunk/src/report/report-system/report-collectors.scm (rev 0)
+++ gnucash/trunk/src/report/report-system/report-collectors.scm 2013-06-02 10:33:27 UTC (rev 23027)
@@ -0,0 +1,198 @@
+(define-module (gnucash report report-system report-collectors))
+
+(use-modules (gnucash gnc-module))
+(gnc:module-load "gnucash/report/report-system" 0)
+
+(use-modules (ice-9 format))
+(use-modules (srfi srfi-1))
+
+(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
+(use-modules (gnucash printf))
+(use-modules (gnucash report report-system))
+(use-modules (gnucash app-utils))
+(use-modules (gnucash engine))
+(use-modules (sw_engine))
+(use-modules (gnucash report report-system collectors))
+(use-modules (gnucash report report-system list-extras))
+
+(export account-destination-alist)
+(export category-by-account-report)
+(export make-gnc-collector-collector)
+
+(export splits-up-to)
+(export split->commodity)
+
+(define (split->commodity split)
+ (xaccAccountGetCommodity (xaccSplitGetAccount split)))
+
+(define (split->date split)
+ (xaccTransGetDate (xaccSplitGetParent split)))
+
+(define (splits-up-to accounts startdate enddate)
+ (gnc:account-get-trans-type-splits-interval accounts #f
+ startdate
+ enddate))
+
+(define (make-gnc-collector-collector)
+ (let ((gnc-collector (gnc:make-commodity-collector)))
+ (define collector
+ (make-collector (lambda (split)
+ (let* ((shares (xaccSplitGetAmount split))
+ (acct-comm (split->commodity split)))
+ (gnc-collector 'add acct-comm shares)
+ collector))
+ (lambda () gnc-collector)))
+ collector))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Plan:
+;; We create reports via collectors - effectively per account, per date stores of values.
+;; Values are held as report-system/collector objects (sorry about the name reuse..),
+;; which can then be evaluated by a collector-reformat step.
+;;
+;; For a given report, we want to retrieve relevant transactions once
+;; (this is the splits-up-to function), and then push the transactions
+;; into a collector structure. This way there's no O(n^2) or worse
+;; complexity.
+
+(define (build-account-collector accounts account-destination-alist
+ split->account
+ per-account-collector)
+ (let ((slotset (slotset-map-input split->account
+ (alist->slotset account-destination-alist))))
+ (collector-from-slotset slotset per-account-collector)))
+
+(define (filter-for-account the-account destination-alist split->account)
+ (let ((wanted-accounts (fold (lambda (pair acc)
+ (if (equal? (cdr pair) the-account)
+ (cons (car pair) acc)
+ acc))
+ '()
+ destination-alist)))
+ (make-filter the-account
+ (lambda (split)
+ (member (split->account split) wanted-accounts)))))
+
+(define (build-date-collector split->date dates per-date-collector)
+ (let* ((date-vector (list->vector dates))
+ (slotset (make-slotset (lambda (split)
+ (let* ((date (split->date split))
+ (interval-index (binary-search-lt (lambda (pair date)
+ (gnc:timepair-le (car pair) date))
+ (cons date 0)
+ date-vector))
+ (interval (vector-ref date-vector interval-index)))
+ interval))
+ dates)))
+ (collector-from-slotset slotset per-date-collector)))
+
+(define (build-category-by-account-collector accounts account-destination-alist dates cell-accumulator result-collector)
+ (build-account-collector accounts account-destination-alist
+ xaccSplitGetAccount
+ (lambda (account)
+ (collector-reformat (lambda (result)
+ (list account (result-collector account result)))
+ (build-date-collector split->date dates
+ (lambda (date)
+ (cell-accumulator account date)))))))
+
+(define (category-by-account-report do-intervals? datepairs account-alist split-collector result-collector progress-range)
+ (if do-intervals?
+ (category-by-account-report-intervals datepairs account-alist split-collector result-collector progress-range)
+ (category-by-account-report-accumulate datepairs account-alist split-collector result-collector progress-range)))
+
+(define (category-by-account-report-intervals datepairs account-alist split-collector result-collector progress-range)
+ (let* ((min-date (car (list-min-max (map first datepairs) gnc:timepair-lt)))
+ (max-date (cdr (list-min-max (map second datepairs) gnc:timepair-lt)))
+ (dest-accounts (collector-add-all (make-eq-set-collector '())
+ (map cdr account-alist)))
+ (splits (splits-up-to (map car account-alist)
+ min-date max-date))
+ (collector (build-category-by-account-collector dest-accounts
+ account-alist datepairs
+ split-collector
+ result-collector)))
+ (collector-add-all (collector-do collector
+ (progress-collector (length splits) progress-range))
+ splits)))
+
+(define (category-by-account-report-accumulate dates account-alist split-collector result-collector progress-range)
+ (let* ((min-date (gnc:secs->timepair 0))
+ (max-date (cdr (list-min-max dates gnc:timepair-lt)))
+ (datepairs (reverse! (cdr (fold (lambda (next acc)
+ (let ((prev (car acc))
+ (pairs-so-far (cdr acc)))
+ (cons next (cons (list prev next) pairs-so-far))))
+ (cons min-date '()) dates))))
+ (dest-accounts (collector-add-all (make-eq-set-collector '())
+ (map cdr account-alist)))
+ (splits (splits-up-to (map car account-alist)
+ min-date max-date))
+ (collector (build-category-by-account-collector dest-accounts account-alist datepairs split-collector
+ result-collector)))
+ (collector-add-all (collector-do collector
+ (progress-collector (length splits) progress-range))
+ splits)))
+
+(define (progress-collector size range)
+ (let* ((from (car range))
+ (to (cdr range))
+ (width (- to from)))
+ (define (count->percentage count)
+ (+ (* width (/ count size)) from))
+ (function-state->collector (lambda (value state)
+ (let ((last (floor (count->percentage (- state 1))))
+ (next (floor (count->percentage state))))
+ (if (not (= last next))
+ (gnc:report-percent-done (+ (* width (/ state size)) from)))
+ (+ state 1)))
+ 0)))
+
+(define (gnc-account-child-accounts-recursive account)
+ (define (helper account initial)
+ (fold (lambda (child-account accumulator)
+ (append (helper child-account (list child-account))
+ accumulator))
+ initial
+ (gnc-account-get-children account)))
+ (helper account '()))
+
+(define (traverse-accounts tree-depth show-acct? account-types)
+ (define (inner-traverse-accounts current-depth accounts)
+ (if (< current-depth tree-depth)
+ (let ((res '()))
+ (for-each
+ (lambda (a)
+ (begin
+ (if (show-acct? a)
+ (set! res
+ (cons (cons a a) res)))
+ (set! res (append
+ (inner-traverse-accounts
+ (+ 1 current-depth)
+ (gnc-account-get-children a))
+ res))))
+ accounts)
+ res)
+ ;; else (i.e. current-depth == tree-depth)
+ (fold (lambda (account acc)
+ (let ((child-accounts (gnc-account-child-accounts-recursive account)))
+ (append (map (lambda (child-account)
+ (cons child-account account))
+ child-accounts)
+ (list (cons account account))
+ acc)))
+ '()
+ (filter show-acct? accounts))))
+ (let* ((topl-accounts (gnc:filter-accountlist-type
+ account-types
+ (gnc-account-get-children-sorted
+ (gnc-get-current-root-account))))
+ (account-head-list (inner-traverse-accounts 1 topl-accounts)))
+ account-head-list))
+
+(define (account-destination-alist accounts account-types tree-depth)
+ (define (show-acct? a)
+ (member a accounts))
+ (traverse-accounts tree-depth show-acct? account-types))
Modified: gnucash/trunk/src/report/standard-reports/Makefile.am
===================================================================
--- gnucash/trunk/src/report/standard-reports/Makefile.am 2013-06-02 10:32:39 UTC (rev 23026)
+++ gnucash/trunk/src/report/standard-reports/Makefile.am 2013-06-02 10:33:27 UTC (rev 23027)
@@ -81,7 +81,7 @@
EXTRA_DIST = ${gncscmmod_DATA} ${gncscmreportmod_DATA}
-CLEANFILES = .scm-links
-DISTCLEANFILES = ${SCM_FILE_LINKS}
+CLEANFILES = .scm-links ${SCM_FILE_LINKS}
+DISTCLEANFILES =
AM_CPPFLAGS += -DG_LOG_DOMAIN=\"gnc.report.standard\"
Modified: gnucash/trunk/src/report/standard-reports/category-barchart.scm
===================================================================
--- gnucash/trunk/src/report/standard-reports/category-barchart.scm 2013-06-02 10:32:39 UTC (rev 23026)
+++ gnucash/trunk/src/report/standard-reports/category-barchart.scm 2013-06-02 10:33:27 UTC (rev 23027)
@@ -24,6 +24,8 @@
;; depends must be outside module scope -- and should eventually go away.
(define-module (gnucash report standard-reports category-barchart))
+(use-modules (gnucash report report-system report-collectors))
+(use-modules (gnucash report report-system collectors))
(use-modules (srfi srfi-1))
(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
(use-modules (ice-9 regex))
@@ -242,9 +244,7 @@
(width (get-option gnc:pagename-display optname-plot-width))
(sort-method (get-option gnc:pagename-display optname-sort-method))
(reverse-balance? (get-option "__report" "reverse-balance?"))
-
- (work-done 0)
- (work-to-do 0)
+
(show-table? (get-option gnc:pagename-display (N_ "Show table")))
(document (gnc:make-html-document))
(chart (gnc:make-html-barchart))
@@ -324,7 +324,9 @@
;; the user wants to see the amounts averaged over some value.
(define (collector->double c date)
;; Future improvement: Let the user choose which kind of
- ;; currency combining she want to be done.
+ ;; currency combining she want to be done.
+ (if (not (gnc:timepair? date))
+ (throw 'wrong))
(*
(gnc-numeric-to-double
(gnc:gnc-monetary-amount
@@ -333,34 +335,6 @@
(lambda (a b) (exchange-fn a b date)))))
averaging-multiplier))
- ;; Calculates the net balance (profit or loss) of an account in
- ;; the given time interval. date-list-entry is a pair containing
- ;; the start- and end-date of that interval. If subacct?==#t,
- ;; the subaccount's balances are included as well. Returns a
- ;; double, exchanged into the report-currency by the above
- ;; conversion function, and possibly with reversed sign.
- (define (get-balance account date-list-entry subacct?)
- ((if (reverse-balance? account)
- - +)
- (if do-intervals?
- (collector->double
- (gnc:account-get-comm-balance-interval
- account
- (first date-list-entry)
- (second date-list-entry) subacct?)
- (second date-list-entry))
- (collector->double
- (gnc:account-get-comm-balance-at-date
- account date-list-entry subacct?)
- date-list-entry))))
-
- ;; Creates the <balance-list> to be used in the function
- ;; below.
- (define (account->balance-list account subacct?)
- (map
- (lambda (d) (get-balance account d subacct?))
- dates-list))
-
(define (count-accounts current-depth accts)
(if (< current-depth tree-depth)
(let ((sum 0))
@@ -386,33 +360,38 @@
;; show-acct? is true. This is necessary because otherwise we
;; would forget an account that is selected but not its
;; parent.
- (define (traverse-accounts current-depth accts)
- (if (< current-depth tree-depth)
- (let ((res '()))
- (for-each
- (lambda (a)
- (begin
- (set! work-done (+ 1 work-done))
- (gnc:report-percent-done (+ 20 (* 70 (/ work-done work-to-do))))
- (if (show-acct? a)
- (set! res
- (cons (list a (account->balance-list a #f))
- res)))
- (set! res (append
- (traverse-accounts
- (+ 1 current-depth)
- (gnc-account-get-children a))
- res))))
- accts)
- res)
- ;; else (i.e. current-depth == tree-depth)
- (map
- (lambda (a)
- (set! work-done (+ 1 work-done))
- (gnc:report-percent-done (+ 20 (* 70 (/ work-done work-to-do))))
- (list a (account->balance-list a #t)))
- (filter show-acct? accts))))
+ (define (apply-sign account x)
+ (if (reverse-balance? account) (- x) x))
+ (define (calculate-report accounts progress-range)
+ (let* ((the-acount-destination-alist (account-destination-alist accounts
+ account-types
+ tree-depth))
+ (account-reformat
+ (if do-intervals?
+ (lambda (account result)
+ (map (lambda (collector datepair)
+ (let ((date (second datepair)))
+ (apply-sign account (collector->double collector date))))
+ result dates-list))
+ (lambda (account result)
+ (let ((commodity-collector (gnc:make-commodity-collector)))
+ (collector-end (fold (lambda (next date list-collector)
+ (commodity-collector 'merge next #f)
+ (collector-add list-collector
+ (apply-sign account
+ (collector->double commodity-collector
+ date))))
+ (collector-into-list)
+ result dates-list))))))
+ (the-report (category-by-account-report do-intervals?
+ dates-list the-acount-destination-alist
+ (lambda (account date)
+ (make-gnc-collector-collector))
+ account-reformat
+ progress-range)))
+ the-report))
+
;; The percentage done numbers here are a hack so that
;; something gets displayed. On my system the
;; gnc:case-exchange-time-fn takes about 20% of the time
@@ -430,13 +409,12 @@
price-source report-currency
commodity-list to-date-tp
5 15))
- (set! work-to-do (count-accounts 1 topl-accounts))
;; Sort the account list according to the account code field.
- (set! all-data (sort
- (filter (lambda (l)
- (not (= 0.0 (apply + (cadr l)))))
- (traverse-accounts 1 topl-accounts))
+ (set! all-data (sort
+ (filter (lambda (l)
+ (not (= 0.0 (apply + (cadr l)))))
+ (calculate-report accounts (cons 0 90)))
(cond
((eq? sort-method 'acct-code)
(lambda (a b)
Modified: gnucash/trunk/src/report/standard-reports/net-barchart.scm
===================================================================
--- gnucash/trunk/src/report/standard-reports/net-barchart.scm 2013-06-02 10:32:39 UTC (rev 23026)
+++ gnucash/trunk/src/report/standard-reports/net-barchart.scm 2013-06-02 10:33:27 UTC (rev 23027)
@@ -31,6 +31,8 @@
(use-modules (gnucash gnc-module))
(use-modules (gnucash printf))
+(use-modules (gnucash report report-system report-collectors))
+(use-modules (gnucash report report-system collectors))
(gnc:module-load "gnucash/report/report-system" 0)
@@ -200,6 +202,8 @@
;; 'report-currency' according to the exchange-fn. Returns a
;; double.
(define (collector->double c date)
+ (if (not (gnc:timepair? date))
+ (throw 'wrong))
(gnc-numeric-to-double
(gnc:gnc-monetary-amount
(gnc:sum-collector-commodity
@@ -250,6 +254,7 @@
(let* ((assets-list #f)
(liability-list #f)
(net-list #f)
+ (progress-range (cons 50 80))
(date-string-list (map
(if inc-exp?
(lambda (date-list-item)
@@ -257,20 +262,46 @@
(car date-list-item)))
gnc-print-date)
dates-list)))
+ (let* ((the-acount-destination-alist
+ (if inc-exp?
+ (append (map (lambda (account) (cons account 'asset))
+ (assoc-ref classified-accounts ACCT-TYPE-INCOME))
+ (map (lambda (account) (cons account 'liability))
+ (assoc-ref classified-accounts ACCT-TYPE-EXPENSE)))
+ (append (map (lambda (account) (cons account 'asset))
+ (assoc-ref classified-accounts ACCT-TYPE-ASSET))
+ (map (lambda (account) (cons account 'liability))
+ (assoc-ref classified-accounts ACCT-TYPE-LIABILITY)))))
+ (account-reformat (if inc-exp?
+ (lambda (account result)
+ (map (lambda (collector date-interval)
+ (- (collector->double collector (second date-interval))))
+ result dates-list))
+ (lambda (account result)
+ (let ((commodity-collector (gnc:make-commodity-collector)))
+ (collector-end (fold (lambda (next date list-collector)
+ (commodity-collector 'merge next #f)
+ (collector-add list-collector
+ (collector->double
+ commodity-collector date)))
+ (collector-into-list)
+ result
+ dates-list))))))
+ (rpt (category-by-account-report inc-exp?
+ dates-list
+ the-acount-destination-alist
+ (lambda (account date)
+ (make-gnc-collector-collector))
+ account-reformat
+ progress-range))
+ (assets (assoc-ref rpt 'asset))
+ (liabilities (assoc-ref rpt 'liability)))
+ (set! assets-list (if assets (car assets)
+ (map (lambda (d) 0) dates-list)))
+ (set! liability-list (if liabilities (car liabilities)
+ (map (lambda (d) 0) dates-list)))
+ )
- (set! assets-list
- (process-datelist
- (if inc-exp?
- accounts
- (assoc-ref classified-accounts ACCT-TYPE-ASSET))
- dates-list #t))
- (gnc:report-percent-done 70)
- (set! liability-list
- (process-datelist
- (if inc-exp?
- accounts
- (assoc-ref classified-accounts ACCT-TYPE-LIABILITY))
- dates-list #f))
(gnc:report-percent-done 80)
(set! net-list
(map + assets-list liability-list))
Modified: gnucash/trunk/src/report/standard-reports/net-linechart.scm
===================================================================
--- gnucash/trunk/src/report/standard-reports/net-linechart.scm 2013-06-02 10:32:39 UTC (rev 23026)
+++ gnucash/trunk/src/report/standard-reports/net-linechart.scm 2013-06-02 10:33:27 UTC (rev 23027)
@@ -32,6 +32,8 @@
(use-modules (gnucash gnc-module))
(use-modules (gnucash printf))
+(use-modules (gnucash report report-system report-collectors))
+(use-modules (gnucash report report-system collectors))
(gnc:module-load "gnucash/report/report-system" 0)
@@ -242,6 +244,8 @@
;; 'report-currency' according to the exchange-fn. Returns a
;; double.
(define (collector->double c date)
+ (if (not (gnc:timepair? date))
+ (throw 'wrong))
(gnc-numeric-to-double
(gnc:gnc-monetary-amount
(gnc:sum-collector-commodity
@@ -292,6 +296,7 @@
(let* ((assets-list #f)
(liability-list #f)
(net-list #f)
+ (progress-range (cons 50 80))
(date-string-list (map
(if inc-exp?
(lambda (date-list-item)
@@ -299,20 +304,46 @@
(car date-list-item)))
gnc-print-date)
dates-list)))
+ (let* ((the-acount-destination-alist
+ (if inc-exp?
+ (append (map (lambda (account) (cons account 'asset))
+ (assoc-ref classified-accounts ACCT-TYPE-INCOME))
+ (map (lambda (account) (cons account 'liability))
+ (assoc-ref classified-accounts ACCT-TYPE-EXPENSE)))
+ (append (map (lambda (account) (cons account 'asset))
+ (assoc-ref classified-accounts ACCT-TYPE-ASSET))
+ (map (lambda (account) (cons account 'liability))
+ (assoc-ref classified-accounts ACCT-TYPE-LIABILITY)))))
+ (account-reformat (if inc-exp?
+ (lambda (account result)
+ (map (lambda (collector date-interval)
+ (- (collector->double collector (second date-interval))))
+ result dates-list))
+ (lambda (account result)
+ (let ((commodity-collector (gnc:make-commodity-collector)))
+ (collector-end (fold (lambda (next date list-collector)
+ (commodity-collector 'merge next #f)
+ (collector-add list-collector
+ (collector->double
+ commodity-collector date)))
+ (collector-into-list)
+ result
+ dates-list))))))
+ (rpt (category-by-account-report inc-exp?
+ dates-list
+ the-acount-destination-alist
+ (lambda (account date)
+ (make-gnc-collector-collector))
+ account-reformat
+ progress-range))
+ (assets (assoc-ref rpt 'asset))
+ (liabilities (assoc-ref rpt 'liability)))
+ (set! assets-list (if assets (car assets)
+ (map (lambda (d) 0) dates-list)))
+ (set! liability-list (if liabilities (car liabilities)
+ (map (lambda (d) 0) dates-list)))
+ )
- (set! assets-list
- (process-datelist
- (if inc-exp?
- accounts
- (assoc-ref classified-accounts ACCT-TYPE-ASSET))
- dates-list #t))
- (gnc:report-percent-done 70)
- (set! liability-list
- (process-datelist
- (if inc-exp?
- accounts
- (assoc-ref classified-accounts ACCT-TYPE-LIABILITY))
- dates-list #f))
(gnc:report-percent-done 80)
(set! net-list
(map + assets-list liability-list))
Modified: gnucash/trunk/src/report/standard-reports/test/test-generic-category-report.scm
===================================================================
--- gnucash/trunk/src/report/standard-reports/test/test-generic-category-report.scm 2013-06-02 10:32:39 UTC (rev 23026)
+++ gnucash/trunk/src/report/standard-reports/test/test-generic-category-report.scm 2013-06-02 10:33:27 UTC (rev 23027)
@@ -14,7 +14,7 @@
(use-modules (gnucash engine))
(use-modules (sw_engine))
-(use-modules (gnucash report report-system streamers))
+(use-modules (gnucash report report-system collectors))
(use-modules (gnucash report report-system test test-extras))
(export run-category-income-expense-test)
@@ -240,4 +240,3 @@
(= (/ (* row-count (+ row-count 1)) 2)
(string->number (car (tbl-ref tbl (- row-count 1) 1))))
#t)))))))
-
Modified: gnucash/trunk/src/report/standard-reports/test/test-standard-category-report.scm
===================================================================
--- gnucash/trunk/src/report/standard-reports/test/test-standard-category-report.scm 2013-06-02 10:32:39 UTC (rev 23026)
+++ gnucash/trunk/src/report/standard-reports/test/test-standard-category-report.scm 2013-06-02 10:33:27 UTC (rev 23027)
@@ -13,9 +13,6 @@
(use-modules (sw_engine))
(use-modules (gnucash report standard-reports net-barchart))
-(use-modules (gnucash report report-system streamers))
-;(use-modules (gnucash report new-reports reports-2))
-
(use-modules (gnucash report report-system test test-extras))
(use-modules (gnucash report standard-reports test test-generic-category-report))
More information about the gnucash-changes
mailing list