Merge branch Chris Lam's 'maint-net-charts' into maint.

gnucash/report/report-system/report-system.scm

@@ -737,6 +737,8 @@
 (export gnc:select-assoc-account-balance)
 (export gnc:get-assoc-account-balances-total)
 (export make-file-url)
+(export gnc:strify)
+(export gnc:pk)
 
 (load-from-path "commodity-utilities")
 (load-from-path "html-barchart")

gnucash/report/report-system/report-utilities.scm

@@ -18,6 +18,7 @@
 ;; Boston, MA  02110-1301,  USA       gnu@gnu.org
 
 (use-modules (srfi srfi-13))
+(use-modules (ice-9 format))
 
 (define (list-ref-safe list elt)
   (and (> (length list) elt)
@@ -966,3 +967,89 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
   (if (string-prefix? "file:///" url)
      url
      (string-append "file:///" url)))
+
+(define-public (gnc:strify d)
+  ;; any object -> string.  The option is passed to various
+  ;; scm->string converters; ultimately a generic stringify
+  ;; function handles symbol/string/other types.
+  (define (split->str spl)
+    (let ((txn (xaccSplitGetParent spl)))
+      (format #f "Split<d:~a,acc:~a,amt:~a,val:~a>"
+              (qof-print-date (xaccTransGetDate txn))
+              (xaccAccountGetName (xaccSplitGetAccount spl))
+              (gnc:monetary->string
+               (gnc:make-gnc-monetary
+                (xaccTransGetCurrency txn)
+                (xaccSplitGetValue spl)))
+              (gnc:monetary->string
+               (gnc:make-gnc-monetary
+                (xaccAccountGetCommodity
+                 (xaccSplitGetAccount spl))
+                (xaccSplitGetAmount spl))))))
+  (define (trans->str txn)
+    (format #f "Txn<d:~a>" (qof-print-date (xaccTransGetDate txn))))
+  (define (account->str acc)
+    (format #f "Acc<~a>" (xaccAccountGetName acc)))
+  (define (monetary-collector->str coll)
+    (format #f "Mon-coll<~a>"
+            (map gnc:strify (coll 'format gnc:make-gnc-monetary #f))))
+  (define (value-collector->str coll)
+    (format #f "Val-coll<~a>"
+            (map gnc:strify (coll 'total gnc:make-gnc-monetary))))
+  (define (procedure->str proc)
+    (format #f "Proc<~a>"
+            (or (procedure-name proc) "unk")))
+  (define (monetary->string mon)
+    (format #f "Mon<~a>"
+            (gnc:monetary->string mon)))
+  (define (try proc)
+    ;; Try proc with d as a parameter, catching 'wrong-type-arg
+    ;; exceptions to return #f to the (or) evaluator below.
+    (catch 'wrong-type-arg
+      (lambda () (proc d))
+      (const #f)))
+  (or (and (boolean? d) (if d "#t" "#f"))
+      (and (null? d) "#null")
+      (and (symbol? d) (format #f "'~a" d))
+      (and (string? d) d)
+      (and (list? d) (string-append
+                      "(list "
+                      (string-join (map gnc:strify d) " ")
+                      ")"))
+      (and (pair? d) (format #f "(~a . ~a)"
+                             (gnc:strify (car d))
+                             (if (eq? (car d) 'absolute)
+                                 (qof-print-date (cdr d))
+                                 (gnc:strify (cdr d)))))
+      (try procedure->str)
+      (try gnc-commodity-get-mnemonic)
+      (try account->str)
+      (try split->str)
+      (try trans->str)
+      (try monetary-collector->str)
+      (try value-collector->str)
+      (try monetary->string)
+      (try gnc-budget-get-name)
+      (object->string d)))
+
+(define (pair->num pair)
+  (+ (car pair)
+     (/ (cdr pair) 1000000)))
+
+(define (delta t1 t2)
+  (exact->inexact
+   (- (pair->num t2)
+      (pair->num t1))))
+
+(define-public gnc:pk
+  (let* ((start-time (gettimeofday))
+         (last-time start-time))
+    (lambda args
+      (let ((now (gettimeofday)))
+        (format #t "d~,4f t~,3f: "
+                (delta last-time now)
+                (delta start-time now))
+        (set! last-time now))
+      (display (map gnc:strify args))
+      (newline)
+      (last args))))

gnucash/report/report-system/test/test-report-utilities.scm

@@ -17,6 +17,7 @@
   (test-account-get-trans-type-splits-interval)
   (test-list-ref-safe)
   (test-list-set-safe)
+  (test-gnc-pk)
   (test-gnc:monetary->string)
   (test-commodity-collector)
   (test-get-account-balances)
@@ -103,6 +104,33 @@
         (string? (gnc:monetary->string monetary))))
     (teardown)))
 
+(define (test-gnc-pk)
+  (test-begin "debugging tools")
+  (test-equal "gnc:pk testing"
+    'works
+    (gnc:pk 'testing "gnc:pk" 'works))
+  (test-equal "gnc:strify #t"
+    "#t"
+    (gnc:strify #t))
+  (test-equal "gnc:strify '()"
+    "#null"
+    (gnc:strify '()))
+  (test-equal "gnc:strify 'sym"
+    "'sym"
+    (gnc:strify 'sym))
+  (test-equal "gnc:strify \"str\""
+    "str"
+    (gnc:strify "str"))
+  (test-equal "gnc:strify '(1 2 3)"
+    "(list 1 2 3)"
+    (gnc:strify '(1 2 3)))
+  (test-equal "gnc:strify (a . 2)"
+    "('a . 2)"
+    (gnc:strify (cons 'a 2)))
+  (test-equal "gnc:strify cons"
+    "Proc<cons>"
+    (gnc:strify cons)))
+
 (define (test-commodity-collector)
   (test-group-with-cleanup "test-commodity-collector"
     (let* ((book (gnc-get-current-book))

gnucash/report/standard-reports/net-charts.scm

@@ -33,8 +33,6 @@
 (use-modules (gnucash gnc-module))
 (use-modules (gnucash gettext))
 
-(use-modules (gnucash report report-system report-collectors))
-(use-modules (gnucash report report-system collectors))
 (use-modules (gnucash report standard-reports category-barchart)) ; for guids of called reports
 (gnc:module-load "gnucash/report/report-system" 0)
 
@@ -216,9 +214,7 @@
          ;;(x-grid (if linechart? (get-option gnc:pagename-display optname-x-grid)))
          (commodity-list #f)
          (exchange-fn #f)
-         (dates-list ((if inc-exp?
+         (dates-list (gnc:make-date-list
-                          gnc:make-date-interval-list
-                          gnc:make-date-list)
                       ((if inc-exp?
                            gnc:time64-start-day-time
                            gnc:time64-end-day-time)
@@ -262,34 +258,135 @@
                 (warn "incompatible currencies in monetary+: " a b)))
           (warn "wrong arguments for monetary+: " a b)))
 
-    (define (monetary->double monetary)
+    (define (split->date s)
-      (gnc-numeric-to-double (gnc:gnc-monetary-amount monetary)))
+      (xaccTransGetDate (xaccSplitGetParent s)))
 
-    ;; This calculates the balances for all the 'accounts' for each
+    ;; this function will scan through the account splitlist, building
-    ;; element of the list 'dates'. If income?==#t, the signs get
+    ;; a list of balances along the way. it will use the dates
-    ;; reversed according to income-sign-reverse general option
+    ;; specified in the variable dates-list.
-    ;; settings. Uses the collector->monetary conversion function
+    ;; input: account
-    ;; above. Returns a list of gnc-monetary.
+    ;;  uses: dates-list (list of time64)
-    (define (process-datelist accounts dates income?)
+    ;;   out: (list account bal0 bal1 ...)
-      (map
+    (define (account->balancelist account)
-       (lambda (date)
+
-         (collector->monetary
+      ;; the test-closing? function will enable testing closing status
-          ((if inc-exp?
+      ;; for inc-exp only. this may squeeze more speed for net-worth charts.
-               (if income?
+      (define test-closing?
-                   gnc:accounts-get-comm-total-income
+        (gnc:account-is-inc-exp? account))
-                   gnc:accounts-get-comm-total-expense)
+
-               gnc:accounts-get-comm-total-assets)
+      (let loop ((splits (xaccAccountGetSplitList account))
-           accounts
+                 (dates dates-list)
-           (lambda (account)
+                 (currentbal 0)
-             (if inc-exp?
+                 (lastbal 0)
-                 ;; for inc-exp, 'date' is a pair of time values, else
+                 (balancelist '()))
-                 ;; it is a time value.
+        (cond
-                 (gnc:account-get-comm-balance-interval
+
-                  account (first date) (second date) #f)
+         ;; end of dates. job done!
-                 (gnc:account-get-comm-balance-at-date
+         ((null? dates)
-                  account date #f))))
+          (cons account (reverse balancelist)))
-          (if inc-exp? (second date) date)))
+
-       dates))
+         ;; end of splits, but still has dates. pad with last-bal
+         ;; until end of dates.
+         ((null? splits)
+          (loop '()
+                (cdr dates)
+                currentbal
+                lastbal
+                (cons lastbal balancelist)))
+
+         (else
+          (let* ((this (car splits))
+                 (rest (cdr splits))
+                 (currentbal (if (and test-closing?
+                                      (xaccTransGetIsClosingTxn (xaccSplitGetParent this)))
+                                 currentbal
+                                 (+ (xaccSplitGetAmount this) currentbal)))
+                 (next (and (pair? rest) (car rest))))
+
+            (cond
+             ;; the next split is still before date
+             ((and next (< (split->date next) (car dates)))
+              (loop rest dates currentbal lastbal balancelist))
+
+             ;; this split after date, add previous bal to balancelist
+             ((< (car dates) (split->date this))
+              (loop splits
+                    (cdr dates)
+                    lastbal
+                    lastbal
+                    (cons lastbal balancelist)))
+
+             ;; this split before date, next split after date, or end.
+             (else
+              (loop rest
+                    (cdr dates)
+                    currentbal
+                    currentbal
+                    (cons currentbal balancelist)))))))))
+
+    ;; This calculates the balances for all the 'account-balances' for
+    ;; each element of the list 'dates'. Uses the collector->monetary
+    ;; conversion function above. Returns a list of gnc-monetary.
+    (define (process-datelist account-balances dates left-col?)
+
+      (define (collector-minus coll1 coll2)
+        (let ((res (gnc:make-commodity-collector)))
+          (res 'merge coll1 #f)
+          (res 'minusmerge coll2 #f)
+          res))
+
+      (define accountlist
+        (if inc-exp?
+            (if left-col?
+                (assoc-ref classified-accounts ACCT-TYPE-INCOME)
+                (assoc-ref classified-accounts ACCT-TYPE-EXPENSE))
+            (if left-col?
+                (assoc-ref classified-accounts ACCT-TYPE-ASSET)
+                (assoc-ref classified-accounts ACCT-TYPE-LIABILITY))))
+
+      (define filtered-account-balances
+        (filter
+         (lambda (a)
+           (member (car a) accountlist))
+         account-balances))
+
+      (define (acc-balances->list-of-balances lst)
+        ;; input: (list (list acc1 bal0 bal1 bal2 ...)
+        ;;              (list acc2 bal0 bal1 bal2 ...) ...)
+        ;; whereby list of balances are numbers in the acc's currency
+        ;; output: (list <mon-coll0> <mon-coll1> <mon-coll2>)
+        (define list-of-collectors
+          (let loop ((n (length dates)) (result '()))
+            (if (zero? n) result
+                (loop (1- n) (cons (gnc:make-commodity-collector) result)))))
+        (let loop ((lst lst))
+          (when (pair? lst)
+            (let innerloop ((list-of-collectors list-of-collectors)
+                            (list-of-balances (cdar lst)))
+              (when (pair? list-of-balances)
+                ((car list-of-collectors) 'add
+                 (xaccAccountGetCommodity (caar lst))
+                 (car list-of-balances))
+                (innerloop (cdr list-of-collectors) (cdr list-of-balances))))
+            (loop (cdr lst))))
+        list-of-collectors)
+
+      (let loop ((dates dates)
+                 (acct-balances (acc-balances->list-of-balances filtered-account-balances))
+                 (result '()))
+        (if (if inc-exp?
+                (null? (cdr dates))
+                (null? dates))
+            (reverse result)
+            (loop (cdr dates)
+                  (cdr acct-balances)
+                  (cons
+                   (collector->monetary
+                    (if inc-exp?
+                        (collector-minus (car acct-balances) (cadr acct-balances))
+                        (car acct-balances))
+                    (if inc-exp? (cadr dates) (car dates)))
+                   result)))))
 
     (gnc:report-percent-done 1)
     (set! commodity-list (gnc:accounts-get-commodities
@@ -306,77 +403,32 @@
 
     (if
      (not (null? accounts))
-     (let* ((the-account-destination-alist
+     (let* ((account-balancelist (map account->balancelist accounts))
-             (if inc-exp?
+            (dummy (gnc:report-percent-done 60))
-                 (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)
-                                           (gnc:monetary-neg (collector->monetary 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->monetary
-                                                                             commodity-collector date)))
-                                                           (collector-into-list)
-                                                           result
-                                                           dates-list))))))
-            (work (category-by-account-report-work inc-exp?
-                                                   dates-list
-                                                   the-account-destination-alist
-                                                   (lambda (account date)
-                                                     (make-gnc-collector-collector))
-                                                   account-reformat))
-            (rpt (category-by-account-report-do-work work (cons 50 90)))
-            (assets (assoc-ref rpt 'asset))
-            (liabilities (assoc-ref rpt 'liability))
-            (assets-list (if assets
-                             (car assets)
-                             (map (lambda (d)
-                                    (gnc:make-gnc-monetary report-currency 0))
-                                  dates-list)))
-            (liability-list (if liabilities
-                                (car liabilities)
-                                (map (lambda (d)
-                                       (gnc:make-gnc-monetary report-currency 0))
-                                     dates-list)))
-            (net-list (map monetary+ assets-list liability-list))
-            ;; Here the date strings for the x-axis labels are
-            ;; created.
-            (datelist->stringlist (lambda (dates-list)
-                                    (map (lambda (date-list-item)
-                                           (qof-print-date
-                                            (if inc-exp?
-                                                (car date-list-item)
-                                                date-list-item)))
-                                         dates-list)))
 
-            (date-string-list (if linechart?
+            (minuend-balances (process-datelist
-                                  (datelist->stringlist dates-list)
+                               account-balancelist
-                                  (map
+                               dates-list #t))
-                                   (if inc-exp?
+            (dummy (gnc:report-percent-done 70))
-                                       (lambda (date-list-item)
+
-                                         (qof-print-date
+            (subtrahend-balances (process-datelist
-                                          (car date-list-item)))
+                                  account-balancelist
-                                       qof-print-date)
+                                  dates-list #f))
-                                   dates-list)))
+            (dummy (gnc:report-percent-done 80))
+
+            (difference-balances (map monetary+ minuend-balances subtrahend-balances))
+
+            (dates-list (if inc-exp?
+                            (list-head dates-list (1- (length dates-list)))
+                            dates-list))
+
+            (date-string-list (map qof-print-date dates-list))
             
-            (date-iso-string-list (let ((save-fmt (qof-date-format-get))
+            (date-iso-string-list (let ((save-fmt (qof-date-format-get)))
-                                        (retlist #f))
                                     (qof-date-format-set QOF-DATE-FORMAT-ISO)
-                                    (set! retlist (datelist->stringlist dates-list))
+                                    (let ((retlist (map qof-print-date dates-list)))
-                                    (qof-date-format-set save-fmt)
+                                      (qof-date-format-set save-fmt)
-                                    retlist)))
+                                      retlist))))
 
        (gnc:report-percent-done 90)
 
@@ -413,15 +465,12 @@
         chart (gnc-commodity-get-mnemonic report-currency))
 
        ;; Add the data
-       (if show-sep?
+       (when show-sep?
-           (begin
+         (add-column! (map gnc:gnc-monetary-amount minuend-balances))
-             (add-column! (map monetary->double assets-list))
+         (add-column! (map - (map gnc:gnc-monetary-amount subtrahend-balances))))
-             (add-column!                     ;;(if inc-exp?
+
-              (map - (map monetary->double liability-list))
-              ;;liability-list)
-              )))
        (if show-net?
-           (add-column! (map monetary->double net-list)))
+           (add-column! (map gnc:gnc-monetary-amount difference-balances)))
 
        ;; Legend labels, colors
        ((if linechart?
@@ -517,18 +566,15 @@
                          (if inc-exp?
                              (list (_ "Net Profit"))
                              (list (_ "Net Worth")))
-                         '()))
+                         '())))
-                    )
                    (gnc:html-table-append-column! table date-string-list)
-                   (if show-sep?
+                   (when show-sep?
-                       (begin
+                     (gnc:html-table-append-column! table minuend-balances)
-                         (gnc:html-table-append-column! table assets-list)
+                     (gnc:html-table-append-column! table subtrahend-balances))
-                         (gnc:html-table-append-column! table liability-list)
+
-                         )
-                       )
                    (if show-net?
-                       (gnc:html-table-append-column! table net-list)
+                       (gnc:html-table-append-column! table difference-balances))
-                       )
+
                    ;; set numeric columns to align right
                    (for-each
                     (lambda (col)

gnucash/report/standard-reports/test/test-charts.scm

@@ -57,6 +57,9 @@
 (define structure
   (list "Root" (list (cons 'type ACCT-TYPE-ASSET))
         (list "Asset"
+              (list "Bank1")
+              (list "Bank2")
+              (list "Bank3")
               (list "Bank"))
         (list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
         (list "Liability" (list (cons 'type ACCT-TYPE-LIABILITY)))
@@ -75,6 +78,69 @@
     (test-chart-variant variant)
     (gnc-clear-current-session)))
 
+(define (test-net-chart-variant variant)
+  (define (set-option! options section name value)
+    (let ((option (gnc:lookup-option options section name)))
+      (if option
+          (gnc:option-set-value option value)
+          (test-assert (format #f "[~a] wrong-option ~a ~a" variant section name) #f))))
+  (let* ((uuid (variant->uuid variant))
+         (inc-exp? (memq variant '(income-expense-barchart income-expense-linechart)))
+         (env (create-test-env))
+         (account-alist (env-create-account-structure-alist env structure))
+         (bank1 (cdr (assoc "Bank1" account-alist)))
+         (bank2 (cdr (assoc "Bank2" account-alist)))
+         (bank3 (cdr (assoc "Bank3" account-alist)))
+         (liability (cdr (assoc "Liability" account-alist)))
+         (income (cdr (assoc "Income" account-alist)))
+         (expense (cdr (assoc "Expenses" account-alist)))
+         (equity (cdr (assoc "Equity" account-alist))))
+
+    (env-transfer env 12 01 1970 income bank1 10)
+    (env-transfer env 18 01 1970 income bank1 15)
+    (env-transfer env 03 03 1970 income bank1 200)
+
+    (env-transfer env 18 01 1970 income bank2 50)
+    (env-transfer env 18 02 1970 income bank2 50)
+
+    (env-transfer env 05 05 1969 income bank3 25)
+    (env-transfer env 05 01 1970 income bank3 25)
+
+    ;; one closing txn which should be ignored by the inc-exp charts
+    (let ((txn (env-transfer env 03 01 1970 equity income 25)))
+      (xaccTransSetIsClosingTxn txn #t))
+
+    (let* ((options (gnc:make-report-options (variant->uuid variant))))
+      (set-option! options "General" "Start Date" (cons 'absolute (gnc-dmy2time64 1 1 1970)))
+      (set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 15 4 1970)))
+      (set-option! options "Accounts" "Accounts" (list income bank1 bank2 bank3))
+      (set-option! options "General" "Step Size" 'MonthDelta)
+      (set-option! options "Display" "Show table" #t)
+      (format #t "\n\ntesting net-chart variant:~a\n" variant)
+      (let ((sxml (gnc:options->sxml uuid options (format #f "test-net-charts ~a 3 months" variant)
+                                     "test-table" #:strip-tag "script")))
+        (unless inc-exp?
+          (test-equal "first row"
+            '("Date" "Assets" "Liabilities" "Net Worth")
+            (sxml->table-row-col sxml 1 0 #f))
+          (test-equal "first data row"
+            '("01/01/70" "$25.00" "$0.00" "$25.00")
+            (sxml->table-row-col sxml 1 1 #f))
+          (test-equal "last data row"
+            '("04/15/70" "$375.00" "$0.00" "$375.00")
+            (sxml->table-row-col sxml 1 -1 #f)))
+
+        (when inc-exp?
+          (test-equal "first row"
+            '("Date" "Income" "Expense" "Net Profit")
+            (sxml->table-row-col sxml 1 0 #f))
+          (test-equal "first data row"
+            '("01/01/70" "$100.00" "$0.00" "$100.00")
+            (sxml->table-row-col sxml 1 1 #f))
+          (test-equal "last data row"
+            '("04/01/70" "$0.00" "$0.00" "$0.00")
+            (sxml->table-row-col sxml 1 -1 #f)))))))
+
 (define (test-chart-variant variant)
   (define (set-option! options section name value)
     (let ((option (gnc:lookup-option options section name)))
@@ -179,4 +245,5 @@
        'daily-tests)
 
       ((net-worth-barchart income-expense-barchart net-worth-linechart income-expense-linechart)
-       'net-charts-tests))))
+       (test-net-chart-variant variant)))))
+