diff --git a/gnucash/report/report-system/report-system.scm b/gnucash/report/report-system/report-system.scm index 73357a646d..f600835cf1 100644 --- a/gnucash/report/report-system/report-system.scm +++ b/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") diff --git a/gnucash/report/report-system/report-utilities.scm b/gnucash/report/report-system/report-utilities.scm index 1b8cde8f04..f01a97a4d5 100644 --- a/gnucash/report/report-system/report-utilities.scm +++ b/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" + (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" (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)))) diff --git a/gnucash/report/report-system/test/test-report-utilities.scm b/gnucash/report/report-system/test/test-report-utilities.scm index 531901b56c..f8d5241ba1 100644 --- a/gnucash/report/report-system/test/test-report-utilities.scm +++ b/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" + (gnc:strify cons))) + (define (test-commodity-collector) (test-group-with-cleanup "test-commodity-collector" (let* ((book (gnc-get-current-book)) diff --git a/gnucash/report/standard-reports/net-charts.scm b/gnucash/report/standard-reports/net-charts.scm index 9e1e885a02..317a2200ba 100644 --- a/gnucash/report/standard-reports/net-charts.scm +++ b/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? - gnc:make-date-interval-list - gnc:make-date-list) + (dates-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) - (gnc-numeric-to-double (gnc:gnc-monetary-amount monetary))) + (define (split->date s) + (xaccTransGetDate (xaccSplitGetParent s))) - ;; This calculates the balances for all the 'accounts' for each - ;; element of the list 'dates'. If income?==#t, the signs get - ;; reversed according to income-sign-reverse general option - ;; settings. Uses the collector->monetary conversion function - ;; above. Returns a list of gnc-monetary. - (define (process-datelist accounts dates income?) - (map - (lambda (date) - (collector->monetary - ((if inc-exp? - (if income? - gnc:accounts-get-comm-total-income - gnc:accounts-get-comm-total-expense) - gnc:accounts-get-comm-total-assets) - accounts - (lambda (account) - (if inc-exp? - ;; for inc-exp, 'date' is a pair of time values, else - ;; it is a time value. - (gnc:account-get-comm-balance-interval - account (first date) (second date) #f) - (gnc:account-get-comm-balance-at-date - account date #f)))) - (if inc-exp? (second date) date))) - dates)) + ;; this function will scan through the account splitlist, building + ;; a list of balances along the way. it will use the dates + ;; specified in the variable dates-list. + ;; input: account + ;; uses: dates-list (list of time64) + ;; out: (list account bal0 bal1 ...) + (define (account->balancelist account) + + ;; the test-closing? function will enable testing closing status + ;; for inc-exp only. this may squeeze more speed for net-worth charts. + (define test-closing? + (gnc:account-is-inc-exp? account)) + + (let loop ((splits (xaccAccountGetSplitList account)) + (dates dates-list) + (currentbal 0) + (lastbal 0) + (balancelist '())) + (cond + + ;; end of dates. job done! + ((null? dates) + (cons account (reverse balancelist))) + + ;; 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 ) + (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 - (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) - (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))) + (let* ((account-balancelist (map account->balancelist accounts)) + (dummy (gnc:report-percent-done 60)) - (date-string-list (if linechart? - (datelist->stringlist dates-list) - (map - (if inc-exp? - (lambda (date-list-item) - (qof-print-date - (car date-list-item))) - qof-print-date) - dates-list))) + (minuend-balances (process-datelist + account-balancelist + dates-list #t)) + (dummy (gnc:report-percent-done 70)) + + (subtrahend-balances (process-datelist + account-balancelist + dates-list #f)) + (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)) - (retlist #f)) + (date-iso-string-list (let ((save-fmt (qof-date-format-get))) (qof-date-format-set QOF-DATE-FORMAT-ISO) - (set! retlist (datelist->stringlist dates-list)) - (qof-date-format-set save-fmt) - retlist))) + (let ((retlist (map qof-print-date dates-list))) + (qof-date-format-set save-fmt) + retlist)))) (gnc:report-percent-done 90) @@ -413,15 +465,12 @@ chart (gnc-commodity-get-mnemonic report-currency)) ;; Add the data - (if show-sep? - (begin - (add-column! (map monetary->double assets-list)) - (add-column! ;;(if inc-exp? - (map - (map monetary->double liability-list)) - ;;liability-list) - ))) + (when show-sep? + (add-column! (map gnc:gnc-monetary-amount minuend-balances)) + (add-column! (map - (map gnc:gnc-monetary-amount subtrahend-balances)))) + (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? - (begin - (gnc:html-table-append-column! table assets-list) - (gnc:html-table-append-column! table liability-list) - ) - ) + (when show-sep? + (gnc:html-table-append-column! table minuend-balances) + (gnc:html-table-append-column! table subtrahend-balances)) + (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) diff --git a/gnucash/report/standard-reports/test/test-charts.scm b/gnucash/report/standard-reports/test/test-charts.scm index 850b472279..b181cab38b 100644 --- a/gnucash/report/standard-reports/test/test-charts.scm +++ b/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))))) +