diff --git a/src/report/report-system/Makefile.am b/src/report/report-system/Makefile.am index 0437d82597..65b7676f87 100644 --- a/src/report/report-system/Makefile.am +++ b/src/report/report-system/Makefile.am @@ -62,7 +62,8 @@ gncmodscmdir = ${GNC_SHAREDIR}/guile-modules/gnucash/report/report-system gncmodscm_DATA = \ collectors.scm \ - list-extras.scm + list-extras.scm \ + report-collectors.scm gncscmmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash/report/ diff --git a/src/report/report-system/report-collectors.scm b/src/report/report-system/report-collectors.scm new file mode 100644 index 0000000000..da39a3137f --- /dev/null +++ b/src/report/report-system/report-collectors.scm @@ -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)) diff --git a/src/report/standard-reports/Makefile.am b/src/report/standard-reports/Makefile.am index 442f46ee1c..5fb726de3a 100644 --- a/src/report/standard-reports/Makefile.am +++ b/src/report/standard-reports/Makefile.am @@ -81,7 +81,7 @@ noinst_DATA = .scm-links 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\" diff --git a/src/report/standard-reports/category-barchart.scm b/src/report/standard-reports/category-barchart.scm index 18682b66cd..4eb3ea0b91 100644 --- a/src/report/standard-reports/category-barchart.scm +++ b/src/report/standard-reports/category-barchart.scm @@ -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 @@ developing over time")) (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 @@ developing over time")) ;; 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 @@ developing over time")) (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 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,32 +360,37 @@ developing over time")) ;; 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 @@ -430,13 +409,12 @@ developing over time")) 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) diff --git a/src/report/standard-reports/net-barchart.scm b/src/report/standard-reports/net-barchart.scm index f01dd32705..7fb598dd0b 100644 --- a/src/report/standard-reports/net-barchart.scm +++ b/src/report/standard-reports/net-barchart.scm @@ -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)) diff --git a/src/report/standard-reports/net-linechart.scm b/src/report/standard-reports/net-linechart.scm index 170cbd9ba1..7284d3fe92 100644 --- a/src/report/standard-reports/net-linechart.scm +++ b/src/report/standard-reports/net-linechart.scm @@ -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)) diff --git a/src/report/standard-reports/test/test-generic-category-report.scm b/src/report/standard-reports/test/test-generic-category-report.scm index 13d148804b..b546c47e0d 100644 --- a/src/report/standard-reports/test/test-generic-category-report.scm +++ b/src/report/standard-reports/test/test-generic-category-report.scm @@ -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))))))) - diff --git a/src/report/standard-reports/test/test-standard-category-report.scm b/src/report/standard-reports/test/test-standard-category-report.scm index a6900043de..038f557ccc 100644 --- a/src/report/standard-reports/test/test-standard-category-report.scm +++ b/src/report/standard-reports/test/test-standard-category-report.scm @@ -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))