Christian Stimming's account-summary patch + a few fixes.

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

src/scm/report-utilities.scm

@@ -365,7 +365,7 @@
 ;; get the account balance at the specified date. if include-children?
 ;; is true, the balances of all children (not just direct children)
 ;; are included in the calculation.
-(define (gnc:account-get-balance-at-date account date include-children?)
+(define (d-gnc:account-get-balance-at-date account date include-children?)
   (let ((children-balance
          (if include-children?
              (gnc:group-get-balance-at-date
@@ -385,6 +385,8 @@
     (set! splits (gnc:glist->list 
                   (gnc:query-get-splits query) 
                   <gnc:Split*>))
+    (gnc:free-query query);
+
     (if (and splits (not (null? splits)))
         (set! balance (gnc:numeric-to-double 
                        (gnc:split-get-balance (car splits))))
@@ -418,18 +420,22 @@
     (set! splits (gnc:glist->list 
                   (gnc:query-get-splits query) 
                   <gnc:Split*>))
+    (gnc:free-query query);
+
     (if (and splits (not (null? splits)))
 	(balance-collector 'add (gnc:account-get-commodity account)
 			   (gnc:split-get-balance (car splits))))
     balance-collector))
 
 ;; get the balance of a group of accounts at the specified date.
-;; all children are included in the calculation
+;; The childrens are NOT included in the calculation since
+;; account-get-children already returned ALL children, whether
+;; they are immediate children or not.
 (define (gnc:group-get-balance-at-date group date)
   (apply +
          (gnc:group-map-accounts
           (lambda (account)
-            (gnc:account-get-balance-at-date account date #t)) 
+            (gnc:account-get-balance-at-date account date #f)) 
           group)))
 
 ;; returns a commodity-collector
@@ -439,7 +445,7 @@
 	      (gnc:group-map-accounts
 	       (lambda (account)
 		 (gnc:account-get-comm-balance-at-date 
-		  account date #t)) 
+		  account date #f)) 
 	       group))
     this-collector))
 

src/scm/report/account-summary.scm

@@ -1,8 +1,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; account-summary.scm : brief account listing 
-;; Copyright 2000 Bill Gribble <grib@gnumatic.com>
+;; Copyright 2001 Christian Stimming <stimming@tu-harburg.de>
+;; Copyright 2000-2001 Bill Gribble <grib@gnumatic.com>
 ;;
-;; Original version by  Terry D. Boldt (tboldt@attglobal.net>
+;; Even older original version by  Terry D. Boldt (tboldt@attglobal.net>
 ;;   Author makes no implicit or explicit guarantee of accuracy of
 ;;   these calculations and accepts no responsibility for direct
 ;;   or indirect losses incurred as a result of using this software.
@@ -29,7 +30,7 @@
 (gnc:depend  "report-html.scm")
 
 ;; account summary report
-;; prints a simple table of account information with clickable 
+;; prints a table of account information with clickable 
 ;; links to open the corresponding register window.
 
 (let () 
@@ -67,70 +68,122 @@
         #f #t))
       
       (opt-register 
-       (gnc:make-simple-boolean-option
+       (gnc:make-multichoice-option
-        (_ "General") (_ "Sub-Accounts")
+        (_ "General") (_ "Account Display Depth")
-        "c" (_ "Include sub-accounts of each selected account?") #f))      
+        "c" (_ "Show accounts to this depth.") 1
+        (list (list->vector
+	       (list 'all
+		     (_ "All")
+		     (_ "Show all accounts")))
+	      (list->vector
+               (list 1
+                     "1"
+                     (_ "Top-level")))
+              (list->vector
+               (list 2
+                     "2"
+                     (_ "Second-level")))
+              (list->vector
+               (list 3
+                     "3"
+                     (_ "Third-level")))
+              (list->vector
+               (list 4
+                     "4"
+                     (_ "Fourth-level"))))))
       
       (opt-register 
        (gnc:make-simple-boolean-option
         (_ "General") (_ "Include Sub-Account balances")
-        "d" (_ "Include sub-account balances in printed balance?") #f))      
+        "d" (_ "Include sub-account balances in printed balance?") #t))
       
       options))
 
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Start of report generating code
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; pair is a list of one gnc:commodity and one gnc:numeric
-  ;; build-acct-table
+  ;; value. This function should disappear once this is an "official"
-  ;; does the dirty work of building a table for a set of accounts. 
+  ;; data type.
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  (define (commodity-value->string pair)
+    (gnc:commodity-amount->string 
+     (cadr pair) (gnc:commodity-print-info (car pair) #t)))
 
-  (define (build-acct-table accounts end-date do-subs? sub-balances?)
+  ;; returns a list with n one-space-strings (" ") which, hopefully,
-    (let ((table (gnc:make-html-table)))
+  ;; result in empty cells
-      ;; column 1: account names 
+  (define (make-empty-cells n)
-      (gnc:html-table-append-column!
+    (if (> n 0)
-       table 
+	(append (list " ") (make-empty-cells (- n 1)))
-       (map (lambda (acct)
+	'()))
+
+  ;; returns a html-table-cell object that has the content content and
+  ;; (hopefully) an option colspan=n
+  (define (make-cell-colspan n content)
+    (if (> n 0)
+	(let ((cell (gnc:make-html-table-cell)))
+	  (gnc:html-table-cell-set-col-span! cell n)
+	  (gnc:html-table-cell-append-objects! 
+	   cell content)
+	  cell)
+	content))
+    
+  ;; returns a list which is ready to be passed to the
+  ;; html-table-append-row! function (one row of our table)
+  (define (make-row acct end-date tree-depth current-depth subtot?)
+    (append
+     (make-empty-cells (- current-depth 1))
+     ;; the account name
+     (list (make-cell-colspan 
+	    (+ 1 (- tree-depth current-depth)) 
 	    (gnc:make-html-text (gnc:html-markup-anchor
 				 (string-append 
 				  "gnc-register:account=" 
 				  (gnc:account-get-full-name acct))
-                                   (gnc:account-get-name acct))))
+				 (gnc:account-get-name acct)))))
-            accounts))
+     (make-empty-cells (- tree-depth current-depth))
+     ;; the account balance
+     (list 
+      (let ((pair ((gnc:account-get-comm-balance-at-date 
+		    acct end-date subtot?) 
+		   'getpair (gnc:account-get-commodity acct) #f)))
+	;; pair is a list of one gnc:commodity and 
+	;; one gnc:numeric value. 
+	(commodity-value->string pair)))
+     (make-empty-cells (- current-depth 1))))
 
-      ;; column 2 (optional): subaccount info
+  ;; Goes through the list of accounts, runs make-row on each account.
-      (if do-subs? 
+  ;; If tree-depth and current-depth require, it will recursively call
-          (let* ((has-subs? #f)
+  ;; itself on the list of children accounts.
-                 (data 
+  (define (traverse-accounts accounts table end-date 
+			     tree-depth current-depth subtot?)
+    (if (<= current-depth tree-depth)
 	(map (lambda (acct)
+	       (begin
+		 (gnc:html-table-append-row!
+		  table 
+		  (make-row acct end-date tree-depth current-depth 
+			    subtot?))
 		 (let* ((children 
 			 (gnc:account-get-immediate-subaccounts acct)))
 		   (if (not (null? children))
-                               (begin 
+		       (traverse-accounts children table end-date
-                                 (set! has-subs? #t)
+					  tree-depth (+ 1 current-depth)
-                                 (build-acct-table children end-date 
+					  subtot?)))))
-                                                   #t sub-balances?))
-                               #f)))
 	     accounts)))
-            (if has-subs? 
-                (begin 
-                  (gnc:html-table-append-column! table data)))))
 	
-      ;; column 3: balances 
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;
-      (gnc:html-table-append-column! 
+  ;; build-acct-table
-       table
+  ;; builds the tree-shaped table
-       (map (lambda (acct)
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;
-              (let ((pair 
-		     ((gnc:account-get-comm-balance-at-date 
-		       acct end-date sub-balances?) 
-		      'getpair (gnc:account-get-commodity acct) #f)))
-		;; pair is a list of one gnc:commodity and 
-		;; one gnc:numeric value
-		 (gnc:commodity-amount->string 
-		  (cadr pair) 
-		  (gnc:commodity-print-info (car pair) #t))))
-	    accounts))
 
-      ;; set column and table styles 
+  (define (build-acct-table accounts end-date tree-depth do-subtot?)
+    (let ((table (gnc:make-html-table)))
+
+      ;; start the recursive account processing
+      (traverse-accounts accounts table end-date tree-depth 1 do-subtot?)
+            
+      ;; set some column and table styles - needs to be improved.
       (let ((bal-col (- (gnc:html-table-num-columns table) 1)))
         (gnc:html-table-set-col-style! 
          table 0 "td" 
@@ -152,6 +205,29 @@
       
       table))
   
+  ;; returns the maximum integer>0 in the given list... I'm
+  ;; sure there is a predefined function for this task, but I don't
+  ;; know where to look for that.
+  (define (find-max-int l)
+    (if (null? l)
+	0
+	(let ((a (find-max-int (cdr l))))
+	  (if (> a (car l))
+	      a
+	      (car l)))))
+  
+  ;; return the depth of the given account tree (needed if no
+  ;; tree-depth was specified)
+  (define (find-depth tree)
+    (find-max-int
+     (map (lambda (acct)
+	    (let ((children 
+		   (gnc:account-get-immediate-subaccounts acct)))
+	      (if (null? children)
+		  1
+		  (+ 1 (find-depth children)))))
+	  tree)))
+  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; accsum-renderer
   ;; set up the document and add the table
@@ -164,28 +240,31 @@
     
     (let ((accounts (get-option (_ "Account")))
           (date-tp (vector-ref (get-option (_ "Date")) 1))
-          (do-subs? (get-option (_ "Sub-Accounts")))
+          (display-depth (get-option (_ "Account Display Depth")))
           (do-subtotals? (get-option (_ "Include Sub-Account balances")))
           (doc (gnc:make-html-document)))
       
       (gnc:html-document-set-title! doc "Account Summary")
       (if (not (null? accounts))
+	  ;; if no max. tree depth is given we have to find the
+	  ;; maximum existing depth
+	  (let ((tree-depth (if (equal? display-depth 'all)
+				(find-depth accounts)
+				display-depth)))
+	    ;; do the (recursive) processing here
 	    (let ((table (build-acct-table accounts date-tp 
-                                         do-subs? do-subtotals?)))
+					   tree-depth do-subtotals?)))
-            ;; set the column headers 
+	      ;; set some column headers 
-            (if (= (gnc:html-table-num-columns table) 3)
+	      
-                (begin 
+	      ;;(gnc:html-table-set-col-style! 
-                  (gnc:html-table-set-col-style! 
+	      ;; table 1 "table" 
-                   table 1 "table" 
+	      ;; 'attribute '("width" "100%"))
-                   'attribute '("width" "100%"))
 	      (gnc:html-table-set-col-headers!
 	       table 
-                   (list (_ "Account name") (_ "Sub-Accounts") (_ "Balance"))))
+	       (list (make-cell-colspan (- tree-depth 1) (_ "Account name"))
-                (begin 
+		     (make-cell-colspan (- tree-depth 1) (_ "Balance"))))
-                  (gnc:html-table-set-col-headers!
-                   table (list (_ "Account name") (_ "Balance")))))
 	      ;; add the table 
-            (gnc:html-document-add-object! doc table))
+	      (gnc:html-document-add-object! doc table)))
           
           ;; error condition: no accounts specified
           (let ((p (gnc:make-html-text)))
@@ -202,8 +281,3 @@
    'name (_ "Account Summary")
    'options-generator accsum-options-generator
    'renderer accsum-renderer))
-
-
-          
-      
-