reports: faster versions of category, net-barchart and net-linechart …

…reports

Author:    Peter Broadbery <p.broadbery@gmail.com>

git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@23027 57a11ea4-9604-0410-9ed3-97b8803252fd

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/

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))

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\"

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 <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,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)